From 5bb8c28959e168b369e1911086542d713af17df0 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 12 Feb 2020 17:40:17 +0100 Subject: [PATCH 1/3] carthage: update tezos copy/pasted files --- .../default_parameters.ml | 193 +- .../default_parameters.mli | 17 +- .../tezos-protocol-alpha-parameters/gen.ml | 24 +- .../tezos-protocol-alpha/alpha_context.ml | 125 +- .../tezos-protocol-alpha/alpha_context.mli | 1332 ++- .../tezos-protocol-alpha/alpha_services.ml | 92 +- .../tezos-protocol-alpha/alpha_services.mli | 18 +- .../tezos-protocol-alpha/amendment.ml | 257 +- .../tezos-protocol-alpha/amendment.mli | 20 +- .../ligo-utils/tezos-protocol-alpha/apply.ml | 1853 ++-- .../tezos-protocol-alpha/apply_results.ml | 1649 +-- .../tezos-protocol-alpha/apply_results.mli | 160 +- .../ligo-utils/tezos-protocol-alpha/baking.ml | 355 +- .../tezos-protocol-alpha/baking.mli | 78 +- .../blinded_public_key_hash.ml | 24 +- .../blinded_public_key_hash.mli | 2 + .../tezos-protocol-alpha/block_header_repr.ml | 132 +- .../block_header_repr.mli | 43 +- .../tezos-protocol-alpha/bootstrap_storage.ml | 170 +- .../bootstrap_storage.mli | 16 +- .../tezos-protocol-alpha/commitment_repr.ml | 16 +- .../tezos-protocol-alpha/commitment_repr.mli | 4 +- .../commitment_storage.ml | 11 +- .../commitment_storage.mli | 16 +- .../tezos-protocol-alpha/constants_repr.ml | 421 +- .../constants_services.ml | 37 +- .../constants_services.mli | 11 +- .../tezos-protocol-alpha/constants_storage.ml | 33 +- .../tezos-protocol-alpha/contract_hash.ml | 20 +- .../tezos-protocol-alpha/contract_repr.ml | 226 +- .../tezos-protocol-alpha/contract_repr.mli | 16 +- .../tezos-protocol-alpha/contract_services.ml | 425 +- .../contract_services.mli | 112 +- .../tezos-protocol-alpha/contract_storage.ml | 799 +- .../tezos-protocol-alpha/contract_storage.mli | 141 +- .../tezos-protocol-alpha/cycle_repr.ml | 44 +- .../tezos-protocol-alpha/cycle_repr.mli | 30 +- .../tezos-protocol-alpha/delegate_services.ml | 711 +- .../delegate_services.mli | 165 +- .../tezos-protocol-alpha/delegate_storage.ml | 807 +- .../tezos-protocol-alpha/delegate_storage.mli | 135 +- .../tezos-protocol-alpha/fees_storage.ml | 74 +- .../tezos-protocol-alpha/fees_storage.mli | 22 +- .../tezos-protocol-alpha/fitness_repr.ml | 32 +- .../tezos-protocol-alpha/fitness_storage.ml | 1 + .../tezos-protocol-alpha/gas_limit_repr.ml | 221 +- .../tezos-protocol-alpha/gas_limit_repr.mli | 20 +- .../tezos-protocol-alpha/helpers_services.ml | 1129 +- .../tezos-protocol-alpha/helpers_services.mli | 236 +- .../tezos-protocol-alpha/init_storage.ml | 364 +- .../legacy_script_support_repr.ml | 1234 ++- .../legacy_script_support_repr.mli | 26 +- .../tezos-protocol-alpha/level_repr.ml | 189 +- .../tezos-protocol-alpha/level_repr.mli | 45 +- .../tezos-protocol-alpha/level_storage.ml | 54 +- .../tezos-protocol-alpha/level_storage.mli | 31 +- .../ligo-utils/tezos-protocol-alpha/main.ml | 431 +- .../ligo-utils/tezos-protocol-alpha/main.mli | 57 +- .../tezos-protocol-alpha/manager_repr.ml | 22 +- .../tezos-protocol-alpha/michelson_v1_gas.ml | 731 +- .../tezos-protocol-alpha/michelson_v1_gas.mli | 123 +- .../michelson_v1_primitives.ml | 1095 +- .../michelson_v1_primitives.mli | 11 +- .../ligo-utils/tezos-protocol-alpha/misc.ml | 79 +- .../ligo-utils/tezos-protocol-alpha/misc.mli | 17 +- .../tezos-protocol-alpha/nonce_hash.ml | 20 +- .../tezos-protocol-alpha/nonce_storage.ml | 57 +- .../tezos-protocol-alpha/nonce_storage.mli | 31 +- .../tezos-protocol-alpha/operation_repr.ml | 1150 +- .../tezos-protocol-alpha/operation_repr.mli | 261 +- .../tezos-protocol-alpha/parameters_repr.ml | 359 +- .../tezos-protocol-alpha/parameters_repr.mli | 57 +- .../tezos-protocol-alpha/period_repr.ml | 24 +- .../tezos-protocol-alpha/period_repr.mli | 17 +- .../tezos-protocol-alpha/qty_repr.ml | 258 +- .../tezos-protocol-alpha/raw_context.ml | 833 +- .../tezos-protocol-alpha/raw_context.mli | 231 +- .../tezos-protocol-alpha/raw_level_repr.ml | 50 +- .../tezos-protocol-alpha/raw_level_repr.mli | 28 +- .../tezos-protocol-alpha/roll_repr.ml | 34 +- .../tezos-protocol-alpha/roll_repr.mli | 18 +- .../tezos-protocol-alpha/roll_storage.ml | 581 +- .../tezos-protocol-alpha/roll_storage.mli | 74 +- .../tezos-protocol-alpha/script_expr_hash.ml | 20 +- .../tezos-protocol-alpha/script_int_repr.ml | 27 +- .../tezos-protocol-alpha/script_int_repr.mli | 4 +- .../script_interpreter.ml | 2216 ++-- .../script_interpreter.mli | 56 +- .../tezos-protocol-alpha/script_ir_annot.ml | 703 +- .../tezos-protocol-alpha/script_ir_annot.mli | 64 +- .../script_ir_translator.ml | 9290 ++++++++++------- .../script_ir_translator.mli | 230 +- .../tezos-protocol-alpha/script_repr.ml | 178 +- .../tezos-protocol-alpha/script_repr.mli | 13 +- .../tezos-protocol-alpha/script_tc_errors.ml | 96 +- .../script_tc_errors_registration.ml | 584 +- .../script_timestamp_repr.ml | 19 +- .../script_timestamp_repr.mli | 4 + .../tezos-protocol-alpha/script_typed_ir.ml | 561 +- .../tezos-protocol-alpha/seed_repr.ml | 59 +- .../tezos-protocol-alpha/seed_repr.mli | 5 +- .../tezos-protocol-alpha/seed_storage.ml | 132 +- .../tezos-protocol-alpha/seed_storage.mli | 21 +- .../services_registration.ml | 68 +- .../tezos-protocol-alpha/state_hash.ml | 19 +- .../tezos-protocol-alpha/storage.ml | 806 +- .../tezos-protocol-alpha/storage.mli | 423 +- .../storage_description.ml | 451 +- .../storage_description.mli | 55 +- .../tezos-protocol-alpha/storage_functors.ml | 1104 +- .../tezos-protocol-alpha/storage_functors.mli | 97 +- .../tezos-protocol-alpha/storage_sigs.ml | 199 +- .../tezos-protocol-alpha/tez_repr.ml | 9 +- .../tezos-protocol-alpha/tez_repr.mli | 3 +- .../tezos-protocol-alpha/time_repr.ml | 24 +- .../tezos-protocol-alpha/time_repr.mli | 17 +- .../tezos-protocol-alpha/vote_repr.ml | 26 +- .../tezos-protocol-alpha/vote_repr.mli | 3 +- .../tezos-protocol-alpha/vote_storage.ml | 149 +- .../tezos-protocol-alpha/vote_storage.mli | 78 +- .../voting_period_repr.ml | 73 +- .../voting_period_repr.mli | 31 +- .../tezos-protocol-alpha/voting_services.ml | 97 +- .../tezos-protocol-alpha/voting_services.mli | 15 +- .../michelson-parser/michelson_v1_macros.ml | 2028 ++-- .../michelson-parser/michelson_v1_macros.mli | 32 +- 126 files changed, 23794 insertions(+), 17362 deletions(-) diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml index 920de32c7..289a40613 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.ml @@ -25,90 +25,98 @@ open Protocol -let constants_mainnet = Constants_repr.{ - preserved_cycles = 5 ; - blocks_per_cycle = 4096l ; - blocks_per_commitment = 32l ; - blocks_per_roll_snapshot = 256l ; - blocks_per_voting_period = 32768l ; - time_between_blocks = - List.map Period_repr.of_seconds_exn [ 60L ; 40L ] ; - endorsers_per_block = 32 ; - hard_gas_limit_per_operation = Z.of_int 800_000 ; - hard_gas_limit_per_block = Z.of_int 8_000_000 ; - proof_of_work_threshold = - Int64.(sub (shift_left 1L 46) 1L) ; - tokens_per_roll = Tez_repr.(mul_exn one 8_000) ; - michelson_maximum_type_size = 1000 ; - seed_nonce_revelation_tip = begin - match Tez_repr.(one /? 8L) with - | Ok c -> c - | Error _ -> assert false - end ; - origination_size = 257 ; - block_security_deposit = Tez_repr.(mul_exn one 512) ; - endorsement_security_deposit = Tez_repr.(mul_exn one 64) ; - block_reward = Tez_repr.(mul_exn one 16) ; - endorsement_reward = Tez_repr.(mul_exn one 2) ; - hard_storage_limit_per_operation = Z.of_int 60_000 ; - cost_per_byte = Tez_repr.of_mutez_exn 1_000L ; - test_chain_duration = Int64.mul 32768L 60L ; - quorum_min = 20_00l ; (* quorum is in centile of a percentage *) - quorum_max = 70_00l ; - min_proposal_quorum = 5_00l ; - initial_endorsers = 24 ; - delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L ; - } +let constants_mainnet = + Constants_repr. + { + preserved_cycles = 5; + blocks_per_cycle = 4096l; + blocks_per_commitment = 32l; + blocks_per_roll_snapshot = 256l; + blocks_per_voting_period = 32768l; + time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 40L]; + endorsers_per_block = 32; + hard_gas_limit_per_operation = Z.of_int 1_040_000; + hard_gas_limit_per_block = Z.of_int 10_400_000; + proof_of_work_threshold = Int64.(sub (shift_left 1L 46) 1L); + tokens_per_roll = Tez_repr.(mul_exn one 8_000); + michelson_maximum_type_size = 1000; + seed_nonce_revelation_tip = + (match Tez_repr.(one /? 8L) with Ok c -> c | Error _ -> assert false); + origination_size = 257; + block_security_deposit = Tez_repr.(mul_exn one 512); + endorsement_security_deposit = Tez_repr.(mul_exn one 64); + baking_reward_per_endorsement = + Tez_repr.[of_mutez_exn 1_250_000L; of_mutez_exn 187_500L]; + endorsement_reward = + Tez_repr.[of_mutez_exn 1_250_000L; of_mutez_exn 833_333L]; + hard_storage_limit_per_operation = Z.of_int 60_000; + cost_per_byte = Tez_repr.of_mutez_exn 1_000L; + test_chain_duration = Int64.mul 32768L 60L; + quorum_min = 20_00l; + (* quorum is in centile of a percentage *) + quorum_max = 70_00l; + min_proposal_quorum = 5_00l; + initial_endorsers = 24; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L; + } -let constants_sandbox = Constants_repr.{ - constants_mainnet with - preserved_cycles = 2 ; - blocks_per_cycle = 8l ; - blocks_per_commitment = 4l ; - blocks_per_roll_snapshot = 4l ; - blocks_per_voting_period = 64l ; - time_between_blocks = - List.map Period_repr.of_seconds_exn [ 1L ; 0L ] ; - proof_of_work_threshold = Int64.of_int (-1) ; - initial_endorsers = 1 ; - delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L ; - } +let constants_sandbox = + Constants_repr. + { + constants_mainnet with + preserved_cycles = 2; + blocks_per_cycle = 8l; + blocks_per_commitment = 4l; + blocks_per_roll_snapshot = 4l; + blocks_per_voting_period = 64l; + time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L]; + proof_of_work_threshold = Int64.of_int (-1); + initial_endorsers = 1; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L; + } -let constants_test = Constants_repr.{ - constants_mainnet with - blocks_per_cycle = 128l ; - blocks_per_commitment = 4l ; - blocks_per_roll_snapshot = 32l ; - blocks_per_voting_period = 256l ; - time_between_blocks = - List.map Period_repr.of_seconds_exn [ 1L ; 0L ] ; - proof_of_work_threshold = Int64.of_int (-1) ; - initial_endorsers = 1 ; - delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L ; - } +let constants_test = + Constants_repr. + { + constants_mainnet with + blocks_per_cycle = 128l; + blocks_per_commitment = 4l; + blocks_per_roll_snapshot = 32l; + blocks_per_voting_period = 256l; + time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L]; + proof_of_work_threshold = Int64.of_int (-1); + initial_endorsers = 1; + delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L; + } + +let bootstrap_accounts_strings = + [ "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"; + "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9"; + "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV"; + "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU"; + "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ] -let bootstrap_accounts_strings = [ - "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" ; - "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9" ; - "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV" ; - "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU" ; - "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ; -] let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L -let bootstrap_accounts = List.map (fun s -> - let public_key = Signature.Public_key.of_b58check_exn s in - let public_key_hash = Signature.Public_key.hash public_key in - Parameters_repr.{ - public_key_hash ; - public_key = Some public_key ; - amount = boostrap_balance ; - }) + +let bootstrap_accounts = + List.map + (fun s -> + let public_key = Signature.Public_key.of_b58check_exn s in + let public_key_hash = Signature.Public_key.hash public_key in + Parameters_repr. + { + public_key_hash; + public_key = Some public_key; + amount = boostrap_balance; + }) bootstrap_accounts_strings (* TODO this could be generated from OCaml together with the faucet for now these are harcoded values in the tests *) let commitments = - let json_result = Data_encoding.Json.from_string {json| + let json_result = + Data_encoding.Json.from_string + {json| [ [ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ], [ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ], @@ -123,27 +131,28 @@ let commitments = ]|json} in match json_result with - | Error err -> raise (Failure err) - | Ok json -> Data_encoding.Json.destruct - (Data_encoding.list Commitment_repr.encoding) json + | Error err -> + raise (Failure err) + | Ok json -> + Data_encoding.Json.destruct + (Data_encoding.list Commitment_repr.encoding) + json let make_bootstrap_account (pkh, pk, amount) = - Parameters_repr.{ public_key_hash = pkh ; public_key = Some pk ; amount } + Parameters_repr.{public_key_hash = pkh; public_key = Some pk; amount} -let parameters_of_constants - ?(bootstrap_accounts = bootstrap_accounts) - ?(bootstrap_contracts = []) - ?(with_commitments = false) - constants = +let parameters_of_constants ?(bootstrap_accounts = bootstrap_accounts) + ?(bootstrap_contracts = []) ?(with_commitments = false) constants = let commitments = if with_commitments then commitments else [] in - Parameters_repr.{ - bootstrap_accounts ; - bootstrap_contracts ; - commitments ; - constants ; - security_deposit_ramp_up_cycles = None ; - no_reward_cycles = None ; - } + Parameters_repr. + { + bootstrap_accounts; + bootstrap_contracts; + commitments; + constants; + security_deposit_ramp_up_cycles = None; + no_reward_cycles = None; + } let json_of_parameters parameters = Data_encoding.Json.construct Parameters_repr.encoding parameters diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli index 2ba8f6b08..598574c8f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/default_parameters.mli @@ -25,18 +25,21 @@ open Protocol -val constants_mainnet: Constants_repr.parametric -val constants_sandbox: Constants_repr.parametric -val constants_test: Constants_repr.parametric +val constants_mainnet : Constants_repr.parametric -val make_bootstrap_account: +val constants_sandbox : Constants_repr.parametric + +val constants_test : Constants_repr.parametric + +val make_bootstrap_account : Signature.public_key_hash * Signature.public_key * Tez_repr.t -> Parameters_repr.bootstrap_account -val parameters_of_constants: +val parameters_of_constants : ?bootstrap_accounts:Parameters_repr.bootstrap_account list -> ?bootstrap_contracts:Parameters_repr.bootstrap_contract list -> ?with_commitments:bool -> - Constants_repr.parametric -> Parameters_repr.t + Constants_repr.parametric -> + Parameters_repr.t -val json_of_parameters: Parameters_repr.t -> Data_encoding.json +val json_of_parameters : Parameters_repr.t -> Data_encoding.json diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml b/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml index 2b6e75dac..93a0a459d 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/gen.ml @@ -29,18 +29,19 @@ let () = let print_usage_and_fail s = - Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" - Sys.argv.(0) ; + Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" Sys.argv.(0) ; raise (Invalid_argument s) in let dump parameters file = - let str = Data_encoding.Json.to_string - (Default_parameters.json_of_parameters parameters) in + let str = + Data_encoding.Json.to_string + (Default_parameters.json_of_parameters parameters) + in let fd = open_out file in - output_string fd str ; - close_out fd + output_string fd str ; close_out fd in - if Array.length Sys.argv < 2 then print_usage_and_fail "" else + if Array.length Sys.argv < 2 then print_usage_and_fail "" + else match Sys.argv.(1) with | "--sandbox" -> dump @@ -48,10 +49,13 @@ let () = "sandbox-parameters.json" | "--test" -> dump - Default_parameters.(parameters_of_constants ~with_commitments:true constants_sandbox) + Default_parameters.( + parameters_of_constants ~with_commitments:true constants_sandbox) "test-parameters.json" | "--mainnet" -> dump - Default_parameters.(parameters_of_constants ~with_commitments:true constants_mainnet) + Default_parameters.( + parameters_of_constants ~with_commitments:true constants_mainnet) "mainnet-parameters.json" - | s -> print_usage_and_fail s + | s -> + print_usage_and_fail s diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml index c5fd259f1..5eaf19850 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.ml @@ -24,13 +24,17 @@ (*****************************************************************************) type t = Raw_context.t + type context = t module type BASIC_DATA = sig type t + include Compare.S with type t := t - val encoding: t Data_encoding.t - val pp: Format.formatter -> t -> unit + + val encoding : t Data_encoding.t + + val pp : Format.formatter -> t -> unit end module Tez = Tez_repr @@ -38,61 +42,77 @@ module Period = Period_repr module Timestamp = struct include Time_repr + let current = Raw_context.current_timestamp end include Operation_repr + module Operation = struct type 'kind t = 'kind operation = { - shell: Operation.shell_header ; - protocol_data: 'kind protocol_data ; + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; } + type packed = packed_operation + let unsigned_encoding = unsigned_operation_encoding + include Operation_repr end + module Block_header = Block_header_repr + module Vote = struct include Vote_repr include Vote_storage end + module Raw_level = Raw_level_repr module Cycle = Cycle_repr module Script_int = Script_int_repr + module Script_timestamp = struct include Script_timestamp_repr + let now ctxt = - let { Constants_repr.time_between_blocks ; _ } = - Raw_context.constants ctxt in + let {Constants_repr.time_between_blocks; _} = Raw_context.constants ctxt in match time_between_blocks with - | [] -> failwith "Internal error: 'time_between_block' constants \ - is an empty list." + | [] -> + failwith + "Internal error: 'time_between_block' constants is an empty list." | first_delay :: _ -> let current_timestamp = Raw_context.predecessor_timestamp ctxt in Time.add current_timestamp (Period_repr.to_seconds first_delay) - |> Timestamp.to_seconds - |> of_int64 + |> Timestamp.to_seconds |> of_int64 end + module Script = struct include Michelson_v1_primitives include Script_repr + let force_decode ctxt lexpr = Lwt.return - (Script_repr.force_decode lexpr >>? fun (v, cost) -> - Raw_context.consume_gas ctxt cost >|? fun ctxt -> - (v, ctxt)) + ( Script_repr.force_decode lexpr + >>? fun (v, cost) -> + Raw_context.consume_gas ctxt cost >|? fun ctxt -> (v, ctxt) ) + let force_bytes ctxt lexpr = Lwt.return - (Script_repr.force_bytes lexpr >>? fun (b, cost) -> - Raw_context.consume_gas ctxt cost >|? fun ctxt -> - (b, ctxt)) + ( Script_repr.force_bytes lexpr + >>? fun (b, cost) -> + Raw_context.consume_gas ctxt cost >|? fun ctxt -> (b, ctxt) ) + module Legacy_support = Legacy_script_support_repr end + module Fees = Fees_storage type public_key = Signature.Public_key.t + type public_key_hash = Signature.Public_key_hash.t -type signature = Signature.t + +type signature = Signature.t module Constants = struct include Constants_repr @@ -103,66 +123,95 @@ module Voting_period = Voting_period_repr module Gas = struct include Gas_limit_repr + type error += Gas_limit_too_high = Raw_context.Gas_limit_too_high + let check_limit = Raw_context.check_gas_limit + let set_limit = Raw_context.set_gas_limit + let set_unlimited = Raw_context.set_gas_unlimited + let consume = Raw_context.consume_gas + let check_enough = Raw_context.check_enough_gas + let level = Raw_context.gas_level + let consumed = Raw_context.gas_consumed + let block_level = Raw_context.block_gas_level end + module Level = struct include Level_repr include Level_storage end + module Contract = struct include Contract_repr include Contract_storage let originate c contract ~balance ~script ~delegate = originate c contract ~balance ~script ~delegate + let init_origination_nonce = Raw_context.init_origination_nonce + let unset_origination_nonce = Raw_context.unset_origination_nonce end + module Big_map = struct type id = Z.t + let fresh = Storage.Big_map.Next.incr + let fresh_temporary = Raw_context.fresh_temporary_big_map + let mem c m k = Storage.Big_map.Contents.mem (c, m) k + let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k + let rpc_arg = Storage.Big_map.rpc_arg + let cleanup_temporary c = - Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c >>= fun c -> - Lwt.return (Raw_context.reset_temporary_big_map c) + Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c + >>= fun c -> Lwt.return (Raw_context.reset_temporary_big_map c) + let exists c id = - Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) >>=? fun c -> - Storage.Big_map.Key_type.get_option c id >>=? fun kt -> + Lwt.return + (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) + >>=? fun c -> + Storage.Big_map.Key_type.get_option c id + >>=? fun kt -> match kt with - | None -> return (c, None) + | None -> + return (c, None) | Some kt -> - Storage.Big_map.Value_type.get c id >>=? fun kv -> - return (c, Some (kt, kv)) + Storage.Big_map.Value_type.get c id + >>=? fun kv -> return (c, Some (kt, kv)) end + module Delegate = Delegate_storage + module Roll = struct include Roll_repr include Roll_storage end + module Nonce = Nonce_storage + module Seed = struct include Seed_repr include Seed_storage end module Fitness = struct - include Fitness_repr include Fitness - type fitness = t - include Fitness_storage + type fitness = t + + include Fitness_storage end module Bootstrap = Bootstrap_storage @@ -174,39 +223,57 @@ end module Global = struct let get_block_priority = Storage.Block_priority.get + let set_block_priority = Storage.Block_priority.set end let prepare_first_block = Init_storage.prepare_first_block + let prepare = Init_storage.prepare let finalize ?commit_message:message c = let fitness = Fitness.from_int64 (Fitness.current c) in let context = Raw_context.recover c in - { Updater.context ; fitness ; message ; max_operations_ttl = 60 ; + { + Updater.context; + fitness; + message; + max_operations_ttl = 60; last_allowed_fork_level = Raw_level.to_int32 @@ Level.last_allowed_fork_level c; } let activate = Raw_context.activate + let fork_test_chain = Raw_context.fork_test_chain let record_endorsement = Raw_context.record_endorsement + let allowed_endorsements = Raw_context.allowed_endorsements + let init_endorsements = Raw_context.init_endorsements + let included_endorsements = Raw_context.included_endorsements let reset_internal_nonce = Raw_context.reset_internal_nonce + let fresh_internal_nonce = Raw_context.fresh_internal_nonce + let record_internal_nonce = Raw_context.record_internal_nonce -let internal_nonce_already_recorded = Raw_context.internal_nonce_already_recorded + +let internal_nonce_already_recorded = + Raw_context.internal_nonce_already_recorded let add_deposit = Raw_context.add_deposit + let add_fees = Raw_context.add_fees + let add_rewards = Raw_context.add_rewards let get_deposits = Raw_context.get_deposits + let get_fees = Raw_context.get_fees + let get_rewards = Raw_context.get_rewards let description = Raw_context.description diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli index 73dcb59ea..17e32aa76 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli @@ -25,169 +25,229 @@ module type BASIC_DATA = sig type t + include Compare.S with type t := t - val encoding: t Data_encoding.t - val pp: Format.formatter -> t -> unit + + val encoding : t Data_encoding.t + + val pp : Format.formatter -> t -> unit end type t = Raw_context.t + type context = t type public_key = Signature.Public_key.t + type public_key_hash = Signature.Public_key_hash.t + type signature = Signature.t module Tez : sig - include BASIC_DATA + type tez = t - val zero: tez - val one_mutez: tez - val one_cent: tez - val fifty_cents: tez - val one: tez + val zero : tez + + val one_mutez : tez + + val one_cent : tez + + val fifty_cents : tez + + val one : tez val ( -? ) : tez -> tez -> tez tzresult + val ( +? ) : tez -> tez -> tez tzresult + val ( *? ) : tez -> int64 -> tez tzresult + val ( /? ) : tez -> int64 -> tez tzresult - val of_string: string -> tez option - val to_string: tez -> string + val of_string : string -> tez option - val of_mutez: int64 -> tez option - val to_mutez: tez -> int64 + val to_string : tez -> string + val of_mutez : int64 -> tez option + + val to_mutez : tez -> int64 end module Period : sig - include BASIC_DATA + type period = t - val rpc_arg: period RPC_arg.arg - val of_seconds: int64 -> period tzresult - val to_seconds: period -> int64 - val mult: int32 -> period -> period tzresult + val rpc_arg : period RPC_arg.arg - val zero: period - val one_second: period - val one_minute: period - val one_hour: period + val of_seconds : int64 -> period tzresult + val to_seconds : period -> int64 + + val mult : int32 -> period -> period tzresult + + val zero : period + + val one_second : period + + val one_minute : period + + val one_hour : period end module Timestamp : sig - include BASIC_DATA with type t = Time.t + type time = t - val (+?) : time -> Period.t -> time tzresult - val (-?) : time -> time -> Period.t tzresult - val of_notation: string -> time option - val to_notation: time -> string + val ( +? ) : time -> Period.t -> time tzresult - val of_seconds: string -> time option - val to_seconds_string: time -> string + val ( -? ) : time -> time -> Period.t tzresult - val current: context -> time + val of_notation : string -> time option + val to_notation : time -> string + + val of_seconds : string -> time option + + val to_seconds_string : time -> string + + val current : context -> time end module Raw_level : sig - include BASIC_DATA + type raw_level = t - val rpc_arg: raw_level RPC_arg.arg - val diff: raw_level -> raw_level -> int32 + val rpc_arg : raw_level RPC_arg.arg - val root: raw_level - val succ: raw_level -> raw_level - val pred: raw_level -> raw_level option - val to_int32: raw_level -> int32 - val of_int32: int32 -> raw_level tzresult + val diff : raw_level -> raw_level -> int32 + val root : raw_level + + val succ : raw_level -> raw_level + + val pred : raw_level -> raw_level option + + val to_int32 : raw_level -> int32 + + val of_int32 : int32 -> raw_level tzresult end module Cycle : sig - include BASIC_DATA - type cycle = t - val rpc_arg: cycle RPC_arg.arg - val root: cycle - val succ: cycle -> cycle - val pred: cycle -> cycle option - val add: cycle -> int -> cycle - val sub: cycle -> int -> cycle option - val to_int32: cycle -> int32 + type cycle = t + + val rpc_arg : cycle RPC_arg.arg + + val root : cycle + + val succ : cycle -> cycle + + val pred : cycle -> cycle option + + val add : cycle -> int -> cycle + + val sub : cycle -> int -> cycle option + + val to_int32 : cycle -> int32 module Map : S.MAP with type key = cycle - end module Gas : sig - type t = private - | Unaccounted - | Limited of { remaining : Z.t } + type t = private Unaccounted | Limited of {remaining : Z.t} val encoding : t Data_encoding.encoding + val pp : Format.formatter -> t -> unit type cost val cost_encoding : cost Data_encoding.encoding + val pp_cost : Format.formatter -> cost -> unit type error += Block_quota_exceeded (* `Temporary *) + type error += Operation_quota_exceeded (* `Temporary *) + type error += Gas_limit_too_high (* `Permanent *) val free : cost + val atomic_step_cost : int -> cost + val step_cost : int -> cost + val alloc_cost : int -> cost + val alloc_bytes_cost : int -> cost + val alloc_mbytes_cost : int -> cost + val alloc_bits_cost : int -> cost + val read_bytes_cost : Z.t -> cost + val write_bytes_cost : Z.t -> cost val ( *@ ) : int -> cost -> cost + val ( +@ ) : cost -> cost -> cost - val check_limit: context -> Z.t -> unit tzresult - val set_limit: context -> Z.t -> context - val set_unlimited: context -> context - val consume: context -> cost -> context tzresult - val check_enough: context -> cost -> unit tzresult - val level: context -> t - val consumed: since: context -> until: context -> Z.t - val block_level: context -> Z.t + val check_limit : context -> Z.t -> unit tzresult + + val set_limit : context -> Z.t -> context + + val set_unlimited : context -> context + + val consume : context -> cost -> context tzresult + + val check_enough : context -> cost -> unit tzresult + + val level : context -> t + + val consumed : since:context -> until:context -> Z.t + + val block_level : context -> Z.t end module Script_int : module type of Script_int_repr module Script_timestamp : sig open Script_int + type t - val compare: t -> t -> int - val to_string: t -> string - val to_notation: t -> string option - val to_num_str: t -> string - val of_string: string -> t option - val diff: t -> t -> z num - val add_delta: t -> z num -> t - val sub_delta: t -> z num -> t - val now: context -> t - val to_zint: t -> Z.t - val of_zint: Z.t -> t + + val compare : t -> t -> int + + val to_string : t -> string + + val to_notation : t -> string option + + val to_num_str : t -> string + + val of_string : string -> t option + + val diff : t -> t -> z num + + val add_delta : t -> z num -> t + + val sub_delta : t -> z num -> t + + val now : context -> t + + val to_zint : t -> Z.t + + val of_zint : Z.t -> t end module Script : sig - type prim = Michelson_v1_primitives.prim = | K_parameter | K_storage @@ -308,7 +368,6 @@ module Script : sig | T_address | T_chain_id - type location = Micheline.canonical_location type annot = Micheline.annot @@ -321,377 +380,449 @@ module Script : sig type node = (location, prim) Micheline.node - type t = - { code: lazy_expr ; - storage: lazy_expr } + type t = {code : lazy_expr; storage : lazy_expr} + + val location_encoding : location Data_encoding.t + + val expr_encoding : expr Data_encoding.t + + val prim_encoding : prim Data_encoding.t + + val encoding : t Data_encoding.t + + val lazy_expr_encoding : lazy_expr Data_encoding.t - val location_encoding: location Data_encoding.t - val expr_encoding: expr Data_encoding.t - val prim_encoding: prim Data_encoding.t - val encoding: t Data_encoding.t - val lazy_expr_encoding: lazy_expr Data_encoding.t val deserialized_cost : expr -> Gas.cost + val serialized_cost : MBytes.t -> Gas.cost + val traversal_cost : node -> Gas.cost + val node_cost : node -> Gas.cost + val int_node_cost : Z.t -> Gas.cost + val int_node_cost_of_numbits : int -> Gas.cost + val string_node_cost : string -> Gas.cost + val string_node_cost_of_length : int -> Gas.cost + val bytes_node_cost : MBytes.t -> Gas.cost + val bytes_node_cost_of_length : int -> Gas.cost - val prim_node_cost_nonrec : expr list -> annot -> Gas.cost + + val prim_node_cost_nonrec : expr list -> annot -> Gas.cost + val prim_node_cost_nonrec_of_length : int -> annot -> Gas.cost + val seq_node_cost_nonrec : expr list -> Gas.cost + val seq_node_cost_nonrec_of_length : int -> Gas.cost + val minimal_deserialize_cost : lazy_expr -> Gas.cost + val force_decode : context -> lazy_expr -> (expr * context) tzresult Lwt.t + val force_bytes : context -> lazy_expr -> (MBytes.t * context) tzresult Lwt.t val unit_parameter : lazy_expr module Legacy_support : sig - val manager_script_code: lazy_expr - val add_do: - manager_pkh: Signature.Public_key_hash.t -> - script_code: lazy_expr -> - script_storage: lazy_expr -> - (lazy_expr * lazy_expr) tzresult Lwt.t - val add_set_delegate: - manager_pkh: Signature.Public_key_hash.t -> - script_code: lazy_expr -> - script_storage: lazy_expr -> - (lazy_expr * lazy_expr) tzresult Lwt.t - val has_default_entrypoint: lazy_expr -> bool - val add_root_entrypoint: - script_code: lazy_expr -> - lazy_expr tzresult Lwt.t - end + val manager_script_code : lazy_expr + val add_do : + manager_pkh:Signature.Public_key_hash.t -> + script_code:lazy_expr -> + script_storage:lazy_expr -> + (lazy_expr * lazy_expr) tzresult Lwt.t + + val add_set_delegate : + manager_pkh:Signature.Public_key_hash.t -> + script_code:lazy_expr -> + script_storage:lazy_expr -> + (lazy_expr * lazy_expr) tzresult Lwt.t + + val has_default_entrypoint : lazy_expr -> bool + + val add_root_entrypoint : script_code:lazy_expr -> lazy_expr tzresult Lwt.t + end end module Constants : sig - (** Fixed constants *) type fixed = { - proof_of_work_nonce_size : int ; - nonce_length : int ; - max_revelations_per_block : int ; - max_operation_data_length : int ; - max_proposals_per_delegate : int ; + proof_of_work_nonce_size : int; + nonce_length : int; + max_revelations_per_block : int; + max_operation_data_length : int; + max_proposals_per_delegate : int; } - val fixed_encoding: fixed Data_encoding.t - val fixed: fixed - val proof_of_work_nonce_size: int - val nonce_length: int - val max_revelations_per_block: int - val max_operation_data_length: int - val max_proposals_per_delegate: int + val fixed_encoding : fixed Data_encoding.t + + val fixed : fixed + + val proof_of_work_nonce_size : int + + val nonce_length : int + + val max_revelations_per_block : int + + val max_operation_data_length : int + + val max_proposals_per_delegate : int (** Constants parameterized by context *) type parametric = { - preserved_cycles: int ; - blocks_per_cycle: int32 ; - blocks_per_commitment: int32 ; - blocks_per_roll_snapshot: int32 ; - blocks_per_voting_period: int32 ; - time_between_blocks: Period.t list ; - endorsers_per_block: int ; - hard_gas_limit_per_operation: Z.t ; - hard_gas_limit_per_block: Z.t ; - proof_of_work_threshold: int64 ; - tokens_per_roll: Tez.t ; - michelson_maximum_type_size: int; - seed_nonce_revelation_tip: Tez.t ; - origination_size: int ; - block_security_deposit: Tez.t ; - endorsement_security_deposit: Tez.t ; - block_reward: Tez.t ; - endorsement_reward: Tez.t ; - cost_per_byte: Tez.t ; - hard_storage_limit_per_operation: Z.t ; - test_chain_duration: int64; - quorum_min: int32 ; - quorum_max: int32 ; - min_proposal_quorum : int32 ; - initial_endorsers: int ; - delay_per_missing_endorsement : Period.t ; + preserved_cycles : int; + blocks_per_cycle : int32; + blocks_per_commitment : int32; + blocks_per_roll_snapshot : int32; + blocks_per_voting_period : int32; + time_between_blocks : Period.t list; + endorsers_per_block : int; + hard_gas_limit_per_operation : Z.t; + hard_gas_limit_per_block : Z.t; + proof_of_work_threshold : int64; + tokens_per_roll : Tez.t; + michelson_maximum_type_size : int; + seed_nonce_revelation_tip : Tez.t; + origination_size : int; + block_security_deposit : Tez.t; + endorsement_security_deposit : Tez.t; + baking_reward_per_endorsement : Tez.t list; + endorsement_reward : Tez.t list; + cost_per_byte : Tez.t; + hard_storage_limit_per_operation : Z.t; + test_chain_duration : int64; + quorum_min : int32; + quorum_max : int32; + min_proposal_quorum : int32; + initial_endorsers : int; + delay_per_missing_endorsement : Period.t; } - val parametric_encoding: parametric Data_encoding.t - val parametric: context -> parametric - val preserved_cycles: context -> int - val blocks_per_cycle: context -> int32 - val blocks_per_commitment: context -> int32 - val blocks_per_roll_snapshot: context -> int32 - val blocks_per_voting_period: context -> int32 - val time_between_blocks: context -> Period.t list - val endorsers_per_block: context -> int - val initial_endorsers: context -> int - val delay_per_missing_endorsement: context -> Period.t - val hard_gas_limit_per_operation: context -> Z.t - val hard_gas_limit_per_block: context -> Z.t - val cost_per_byte: context -> Tez.t - val hard_storage_limit_per_operation: context -> Z.t - val proof_of_work_threshold: context -> int64 - val tokens_per_roll: context -> Tez.t - val michelson_maximum_type_size: context -> int - val block_reward: context -> Tez.t - val endorsement_reward: context -> Tez.t - val seed_nonce_revelation_tip: context -> Tez.t - val origination_size: context -> int - val block_security_deposit: context -> Tez.t - val endorsement_security_deposit: context -> Tez.t - val test_chain_duration: context -> int64 - val quorum_min: context -> int32 - val quorum_max: context -> int32 - val min_proposal_quorum: context -> int32 + + val parametric_encoding : parametric Data_encoding.t + + val parametric : context -> parametric + + val preserved_cycles : context -> int + + val blocks_per_cycle : context -> int32 + + val blocks_per_commitment : context -> int32 + + val blocks_per_roll_snapshot : context -> int32 + + val blocks_per_voting_period : context -> int32 + + val time_between_blocks : context -> Period.t list + + val endorsers_per_block : context -> int + + val initial_endorsers : context -> int + + val delay_per_missing_endorsement : context -> Period.t + + val hard_gas_limit_per_operation : context -> Z.t + + val hard_gas_limit_per_block : context -> Z.t + + val cost_per_byte : context -> Tez.t + + val hard_storage_limit_per_operation : context -> Z.t + + val proof_of_work_threshold : context -> int64 + + val tokens_per_roll : context -> Tez.t + + val michelson_maximum_type_size : context -> int + + val baking_reward_per_endorsement : context -> Tez.t list + + val endorsement_reward : context -> Tez.t list + + val seed_nonce_revelation_tip : context -> Tez.t + + val origination_size : context -> int + + val block_security_deposit : context -> Tez.t + + val endorsement_security_deposit : context -> Tez.t + + val test_chain_duration : context -> int64 + + val quorum_min : context -> int32 + + val quorum_max : context -> int32 + + val min_proposal_quorum : context -> int32 (** All constants: fixed and parametric *) - type t = { - fixed : fixed ; - parametric : parametric ; - } - val encoding: t Data_encoding.t + type t = {fixed : fixed; parametric : parametric} + val encoding : t Data_encoding.t end module Voting_period : sig - include BASIC_DATA + type voting_period = t - val rpc_arg: voting_period RPC_arg.arg - val root: voting_period - val succ: voting_period -> voting_period + val rpc_arg : voting_period RPC_arg.arg - type kind = - | Proposal - | Testing_vote - | Testing - | Promotion_vote - val kind_encoding: kind Data_encoding.encoding - val to_int32: voting_period -> int32 + val root : voting_period + val succ : voting_period -> voting_period + + type kind = Proposal | Testing_vote | Testing | Promotion_vote + + val kind_encoding : kind Data_encoding.encoding + + val to_int32 : voting_period -> int32 end module Level : sig - type t = private { - level: Raw_level.t ; - level_position: int32 ; - cycle: Cycle.t ; - cycle_position: int32 ; - voting_period: Voting_period.t ; - voting_period_position: int32 ; - expected_commitment: bool ; + level : Raw_level.t; + level_position : int32; + cycle : Cycle.t; + cycle_position : int32; + voting_period : Voting_period.t; + voting_period_position : int32; + expected_commitment : bool; } + include BASIC_DATA with type t := t - val pp_full: Format.formatter -> t -> unit + + val pp_full : Format.formatter -> t -> unit + type level = t - val root: context -> level + val root : context -> level - val succ: context -> level -> level - val pred: context -> level -> level option + val succ : context -> level -> level - val from_raw: context -> ?offset:int32 -> Raw_level.t -> level + val pred : context -> level -> level option - val diff: level -> level -> int32 + val from_raw : context -> ?offset:int32 -> Raw_level.t -> level - val current: context -> level + val diff : level -> level -> int32 - val last_level_in_cycle: context -> Cycle.t -> level - val levels_in_cycle: context -> Cycle.t -> level list - val levels_in_current_cycle: context -> ?offset:int32 -> unit -> level list + val current : context -> level - val last_allowed_fork_level: context -> Raw_level.t + val last_level_in_cycle : context -> Cycle.t -> level + val levels_in_cycle : context -> Cycle.t -> level list + + val levels_in_current_cycle : context -> ?offset:int32 -> unit -> level list + + val last_allowed_fork_level : context -> Raw_level.t end module Fitness : sig + include module type of Fitness - include (module type of Fitness) type fitness = t - val increase: ?gap:int -> context -> context + val increase : ?gap:int -> context -> context - val current: context -> int64 - - val to_int64: fitness -> int64 tzresult + val current : context -> int64 + val to_int64 : fitness -> int64 tzresult end module Nonce : sig - type t + type nonce = t - val encoding: nonce Data_encoding.t + + val encoding : nonce Data_encoding.t type unrevealed = { - nonce_hash: Nonce_hash.t ; - delegate: public_key_hash ; - rewards: Tez.t ; - fees: Tez.t ; + nonce_hash : Nonce_hash.t; + delegate : public_key_hash; + rewards : Tez.t; + fees : Tez.t; } - val record_hash: - context -> unrevealed -> context tzresult Lwt.t + val record_hash : context -> unrevealed -> context tzresult Lwt.t - val reveal: - context -> Level.t -> nonce -> - context tzresult Lwt.t + val reveal : context -> Level.t -> nonce -> context tzresult Lwt.t - type status = - | Unrevealed of unrevealed - | Revealed of nonce + type status = Unrevealed of unrevealed | Revealed of nonce - val get: context -> Level.t -> status tzresult Lwt.t + val get : context -> Level.t -> status tzresult Lwt.t - val of_bytes: MBytes.t -> nonce tzresult - val hash: nonce -> Nonce_hash.t - val check_hash: nonce -> Nonce_hash.t -> bool + val of_bytes : MBytes.t -> nonce tzresult + val hash : nonce -> Nonce_hash.t + + val check_hash : nonce -> Nonce_hash.t -> bool end module Seed : sig - type seed type error += - | Unknown of { oldest : Cycle.t ; - cycle : Cycle.t ; - latest : Cycle.t } + | Unknown of {oldest : Cycle.t; cycle : Cycle.t; latest : Cycle.t} - val for_cycle: - context -> Cycle.t -> seed tzresult Lwt.t + val for_cycle : context -> Cycle.t -> seed tzresult Lwt.t - val cycle_end: + val cycle_end : context -> Cycle.t -> (context * Nonce.unrevealed list) tzresult Lwt.t val seed_encoding : seed Data_encoding.t - end -module Big_map: sig +module Big_map : sig type id = Z.t + val fresh : context -> (context * id) tzresult Lwt.t + val fresh_temporary : context -> context * id - val mem : context -> id -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t - val get_opt : context -> id -> Script_expr_hash.t -> (context * Script.expr option) tzresult Lwt.t + + val mem : + context -> id -> Script_expr_hash.t -> (context * bool) tzresult Lwt.t + + val get_opt : + context -> + id -> + Script_expr_hash.t -> + (context * Script.expr option) tzresult Lwt.t + val rpc_arg : id RPC_arg.t + val cleanup_temporary : context -> context Lwt.t - val exists : context -> id -> (context * (Script.expr * Script.expr) option) tzresult Lwt.t + + val exists : + context -> + id -> + (context * (Script.expr * Script.expr) option) tzresult Lwt.t end module Contract : sig - include BASIC_DATA + type contract = t - val rpc_arg: contract RPC_arg.arg - val to_b58check: contract -> string - val of_b58check: string -> contract tzresult + val rpc_arg : contract RPC_arg.arg - val implicit_contract: public_key_hash -> contract - val is_implicit: contract -> public_key_hash option + val to_b58check : contract -> string - val exists: context -> contract -> bool tzresult Lwt.t - val must_exist: context -> contract -> unit tzresult Lwt.t + val of_b58check : string -> contract tzresult - val allocated: context -> contract -> bool tzresult Lwt.t - val must_be_allocated: context -> contract -> unit tzresult Lwt.t + val implicit_contract : public_key_hash -> contract - val list: context -> contract list Lwt.t + val is_implicit : contract -> public_key_hash option - val get_manager_key: - context -> public_key_hash -> public_key tzresult Lwt.t - val is_manager_key_revealed: + val exists : context -> contract -> bool tzresult Lwt.t + + val must_exist : context -> contract -> unit tzresult Lwt.t + + val allocated : context -> contract -> bool tzresult Lwt.t + + val must_be_allocated : context -> contract -> unit tzresult Lwt.t + + val list : context -> contract list Lwt.t + + val get_manager_key : context -> public_key_hash -> public_key tzresult Lwt.t + + val is_manager_key_revealed : context -> public_key_hash -> bool tzresult Lwt.t - val reveal_manager_key: + val reveal_manager_key : context -> public_key_hash -> public_key -> context tzresult Lwt.t - val get_script_code: + val get_script_code : context -> contract -> (context * Script.lazy_expr option) tzresult Lwt.t - val get_script: + + val get_script : context -> contract -> (context * Script.t option) tzresult Lwt.t - val get_storage: + + val get_storage : context -> contract -> (context * Script.expr option) tzresult Lwt.t - val get_counter: context -> public_key_hash -> Z.t tzresult Lwt.t - val get_balance: - context -> contract -> Tez.t tzresult Lwt.t + val get_counter : context -> public_key_hash -> Z.t tzresult Lwt.t - val init_origination_nonce: context -> Operation_hash.t -> context - val unset_origination_nonce: context -> context - val fresh_contract_from_current_nonce : context -> (context * t) tzresult Lwt.t - val originated_from_current_nonce: since: context -> until:context -> contract list tzresult Lwt.t + val get_balance : context -> contract -> Tez.t tzresult Lwt.t + + val init_origination_nonce : context -> Operation_hash.t -> context + + val unset_origination_nonce : context -> context + + val fresh_contract_from_current_nonce : + context -> (context * t) tzresult Lwt.t + + val originated_from_current_nonce : + since:context -> until:context -> contract list tzresult Lwt.t type big_map_diff_item = - | Update of { - big_map : Big_map.id ; - diff_key : Script.expr; - diff_key_hash : Script_expr_hash.t; - diff_value : Script.expr option; - } - | Clear of Big_map.id - | Copy of Big_map.id * Big_map.id - | Alloc of { - big_map : Big_map.id; - key_type : Script.expr; - value_type : Script.expr; - } + | Update of { + big_map : Big_map.id; + diff_key : Script.expr; + diff_key_hash : Script_expr_hash.t; + diff_value : Script.expr option; + } + | Clear of Big_map.id + | Copy of Big_map.id * Big_map.id + | Alloc of { + big_map : Big_map.id; + key_type : Script.expr; + value_type : Script.expr; + } + type big_map_diff = big_map_diff_item list + val big_map_diff_encoding : big_map_diff Data_encoding.t - val originate: - context -> contract -> - balance: Tez.t -> - script: (Script.t * big_map_diff option) -> - delegate: public_key_hash option -> + val originate : + context -> + contract -> + balance:Tez.t -> + script:Script.t * big_map_diff option -> + delegate:public_key_hash option -> context tzresult Lwt.t type error += Balance_too_low of contract * Tez.t * Tez.t - val spend: - context -> contract -> Tez.t -> context tzresult Lwt.t + val spend : context -> contract -> Tez.t -> context tzresult Lwt.t - val credit: - context -> contract -> Tez.t -> context tzresult Lwt.t + val credit : context -> contract -> Tez.t -> context tzresult Lwt.t - val update_script_storage: - context -> contract -> - Script.expr -> big_map_diff option -> + val update_script_storage : + context -> + contract -> + Script.expr -> + big_map_diff option -> context tzresult Lwt.t - val used_storage_space: context -> t -> Z.t tzresult Lwt.t + val used_storage_space : context -> t -> Z.t tzresult Lwt.t - val increment_counter: - context -> public_key_hash -> context tzresult Lwt.t + val increment_counter : context -> public_key_hash -> context tzresult Lwt.t - val check_counter_increment: + val check_counter_increment : context -> public_key_hash -> Z.t -> unit tzresult Lwt.t (**/**) + (* Only for testing *) type origination_nonce - val initial_origination_nonce : Operation_hash.t -> origination_nonce - val originated_contract : origination_nonce -> contract + val initial_origination_nonce : Operation_hash.t -> origination_nonce + + val originated_contract : origination_nonce -> contract end module Delegate : sig - type balance = | Contract of Contract.t | Rewards of Signature.Public_key_hash.t * Cycle.t | Fees of Signature.Public_key_hash.t * Cycle.t | Deposits of Signature.Public_key_hash.t * Cycle.t - type balance_update = - | Debited of Tez.t - | Credited of Tez.t + type balance_update = Debited of Tez.t | Credited of Tez.t type balance_updates = (balance * balance_update) list @@ -699,190 +830,197 @@ module Delegate : sig val cleanup_balance_updates : balance_updates -> balance_updates - val get: context -> Contract.t -> public_key_hash option tzresult Lwt.t + val get : context -> Contract.t -> public_key_hash option tzresult Lwt.t - val set: + val set : context -> Contract.t -> public_key_hash option -> context tzresult Lwt.t - val fold: + val fold : + context -> init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t + + val list : context -> public_key_hash list Lwt.t + + val freeze_deposit : + context -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val freeze_rewards : + context -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val freeze_fees : + context -> public_key_hash -> Tez.t -> context tzresult Lwt.t + + val cycle_end : context -> - init:'a -> f:(public_key_hash -> 'a -> 'a Lwt.t) -> 'a Lwt.t + Cycle.t -> + Nonce.unrevealed list -> + (context * balance_updates * Signature.Public_key_hash.t list) tzresult + Lwt.t - val list: context -> public_key_hash list Lwt.t + type frozen_balance = {deposit : Tez.t; fees : Tez.t; rewards : Tez.t} - val freeze_deposit: - context -> public_key_hash -> Tez.t -> context tzresult Lwt.t - - val freeze_rewards: - context -> public_key_hash -> Tez.t -> context tzresult Lwt.t - - val freeze_fees: - context -> public_key_hash -> Tez.t -> context tzresult Lwt.t - - val cycle_end: - context -> Cycle.t -> Nonce.unrevealed list -> - (context * balance_updates * Signature.Public_key_hash.t list) tzresult Lwt.t - - type frozen_balance = { - deposit : Tez.t ; - fees : Tez.t ; - rewards : Tez.t ; - } - - val punish: - context -> public_key_hash -> Cycle.t -> + val punish : + context -> + public_key_hash -> + Cycle.t -> (context * frozen_balance) tzresult Lwt.t - val full_balance: - context -> public_key_hash -> Tez.t tzresult Lwt.t + val full_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t - val has_frozen_balance: - context -> public_key_hash -> Cycle.t -> - bool tzresult Lwt.t + val has_frozen_balance : + context -> public_key_hash -> Cycle.t -> bool tzresult Lwt.t - val frozen_balance: - context -> public_key_hash -> Tez.t tzresult Lwt.t + val frozen_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t - val frozen_balance_encoding: frozen_balance Data_encoding.t - val frozen_balance_by_cycle_encoding: frozen_balance Cycle.Map.t Data_encoding.t + val frozen_balance_encoding : frozen_balance Data_encoding.t - val frozen_balance_by_cycle: - context -> Signature.Public_key_hash.t -> - frozen_balance Cycle.Map.t Lwt.t + val frozen_balance_by_cycle_encoding : + frozen_balance Cycle.Map.t Data_encoding.t - val staking_balance: - context -> Signature.Public_key_hash.t -> - Tez.t tzresult Lwt.t + val frozen_balance_by_cycle : + context -> Signature.Public_key_hash.t -> frozen_balance Cycle.Map.t Lwt.t - val delegated_contracts: - context -> Signature.Public_key_hash.t -> - Contract_repr.t list Lwt.t + val staking_balance : + context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t - val delegated_balance: - context -> Signature.Public_key_hash.t -> - Tez.t tzresult Lwt.t + val delegated_contracts : + context -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t - val deactivated: - context -> Signature.Public_key_hash.t -> - bool tzresult Lwt.t + val delegated_balance : + context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t - val grace_period: - context -> Signature.Public_key_hash.t -> - Cycle.t tzresult Lwt.t + val deactivated : + context -> Signature.Public_key_hash.t -> bool tzresult Lwt.t + val grace_period : + context -> Signature.Public_key_hash.t -> Cycle.t tzresult Lwt.t end module Vote : sig - type proposal = Protocol_hash.t - val record_proposal: - context -> Protocol_hash.t -> public_key_hash -> - context tzresult Lwt.t - val get_proposals: - context -> int32 Protocol_hash.Map.t tzresult Lwt.t - val clear_proposals: context -> context Lwt.t + val record_proposal : + context -> Protocol_hash.t -> public_key_hash -> context tzresult Lwt.t - val recorded_proposal_count_for_delegate: + val get_proposals : context -> int32 Protocol_hash.Map.t tzresult Lwt.t + + val clear_proposals : context -> context Lwt.t + + val recorded_proposal_count_for_delegate : context -> public_key_hash -> int tzresult Lwt.t - val listings_encoding : (Signature.Public_key_hash.t * int32) list Data_encoding.t - val freeze_listings: context -> context tzresult Lwt.t - val clear_listings: context -> context tzresult Lwt.t - val listing_size: context -> int32 tzresult Lwt.t - val in_listings: context -> public_key_hash -> bool Lwt.t + val listings_encoding : + (Signature.Public_key_hash.t * int32) list Data_encoding.t + + val freeze_listings : context -> context tzresult Lwt.t + + val clear_listings : context -> context tzresult Lwt.t + + val listing_size : context -> int32 tzresult Lwt.t + + val in_listings : context -> public_key_hash -> bool Lwt.t + val get_listings : context -> (public_key_hash * int32) list Lwt.t type ballot = Yay | Nay | Pass + val ballot_encoding : ballot Data_encoding.t - type ballots = { - yay: int32 ; - nay: int32 ; - pass: int32 ; - } + type ballots = {yay : int32; nay : int32; pass : int32} val ballots_encoding : ballots Data_encoding.t - val has_recorded_ballot : - context -> public_key_hash -> bool Lwt.t - val record_ballot: - context -> public_key_hash -> ballot -> context tzresult Lwt.t - val get_ballots: context -> ballots tzresult Lwt.t - val get_ballot_list: context -> (Signature.Public_key_hash.t * ballot) list Lwt.t - val clear_ballots: context -> context Lwt.t + val has_recorded_ballot : context -> public_key_hash -> bool Lwt.t - val get_current_period_kind: - context -> Voting_period.kind tzresult Lwt.t - val set_current_period_kind: + val record_ballot : + context -> public_key_hash -> ballot -> context tzresult Lwt.t + + val get_ballots : context -> ballots tzresult Lwt.t + + val get_ballot_list : + context -> (Signature.Public_key_hash.t * ballot) list Lwt.t + + val clear_ballots : context -> context Lwt.t + + val get_current_period_kind : context -> Voting_period.kind tzresult Lwt.t + + val set_current_period_kind : context -> Voting_period.kind -> context tzresult Lwt.t - val get_current_quorum: context -> int32 tzresult Lwt.t + val get_current_quorum : context -> int32 tzresult Lwt.t - val get_participation_ema: context -> int32 tzresult Lwt.t - val set_participation_ema: context -> int32 -> context tzresult Lwt.t + val get_participation_ema : context -> int32 tzresult Lwt.t - val get_current_proposal: - context -> proposal tzresult Lwt.t - val init_current_proposal: - context -> proposal -> context tzresult Lwt.t - val clear_current_proposal: - context -> context tzresult Lwt.t + val set_participation_ema : context -> int32 -> context tzresult Lwt.t + val get_current_proposal : context -> proposal tzresult Lwt.t + + val init_current_proposal : context -> proposal -> context tzresult Lwt.t + + val clear_current_proposal : context -> context tzresult Lwt.t end module Block_header : sig + type t = {shell : Block_header.shell_header; protocol_data : protocol_data} - type t = { - shell: Block_header.shell_header ; - protocol_data: protocol_data ; - } - - and protocol_data = { - contents: contents ; - signature: Signature.t ; - } + and protocol_data = {contents : contents; signature : Signature.t} and contents = { - priority: int ; - seed_nonce_hash: Nonce_hash.t option ; - proof_of_work_nonce: MBytes.t ; + priority : int; + seed_nonce_hash : Nonce_hash.t option; + proof_of_work_nonce : MBytes.t; } type block_header = t type raw = Block_header.t + type shell_header = Block_header.shell_header - val raw: block_header -> raw + val raw : block_header -> raw - val hash: block_header -> Block_hash.t - val hash_raw: raw -> Block_hash.t + val hash : block_header -> Block_hash.t - val encoding: block_header Data_encoding.encoding - val raw_encoding: raw Data_encoding.t - val contents_encoding: contents Data_encoding.t - val unsigned_encoding: (shell_header * contents) Data_encoding.t - val protocol_data_encoding: protocol_data Data_encoding.encoding - val shell_header_encoding: shell_header Data_encoding.encoding + val hash_raw : raw -> Block_hash.t + + val encoding : block_header Data_encoding.encoding + + val raw_encoding : raw Data_encoding.t + + val contents_encoding : contents Data_encoding.t + + val unsigned_encoding : (shell_header * contents) Data_encoding.t + + val protocol_data_encoding : protocol_data Data_encoding.encoding + + val shell_header_encoding : shell_header Data_encoding.encoding - val max_header_length: int (** The maximum size of block headers in bytes *) - + val max_header_length : int end module Kind : sig type seed_nonce_revelation = Seed_nonce_revelation_kind + type double_endorsement_evidence = Double_endorsement_evidence_kind + type double_baking_evidence = Double_baking_evidence_kind + type activate_account = Activate_account_kind + type endorsement = Endorsement_kind + type proposals = Proposals_kind + type ballot = Ballot_kind + type reveal = Reveal_kind + type transaction = Transaction_kind + type origination = Origination_kind + type delegation = Delegation_kind + type 'a manager = | Reveal_manager_kind : reveal manager | Transaction_manager_kind : transaction manager @@ -891,90 +1029,98 @@ module Kind : sig end type 'kind operation = { - shell: Operation.shell_header ; - protocol_data: 'kind protocol_data ; + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; } and 'kind protocol_data = { - contents: 'kind contents_list ; - signature: Signature.t option ; + contents : 'kind contents_list; + signature : Signature.t option; } 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 + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list and _ contents = - | Endorsement : { - level: Raw_level.t ; - } -> Kind.endorsement contents + | Endorsement : {level : Raw_level.t} -> Kind.endorsement contents | Seed_nonce_revelation : { - level: Raw_level.t ; - nonce: Nonce.t ; - } -> Kind.seed_nonce_revelation contents + level : Raw_level.t; + nonce : Nonce.t; + } + -> Kind.seed_nonce_revelation contents | Double_endorsement_evidence : { - op1: Kind.endorsement operation ; - op2: Kind.endorsement operation ; - } -> Kind.double_endorsement_evidence contents + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents | Double_baking_evidence : { - bh1: Block_header.t ; - bh2: Block_header.t ; - } -> Kind.double_baking_evidence contents + bh1 : Block_header.t; + bh2 : Block_header.t; + } + -> Kind.double_baking_evidence contents | Activate_account : { - id: Ed25519.Public_key_hash.t ; - activation_code: Blinded_public_key_hash.activation_code ; - } -> Kind.activate_account contents + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents | Proposals : { - source: Signature.Public_key_hash.t ; - period: Voting_period.t ; - proposals: Protocol_hash.t list ; - } -> Kind.proposals contents + source : Signature.Public_key_hash.t; + period : Voting_period.t; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents | Ballot : { - source: Signature.Public_key_hash.t ; - period: Voting_period.t ; - proposal: Protocol_hash.t ; - ballot: Vote.ballot ; - } -> Kind.ballot contents + source : Signature.Public_key_hash.t; + period : Voting_period.t; + proposal : Protocol_hash.t; + ballot : Vote.ballot; + } + -> Kind.ballot contents | Manager_operation : { - source: Signature.Public_key_hash.t ; - fee: Tez.tez ; - counter: counter ; - operation: 'kind manager_operation ; - gas_limit: Z.t; - storage_limit: Z.t; - } -> 'kind Kind.manager contents + source : Signature.Public_key_hash.t; + fee : Tez.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Z.t; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : { - amount: Tez.tez ; - parameters: Script.lazy_expr ; - entrypoint: string ; - destination: Contract.contract ; - } -> Kind.transaction manager_operation + amount : Tez.tez; + parameters : Script.lazy_expr; + entrypoint : string; + destination : Contract.contract; + } + -> Kind.transaction manager_operation | Origination : { - delegate: Signature.Public_key_hash.t option ; - script: Script.t ; - credit: Tez.tez ; - preorigination: Contract.t option ; - } -> Kind.origination manager_operation + delegate : Signature.Public_key_hash.t option; + script : Script.t; + credit : Tez.tez; + preorigination : Contract.t option; + } + -> Kind.origination manager_operation | Delegation : - Signature.Public_key_hash.t option -> Kind.delegation manager_operation + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation and counter = Z.t type 'kind internal_operation = { - source: Contract.contract ; - operation: 'kind manager_operation ; - nonce: int ; + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; } type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation -type packed_contents = - | Contents : 'kind contents -> packed_contents +type packed_contents = Contents : 'kind contents -> packed_contents type packed_contents_list = | Contents_list : 'kind contents_list -> packed_contents_list @@ -983,192 +1129,217 @@ type packed_protocol_data = | Operation_data : 'kind protocol_data -> packed_protocol_data type packed_operation = { - shell: Operation.shell_header ; - protocol_data: packed_protocol_data ; + shell : Operation.shell_header; + protocol_data : packed_protocol_data; } type packed_internal_operation = | Internal_operation : 'kind internal_operation -> packed_internal_operation -val manager_kind: 'kind manager_operation -> 'kind Kind.manager +val manager_kind : 'kind manager_operation -> 'kind Kind.manager module Fees : sig + val origination_burn : context -> (context * Tez.t) tzresult Lwt.t - val origination_burn: - context -> (context * Tez.t) tzresult Lwt.t - - val record_paid_storage_space: + val record_paid_storage_space : context -> Contract.t -> (context * Z.t * Z.t * Tez.t) tzresult Lwt.t - val start_counting_storage_fees : - context -> context + val start_counting_storage_fees : context -> context - val burn_storage_fees: + val burn_storage_fees : context -> storage_limit:Z.t -> payer:Contract.t -> context tzresult Lwt.t type error += Cannot_pay_storage_fee (* `Temporary *) + type error += Operation_quota_exceeded (* `Temporary *) + type error += Storage_limit_too_high (* `Permanent *) - val check_storage_limit: context -> storage_limit:Z.t -> unit tzresult - + val check_storage_limit : context -> storage_limit:Z.t -> unit tzresult end module Operation : sig - type nonrec 'kind contents = 'kind contents + type nonrec packed_contents = packed_contents - val contents_encoding: packed_contents Data_encoding.t + + val contents_encoding : packed_contents Data_encoding.t type nonrec 'kind protocol_data = 'kind protocol_data - type nonrec packed_protocol_data = packed_protocol_data - val protocol_data_encoding: packed_protocol_data Data_encoding.t - val unsigned_encoding: (Operation.shell_header * packed_contents_list) Data_encoding.t - type raw = Operation.t = { - shell: Operation.shell_header ; - proto: MBytes.t ; - } - val raw_encoding: raw Data_encoding.t - val contents_list_encoding: packed_contents_list Data_encoding.t + type nonrec packed_protocol_data = packed_protocol_data + + val protocol_data_encoding : packed_protocol_data Data_encoding.t + + val unsigned_encoding : + (Operation.shell_header * packed_contents_list) Data_encoding.t + + type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t} + + val raw_encoding : raw Data_encoding.t + + val contents_list_encoding : packed_contents_list Data_encoding.t type 'kind t = 'kind operation = { - shell: Operation.shell_header ; - protocol_data: 'kind protocol_data ; + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; } + type nonrec packed = packed_operation - val encoding: packed Data_encoding.t - val raw: _ operation -> raw + val encoding : packed Data_encoding.t - val hash: _ operation -> Operation_hash.t - val hash_raw: raw -> Operation_hash.t - val hash_packed: packed_operation -> Operation_hash.t + val raw : _ operation -> raw - val acceptable_passes: packed_operation -> int list + val hash : _ operation -> Operation_hash.t + + val hash_raw : raw -> Operation_hash.t + + val hash_packed : packed_operation -> Operation_hash.t + + val acceptable_passes : packed_operation -> int list type error += Missing_signature (* `Permanent *) + type error += Invalid_signature (* `Permanent *) - val check_signature: public_key -> Chain_id.t -> _ operation -> unit tzresult Lwt.t - val check_signature_sync: public_key -> Chain_id.t -> _ operation -> unit tzresult + val check_signature : + public_key -> Chain_id.t -> _ operation -> unit tzresult Lwt.t - val internal_operation_encoding: packed_internal_operation Data_encoding.t + val check_signature_sync : + public_key -> Chain_id.t -> _ operation -> unit tzresult - val pack: 'kind operation -> packed_operation + val internal_operation_encoding : packed_internal_operation Data_encoding.t + + val pack : 'kind operation -> packed_operation type ('a, 'b) eq = Eq : ('a, 'a) eq - val equal: 'a operation -> 'b operation -> ('a, 'b) eq option + + val equal : 'a operation -> 'b operation -> ('a, 'b) eq option module Encoding : sig - type 'b case = - Case : { tag: int ; - name: string ; - encoding: 'a Data_encoding.t ; - select: packed_contents -> 'b contents option ; - proj: 'b contents -> 'a ; - inj: 'a -> 'b contents } -> 'b case + | Case : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_contents -> 'b contents option; + proj : 'b contents -> 'a; + inj : 'a -> 'b contents; + } + -> 'b case - val endorsement_case: Kind.endorsement case - val seed_nonce_revelation_case: Kind.seed_nonce_revelation case - val double_endorsement_evidence_case: Kind.double_endorsement_evidence case - val double_baking_evidence_case: Kind.double_baking_evidence case - val activate_account_case: Kind.activate_account case - val proposals_case: Kind.proposals case - val ballot_case: Kind.ballot case - val reveal_case: Kind.reveal Kind.manager case - val transaction_case: Kind.transaction Kind.manager case - val origination_case: Kind.origination Kind.manager case - val delegation_case: Kind.delegation Kind.manager case + val endorsement_case : Kind.endorsement case + + val seed_nonce_revelation_case : Kind.seed_nonce_revelation case + + val double_endorsement_evidence_case : + Kind.double_endorsement_evidence case + + val double_baking_evidence_case : Kind.double_baking_evidence case + + val activate_account_case : Kind.activate_account case + + val proposals_case : Kind.proposals case + + val ballot_case : Kind.ballot case + + val reveal_case : Kind.reveal Kind.manager case + + val transaction_case : Kind.transaction Kind.manager case + + val origination_case : Kind.origination Kind.manager case + + val delegation_case : Kind.delegation Kind.manager case module Manager_operations : sig - type 'b case = - MCase : { tag: int ; - name: string ; - encoding: 'a Data_encoding.t ; - select: packed_manager_operation -> 'kind manager_operation option ; - proj: 'kind manager_operation -> 'a ; - inj: 'a -> 'kind manager_operation } -> 'kind case + | MCase : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : + packed_manager_operation -> 'kind manager_operation option; + proj : 'kind manager_operation -> 'a; + inj : 'a -> 'kind manager_operation; + } + -> 'kind case - val reveal_case: Kind.reveal case - val transaction_case: Kind.transaction case - val origination_case: Kind.origination case - val delegation_case: Kind.delegation case + val reveal_case : Kind.reveal case + val transaction_case : Kind.transaction case + + val origination_case : Kind.origination case + + val delegation_case : Kind.delegation case end - end - val of_list: packed_contents list -> packed_contents_list - val to_list: packed_contents_list -> packed_contents list + val of_list : packed_contents list -> packed_contents_list + val to_list : packed_contents_list -> packed_contents list end module Roll : sig - type t = private int32 + type roll = t - val encoding: roll Data_encoding.t + val encoding : roll Data_encoding.t - val snapshot_rolls: context -> context tzresult Lwt.t - val cycle_end: context -> Cycle.t -> context tzresult Lwt.t + val snapshot_rolls : context -> context tzresult Lwt.t - val baking_rights_owner: + val cycle_end : context -> Cycle.t -> context tzresult Lwt.t + + val baking_rights_owner : context -> Level.t -> priority:int -> public_key tzresult Lwt.t - val endorsement_rights_owner: + val endorsement_rights_owner : context -> Level.t -> slot:int -> public_key tzresult Lwt.t - val delegate_pubkey: - context -> public_key_hash -> public_key tzresult Lwt.t + val delegate_pubkey : context -> public_key_hash -> public_key tzresult Lwt.t - val get_rolls: + val get_rolls : context -> Signature.Public_key_hash.t -> roll list tzresult Lwt.t - val get_change: - context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t + val get_change : + context -> Signature.Public_key_hash.t -> Tez.t tzresult Lwt.t end module Commitment : sig + type t = { + blinded_public_key_hash : Blinded_public_key_hash.t; + amount : Tez.tez; + } - type t = - { blinded_public_key_hash : Blinded_public_key_hash.t ; - amount : Tez.tez } - - val get_opt: + val get_opt : context -> Blinded_public_key_hash.t -> Tez.t option tzresult Lwt.t - val delete: - context -> Blinded_public_key_hash.t -> context tzresult Lwt.t + val delete : context -> Blinded_public_key_hash.t -> context tzresult Lwt.t end module Bootstrap : sig - - val cycle_end: - context -> Cycle.t -> context tzresult Lwt.t - + val cycle_end : context -> Cycle.t -> context tzresult Lwt.t end module Global : sig + val get_block_priority : context -> int tzresult Lwt.t - val get_block_priority: context -> int tzresult Lwt.t - val set_block_priority: context -> int -> context tzresult Lwt.t - + val set_block_priority : context -> int -> context tzresult Lwt.t end -val prepare_first_block: +val prepare_first_block : Context.t -> - typecheck:(context -> Script.t -> - ((Script.t * Contract.big_map_diff option) * context) tzresult Lwt.t) -> + typecheck:(context -> + Script.t -> + ((Script.t * Contract.big_map_diff option) * context) tzresult + Lwt.t) -> level:Int32.t -> timestamp:Time.t -> fitness:Fitness.t -> context tzresult Lwt.t -val prepare: +val prepare : Context.t -> level:Int32.t -> predecessor_timestamp:Time.t -> @@ -1176,35 +1347,44 @@ val prepare: fitness:Fitness.t -> context tzresult Lwt.t -val finalize: ?commit_message:string -> context -> Updater.validation_result +val finalize : ?commit_message:string -> context -> Updater.validation_result -val activate: context -> Protocol_hash.t -> context Lwt.t -val fork_test_chain: context -> Protocol_hash.t -> Time.t -> context Lwt.t +val activate : context -> Protocol_hash.t -> context Lwt.t -val record_endorsement: - context -> Signature.Public_key_hash.t -> context -val allowed_endorsements: +val fork_test_chain : context -> Protocol_hash.t -> Time.t -> context Lwt.t + +val record_endorsement : context -> Signature.Public_key_hash.t -> context + +val allowed_endorsements : context -> (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t -val init_endorsements: + +val init_endorsements : context -> (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t -> context -val included_endorsements: - context -> int -val reset_internal_nonce: context -> context -val fresh_internal_nonce: context -> (context * int) tzresult -val record_internal_nonce: context -> int -> context -val internal_nonce_already_recorded: context -> int -> bool +val included_endorsements : context -> int -val add_fees: context -> Tez.t -> context tzresult Lwt.t -val add_rewards: context -> Tez.t -> context tzresult Lwt.t -val add_deposit: +val reset_internal_nonce : context -> context + +val fresh_internal_nonce : context -> (context * int) tzresult + +val record_internal_nonce : context -> int -> context + +val internal_nonce_already_recorded : context -> int -> bool + +val add_fees : context -> Tez.t -> context tzresult Lwt.t + +val add_rewards : context -> Tez.t -> context tzresult Lwt.t + +val add_deposit : context -> Signature.Public_key_hash.t -> Tez.t -> context tzresult Lwt.t -val get_fees: context -> Tez.t -val get_rewards: context -> Tez.t -val get_deposits: context -> Tez.t Signature.Public_key_hash.Map.t +val get_fees : context -> Tez.t -val description: context Storage_description.t +val get_rewards : context -> Tez.t + +val get_deposits : context -> Tez.t Signature.Public_key_hash.Map.t + +val description : context Storage_description.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml index 5194db531..a5dcee646 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.ml @@ -28,86 +28,76 @@ open Alpha_context let custom_root = RPC_path.open_root module Seed = struct - module S = struct - open Data_encoding let seed = RPC_service.post_service - ~description: "Seed of the cycle to which the block belongs." - ~query: RPC_query.empty - ~input: empty - ~output: Seed.seed_encoding + ~description:"Seed of the cycle to which the block belongs." + ~query:RPC_query.empty + ~input:empty + ~output:Seed.seed_encoding RPC_path.(custom_root / "context" / "seed") - end let () = let open Services_registration in - register0 S.seed begin fun ctxt () () -> - let l = Level.current ctxt in - Seed.for_cycle ctxt l.cycle - end - - - let get ctxt block = - RPC_context.make_call0 S.seed ctxt block () () + register0 S.seed (fun ctxt () () -> + let l = Level.current ctxt in + Seed.for_cycle ctxt l.cycle) + let get ctxt block = RPC_context.make_call0 S.seed ctxt block () () end module Nonce = struct - - type info = - | Revealed of Nonce.t - | Missing of Nonce_hash.t - | Forgotten + type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten let info_encoding = let open Data_encoding in - union [ - case (Tag 0) - ~title:"Revealed" - (obj1 (req "nonce" Nonce.encoding)) - (function Revealed nonce -> Some nonce | _ -> None) - (fun nonce -> Revealed nonce) ; - case (Tag 1) - ~title:"Missing" - (obj1 (req "hash" Nonce_hash.encoding)) - (function Missing nonce -> Some nonce | _ -> None) - (fun nonce -> Missing nonce) ; - case (Tag 2) - ~title:"Forgotten" - empty - (function Forgotten -> Some () | _ -> None) - (fun () -> Forgotten) ; - ] + union + [ case + (Tag 0) + ~title:"Revealed" + (obj1 (req "nonce" Nonce.encoding)) + (function Revealed nonce -> Some nonce | _ -> None) + (fun nonce -> Revealed nonce); + case + (Tag 1) + ~title:"Missing" + (obj1 (req "hash" Nonce_hash.encoding)) + (function Missing nonce -> Some nonce | _ -> None) + (fun nonce -> Missing nonce); + case + (Tag 2) + ~title:"Forgotten" + empty + (function Forgotten -> Some () | _ -> None) + (fun () -> Forgotten) ] module S = struct - let get = RPC_service.get_service - ~description: "Info about the nonce of a previous block." - ~query: RPC_query.empty - ~output: info_encoding + ~description:"Info about the nonce of a previous block." + ~query:RPC_query.empty + ~output:info_encoding RPC_path.(custom_root / "context" / "nonces" /: Raw_level.rpc_arg) - end let register () = let open Services_registration in - register1 S.get begin fun ctxt raw_level () () -> - let level = Level.from_raw ctxt raw_level in - Nonce.get ctxt level >>= function - | Ok (Revealed nonce) -> return (Revealed nonce) - | Ok (Unrevealed { nonce_hash ; _ }) -> - return (Missing nonce_hash) - | Error _ -> return Forgotten - end + register1 S.get (fun ctxt raw_level () () -> + let level = Level.from_raw ctxt raw_level in + Nonce.get ctxt level + >>= function + | Ok (Revealed nonce) -> + return (Revealed nonce) + | Ok (Unrevealed {nonce_hash; _}) -> + return (Missing nonce_hash) + | Error _ -> + return Forgotten) let get ctxt block level = RPC_context.make_call1 S.get ctxt block level () () - end module Contract = Contract_services diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli index f6e4a6b25..9e9c4458a 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_services.mli @@ -26,22 +26,14 @@ open Alpha_context module Seed : sig - - val get: 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t - + val get : 'a #RPC_context.simple -> 'a -> Seed.seed shell_tzresult Lwt.t end module Nonce : sig + type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten - type info = - | Revealed of Nonce.t - | Missing of Nonce_hash.t - | Forgotten - - val get: - 'a #RPC_context.simple -> - 'a -> Raw_level.t -> info shell_tzresult Lwt.t - + val get : + 'a #RPC_context.simple -> 'a -> Raw_level.t -> info shell_tzresult Lwt.t end module Contract = Contract_services @@ -52,4 +44,4 @@ module Forge = Helpers_services.Forge module Parse = Helpers_services.Parse module Voting = Voting_services -val register: unit -> unit +val register : unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml b/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml index ba6d9ba64..21686115f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/amendment.ml @@ -29,29 +29,32 @@ open Alpha_context Returns None in case of a tie, if proposal quorum is below required minimum or if there are no proposals. *) let select_winning_proposal ctxt = - Vote.get_proposals ctxt >>=? fun proposals -> + Vote.get_proposals ctxt + >>=? fun proposals -> let merge proposal vote winners = match winners with - | None -> Some ([proposal], vote) + | None -> + Some ([proposal], vote) | Some (winners, winners_vote) as previous -> if Compare.Int32.(vote = winners_vote) then Some (proposal :: winners, winners_vote) - else if Compare.Int32.(vote > winners_vote) then - Some ([proposal], vote) - else - previous in + else if Compare.Int32.(vote > winners_vote) then Some ([proposal], vote) + else previous + in match Protocol_hash.Map.fold merge proposals None with | Some ([proposal], vote) -> - Vote.listing_size ctxt >>=? fun max_vote -> + Vote.listing_size ctxt + >>=? fun max_vote -> let min_proposal_quorum = Constants.min_proposal_quorum ctxt in let min_vote_to_pass = - Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l in - if Compare.Int32.(vote >= min_vote_to_pass) then - return_some proposal - else - return_none + Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l + in + if Compare.Int32.(vote >= min_vote_to_pass) then return_some proposal + else return_none | _ -> - return_none (* in case of a tie, let's do nothing. *) + return_none + +(* in case of a tie, let's do nothing. *) (** A proposal is approved if it has supermajority and the participation reaches the current quorum. @@ -63,10 +66,14 @@ let select_winning_proposal ctxt = The expected quorum is calculated using the last participation EMA, capped by the min/max quorum protocol constants. *) let check_approval_and_update_participation_ema ctxt = - Vote.get_ballots ctxt >>=? fun ballots -> - Vote.listing_size ctxt >>=? fun maximum_vote -> - Vote.get_participation_ema ctxt >>=? fun participation_ema -> - Vote.get_current_quorum ctxt >>=? fun expected_quorum -> + Vote.get_ballots ctxt + >>=? fun ballots -> + Vote.listing_size ctxt + >>=? fun maximum_vote -> + Vote.get_participation_ema ctxt + >>=? fun participation_ema -> + Vote.get_current_quorum ctxt + >>=? fun expected_quorum -> (* Note overflows: considering a maximum of 8e8 tokens, with roll size as small as 1e3, there is a maximum of 8e5 rolls and thus votes. In 'participation' an Int64 is used because in the worst case 'all_votes is @@ -75,80 +82,96 @@ let check_approval_and_update_participation_ema ctxt = let casted_votes = Int32.add ballots.yay ballots.nay in let all_votes = Int32.add casted_votes ballots.pass in let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in - let participation = (* in centile of percentage *) - Int64.(to_int32 - (div - (mul (of_int32 all_votes) 100_00L) - (of_int32 maximum_vote))) in - let outcome = Compare.Int32.(participation >= expected_quorum && - ballots.yay >= supermajority) in + let participation = + (* in centile of percentage *) + Int64.( + to_int32 (div (mul (of_int32 all_votes) 100_00L) (of_int32 maximum_vote))) + in + let outcome = + Compare.Int32.( + participation >= expected_quorum && ballots.yay >= supermajority) + in let new_participation_ema = - Int32.(div (add - (mul 8l participation_ema) - (mul 2l participation)) - 10l) in - Vote.set_participation_ema ctxt new_participation_ema >>=? fun ctxt -> - return (ctxt, outcome) + Int32.(div (add (mul 8l participation_ema) (mul 2l participation)) 10l) + in + Vote.set_participation_ema ctxt new_participation_ema + >>=? fun ctxt -> return (ctxt, outcome) (** Implements the state machine of the amendment procedure. Note that [freeze_listings], that computes the vote weight of each delegate, is run at the beginning of each voting period. *) let start_new_voting_period ctxt = - Vote.get_current_period_kind ctxt >>=? function - | Proposal -> begin - select_winning_proposal ctxt >>=? fun proposal -> - Vote.clear_proposals ctxt >>= fun ctxt -> - Vote.clear_listings ctxt >>=? fun ctxt -> + Vote.get_current_period_kind ctxt + >>=? function + | Proposal -> ( + select_winning_proposal ctxt + >>=? fun proposal -> + Vote.clear_proposals ctxt + >>= fun ctxt -> + Vote.clear_listings ctxt + >>=? fun ctxt -> match proposal with | None -> - Vote.freeze_listings ctxt >>=? fun ctxt -> - return ctxt + Vote.freeze_listings ctxt >>=? fun ctxt -> return ctxt | Some proposal -> - Vote.init_current_proposal ctxt proposal >>=? fun ctxt -> - Vote.freeze_listings ctxt >>=? fun ctxt -> - Vote.set_current_period_kind ctxt Testing_vote >>=? fun ctxt -> - return ctxt - end + Vote.init_current_proposal ctxt proposal + >>=? fun ctxt -> + Vote.freeze_listings ctxt + >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Testing_vote + >>=? fun ctxt -> return ctxt ) | Testing_vote -> - check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) -> - Vote.clear_ballots ctxt >>= fun ctxt -> - Vote.clear_listings ctxt >>=? fun ctxt -> + check_approval_and_update_participation_ema ctxt + >>=? fun (ctxt, approved) -> + Vote.clear_ballots ctxt + >>= fun ctxt -> + Vote.clear_listings ctxt + >>=? fun ctxt -> if approved then - let expiration = (* in two days maximum... *) - Time.add (Timestamp.current ctxt) (Constants.test_chain_duration ctxt) in - Vote.get_current_proposal ctxt >>=? fun proposal -> - fork_test_chain ctxt proposal expiration >>= fun ctxt -> - Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> - return ctxt + let expiration = + (* in two days maximum... *) + Time.add + (Timestamp.current ctxt) + (Constants.test_chain_duration ctxt) + in + Vote.get_current_proposal ctxt + >>=? fun proposal -> + fork_test_chain ctxt proposal expiration + >>= fun ctxt -> + Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> return ctxt else - Vote.clear_current_proposal ctxt >>=? fun ctxt -> - Vote.freeze_listings ctxt >>=? fun ctxt -> - Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> - return ctxt + Vote.clear_current_proposal ctxt + >>=? fun ctxt -> + Vote.freeze_listings ctxt + >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt | Testing -> - Vote.freeze_listings ctxt >>=? fun ctxt -> - Vote.set_current_period_kind ctxt Promotion_vote >>=? fun ctxt -> - return ctxt + Vote.freeze_listings ctxt + >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Promotion_vote + >>=? fun ctxt -> return ctxt | Promotion_vote -> - check_approval_and_update_participation_ema ctxt >>=? fun (ctxt, approved) -> - begin - if approved then - Vote.get_current_proposal ctxt >>=? fun proposal -> - activate ctxt proposal >>= fun ctxt -> - return ctxt - else - return ctxt - end >>=? fun ctxt -> - Vote.clear_ballots ctxt >>= fun ctxt -> - Vote.clear_listings ctxt >>=? fun ctxt -> - Vote.clear_current_proposal ctxt >>=? fun ctxt -> - Vote.freeze_listings ctxt >>=? fun ctxt -> - Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> - return ctxt + check_approval_and_update_participation_ema ctxt + >>=? fun (ctxt, approved) -> + ( if approved then + Vote.get_current_proposal ctxt + >>=? fun proposal -> activate ctxt proposal >>= fun ctxt -> return ctxt + else return ctxt ) + >>=? fun ctxt -> + Vote.clear_ballots ctxt + >>= fun ctxt -> + Vote.clear_listings ctxt + >>=? fun ctxt -> + Vote.clear_current_proposal ctxt + >>=? fun ctxt -> + Vote.freeze_listings ctxt + >>=? fun ctxt -> + Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt -type error += (* `Branch *) - | Invalid_proposal +type error += + | (* `Branch *) + Invalid_proposal | Unexpected_proposal | Unauthorized_proposal | Too_many_proposals @@ -183,7 +206,8 @@ let () = `Branch ~id:"unauthorized_proposal" ~title:"Unauthorized proposal" - ~description:"The delegate provided for the proposal is not in the voting listings." + ~description: + "The delegate provided for the proposal is not in the voting listings." ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized proposal") empty (function Unauthorized_proposal -> Some () | _ -> None) @@ -203,7 +227,8 @@ let () = `Branch ~id:"unauthorized_ballot" ~title:"Unauthorized ballot" - ~description:"The delegate provided for the ballot is not in the voting listings." + ~description: + "The delegate provided for the ballot is not in the voting listings." ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized ballot") empty (function Unauthorized_ballot -> Some () | _ -> None) @@ -213,7 +238,8 @@ let () = `Branch ~id:"too_many_proposals" ~title:"Too many proposals" - ~description:"The delegate reached the maximum number of allowed proposals." + ~description: + "The delegate reached the maximum number of allowed proposals." ~pp:(fun ppf () -> Format.fprintf ppf "Too many proposals") empty (function Too_many_proposals -> Some () | _ -> None) @@ -231,60 +257,67 @@ let () = (* @return [true] if [List.length l] > [n] w/o computing length *) let rec longer_than l n = - if Compare.Int.(n < 0) then assert false else + if Compare.Int.(n < 0) then assert false + else match l with - | [] -> false + | [] -> + false | _ :: rest -> if Compare.Int.(n = 0) then true else (* n > 0 *) - longer_than rest (n-1) + longer_than rest (n - 1) let record_proposals ctxt delegate proposals = - begin match proposals with - | [] -> fail Empty_proposal - | _ :: _ -> return_unit - end >>=? fun () -> - Vote.get_current_period_kind ctxt >>=? function + (match proposals with [] -> fail Empty_proposal | _ :: _ -> return_unit) + >>=? fun () -> + Vote.get_current_period_kind ctxt + >>=? function | Proposal -> - Vote.in_listings ctxt delegate >>= fun in_listings -> + Vote.in_listings ctxt delegate + >>= fun in_listings -> if in_listings then - Vote.recorded_proposal_count_for_delegate ctxt delegate >>=? fun count -> + Vote.recorded_proposal_count_for_delegate ctxt delegate + >>=? fun count -> fail_when (longer_than proposals (Constants.max_proposals_per_delegate - count)) - Too_many_proposals >>=? fun () -> + Too_many_proposals + >>=? fun () -> fold_left_s - (fun ctxt proposal -> - Vote.record_proposal ctxt proposal delegate) - ctxt proposals >>=? fun ctxt -> - return ctxt - else - fail Unauthorized_proposal + (fun ctxt proposal -> Vote.record_proposal ctxt proposal delegate) + ctxt + proposals + >>=? fun ctxt -> return ctxt + else fail Unauthorized_proposal | Testing_vote | Testing | Promotion_vote -> fail Unexpected_proposal let record_ballot ctxt delegate proposal ballot = - Vote.get_current_period_kind ctxt >>=? function + Vote.get_current_period_kind ctxt + >>=? function | Testing_vote | Promotion_vote -> - Vote.get_current_proposal ctxt >>=? fun current_proposal -> - fail_unless (Protocol_hash.equal proposal current_proposal) - Invalid_proposal >>=? fun () -> - Vote.has_recorded_ballot ctxt delegate >>= fun has_ballot -> - fail_when has_ballot Unauthorized_ballot >>=? fun () -> - Vote.in_listings ctxt delegate >>= fun in_listings -> - if in_listings then - Vote.record_ballot ctxt delegate ballot - else - fail Unauthorized_ballot + Vote.get_current_proposal ctxt + >>=? fun current_proposal -> + fail_unless + (Protocol_hash.equal proposal current_proposal) + Invalid_proposal + >>=? fun () -> + Vote.has_recorded_ballot ctxt delegate + >>= fun has_ballot -> + fail_when has_ballot Unauthorized_ballot + >>=? fun () -> + Vote.in_listings ctxt delegate + >>= fun in_listings -> + if in_listings then Vote.record_ballot ctxt delegate ballot + else fail Unauthorized_ballot | Testing | Proposal -> fail Unexpected_ballot let last_of_a_voting_period ctxt l = - Compare.Int32.(Int32.succ l.Level.voting_period_position = - Constants.blocks_per_voting_period ctxt ) + Compare.Int32.( + Int32.succ l.Level.voting_period_position + = Constants.blocks_per_voting_period ctxt) let may_start_new_voting_period ctxt = let level = Level.current ctxt in - if last_of_a_voting_period ctxt level then - start_new_voting_period ctxt - else - return ctxt + if last_of_a_voting_period ctxt level then start_new_voting_period ctxt + else return ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/amendment.mli b/vendors/ligo-utils/tezos-protocol-alpha/amendment.mli index c37db2889..2a4062d56 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/amendment.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/amendment.mli @@ -51,8 +51,7 @@ open Alpha_context (** If at the end of a voting period, moves to the next one following the state machine of the amendment procedure. *) -val may_start_new_voting_period: - context -> context tzresult Lwt.t +val may_start_new_voting_period : context -> context tzresult Lwt.t type error += | Unexpected_proposal @@ -63,17 +62,14 @@ type error += (** Records a list of proposals for a delegate. @raise Unexpected_proposal if [ctxt] is not in a proposal period. @raise Unauthorized_proposal if [delegate] is not in the listing. *) -val record_proposals: - context -> - public_key_hash -> Protocol_hash.t list -> - context tzresult Lwt.t +val record_proposals : + context -> public_key_hash -> Protocol_hash.t list -> context tzresult Lwt.t -type error += - | Invalid_proposal - | Unexpected_ballot - | Unauthorized_ballot +type error += Invalid_proposal | Unexpected_ballot | Unauthorized_ballot -val record_ballot: +val record_ballot : context -> - public_key_hash -> Protocol_hash.t -> Vote.ballot -> + public_key_hash -> + Protocol_hash.t -> + Vote.ballot -> context tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/apply.ml b/vendors/ligo-utils/tezos-protocol-alpha/apply.ml index df4ba5b85..0cd9ee01b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/apply.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/apply.ml @@ -27,92 +27,167 @@ open Alpha_context -type error += Wrong_voting_period of Voting_period.t * Voting_period.t (* `Temporary *) -type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t (* `Temporary *) -type error += Duplicate_endorsement of Signature.Public_key_hash.t (* `Branch *) +type error += Wrong_voting_period of Voting_period.t * Voting_period.t + +(* `Temporary *) + +type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t + +(* `Temporary *) + +type error += Duplicate_endorsement of Signature.Public_key_hash.t + +(* `Branch *) + type error += Invalid_endorsement_level -type error += Invalid_commitment of { expected: bool } + +type error += Invalid_commitment of {expected : bool} + type error += Internal_operation_replay of packed_internal_operation type error += Invalid_double_endorsement_evidence (* `Permanent *) -type error += Inconsistent_double_endorsement_evidence - of { delegate1: Signature.Public_key_hash.t ; delegate2: Signature.Public_key_hash.t } (* `Permanent *) -type error += Unrequired_double_endorsement_evidence (* `Branch*) -type error += Too_early_double_endorsement_evidence - of { level: Raw_level.t ; current: Raw_level.t } (* `Temporary *) -type error += Outdated_double_endorsement_evidence - of { level: Raw_level.t ; last: Raw_level.t } (* `Permanent *) -type error += Invalid_double_baking_evidence - of { hash1: Block_hash.t ; - level1: Int32.t ; - hash2: Block_hash.t ; - level2: Int32.t } (* `Permanent *) -type error += Inconsistent_double_baking_evidence - of { delegate1: Signature.Public_key_hash.t ; delegate2: Signature.Public_key_hash.t } (* `Permanent *) -type error += Unrequired_double_baking_evidence (* `Branch*) -type error += Too_early_double_baking_evidence - of { level: Raw_level.t ; current: Raw_level.t } (* `Temporary *) -type error += Outdated_double_baking_evidence - of { level: Raw_level.t ; last: Raw_level.t } (* `Permanent *) -type error += Invalid_activation of { pkh : Ed25519.Public_key_hash.t } -type error += Multiple_revelation -type error += Gas_quota_exceeded_init_deserialize (* Permanent *) type error += - Not_enough_endorsements_for_priority of - { required : int ; - priority : int ; - endorsements : int ; - timestamp: Time.t } + | Inconsistent_double_endorsement_evidence of { + delegate1 : Signature.Public_key_hash.t; + delegate2 : Signature.Public_key_hash.t; + } + +(* `Permanent *) + +type error += Unrequired_double_endorsement_evidence (* `Branch*) + +type error += + | Too_early_double_endorsement_evidence of { + level : Raw_level.t; + current : Raw_level.t; + } + +(* `Temporary *) + +type error += + | Outdated_double_endorsement_evidence of { + level : Raw_level.t; + last : Raw_level.t; + } + +(* `Permanent *) + +type error += + | Invalid_double_baking_evidence of { + hash1 : Block_hash.t; + level1 : Int32.t; + hash2 : Block_hash.t; + level2 : Int32.t; + } + +(* `Permanent *) + +type error += + | Inconsistent_double_baking_evidence of { + delegate1 : Signature.Public_key_hash.t; + delegate2 : Signature.Public_key_hash.t; + } + +(* `Permanent *) + +type error += Unrequired_double_baking_evidence (* `Branch*) + +type error += + | Too_early_double_baking_evidence of { + level : Raw_level.t; + current : Raw_level.t; + } + +(* `Temporary *) + +type error += + | Outdated_double_baking_evidence of { + level : Raw_level.t; + last : Raw_level.t; + } + +(* `Permanent *) + +type error += Invalid_activation of {pkh : Ed25519.Public_key_hash.t} + +type error += Multiple_revelation + +type error += Gas_quota_exceeded_init_deserialize (* Permanent *) + +type error += + | Not_enough_endorsements_for_priority of { + required : int; + priority : int; + endorsements : int; + timestamp : Time.t; + } let () = register_error_kind `Temporary ~id:"operation.wrong_endorsement_predecessor" ~title:"Wrong endorsement predecessor" - ~description:"Trying to include an endorsement in a block \ - that is not the successor of the endorsed one" + ~description: + "Trying to include an endorsement in a block that is not the successor \ + of the endorsed one" ~pp:(fun ppf (e, p) -> - Format.fprintf ppf "Wrong predecessor %a, expected %a" - Block_hash.pp p Block_hash.pp e) - Data_encoding.(obj2 - (req "expected" Block_hash.encoding) - (req "provided" Block_hash.encoding)) - (function Wrong_endorsement_predecessor (e, p) -> Some (e, p) | _ -> None) + Format.fprintf + ppf + "Wrong predecessor %a, expected %a" + Block_hash.pp + p + Block_hash.pp + e) + Data_encoding.( + obj2 + (req "expected" Block_hash.encoding) + (req "provided" Block_hash.encoding)) + (function + | Wrong_endorsement_predecessor (e, p) -> Some (e, p) | _ -> None) (fun (e, p) -> Wrong_endorsement_predecessor (e, p)) ; register_error_kind `Temporary ~id:"operation.wrong_voting_period" ~title:"Wrong voting period" - ~description:"Trying to onclude a proposal or ballot \ - meant for another voting period" + ~description: + "Trying to onclude a proposal or ballot meant for another voting period" ~pp:(fun ppf (e, p) -> - Format.fprintf ppf "Wrong voting period %a, current is %a" - Voting_period.pp p Voting_period.pp e) - Data_encoding.(obj2 - (req "current" Voting_period.encoding) - (req "provided" Voting_period.encoding)) + Format.fprintf + ppf + "Wrong voting period %a, current is %a" + Voting_period.pp + p + Voting_period.pp + e) + Data_encoding.( + obj2 + (req "current" Voting_period.encoding) + (req "provided" Voting_period.encoding)) (function Wrong_voting_period (e, p) -> Some (e, p) | _ -> None) - (fun (e, p) -> Wrong_voting_period (e, p)); + (fun (e, p) -> Wrong_voting_period (e, p)) ; register_error_kind `Branch ~id:"operation.duplicate_endorsement" ~title:"Duplicate endorsement" ~description:"Two endorsements received from same delegate" ~pp:(fun ppf k -> - Format.fprintf ppf "Duplicate endorsement from delegate %a (possible replay attack)." - Signature.Public_key_hash.pp_short k) + Format.fprintf + ppf + "Duplicate endorsement from delegate %a (possible replay attack)." + Signature.Public_key_hash.pp_short + k) Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) (function Duplicate_endorsement k -> Some k | _ -> None) - (fun k -> Duplicate_endorsement k); + (fun k -> Duplicate_endorsement k) ; register_error_kind `Temporary ~id:"operation.invalid_endorsement_level" ~title:"Unexpected level in endorsement" - ~description:"The level of an endorsement is inconsistent with the \ - \ provided block hash." - ~pp:(fun ppf () -> - Format.fprintf ppf "Unexpected level in endorsement.") + ~description: + "The level of an endorsement is inconsistent with the provided block \ + hash." + ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected level in endorsement.") Data_encoding.unit (function Invalid_endorsement_level -> Some () | _ -> None) (fun () -> Invalid_endorsement_level) ; @@ -122,20 +197,25 @@ let () = ~title:"Invalid commitment in block header" ~description:"The block header has invalid commitment." ~pp:(fun ppf expected -> - if expected then - Format.fprintf ppf "Missing seed's nonce commitment in block header." - else - Format.fprintf ppf "Unexpected seed's nonce commitment in block header.") + if expected then + Format.fprintf ppf "Missing seed's nonce commitment in block header." + else + Format.fprintf + ppf + "Unexpected seed's nonce commitment in block header.") Data_encoding.(obj1 (req "expected" bool)) - (function Invalid_commitment { expected } -> Some expected | _ -> None) - (fun expected -> Invalid_commitment { expected }) ; + (function Invalid_commitment {expected} -> Some expected | _ -> None) + (fun expected -> Invalid_commitment {expected}) ; register_error_kind `Permanent ~id:"internal_operation_replay" ~title:"Internal operation replay" ~description:"An internal operation was emitted twice by a script" - ~pp:(fun ppf (Internal_operation { nonce ; _ }) -> - Format.fprintf ppf "Internal operation %d was emitted twice by a script" nonce) + ~pp:(fun ppf (Internal_operation {nonce; _}) -> + Format.fprintf + ppf + "Internal operation %d was emitted twice by a script" + nonce) Operation.internal_operation_encoding (function Internal_operation_replay op -> Some op | _ -> None) (fun op -> Internal_operation_replay op) ; @@ -145,7 +225,7 @@ let () = ~title:"Invalid double endorsement evidence" ~description:"A double-endorsement evidence is malformed" ~pp:(fun ppf () -> - Format.fprintf ppf "Malformed double-endorsement evidence") + Format.fprintf ppf "Malformed double-endorsement evidence") Data_encoding.empty (function Invalid_double_endorsement_evidence -> Some () | _ -> None) (fun () -> Invalid_double_endorsement_evidence) ; @@ -153,32 +233,38 @@ let () = `Permanent ~id:"block.inconsistent_double_endorsement_evidence" ~title:"Inconsistent double endorsement evidence" - ~description:"A double-endorsement evidence is inconsistent \ - \ (two distinct delegates)" + ~description: + "A double-endorsement evidence is inconsistent (two distinct delegates)" ~pp:(fun ppf (delegate1, delegate2) -> - Format.fprintf ppf - "Inconsistent double-endorsement evidence \ - \ (distinct delegate: %a and %a)" - Signature.Public_key_hash.pp_short delegate1 - Signature.Public_key_hash.pp_short delegate2) - Data_encoding.(obj2 - (req "delegate1" Signature.Public_key_hash.encoding) - (req "delegate2" Signature.Public_key_hash.encoding)) + Format.fprintf + ppf + "Inconsistent double-endorsement evidence (distinct delegate: %a and \ + %a)" + Signature.Public_key_hash.pp_short + delegate1 + Signature.Public_key_hash.pp_short + delegate2) + Data_encoding.( + obj2 + (req "delegate1" Signature.Public_key_hash.encoding) + (req "delegate2" Signature.Public_key_hash.encoding)) (function - | Inconsistent_double_endorsement_evidence { delegate1 ; delegate2 } -> + | Inconsistent_double_endorsement_evidence {delegate1; delegate2} -> Some (delegate1, delegate2) - | _ -> None) + | _ -> + None) (fun (delegate1, delegate2) -> - Inconsistent_double_endorsement_evidence { delegate1 ; delegate2 }) ; + Inconsistent_double_endorsement_evidence {delegate1; delegate2}) ; register_error_kind `Branch ~id:"block.unrequired_double_endorsement_evidence" ~title:"Unrequired double endorsement evidence" ~description:"A double-endorsement evidence is unrequired" ~pp:(fun ppf () -> - Format.fprintf ppf "A valid double-endorsement operation cannot \ - \ be applied: the associated delegate \ - \ has previously been denunciated in this cycle.") + Format.fprintf + ppf + "A valid double-endorsement operation cannot be applied: the \ + associated delegate has previously been denunciated in this cycle.") Data_encoding.empty (function Unrequired_double_endorsement_evidence -> Some () | _ -> None) (fun () -> Unrequired_double_endorsement_evidence) ; @@ -188,92 +274,109 @@ let () = ~title:"Too early double endorsement evidence" ~description:"A double-endorsement evidence is in the future" ~pp:(fun ppf (level, current) -> - Format.fprintf ppf - "A double-endorsement evidence is in the future \ - \ (current level: %a, endorsement level: %a)" - Raw_level.pp current - Raw_level.pp level) - Data_encoding.(obj2 - (req "level" Raw_level.encoding) - (req "current" Raw_level.encoding)) + Format.fprintf + ppf + "A double-endorsement evidence is in the future (current level: %a, \ + endorsement level: %a)" + Raw_level.pp + current + Raw_level.pp + level) + Data_encoding.( + obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding)) (function - | Too_early_double_endorsement_evidence { level ; current } -> + | Too_early_double_endorsement_evidence {level; current} -> Some (level, current) - | _ -> None) + | _ -> + None) (fun (level, current) -> - Too_early_double_endorsement_evidence { level ; current }) ; + Too_early_double_endorsement_evidence {level; current}) ; register_error_kind `Permanent ~id:"block.outdated_double_endorsement_evidence" ~title:"Outdated double endorsement evidence" ~description:"A double-endorsement evidence is outdated." ~pp:(fun ppf (level, last) -> - Format.fprintf ppf - "A double-endorsement evidence is outdated \ - \ (last acceptable level: %a, endorsement level: %a)" - Raw_level.pp last - Raw_level.pp level) - Data_encoding.(obj2 - (req "level" Raw_level.encoding) - (req "last" Raw_level.encoding)) + Format.fprintf + ppf + "A double-endorsement evidence is outdated (last acceptable level: \ + %a, endorsement level: %a)" + Raw_level.pp + last + Raw_level.pp + level) + Data_encoding.( + obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding)) (function - | Outdated_double_endorsement_evidence { level ; last } -> + | Outdated_double_endorsement_evidence {level; last} -> Some (level, last) - | _ -> None) - (fun (level, last) -> - Outdated_double_endorsement_evidence { level ; last }) ; + | _ -> + None) + (fun (level, last) -> Outdated_double_endorsement_evidence {level; last}) ; register_error_kind `Permanent ~id:"block.invalid_double_baking_evidence" ~title:"Invalid double baking evidence" - ~description:"A double-baking evidence is inconsistent \ - \ (two distinct level)" + ~description: + "A double-baking evidence is inconsistent (two distinct level)" ~pp:(fun ppf (hash1, level1, hash2, level2) -> - Format.fprintf ppf - "Invalid double-baking evidence (hash: %a and %a, levels: %ld and %ld)" - Block_hash.pp hash1 Block_hash.pp hash2 - level1 level2) - Data_encoding.(obj4 - (req "hash1" Block_hash.encoding) - (req "level1" int32) - (req "hash2" Block_hash.encoding) - (req "level2" int32)) + Format.fprintf + ppf + "Invalid double-baking evidence (hash: %a and %a, levels: %ld and %ld)" + Block_hash.pp + hash1 + Block_hash.pp + hash2 + level1 + level2) + Data_encoding.( + obj4 + (req "hash1" Block_hash.encoding) + (req "level1" int32) + (req "hash2" Block_hash.encoding) + (req "level2" int32)) (function - | Invalid_double_baking_evidence { hash1 ; level1 ; hash2 ; level2 } -> + | Invalid_double_baking_evidence {hash1; level1; hash2; level2} -> Some (hash1, level1, hash2, level2) - | _ -> None) + | _ -> + None) (fun (hash1, level1, hash2, level2) -> - Invalid_double_baking_evidence { hash1 ; level1 ; hash2 ; level2 }) ; + Invalid_double_baking_evidence {hash1; level1; hash2; level2}) ; register_error_kind `Permanent ~id:"block.inconsistent_double_baking_evidence" ~title:"Inconsistent double baking evidence" - ~description:"A double-baking evidence is inconsistent \ - \ (two distinct delegates)" + ~description: + "A double-baking evidence is inconsistent (two distinct delegates)" ~pp:(fun ppf (delegate1, delegate2) -> - Format.fprintf ppf - "Inconsistent double-baking evidence \ - \ (distinct delegate: %a and %a)" - Signature.Public_key_hash.pp_short delegate1 - Signature.Public_key_hash.pp_short delegate2) - Data_encoding.(obj2 - (req "delegate1" Signature.Public_key_hash.encoding) - (req "delegate2" Signature.Public_key_hash.encoding)) + Format.fprintf + ppf + "Inconsistent double-baking evidence (distinct delegate: %a and %a)" + Signature.Public_key_hash.pp_short + delegate1 + Signature.Public_key_hash.pp_short + delegate2) + Data_encoding.( + obj2 + (req "delegate1" Signature.Public_key_hash.encoding) + (req "delegate2" Signature.Public_key_hash.encoding)) (function - | Inconsistent_double_baking_evidence { delegate1 ; delegate2 } -> + | Inconsistent_double_baking_evidence {delegate1; delegate2} -> Some (delegate1, delegate2) - | _ -> None) + | _ -> + None) (fun (delegate1, delegate2) -> - Inconsistent_double_baking_evidence { delegate1 ; delegate2 }) ; + Inconsistent_double_baking_evidence {delegate1; delegate2}) ; register_error_kind `Branch ~id:"block.unrequired_double_baking_evidence" ~title:"Unrequired double baking evidence" ~description:"A double-baking evidence is unrequired" ~pp:(fun ppf () -> - Format.fprintf ppf "A valid double-baking operation cannot \ - \ be applied: the associated delegate \ - \ has previously been denunciated in this cycle.") + Format.fprintf + ppf + "A valid double-baking operation cannot be applied: the associated \ + delegate has previously been denunciated in this cycle.") Data_encoding.empty (function Unrequired_double_baking_evidence -> Some () | _ -> None) (fun () -> Unrequired_double_baking_evidence) ; @@ -283,62 +386,70 @@ let () = ~title:"Too early double baking evidence" ~description:"A double-baking evidence is in the future" ~pp:(fun ppf (level, current) -> - Format.fprintf ppf - "A double-baking evidence is in the future \ - \ (current level: %a, baking level: %a)" - Raw_level.pp current - Raw_level.pp level) - Data_encoding.(obj2 - (req "level" Raw_level.encoding) - (req "current" Raw_level.encoding)) + Format.fprintf + ppf + "A double-baking evidence is in the future (current level: %a, \ + baking level: %a)" + Raw_level.pp + current + Raw_level.pp + level) + Data_encoding.( + obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding)) (function - | Too_early_double_baking_evidence { level ; current } -> + | Too_early_double_baking_evidence {level; current} -> Some (level, current) - | _ -> None) - (fun (level, current) -> - Too_early_double_baking_evidence { level ; current }) ; + | _ -> + None) + (fun (level, current) -> Too_early_double_baking_evidence {level; current}) ; register_error_kind `Permanent ~id:"block.outdated_double_baking_evidence" ~title:"Outdated double baking evidence" ~description:"A double-baking evidence is outdated." ~pp:(fun ppf (level, last) -> - Format.fprintf ppf - "A double-baking evidence is outdated \ - \ (last acceptable level: %a, baking level: %a)" - Raw_level.pp last - Raw_level.pp level) - Data_encoding.(obj2 - (req "level" Raw_level.encoding) - (req "last" Raw_level.encoding)) + Format.fprintf + ppf + "A double-baking evidence is outdated (last acceptable level: %a, \ + baking level: %a)" + Raw_level.pp + last + Raw_level.pp + level) + Data_encoding.( + obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding)) (function - | Outdated_double_baking_evidence { level ; last } -> + | Outdated_double_baking_evidence {level; last} -> Some (level, last) - | _ -> None) - (fun (level, last) -> - Outdated_double_baking_evidence { level ; last }) ; + | _ -> + None) + (fun (level, last) -> Outdated_double_baking_evidence {level; last}) ; register_error_kind `Permanent ~id:"operation.invalid_activation" ~title:"Invalid activation" - ~description:"The given key and secret do not correspond to any \ - existing preallocated contract" + ~description: + "The given key and secret do not correspond to any existing \ + preallocated contract" ~pp:(fun ppf pkh -> - Format.fprintf ppf "Invalid activation. The public key %a does \ - not match any commitment." - Ed25519.Public_key_hash.pp pkh - ) + Format.fprintf + ppf + "Invalid activation. The public key %a does not match any commitment." + Ed25519.Public_key_hash.pp + pkh) Data_encoding.(obj1 (req "pkh" Ed25519.Public_key_hash.encoding)) - (function Invalid_activation { pkh } -> Some pkh | _ -> None) - (fun pkh -> Invalid_activation { pkh } ) ; + (function Invalid_activation {pkh} -> Some pkh | _ -> None) + (fun pkh -> Invalid_activation {pkh}) ; register_error_kind `Permanent ~id:"block.multiple_revelation" ~title:"Multiple revelations were included in a manager operation" - ~description:"A manager operation should not contain more than one revelation" + ~description: + "A manager operation should not contain more than one revelation" ~pp:(fun ppf () -> - Format.fprintf ppf - "Multiple revelations were included in a manager operation") + Format.fprintf + ppf + "Multiple revelations were included in a manager operation") Data_encoding.empty (function Multiple_revelation -> Some () | _ -> None) (fun () -> Multiple_revelation) ; @@ -346,10 +457,10 @@ let () = `Permanent ~id:"gas_exhausted.init_deserialize" ~title:"Not enough gas for initial deserialization of script expresions" - ~description:"Gas limit was not high enough to deserialize the \ - transaction parameters or origination script code or \ - initial storage, making the operation impossible to \ - parse within the provided gas bounds." + ~description: + "Gas limit was not high enough to deserialize the transaction \ + parameters or origination script code or initial storage, making the \ + operation impossible to parse within the provided gas bounds." Data_encoding.empty (function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None) (fun () -> Gas_quota_exceeded_init_deserialize) ; @@ -357,722 +468,1018 @@ let () = `Permanent ~id:"operation.not_enought_endorsements_for_priority" ~title:"Not enough endorsements for priority" - ~description:"The block being validated does not include the \ - required minimum number of endorsements for this priority." + ~description: + "The block being validated does not include the required minimum number \ + of endorsements for this priority." ~pp:(fun ppf (required, endorsements, priority, timestamp) -> - Format.fprintf ppf "Wrong number of endorsements (%i) for \ - priority (%i), %i are expected at %a" - endorsements priority required Time.pp_hum timestamp) - Data_encoding.(obj4 - (req "required" int31) - (req "endorsements" int31) - (req "priority" int31) - (req "timestamp" Time.encoding)) - (function Not_enough_endorsements_for_priority - { required ; endorsements ; priority ; timestamp } -> - Some (required, endorsements, priority, timestamp) | _ -> None) + Format.fprintf + ppf + "Wrong number of endorsements (%i) for priority (%i), %i are expected \ + at %a" + endorsements + priority + required + Time.pp_hum + timestamp) + Data_encoding.( + obj4 + (req "required" int31) + (req "endorsements" int31) + (req "priority" int31) + (req "timestamp" Time.encoding)) + (function + | Not_enough_endorsements_for_priority + {required; endorsements; priority; timestamp} -> + Some (required, endorsements, priority, timestamp) + | _ -> + None) (fun (required, endorsements, priority, timestamp) -> - Not_enough_endorsements_for_priority - { required ; endorsements ; priority ; timestamp }) + Not_enough_endorsements_for_priority + {required; endorsements; priority; timestamp}) open Apply_results let apply_manager_operation_content : - type kind. - ( Alpha_context.t -> Script_ir_translator.unparsing_mode -> payer:Contract.t -> source:Contract.t -> - chain_id:Chain_id.t -> internal:bool -> kind manager_operation -> - (context * kind successful_manager_operation_result * packed_internal_operation list) tzresult Lwt.t ) = - fun ctxt mode ~payer ~source ~chain_id ~internal operation -> - let before_operation = - (* This context is not used for backtracking. Only to compute + type kind. + Alpha_context.t -> + Script_ir_translator.unparsing_mode -> + payer:Contract.t -> + source:Contract.t -> + chain_id:Chain_id.t -> + internal:bool -> + kind manager_operation -> + ( context + * kind successful_manager_operation_result + * packed_internal_operation list ) + tzresult + Lwt.t = + fun ctxt mode ~payer ~source ~chain_id ~internal operation -> + let before_operation = + (* This context is not used for backtracking. Only to compute gas consumption and originations for the operation result. *) - ctxt in - Contract.must_exist ctxt source >>=? fun () -> - Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation) >>=? fun ctxt -> - match operation with - | Reveal _ -> - return (* No-op: action already performed by `precheck_manager_contents`. *) - (ctxt, (Reveal_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt } : kind successful_manager_operation_result), []) - | Transaction { amount ; parameters ; destination ; entrypoint } -> begin - Contract.spend ctxt source amount >>=? fun ctxt -> - begin match Contract.is_implicit destination with - | None -> return (ctxt, [], false) - | Some _ -> - Contract.allocated ctxt destination >>=? function - | true -> return (ctxt, [], false) - | false -> - Fees.origination_burn ctxt >>=? fun (ctxt, origination_burn) -> - return (ctxt, [ Delegate.Contract payer, Delegate.Debited origination_burn ], true) - end >>=? fun (ctxt, maybe_burn_balance_update, allocated_destination_contract) -> - Contract.credit ctxt destination amount >>=? fun ctxt -> - Contract.get_script ctxt destination >>=? fun (ctxt, script) -> - match script with - | None -> begin - begin match entrypoint with - | "default" -> return () - | entrypoint -> fail (Script_tc_errors.No_such_entrypoint entrypoint) - end >>=? fun () -> - Script.force_decode ctxt parameters >>=? fun (arg, ctxt) -> (* see [note] *) - (* [note]: for toplevel ops, cost is nil since the + ctxt + in + Contract.must_exist ctxt source + >>=? fun () -> + Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation) + >>=? fun ctxt -> + match operation with + | Reveal _ -> + return + (* No-op: action already performed by `precheck_manager_contents`. *) + ( ctxt, + ( Reveal_result + {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} + : kind successful_manager_operation_result ), + [] ) + | Transaction {amount; parameters; destination; entrypoint} -> ( + Contract.spend ctxt source amount + >>=? fun ctxt -> + ( match Contract.is_implicit destination with + | None -> + return (ctxt, [], false) + | Some _ -> ( + Contract.allocated ctxt destination + >>=? function + | true -> + return (ctxt, [], false) + | false -> + Fees.origination_burn ctxt + >>=? fun (ctxt, origination_burn) -> + return + ( ctxt, + [(Delegate.Contract payer, Delegate.Debited origination_burn)], + true ) ) ) + >>=? fun (ctxt, maybe_burn_balance_update, allocated_destination_contract) + -> + Contract.credit ctxt destination amount + >>=? fun ctxt -> + Contract.get_script ctxt destination + >>=? fun (ctxt, script) -> + match script with + | None -> + ( match entrypoint with + | "default" -> + return () + | entrypoint -> + fail (Script_tc_errors.No_such_entrypoint entrypoint) ) + >>=? (fun () -> + Script.force_decode ctxt parameters + >>=? fun (arg, ctxt) -> + (* see [note] *) + (* [note]: for toplevel ops, cost is nil since the lazy value has already been forced at precheck, so we compute and consume the full cost again *) - let cost_arg = Script.deserialized_cost arg in - Lwt.return (Gas.consume ctxt cost_arg) >>=? fun ctxt -> - match Micheline.root arg with - | Prim (_, D_Unit, [], _) -> - (* Allow [Unit] parameter to non-scripted contracts. *) - return ctxt - | _ -> fail (Script_interpreter.Bad_contract_parameter destination) - end >>=? fun ctxt -> - let result = - Transaction_result - { storage = None ; - big_map_diff = None; - balance_updates = - Delegate.cleanup_balance_updates - ([ Delegate.Contract source, Delegate.Debited amount ; - Contract destination, Credited amount ] - @ maybe_burn_balance_update) ; - originated_contracts = [] ; - consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt ; - storage_size = Z.zero ; - paid_storage_size_diff = Z.zero ; - allocated_destination_contract ; - } in - return (ctxt, result, []) - | Some script -> - Script.force_decode ctxt parameters >>=? fun (parameter, ctxt) -> (* see [note] *) - let cost_parameter = Script.deserialized_cost parameter in - Lwt.return (Gas.consume ctxt cost_parameter) >>=? fun ctxt -> - let step_constants = - let open Script_interpreter in - { source ; - payer ; - self = destination ; - amount ; - chain_id } in - Script_interpreter.execute - ctxt mode step_constants ~script ~parameter ~entrypoint - >>=? fun { ctxt ; storage ; big_map_diff ; operations } -> - Contract.update_script_storage - ctxt destination storage big_map_diff >>=? fun ctxt -> - Fees.record_paid_storage_space - ctxt destination >>=? fun (ctxt, new_size, paid_storage_size_diff, fees) -> - Contract.originated_from_current_nonce - ~since: before_operation - ~until: ctxt >>=? fun originated_contracts -> - let result = - Transaction_result - { storage = Some storage ; - big_map_diff; - balance_updates = - Delegate.cleanup_balance_updates - [ Contract payer, Debited fees ; - Contract source, Debited amount ; - Contract destination, Credited amount ] ; - originated_contracts ; - consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt ; - storage_size = new_size ; - paid_storage_size_diff ; - allocated_destination_contract } in - return (ctxt, result, operations) - end - | Origination { delegate ; script ; preorigination ; credit } -> - Script.force_decode ctxt script.storage >>=? fun (unparsed_storage, ctxt) -> (* see [note] *) - Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) >>=? fun ctxt -> - Script.force_decode ctxt script.code >>=? fun (unparsed_code, ctxt) -> (* see [note] *) - Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) >>=? fun ctxt -> - Script_ir_translator.parse_script ctxt ~legacy:false script >>=? fun (Ex_script parsed_script, ctxt) -> - Script_ir_translator.collect_big_maps ctxt parsed_script.storage_type parsed_script.storage >>=? fun (to_duplicate, ctxt) -> - let to_update = Script_ir_translator.no_big_map_id in - Script_ir_translator.extract_big_map_diff ctxt Optimized parsed_script.storage_type parsed_script.storage - ~to_duplicate ~to_update ~temporary:false >>=? fun (storage, big_map_diff, ctxt) -> - Script_ir_translator.unparse_data ctxt Optimized parsed_script.storage_type storage >>=? fun (storage, ctxt) -> - let storage = Script.lazy_expr (Micheline.strip_locations storage) in - let script = { script with storage } in - Contract.spend ctxt source credit >>=? fun ctxt -> - begin match preorigination with - | Some contract -> - assert internal ; - (* The preorigination field is only used to early return + let cost_arg = Script.deserialized_cost arg in + Lwt.return (Gas.consume ctxt cost_arg) + >>=? fun ctxt -> + match Micheline.root arg with + | Prim (_, D_Unit, [], _) -> + (* Allow [Unit] parameter to non-scripted contracts. *) + return ctxt + | _ -> + fail + (Script_interpreter.Bad_contract_parameter destination)) + >>=? fun ctxt -> + let result = + Transaction_result + { + storage = None; + big_map_diff = None; + balance_updates = + Delegate.cleanup_balance_updates + ( [ (Delegate.Contract source, Delegate.Debited amount); + (Contract destination, Credited amount) ] + @ maybe_burn_balance_update ); + originated_contracts = []; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = Z.zero; + paid_storage_size_diff = Z.zero; + allocated_destination_contract; + } + in + return (ctxt, result, []) + | Some script -> + Script.force_decode ctxt parameters + >>=? fun (parameter, ctxt) -> + (* see [note] *) + let cost_parameter = Script.deserialized_cost parameter in + Lwt.return (Gas.consume ctxt cost_parameter) + >>=? fun ctxt -> + let step_constants = + let open Script_interpreter in + {source; payer; self = destination; amount; chain_id} + in + Script_interpreter.execute + ctxt + mode + step_constants + ~script + ~parameter + ~entrypoint + >>=? fun {ctxt; storage; big_map_diff; operations} -> + Contract.update_script_storage ctxt destination storage big_map_diff + >>=? fun ctxt -> + Fees.record_paid_storage_space ctxt destination + >>=? fun (ctxt, new_size, paid_storage_size_diff, fees) -> + Contract.originated_from_current_nonce + ~since:before_operation + ~until:ctxt + >>=? fun originated_contracts -> + let result = + Transaction_result + { + storage = Some storage; + big_map_diff; + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract payer, Debited fees); + (Contract source, Debited amount); + (Contract destination, Credited amount) ]; + originated_contracts; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = new_size; + paid_storage_size_diff; + allocated_destination_contract; + } + in + return (ctxt, result, operations) ) + | Origination {delegate; script; preorigination; credit} -> + Script.force_decode ctxt script.storage + >>=? fun (unparsed_storage, ctxt) -> + (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage)) + >>=? fun ctxt -> + Script.force_decode ctxt script.code + >>=? fun (unparsed_code, ctxt) -> + (* see [note] *) + Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code)) + >>=? fun ctxt -> + Script_ir_translator.parse_script ctxt ~legacy:false script + >>=? fun (Ex_script parsed_script, ctxt) -> + Script_ir_translator.collect_big_maps + ctxt + parsed_script.storage_type + parsed_script.storage + >>=? fun (to_duplicate, ctxt) -> + let to_update = Script_ir_translator.no_big_map_id in + Script_ir_translator.extract_big_map_diff + ctxt + Optimized + parsed_script.storage_type + parsed_script.storage + ~to_duplicate + ~to_update + ~temporary:false + >>=? fun (storage, big_map_diff, ctxt) -> + Script_ir_translator.unparse_data + ctxt + Optimized + parsed_script.storage_type + storage + >>=? fun (storage, ctxt) -> + let storage = Script.lazy_expr (Micheline.strip_locations storage) in + let script = {script with storage} in + Contract.spend ctxt source credit + >>=? fun ctxt -> + ( match preorigination with + | Some contract -> + assert internal ; + (* The preorigination field is only used to early return the address of an originated contract in Michelson. It cannot come from the outside. *) - return (ctxt, contract) - | None -> - Contract.fresh_contract_from_current_nonce ctxt - end >>=? fun (ctxt, contract) -> - Contract.originate ctxt contract - ~delegate ~balance:credit - ~script:(script, big_map_diff) >>=? fun ctxt -> - Fees.origination_burn ctxt >>=? fun (ctxt, origination_burn) -> - Fees.record_paid_storage_space ctxt contract >>=? fun (ctxt, size, paid_storage_size_diff, fees) -> - let result = - Origination_result - { big_map_diff ; - balance_updates = - Delegate.cleanup_balance_updates - [ Contract payer, Debited fees ; - Contract payer, Debited origination_burn ; - Contract source, Debited credit ; - Contract contract, Credited credit ] ; - originated_contracts = [ contract ] ; - consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt ; - storage_size = size ; - paid_storage_size_diff } in - return (ctxt, result, []) - | Delegation delegate -> - Delegate.set ctxt source delegate >>=? fun ctxt -> - return (ctxt, Delegation_result { consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt }, []) + return (ctxt, contract) + | None -> + Contract.fresh_contract_from_current_nonce ctxt ) + >>=? fun (ctxt, contract) -> + Contract.originate + ctxt + contract + ~delegate + ~balance:credit + ~script:(script, big_map_diff) + >>=? fun ctxt -> + Fees.origination_burn ctxt + >>=? fun (ctxt, origination_burn) -> + Fees.record_paid_storage_space ctxt contract + >>=? fun (ctxt, size, paid_storage_size_diff, fees) -> + let result = + Origination_result + { + big_map_diff; + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract payer, Debited fees); + (Contract payer, Debited origination_burn); + (Contract source, Debited credit); + (Contract contract, Credited credit) ]; + originated_contracts = [contract]; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = size; + paid_storage_size_diff; + } + in + return (ctxt, result, []) + | Delegation delegate -> + Delegate.set ctxt source delegate + >>=? fun ctxt -> + return + ( ctxt, + Delegation_result + {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}, + [] ) let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = let rec apply ctxt applied worklist = match worklist with - | [] -> Lwt.return (`Success ctxt, List.rev applied) - | (Internal_operation - ({ source ; operation ; nonce } as op)) :: rest -> - begin - if internal_nonce_already_recorded ctxt nonce then - fail (Internal_operation_replay (Internal_operation op)) - else - let ctxt = record_internal_nonce ctxt nonce in - apply_manager_operation_content - ctxt mode ~source ~payer ~chain_id ~internal:true operation - end >>= function + | [] -> + Lwt.return (`Success ctxt, List.rev applied) + | Internal_operation ({source; operation; nonce} as op) :: rest -> ( + ( if internal_nonce_already_recorded ctxt nonce then + fail (Internal_operation_replay (Internal_operation op)) + else + let ctxt = record_internal_nonce ctxt nonce in + apply_manager_operation_content + ctxt + mode + ~source + ~payer + ~chain_id + ~internal:true + operation ) + >>= function | Error errors -> let result = - Internal_operation_result (op, Failed (manager_kind op.operation, errors)) in + Internal_operation_result + (op, Failed (manager_kind op.operation, errors)) + in let skipped = List.rev_map (fun (Internal_operation op) -> - Internal_operation_result (op, Skipped (manager_kind op.operation))) - rest in + Internal_operation_result + (op, Skipped (manager_kind op.operation))) + rest + in Lwt.return (`Failure, List.rev (skipped @ (result :: applied))) | Ok (ctxt, result, emitted) -> - apply ctxt + apply + ctxt (Internal_operation_result (op, Applied result) :: applied) - (rest @ emitted) in + (rest @ emitted) ) + in apply ctxt [] ops -let precheck_manager_contents - (type kind) ctxt chain_id raw_operation (op : kind Kind.manager contents) - : context tzresult Lwt.t = - let Manager_operation { source ; fee ; counter ; operation ; gas_limit ; storage_limit } = op in - Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () -> +let precheck_manager_contents (type kind) ctxt chain_id raw_operation + (op : kind Kind.manager contents) : context tzresult Lwt.t = + let (Manager_operation + {source; fee; counter; operation; gas_limit; storage_limit}) = + op + in + Lwt.return (Gas.check_limit ctxt gas_limit) + >>=? fun () -> let ctxt = Gas.set_limit ctxt gas_limit in - Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () -> - Contract.must_be_allocated ctxt (Contract.implicit_contract source) >>=? fun () -> - Contract.check_counter_increment ctxt source counter >>=? fun () -> - begin - match operation with - | Reveal pk -> - Contract.reveal_manager_key ctxt source pk - | Transaction { parameters ; _ } -> - (* Fail quickly if not enough gas for minimal deserialization cost *) - Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ - Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters) >>=? fun () -> - (* Fail if not enough gas for complete deserialization cost *) - trace Gas_quota_exceeded_init_deserialize @@ - Script.force_decode ctxt parameters >>|? fun (_arg, ctxt) -> ctxt - | Origination { script ; _ } -> - (* Fail quickly if not enough gas for minimal deserialization cost *) - Lwt.return @@ record_trace Gas_quota_exceeded_init_deserialize @@ - (Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt -> - Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun () -> - (* Fail if not enough gas for complete deserialization cost *) - trace Gas_quota_exceeded_init_deserialize @@ - Script.force_decode ctxt script.code >>=? fun (_code, ctxt) -> - trace Gas_quota_exceeded_init_deserialize @@ - Script.force_decode ctxt script.storage >>|? fun (_storage, ctxt) -> - ctxt - | _ -> return ctxt - end >>=? fun ctxt -> - Contract.get_manager_key ctxt source >>=? fun public_key -> + Lwt.return (Fees.check_storage_limit ctxt storage_limit) + >>=? fun () -> + Contract.must_be_allocated ctxt (Contract.implicit_contract source) + >>=? fun () -> + Contract.check_counter_increment ctxt source counter + >>=? fun () -> + ( match operation with + | Reveal pk -> + Contract.reveal_manager_key ctxt source pk + | Transaction {parameters; _} -> + (* Fail quickly if not enough gas for minimal deserialization cost *) + Lwt.return + @@ record_trace Gas_quota_exceeded_init_deserialize + @@ Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters) + >>=? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + trace Gas_quota_exceeded_init_deserialize + @@ Script.force_decode ctxt parameters + >>|? fun (_arg, ctxt) -> ctxt + | Origination {script; _} -> + (* Fail quickly if not enough gas for minimal deserialization cost *) + Lwt.return + @@ record_trace Gas_quota_exceeded_init_deserialize + @@ ( Gas.consume ctxt (Script.minimal_deserialize_cost script.code) + >>? fun ctxt -> + Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage) + ) + >>=? fun () -> + (* Fail if not enough gas for complete deserialization cost *) + trace Gas_quota_exceeded_init_deserialize + @@ Script.force_decode ctxt script.code + >>=? fun (_code, ctxt) -> + trace Gas_quota_exceeded_init_deserialize + @@ Script.force_decode ctxt script.storage + >>|? fun (_storage, ctxt) -> ctxt + | _ -> + return ctxt ) + >>=? fun ctxt -> + Contract.get_manager_key ctxt source + >>=? fun public_key -> (* Currently, the `raw_operation` only contains one signature, so all operations are required to be from the same manager. This may change in the future, allowing several managers to group-sign a sequence of transactions. *) - Operation.check_signature public_key chain_id raw_operation >>=? fun () -> - Contract.increment_counter ctxt source >>=? fun ctxt -> - Contract.spend ctxt (Contract.implicit_contract source) fee >>=? fun ctxt -> - add_fees ctxt fee >>=? fun ctxt -> - return ctxt + Operation.check_signature public_key chain_id raw_operation + >>=? fun () -> + Contract.increment_counter ctxt source + >>=? fun ctxt -> + Contract.spend ctxt (Contract.implicit_contract source) fee + >>=? fun ctxt -> add_fees ctxt fee >>=? fun ctxt -> return ctxt -let apply_manager_contents - (type kind) ctxt mode chain_id (op : kind Kind.manager contents) - : ([ `Success of context | `Failure ] * - kind manager_operation_result * - packed_internal_operation_result list) Lwt.t = - let Manager_operation - { source ; operation ; gas_limit ; storage_limit } = op in +let apply_manager_contents (type kind) ctxt mode chain_id + (op : kind Kind.manager contents) : + ( [`Success of context | `Failure] + * kind manager_operation_result + * packed_internal_operation_result list ) + Lwt.t = + let (Manager_operation {source; operation; gas_limit; storage_limit}) = op in let ctxt = Gas.set_limit ctxt gas_limit in let ctxt = Fees.start_counting_storage_fees ctxt in let source = Contract.implicit_contract source in - apply_manager_operation_content ctxt mode - ~source ~payer:source ~internal:false ~chain_id operation >>= function - | Ok (ctxt, operation_results, internal_operations) -> begin + apply_manager_operation_content + ctxt + mode + ~source + ~payer:source + ~internal:false + ~chain_id + operation + >>= function + | Ok (ctxt, operation_results, internal_operations) -> ( apply_internal_manager_operations - ctxt mode ~payer:source ~chain_id internal_operations >>= function - | (`Success ctxt, internal_operations_results) -> begin - Fees.burn_storage_fees ctxt ~storage_limit ~payer:source >>= function + ctxt + mode + ~payer:source + ~chain_id + internal_operations + >>= function + | (`Success ctxt, internal_operations_results) -> ( + Fees.burn_storage_fees ctxt ~storage_limit ~payer:source + >>= function | Ok ctxt -> Lwt.return - (`Success ctxt, Applied operation_results, internal_operations_results) + ( `Success ctxt, + Applied operation_results, + internal_operations_results ) | Error errors -> Lwt.return - (`Failure, Backtracked (operation_results, Some errors), internal_operations_results) - end + ( `Failure, + Backtracked (operation_results, Some errors), + internal_operations_results ) ) | (`Failure, internal_operations_results) -> Lwt.return (`Failure, Applied operation_results, internal_operations_results) - end + ) | Error errors -> - Lwt.return - (`Failure, Failed (manager_kind operation, errors), []) + Lwt.return (`Failure, Failed (manager_kind operation, errors), []) -let skipped_operation_result - : type kind. kind manager_operation -> kind manager_operation_result - = function operation -> - match operation with - | Reveal _ -> - Applied ( Reveal_result { consumed_gas = Z.zero } : kind successful_manager_operation_result ) - | _ -> Skipped (manager_kind operation) +let skipped_operation_result : + type kind. kind manager_operation -> kind manager_operation_result = + function + | operation -> ( + match operation with + | Reveal _ -> + Applied + ( Reveal_result {consumed_gas = Z.zero} + : kind successful_manager_operation_result ) + | _ -> + Skipped (manager_kind operation) ) -let rec mark_skipped - : type kind. - baker : Signature.Public_key_hash.t -> Level.t -> kind Kind.manager contents_list -> - kind Kind.manager contents_result_list = fun ~baker level -> function - | Single (Manager_operation { source ; fee ; operation } ) -> +let rec mark_skipped : + type kind. + baker:Signature.Public_key_hash.t -> + Level.t -> + kind Kind.manager contents_list -> + kind Kind.manager contents_result_list = + fun ~baker level -> function + | Single (Manager_operation {source; fee; operation}) -> let source = Contract.implicit_contract source in Single_result (Manager_operation_result - { balance_updates = + { + balance_updates = Delegate.cleanup_balance_updates - [ Contract source, Debited fee ; - Fees (baker, level.cycle), Credited fee ] ; - operation_result = skipped_operation_result operation ; - internal_operation_results = [] }) - | Cons (Manager_operation { source ; fee ; operation } , rest) -> + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result = skipped_operation_result operation; + internal_operation_results = []; + }) + | Cons (Manager_operation {source; fee; operation}, rest) -> let source = Contract.implicit_contract source in Cons_result - (Manager_operation_result { - balance_updates = - Delegate.cleanup_balance_updates - [ Contract source, Debited fee ; - Fees (baker, level.cycle), Credited fee ] ; - operation_result = skipped_operation_result operation ; - internal_operation_results = [] }, - mark_skipped ~baker level rest) + ( Manager_operation_result + { + balance_updates = + Delegate.cleanup_balance_updates + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result = skipped_operation_result operation; + internal_operation_results = []; + }, + mark_skipped ~baker level rest ) -let rec precheck_manager_contents_list - : type kind. - Alpha_context.t -> Chain_id.t -> _ Operation.t -> kind Kind.manager contents_list -> +let rec precheck_manager_contents_list : + type kind. + Alpha_context.t -> + Chain_id.t -> + _ Operation.t -> + kind Kind.manager contents_list -> context tzresult Lwt.t = - fun ctxt chain_id raw_operation contents_list -> - match contents_list with - | Single (Manager_operation _ as op) -> - precheck_manager_contents ctxt chain_id raw_operation op - | Cons (Manager_operation _ as op, rest) -> - precheck_manager_contents ctxt chain_id raw_operation op >>=? fun ctxt -> - precheck_manager_contents_list ctxt chain_id raw_operation rest + fun ctxt chain_id raw_operation contents_list -> + match contents_list with + | Single (Manager_operation _ as op) -> + precheck_manager_contents ctxt chain_id raw_operation op + | Cons ((Manager_operation _ as op), rest) -> + precheck_manager_contents ctxt chain_id raw_operation op + >>=? fun ctxt -> + precheck_manager_contents_list ctxt chain_id raw_operation rest -let rec apply_manager_contents_list_rec - : type kind. - Alpha_context.t -> Script_ir_translator.unparsing_mode -> - public_key_hash -> Chain_id.t -> kind Kind.manager contents_list -> - ([ `Success of context | `Failure ] * - kind Kind.manager contents_result_list) Lwt.t = - fun ctxt mode baker chain_id contents_list -> - let level = Level.current ctxt in - match contents_list with - | Single (Manager_operation { source ; fee ; _ } as op) -> begin - let source = Contract.implicit_contract source in - apply_manager_contents ctxt mode chain_id op - >>= fun (ctxt_result, operation_result, internal_operation_results) -> - let result = - Manager_operation_result { +let rec apply_manager_contents_list_rec : + type kind. + Alpha_context.t -> + Script_ir_translator.unparsing_mode -> + public_key_hash -> + Chain_id.t -> + kind Kind.manager contents_list -> + ([`Success of context | `Failure] * kind Kind.manager contents_result_list) + Lwt.t = + fun ctxt mode baker chain_id contents_list -> + let level = Level.current ctxt in + match contents_list with + | Single (Manager_operation {source; fee; _} as op) -> + let source = Contract.implicit_contract source in + apply_manager_contents ctxt mode chain_id op + >>= fun (ctxt_result, operation_result, internal_operation_results) -> + let result = + Manager_operation_result + { balance_updates = Delegate.cleanup_balance_updates - [ Contract source, Debited fee ; - Fees (baker, level.cycle), Credited fee ] ; - operation_result ; - internal_operation_results ; - } in - Lwt.return (ctxt_result, Single_result (result)) - end - | Cons (Manager_operation { source ; fee ; _ } as op, rest) -> - let source = Contract.implicit_contract source in - apply_manager_contents ctxt mode chain_id op >>= function - | (`Failure, operation_result, internal_operation_results) -> - let result = - Manager_operation_result { + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result; + internal_operation_results; + } + in + Lwt.return (ctxt_result, Single_result result) + | Cons ((Manager_operation {source; fee; _} as op), rest) -> ( + let source = Contract.implicit_contract source in + apply_manager_contents ctxt mode chain_id op + >>= function + | (`Failure, operation_result, internal_operation_results) -> + let result = + Manager_operation_result + { balance_updates = Delegate.cleanup_balance_updates - [ Contract source, Debited fee ; - Fees (baker, level.cycle), Credited fee ] ; - operation_result ; - internal_operation_results ; - } in - Lwt.return (`Failure, Cons_result (result, mark_skipped ~baker level rest)) - | (`Success ctxt, operation_result, internal_operation_results) -> - let result = - Manager_operation_result { + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result; + internal_operation_results; + } + in + Lwt.return + (`Failure, Cons_result (result, mark_skipped ~baker level rest)) + | (`Success ctxt, operation_result, internal_operation_results) -> + let result = + Manager_operation_result + { balance_updates = Delegate.cleanup_balance_updates - [ Contract source, Debited fee ; - Fees (baker, level.cycle), Credited fee ] ; - operation_result ; - internal_operation_results ; - } in - apply_manager_contents_list_rec ctxt mode baker chain_id rest >>= fun (ctxt_result, results) -> - Lwt.return (ctxt_result, Cons_result (result, results)) + [ (Contract source, Debited fee); + (Fees (baker, level.cycle), Credited fee) ]; + operation_result; + internal_operation_results; + } + in + apply_manager_contents_list_rec ctxt mode baker chain_id rest + >>= fun (ctxt_result, results) -> + Lwt.return (ctxt_result, Cons_result (result, results)) ) let mark_backtracked results = - let rec mark_contents_list - : type kind. kind Kind.manager contents_result_list -> kind Kind.manager contents_result_list - = function - | Single_result (Manager_operation_result op) -> - Single_result (Manager_operation_result - { balance_updates = - op.balance_updates ; - operation_result = - mark_manager_operation_result op.operation_result ; - internal_operation_results = - List.map mark_internal_operation_results op.internal_operation_results}) - | Cons_result (Manager_operation_result op, rest) -> - Cons_result (Manager_operation_result - { balance_updates = - op.balance_updates ; - operation_result = - mark_manager_operation_result op.operation_result ; - internal_operation_results = - List.map mark_internal_operation_results op.internal_operation_results}, - mark_contents_list rest) - and mark_internal_operation_results (Internal_operation_result (kind, result)) = - (Internal_operation_result (kind, mark_manager_operation_result result)) - and mark_manager_operation_result - : type kind. kind manager_operation_result -> kind manager_operation_result - = function - | Failed _ | Skipped _ | Backtracked _ as result -> result - | Applied (Reveal_result _) as result -> result - | Applied result -> Backtracked (result, None) in + let rec mark_contents_list : + type kind. + kind Kind.manager contents_result_list -> + kind Kind.manager contents_result_list = function + | Single_result (Manager_operation_result op) -> + Single_result + (Manager_operation_result + { + balance_updates = op.balance_updates; + operation_result = + mark_manager_operation_result op.operation_result; + internal_operation_results = + List.map + mark_internal_operation_results + op.internal_operation_results; + }) + | Cons_result (Manager_operation_result op, rest) -> + Cons_result + ( Manager_operation_result + { + balance_updates = op.balance_updates; + operation_result = + mark_manager_operation_result op.operation_result; + internal_operation_results = + List.map + mark_internal_operation_results + op.internal_operation_results; + }, + mark_contents_list rest ) + and mark_internal_operation_results + (Internal_operation_result (kind, result)) = + Internal_operation_result (kind, mark_manager_operation_result result) + and mark_manager_operation_result : + type kind. kind manager_operation_result -> kind manager_operation_result + = function + | (Failed _ | Skipped _ | Backtracked _) as result -> + result + | Applied (Reveal_result _) as result -> + result + | Applied result -> + Backtracked (result, None) + in mark_contents_list results let apply_manager_contents_list ctxt mode baker chain_id contents_list = - apply_manager_contents_list_rec ctxt mode baker chain_id contents_list >>= fun (ctxt_result, results) -> + apply_manager_contents_list_rec ctxt mode baker chain_id contents_list + >>= fun (ctxt_result, results) -> match ctxt_result with - | `Failure -> Lwt.return (ctxt (* backtracked *), mark_backtracked results) + | `Failure -> + Lwt.return (ctxt (* backtracked *), mark_backtracked results) | `Success ctxt -> - Big_map.cleanup_temporary ctxt >>= fun ctxt -> - Lwt.return (ctxt, results) + Big_map.cleanup_temporary ctxt >>= fun ctxt -> Lwt.return (ctxt, results) -let apply_contents_list - (type kind) ctxt chain_id mode pred_block baker - (operation : kind operation) - (contents_list : kind contents_list) - : (context * kind contents_result_list) tzresult Lwt.t = +let apply_contents_list (type kind) ctxt chain_id mode pred_block baker + (operation : kind operation) (contents_list : kind contents_list) : + (context * kind contents_result_list) tzresult Lwt.t = match contents_list with - | Single (Endorsement { level }) -> + | Single (Endorsement {level}) -> let block = operation.shell.branch in fail_unless (Block_hash.equal block pred_block) - (Wrong_endorsement_predecessor (pred_block, block)) >>=? fun () -> + (Wrong_endorsement_predecessor (pred_block, block)) + >>=? fun () -> let current_level = (Level.current ctxt).level in fail_unless Raw_level.(succ level = current_level) - Invalid_endorsement_level >>=? fun () -> - Baking.check_endorsement_rights ctxt chain_id operation >>=? fun (delegate, slots, used) -> + Invalid_endorsement_level + >>=? fun () -> + Baking.check_endorsement_rights ctxt chain_id operation + >>=? fun (delegate, slots, used) -> if used then fail (Duplicate_endorsement delegate) else let ctxt = record_endorsement ctxt delegate in let gap = List.length slots in Lwt.return - Tez.(Constants.endorsement_security_deposit ctxt *? - Int64.of_int gap) >>=? fun deposit -> - Delegate.freeze_deposit ctxt delegate deposit >>=? fun ctxt -> - Global.get_block_priority ctxt >>=? fun block_priority -> - Baking.endorsing_reward ctxt ~block_priority gap >>=? fun reward -> - Delegate.freeze_rewards ctxt delegate reward >>=? fun ctxt -> + Tez.(Constants.endorsement_security_deposit ctxt *? Int64.of_int gap) + >>=? fun deposit -> + Delegate.freeze_deposit ctxt delegate deposit + >>=? fun ctxt -> + Global.get_block_priority ctxt + >>=? fun block_priority -> + Baking.endorsing_reward ctxt ~block_priority gap + >>=? fun reward -> + Delegate.freeze_rewards ctxt delegate reward + >>=? fun ctxt -> let level = Level.from_raw ctxt level in - return (ctxt, Single_result - (Endorsement_result - { balance_updates = Delegate.cleanup_balance_updates - [ Contract (Contract.implicit_contract delegate), Debited deposit; - Deposits (delegate, level.cycle), Credited deposit; - Rewards (delegate, level.cycle), Credited reward; ] ; - delegate ; slots })) - | Single (Seed_nonce_revelation { level ; nonce }) -> + return + ( ctxt, + Single_result + (Endorsement_result + { + balance_updates = + Delegate.cleanup_balance_updates + [ ( Contract (Contract.implicit_contract delegate), + Debited deposit ); + (Deposits (delegate, level.cycle), Credited deposit); + (Rewards (delegate, level.cycle), Credited reward) ]; + delegate; + slots; + }) ) + | Single (Seed_nonce_revelation {level; nonce}) -> let level = Level.from_raw ctxt level in - Nonce.reveal ctxt level nonce >>=? fun ctxt -> + Nonce.reveal ctxt level nonce + >>=? fun ctxt -> let seed_nonce_revelation_tip = - Constants.seed_nonce_revelation_tip ctxt in - add_rewards ctxt seed_nonce_revelation_tip >>=? fun ctxt -> - return (ctxt, Single_result - (Seed_nonce_revelation_result - [ Rewards (baker, level.cycle), Credited seed_nonce_revelation_tip ])) - | Single (Double_endorsement_evidence { op1 ; op2 }) -> begin - match op1.protocol_data.contents, op2.protocol_data.contents with - | Single (Endorsement e1), - Single (Endorsement e2) - when Raw_level.(e1.level = e2.level) && - not (Block_hash.equal op1.shell.branch op2.shell.branch) -> - let level = Level.from_raw ctxt e1.level in - let oldest_level = Level.last_allowed_fork_level ctxt in - fail_unless Level.(level < Level.current ctxt) - (Too_early_double_endorsement_evidence - { level = level.level ; - current = (Level.current ctxt).level }) >>=? fun () -> - fail_unless Raw_level.(oldest_level <= level.level) - (Outdated_double_endorsement_evidence - { level = level.level ; - last = oldest_level }) >>=? fun () -> - Baking.check_endorsement_rights ctxt chain_id op1 >>=? fun (delegate1, _, _) -> - Baking.check_endorsement_rights ctxt chain_id op2 >>=? fun (delegate2, _, _) -> - fail_unless - (Signature.Public_key_hash.equal delegate1 delegate2) - (Inconsistent_double_endorsement_evidence - { delegate1 ; delegate2 }) >>=? fun () -> - Delegate.has_frozen_balance ctxt delegate1 level.cycle >>=? fun valid -> - fail_unless valid Unrequired_double_endorsement_evidence >>=? fun () -> - Delegate.punish ctxt delegate1 level.cycle >>=? fun (ctxt, balance) -> - Lwt.return Tez.(balance.deposit +? balance.fees) >>=? fun burned -> - let reward = - match Tez.(burned /? 2L) with - | Ok v -> v - | Error _ -> Tez.zero in - add_rewards ctxt reward >>=? fun ctxt -> - let current_cycle = (Level.current ctxt).cycle in - return (ctxt, Single_result - (Double_endorsement_evidence_result - (Delegate.cleanup_balance_updates [ - Deposits (delegate1, level.cycle), Debited balance.deposit ; - Fees (delegate1, level.cycle), Debited balance.fees ; - Rewards (delegate1, level.cycle), Debited balance.rewards ; - Rewards (baker, current_cycle), Credited reward ]))) - | _, _ -> fail Invalid_double_endorsement_evidence - end - | Single (Double_baking_evidence { bh1 ; bh2 }) -> + Constants.seed_nonce_revelation_tip ctxt + in + add_rewards ctxt seed_nonce_revelation_tip + >>=? fun ctxt -> + return + ( ctxt, + Single_result + (Seed_nonce_revelation_result + [ ( Rewards (baker, level.cycle), + Credited seed_nonce_revelation_tip ) ]) ) + | Single (Double_endorsement_evidence {op1; op2}) -> ( + match (op1.protocol_data.contents, op2.protocol_data.contents) with + | (Single (Endorsement e1), Single (Endorsement e2)) + when Raw_level.(e1.level = e2.level) + && not (Block_hash.equal op1.shell.branch op2.shell.branch) -> + let level = Level.from_raw ctxt e1.level in + let oldest_level = Level.last_allowed_fork_level ctxt in + fail_unless + Level.(level < Level.current ctxt) + (Too_early_double_endorsement_evidence + {level = level.level; current = (Level.current ctxt).level}) + >>=? fun () -> + fail_unless + Raw_level.(oldest_level <= level.level) + (Outdated_double_endorsement_evidence + {level = level.level; last = oldest_level}) + >>=? fun () -> + Baking.check_endorsement_rights ctxt chain_id op1 + >>=? fun (delegate1, _, _) -> + Baking.check_endorsement_rights ctxt chain_id op2 + >>=? fun (delegate2, _, _) -> + fail_unless + (Signature.Public_key_hash.equal delegate1 delegate2) + (Inconsistent_double_endorsement_evidence {delegate1; delegate2}) + >>=? fun () -> + Delegate.has_frozen_balance ctxt delegate1 level.cycle + >>=? fun valid -> + fail_unless valid Unrequired_double_endorsement_evidence + >>=? fun () -> + Delegate.punish ctxt delegate1 level.cycle + >>=? fun (ctxt, balance) -> + Lwt.return Tez.(balance.deposit +? balance.fees) + >>=? fun burned -> + let reward = + match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero + in + add_rewards ctxt reward + >>=? fun ctxt -> + let current_cycle = (Level.current ctxt).cycle in + return + ( ctxt, + Single_result + (Double_endorsement_evidence_result + (Delegate.cleanup_balance_updates + [ ( Deposits (delegate1, level.cycle), + Debited balance.deposit ); + (Fees (delegate1, level.cycle), Debited balance.fees); + ( Rewards (delegate1, level.cycle), + Debited balance.rewards ); + (Rewards (baker, current_cycle), Credited reward) ])) ) + | (_, _) -> + fail Invalid_double_endorsement_evidence ) + | Single (Double_baking_evidence {bh1; bh2}) -> let hash1 = Block_header.hash bh1 in let hash2 = Block_header.hash bh2 in fail_unless - (Compare.Int32.(bh1.shell.level = bh2.shell.level) && - not (Block_hash.equal hash1 hash2)) + ( Compare.Int32.(bh1.shell.level = bh2.shell.level) + && not (Block_hash.equal hash1 hash2) ) (Invalid_double_baking_evidence - { hash1 ; - level1 = bh1.shell.level ; - hash2 ; - level2 = bh2.shell.level ; - }) >>=? fun () -> - Lwt.return (Raw_level.of_int32 bh1.shell.level) >>=? fun raw_level -> + {hash1; level1 = bh1.shell.level; hash2; level2 = bh2.shell.level}) + >>=? fun () -> + Lwt.return (Raw_level.of_int32 bh1.shell.level) + >>=? fun raw_level -> let oldest_level = Level.last_allowed_fork_level ctxt in - fail_unless Raw_level.(raw_level < (Level.current ctxt).level) + fail_unless + Raw_level.(raw_level < (Level.current ctxt).level) (Too_early_double_baking_evidence - { level = raw_level ; - current = (Level.current ctxt).level }) >>=? fun () -> - fail_unless Raw_level.(oldest_level <= raw_level) + {level = raw_level; current = (Level.current ctxt).level}) + >>=? fun () -> + fail_unless + Raw_level.(oldest_level <= raw_level) (Outdated_double_baking_evidence - { level = raw_level ; - last = oldest_level }) >>=? fun () -> + {level = raw_level; last = oldest_level}) + >>=? fun () -> let level = Level.from_raw ctxt raw_level in Roll.baking_rights_owner - ctxt level ~priority:bh1.protocol_data.contents.priority >>=? fun delegate1 -> - Baking.check_signature bh1 chain_id delegate1 >>=? fun () -> + ctxt + level + ~priority:bh1.protocol_data.contents.priority + >>=? fun delegate1 -> + Baking.check_signature bh1 chain_id delegate1 + >>=? fun () -> Roll.baking_rights_owner - ctxt level ~priority:bh2.protocol_data.contents.priority >>=? fun delegate2 -> - Baking.check_signature bh2 chain_id delegate2 >>=? fun () -> + ctxt + level + ~priority:bh2.protocol_data.contents.priority + >>=? fun delegate2 -> + Baking.check_signature bh2 chain_id delegate2 + >>=? fun () -> fail_unless (Signature.Public_key.equal delegate1 delegate2) (Inconsistent_double_baking_evidence - { delegate1 = Signature.Public_key.hash delegate1 ; - delegate2 = Signature.Public_key.hash delegate2 }) >>=? fun () -> + { + delegate1 = Signature.Public_key.hash delegate1; + delegate2 = Signature.Public_key.hash delegate2; + }) + >>=? fun () -> let delegate = Signature.Public_key.hash delegate1 in - Delegate.has_frozen_balance ctxt delegate level.cycle >>=? fun valid -> - fail_unless valid Unrequired_double_baking_evidence >>=? fun () -> - Delegate.punish ctxt delegate level.cycle >>=? fun (ctxt, balance) -> - Lwt.return Tez.(balance.deposit +? balance.fees) >>=? fun burned -> + Delegate.has_frozen_balance ctxt delegate level.cycle + >>=? fun valid -> + fail_unless valid Unrequired_double_baking_evidence + >>=? fun () -> + Delegate.punish ctxt delegate level.cycle + >>=? fun (ctxt, balance) -> + Lwt.return Tez.(balance.deposit +? balance.fees) + >>=? fun burned -> let reward = - match Tez.(burned /? 2L) with - | Ok v -> v - | Error _ -> Tez.zero in - add_rewards ctxt reward >>=? fun ctxt -> + match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero + in + add_rewards ctxt reward + >>=? fun ctxt -> let current_cycle = (Level.current ctxt).cycle in - return (ctxt, Single_result - (Double_baking_evidence_result - (Delegate.cleanup_balance_updates [ - Deposits (delegate, level.cycle), Debited balance.deposit ; - Fees (delegate, level.cycle), Debited balance.fees ; - Rewards (delegate, level.cycle), Debited balance.rewards ; - Rewards (baker, current_cycle), Credited reward ; ]))) - | Single (Activate_account { id = pkh ; activation_code }) -> begin + return + ( ctxt, + Single_result + (Double_baking_evidence_result + (Delegate.cleanup_balance_updates + [ (Deposits (delegate, level.cycle), Debited balance.deposit); + (Fees (delegate, level.cycle), Debited balance.fees); + (Rewards (delegate, level.cycle), Debited balance.rewards); + (Rewards (baker, current_cycle), Credited reward) ])) ) + | Single (Activate_account {id = pkh; activation_code}) -> ( let blinded_pkh = - Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in - Commitment.get_opt ctxt blinded_pkh >>=? function - | None -> fail (Invalid_activation { pkh }) + Blinded_public_key_hash.of_ed25519_pkh activation_code pkh + in + Commitment.get_opt ctxt blinded_pkh + >>=? function + | None -> + fail (Invalid_activation {pkh}) | Some amount -> - Commitment.delete ctxt blinded_pkh >>=? fun ctxt -> + Commitment.delete ctxt blinded_pkh + >>=? fun ctxt -> let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in - Contract.(credit ctxt contract amount) >>=? fun ctxt -> - return (ctxt, Single_result (Activate_account_result - [ Contract contract, Credited amount ])) - end - | Single (Proposals { source ; period ; proposals }) -> - Roll.delegate_pubkey ctxt source >>=? fun delegate -> - Operation.check_signature delegate chain_id operation >>=? fun () -> + Contract.(credit ctxt contract amount) + >>=? fun ctxt -> + return + ( ctxt, + Single_result + (Activate_account_result [(Contract contract, Credited amount)]) + ) ) + | Single (Proposals {source; period; proposals}) -> + Roll.delegate_pubkey ctxt source + >>=? fun delegate -> + Operation.check_signature delegate chain_id operation + >>=? fun () -> let level = Level.current ctxt in - fail_unless Voting_period.(level.voting_period = period) - (Wrong_voting_period (level.voting_period, period)) >>=? fun () -> - Amendment.record_proposals ctxt source proposals >>=? fun ctxt -> - return (ctxt, Single_result Proposals_result) - | Single (Ballot { source ; period ; proposal ; ballot }) -> - Roll.delegate_pubkey ctxt source >>=? fun delegate -> - Operation.check_signature delegate chain_id operation >>=? fun () -> + fail_unless + Voting_period.(level.voting_period = period) + (Wrong_voting_period (level.voting_period, period)) + >>=? fun () -> + Amendment.record_proposals ctxt source proposals + >>=? fun ctxt -> return (ctxt, Single_result Proposals_result) + | Single (Ballot {source; period; proposal; ballot}) -> + Roll.delegate_pubkey ctxt source + >>=? fun delegate -> + Operation.check_signature delegate chain_id operation + >>=? fun () -> let level = Level.current ctxt in - fail_unless Voting_period.(level.voting_period = period) - (Wrong_voting_period (level.voting_period, period)) >>=? fun () -> - Amendment.record_ballot ctxt source proposal ballot >>=? fun ctxt -> - return (ctxt, Single_result Ballot_result) + fail_unless + Voting_period.(level.voting_period = period) + (Wrong_voting_period (level.voting_period, period)) + >>=? fun () -> + Amendment.record_ballot ctxt source proposal ballot + >>=? fun ctxt -> return (ctxt, Single_result Ballot_result) | Single (Manager_operation _) as op -> - precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt -> - apply_manager_contents_list ctxt mode baker chain_id op >>= fun (ctxt, result) -> - return (ctxt, result) + precheck_manager_contents_list ctxt chain_id operation op + >>=? fun ctxt -> + apply_manager_contents_list ctxt mode baker chain_id op + >>= fun (ctxt, result) -> return (ctxt, result) | Cons (Manager_operation _, _) as op -> - precheck_manager_contents_list ctxt chain_id operation op >>=? fun ctxt -> - apply_manager_contents_list ctxt mode baker chain_id op >>= fun (ctxt, result) -> - return (ctxt, result) + precheck_manager_contents_list ctxt chain_id operation op + >>=? fun ctxt -> + apply_manager_contents_list ctxt mode baker chain_id op + >>= fun (ctxt, result) -> return (ctxt, result) let apply_operation ctxt chain_id mode pred_block baker hash operation = let ctxt = Contract.init_origination_nonce ctxt hash in apply_contents_list - ctxt chain_id mode pred_block baker operation - operation.protocol_data.contents >>=? fun (ctxt, result) -> + ctxt + chain_id + mode + pred_block + baker + operation + operation.protocol_data.contents + >>=? fun (ctxt, result) -> let ctxt = Gas.set_unlimited ctxt in let ctxt = Contract.unset_origination_nonce ctxt in - return (ctxt, { contents = result }) + return (ctxt, {contents = result}) let may_snapshot_roll ctxt = let level = Alpha_context.Level.current ctxt in let blocks_per_roll_snapshot = Constants.blocks_per_roll_snapshot ctxt in - if Compare.Int32.equal + if + Compare.Int32.equal (Int32.rem level.cycle_position blocks_per_roll_snapshot) (Int32.pred blocks_per_roll_snapshot) - then - Alpha_context.Roll.snapshot_rolls ctxt >>=? fun ctxt -> - return ctxt - else - return ctxt + then Alpha_context.Roll.snapshot_rolls ctxt >>=? fun ctxt -> return ctxt + else return ctxt let may_start_new_cycle ctxt = - Baking.dawn_of_a_new_cycle ctxt >>=? function - | None -> return (ctxt, [], []) + Baking.dawn_of_a_new_cycle ctxt + >>=? function + | None -> + return (ctxt, [], []) | Some last_cycle -> - Seed.cycle_end ctxt last_cycle >>=? fun (ctxt, unrevealed) -> - Roll.cycle_end ctxt last_cycle >>=? fun ctxt -> - Delegate.cycle_end ctxt last_cycle unrevealed >>=? fun (ctxt, update_balances, deactivated) -> - Bootstrap.cycle_end ctxt last_cycle >>=? fun ctxt -> - return (ctxt, update_balances, deactivated) + Seed.cycle_end ctxt last_cycle + >>=? fun (ctxt, unrevealed) -> + Roll.cycle_end ctxt last_cycle + >>=? fun ctxt -> + Delegate.cycle_end ctxt last_cycle unrevealed + >>=? fun (ctxt, update_balances, deactivated) -> + Bootstrap.cycle_end ctxt last_cycle + >>=? fun ctxt -> return (ctxt, update_balances, deactivated) let begin_full_construction ctxt pred_timestamp protocol_data = - Alpha_context.Global.set_block_priority ctxt - protocol_data.Block_header.priority >>=? fun ctxt -> - Baking.check_baking_rights - ctxt protocol_data pred_timestamp >>=? fun (delegate_pk, block_delay) -> + Alpha_context.Global.set_block_priority + ctxt + protocol_data.Block_header.priority + >>=? fun ctxt -> + Baking.check_baking_rights ctxt protocol_data pred_timestamp + >>=? fun (delegate_pk, block_delay) -> let ctxt = Fitness.increase ctxt in match Level.pred ctxt (Level.current ctxt) with - | None -> assert false (* genesis *) + | None -> + assert false (* genesis *) | Some pred_level -> - Baking.endorsement_rights ctxt pred_level >>=? fun rights -> + Baking.endorsement_rights ctxt pred_level + >>=? fun rights -> let ctxt = init_endorsements ctxt rights in return (ctxt, protocol_data, delegate_pk, block_delay) let begin_partial_construction ctxt = let ctxt = Fitness.increase ctxt in match Level.pred ctxt (Level.current ctxt) with - | None -> assert false (* genesis *) + | None -> + assert false (* genesis *) | Some pred_level -> - Baking.endorsement_rights ctxt pred_level >>=? fun rights -> + Baking.endorsement_rights ctxt pred_level + >>=? fun rights -> let ctxt = init_endorsements ctxt rights in return ctxt let begin_application ctxt chain_id block_header pred_timestamp = - Alpha_context.Global.set_block_priority ctxt - block_header.Block_header.protocol_data.contents.priority >>=? fun ctxt -> + Alpha_context.Global.set_block_priority + ctxt + block_header.Block_header.protocol_data.contents.priority + >>=? fun ctxt -> let current_level = Alpha_context.Level.current ctxt in - Baking.check_proof_of_work_stamp ctxt block_header >>=? fun () -> - Baking.check_fitness_gap ctxt block_header >>=? fun () -> + Baking.check_proof_of_work_stamp ctxt block_header + >>=? fun () -> + Baking.check_fitness_gap ctxt block_header + >>=? fun () -> Baking.check_baking_rights - ctxt block_header.protocol_data.contents pred_timestamp + ctxt + block_header.protocol_data.contents + pred_timestamp >>=? fun (delegate_pk, block_delay) -> - Baking.check_signature block_header chain_id delegate_pk >>=? fun () -> + Baking.check_signature block_header chain_id delegate_pk + >>=? fun () -> let has_commitment = match block_header.protocol_data.contents.seed_nonce_hash with - | None -> false - | Some _ -> true in + | None -> + false + | Some _ -> + true + in fail_unless Compare.Bool.(has_commitment = current_level.expected_commitment) - (Invalid_commitment - { expected = current_level.expected_commitment }) >>=? fun () -> + (Invalid_commitment {expected = current_level.expected_commitment}) + >>=? fun () -> let ctxt = Fitness.increase ctxt in match Level.pred ctxt (Level.current ctxt) with - | None -> assert false (* genesis *) + | None -> + assert false (* genesis *) | Some pred_level -> - Baking.endorsement_rights ctxt pred_level >>=? fun rights -> + Baking.endorsement_rights ctxt pred_level + >>=? fun rights -> let ctxt = init_endorsements ctxt rights in return (ctxt, delegate_pk, block_delay) -let check_minimum_endorsements ctxt protocol_data block_delay included_endorsements = +let check_minimum_endorsements ctxt protocol_data block_delay + included_endorsements = let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in let timestamp = Timestamp.current ctxt in - fail_unless Compare.Int.(included_endorsements >= minimum) + fail_unless + Compare.Int.(included_endorsements >= minimum) (Not_enough_endorsements_for_priority - { required = minimum ; - priority = protocol_data.Block_header.priority ; - endorsements = included_endorsements ; - timestamp }) + { + required = minimum; + priority = protocol_data.Block_header.priority; + endorsements = included_endorsements; + timestamp; + }) let finalize_application ctxt protocol_data delegate ~block_delay = let included_endorsements = included_endorsements ctxt in - check_minimum_endorsements ctxt - protocol_data block_delay included_endorsements >>=? fun () -> + check_minimum_endorsements + ctxt + protocol_data + block_delay + included_endorsements + >>=? fun () -> let deposit = Constants.block_security_deposit ctxt in - add_deposit ctxt delegate deposit >>=? fun ctxt -> - - Baking.baking_reward ctxt - ~block_priority:protocol_data.priority ~included_endorsements >>=? fun reward -> - add_rewards ctxt reward >>=? fun ctxt -> + add_deposit ctxt delegate deposit + >>=? fun ctxt -> + Baking.baking_reward + ctxt + ~block_priority:protocol_data.priority + ~included_endorsements + >>=? fun reward -> + add_rewards ctxt reward + >>=? fun ctxt -> Signature.Public_key_hash.Map.fold (fun delegate deposit ctxt -> - ctxt >>=? fun ctxt -> - Delegate.freeze_deposit ctxt delegate deposit) + ctxt >>=? fun ctxt -> Delegate.freeze_deposit ctxt delegate deposit) (get_deposits ctxt) - (return ctxt) >>=? fun ctxt -> + (return ctxt) + >>=? fun ctxt -> (* end of level (from this point nothing should fail) *) let fees = Alpha_context.get_fees ctxt in - Delegate.freeze_fees ctxt delegate fees >>=? fun ctxt -> + Delegate.freeze_fees ctxt delegate fees + >>=? fun ctxt -> let rewards = Alpha_context.get_rewards ctxt in - Delegate.freeze_rewards ctxt delegate rewards >>=? fun ctxt -> - begin - match protocol_data.Block_header.seed_nonce_hash with - | None -> return ctxt - | Some nonce_hash -> - Nonce.record_hash ctxt - { nonce_hash ; delegate ; rewards ; fees } - end >>=? fun ctxt -> + Delegate.freeze_rewards ctxt delegate rewards + >>=? fun ctxt -> + ( match protocol_data.Block_header.seed_nonce_hash with + | None -> + return ctxt + | Some nonce_hash -> + Nonce.record_hash ctxt {nonce_hash; delegate; rewards; fees} ) + >>=? fun ctxt -> (* end of cycle *) - may_snapshot_roll ctxt >>=? fun ctxt -> - may_start_new_cycle ctxt >>=? fun (ctxt, balance_updates, deactivated) -> - Amendment.may_start_new_voting_period ctxt >>=? fun ctxt -> + may_snapshot_roll ctxt + >>=? fun ctxt -> + may_start_new_cycle ctxt + >>=? fun (ctxt, balance_updates, deactivated) -> + Amendment.may_start_new_voting_period ctxt + >>=? fun ctxt -> let cycle = (Level.current ctxt).cycle in let balance_updates = - Delegate.(cleanup_balance_updates - ([ Contract (Contract.implicit_contract delegate), Debited deposit ; - Deposits (delegate, cycle), Credited deposit ; - Rewards (delegate, cycle), Credited reward ] @ balance_updates)) in - let consumed_gas = Z.sub (Constants.hard_gas_limit_per_block ctxt) (Alpha_context.Gas.block_level ctxt) in - Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind -> - let receipt = Apply_results.{ baker = delegate ; - level = Level.current ctxt; - voting_period_kind ; - nonce_hash = protocol_data.seed_nonce_hash ; - consumed_gas ; - deactivated ; - balance_updates } in + Delegate.( + cleanup_balance_updates + ( [ (Contract (Contract.implicit_contract delegate), Debited deposit); + (Deposits (delegate, cycle), Credited deposit); + (Rewards (delegate, cycle), Credited reward) ] + @ balance_updates )) + in + let consumed_gas = + Z.sub + (Constants.hard_gas_limit_per_block ctxt) + (Alpha_context.Gas.block_level ctxt) + in + Alpha_context.Vote.get_current_period_kind ctxt + >>=? fun voting_period_kind -> + let receipt = + Apply_results. + { + baker = delegate; + level = Level.current ctxt; + voting_period_kind; + nonce_hash = protocol_data.seed_nonce_hash; + consumed_gas; + deactivated; + balance_updates; + } + in return (ctxt, receipt) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml index d02de349a..14f631c70 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.ml @@ -27,149 +27,166 @@ open Alpha_context open Data_encoding let error_encoding = - def "error" + def + "error" ~description: "The full list of RPC errors would be too long to include.\n\ It is available at RPC `/errors` (GET).\n\ - Errors specific to protocol Alpha have an id that starts with `proto.alpha`." @@ - splitted - ~json:(conv - (fun err -> - Data_encoding.Json.construct Error_monad.error_encoding err) - (fun json -> - Data_encoding.Json.destruct Error_monad.error_encoding json) - json) - ~binary:Error_monad.error_encoding + Errors specific to protocol Alpha have an id that starts with \ + `proto.alpha`." + @@ splitted + ~json: + (conv + (fun err -> + Data_encoding.Json.construct Error_monad.error_encoding err) + (fun json -> + Data_encoding.Json.destruct Error_monad.error_encoding json) + json) + ~binary:Error_monad.error_encoding type _ successful_manager_operation_result = - | Reveal_result : - { consumed_gas : Z.t - } -> Kind.reveal successful_manager_operation_result - | Transaction_result : - { storage : Script.expr option ; - big_map_diff : Contract.big_map_diff option ; - balance_updates : Delegate.balance_updates ; - originated_contracts : Contract.t list ; - consumed_gas : Z.t ; - storage_size : Z.t ; - paid_storage_size_diff : Z.t ; - allocated_destination_contract : bool ; - } -> Kind.transaction successful_manager_operation_result - | Origination_result : - { big_map_diff : Contract.big_map_diff option ; - balance_updates : Delegate.balance_updates ; - originated_contracts : Contract.t list ; - consumed_gas : Z.t ; - storage_size : Z.t ; - paid_storage_size_diff : Z.t ; - } -> Kind.origination successful_manager_operation_result - | Delegation_result : - { consumed_gas : Z.t - } -> Kind.delegation successful_manager_operation_result + | Reveal_result : { + consumed_gas : Z.t; + } + -> Kind.reveal successful_manager_operation_result + | Transaction_result : { + storage : Script.expr option; + big_map_diff : Contract.big_map_diff option; + balance_updates : Delegate.balance_updates; + originated_contracts : Contract.t list; + consumed_gas : Z.t; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + allocated_destination_contract : bool; + } + -> Kind.transaction successful_manager_operation_result + | Origination_result : { + big_map_diff : Contract.big_map_diff option; + balance_updates : Delegate.balance_updates; + originated_contracts : Contract.t list; + consumed_gas : Z.t; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + } + -> Kind.origination successful_manager_operation_result + | Delegation_result : { + consumed_gas : Z.t; + } + -> Kind.delegation successful_manager_operation_result type packed_successful_manager_operation_result = | Successful_manager_result : - 'kind successful_manager_operation_result -> packed_successful_manager_operation_result + 'kind successful_manager_operation_result + -> packed_successful_manager_operation_result type 'kind manager_operation_result = | Applied of 'kind successful_manager_operation_result - | Backtracked of 'kind successful_manager_operation_result * error list option + | Backtracked of + 'kind successful_manager_operation_result * error list option | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result | Skipped : 'kind Kind.manager -> 'kind manager_operation_result type packed_internal_operation_result = | Internal_operation_result : - 'kind internal_operation * 'kind manager_operation_result -> packed_internal_operation_result + 'kind internal_operation * 'kind manager_operation_result + -> packed_internal_operation_result module Manager_result = struct - type 'kind case = - MCase : { - op_case: 'kind Operation.Encoding.Manager_operations.case ; - encoding: 'a Data_encoding.t ; - kind: 'kind Kind.manager ; - iselect: + | MCase : { + op_case : 'kind Operation.Encoding.Manager_operations.case; + encoding : 'a Data_encoding.t; + kind : 'kind Kind.manager; + iselect : packed_internal_operation_result -> ('kind internal_operation * 'kind manager_operation_result) option; - select: + select : packed_successful_manager_operation_result -> - 'kind successful_manager_operation_result option ; - proj: 'kind successful_manager_operation_result -> 'a ; - inj: 'a -> 'kind successful_manager_operation_result ; - t: 'kind manager_operation_result Data_encoding.t ; - } -> 'kind case + 'kind successful_manager_operation_result option; + proj : 'kind successful_manager_operation_result -> 'a; + inj : 'a -> 'kind successful_manager_operation_result; + t : 'kind manager_operation_result Data_encoding.t; + } + -> 'kind case let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj = - let Operation.Encoding.Manager_operations.MCase { name ; _ } = op_case in + let (Operation.Encoding.Manager_operations.MCase {name; _}) = op_case in let t = - def (Format.asprintf "operation.alpha.operation_result.%s" name) @@ - union ~tag_size:`Uint8 [ - case (Tag 0) - ~title:"Applied" - (merge_objs - (obj1 - (req "status" (constant "applied"))) - encoding) - (fun o -> - match o with - | Skipped _ | Failed _ | Backtracked _ -> None - | Applied o -> - match select (Successful_manager_result o) with - | None -> None - | Some o -> Some ((), proj o)) - (fun ((), x) -> (Applied (inj x))) ; - case (Tag 1) - ~title:"Failed" - (obj2 - (req "status" (constant "failed")) - (req "errors" (list error_encoding))) - (function (Failed (_, errs)) -> Some ((), errs) | _ -> None) - (fun ((), errs) -> Failed (kind, errs)) ; - case (Tag 2) - ~title:"Skipped" - (obj1 (req "status" (constant "skipped"))) - (function Skipped _ -> Some () | _ -> None) - (fun () -> Skipped kind) ; - case (Tag 3) - ~title:"Backtracked" - (merge_objs - (obj2 - (req "status" (constant "backtracked")) - (opt "errors" (list error_encoding))) - encoding) - (fun o -> - match o with - | Skipped _ | Failed _ | Applied _ -> None - | Backtracked (o, errs) -> - match select (Successful_manager_result o) with - | None -> None - | Some o -> Some (((), errs), proj o)) - (fun (((), errs), x) -> (Backtracked (inj x, errs))) ; - ] in - MCase { op_case ; encoding ; kind ; iselect ; select ; proj ; inj ; t } + def (Format.asprintf "operation.alpha.operation_result.%s" name) + @@ union + ~tag_size:`Uint8 + [ case + (Tag 0) + ~title:"Applied" + (merge_objs (obj1 (req "status" (constant "applied"))) encoding) + (fun o -> + match o with + | Skipped _ | Failed _ | Backtracked _ -> + None + | Applied o -> ( + match select (Successful_manager_result o) with + | None -> + None + | Some o -> + Some ((), proj o) )) + (fun ((), x) -> Applied (inj x)); + case + (Tag 1) + ~title:"Failed" + (obj2 + (req "status" (constant "failed")) + (req "errors" (list error_encoding))) + (function Failed (_, errs) -> Some ((), errs) | _ -> None) + (fun ((), errs) -> Failed (kind, errs)); + case + (Tag 2) + ~title:"Skipped" + (obj1 (req "status" (constant "skipped"))) + (function Skipped _ -> Some () | _ -> None) + (fun () -> Skipped kind); + case + (Tag 3) + ~title:"Backtracked" + (merge_objs + (obj2 + (req "status" (constant "backtracked")) + (opt "errors" (list error_encoding))) + encoding) + (fun o -> + match o with + | Skipped _ | Failed _ | Applied _ -> + None + | Backtracked (o, errs) -> ( + match select (Successful_manager_result o) with + | None -> + None + | Some o -> + Some (((), errs), proj o) )) + (fun (((), errs), x) -> Backtracked (inj x, errs)) ] + in + MCase {op_case; encoding; kind; iselect; select; proj; inj; t} let reveal_case = make - ~op_case: Operation.Encoding.Manager_operations.reveal_case - ~encoding: Data_encoding.(obj1 (dft "consumed_gas" z Z.zero)) - - ~iselect: - (function - | Internal_operation_result - ({ operation = Reveal _ ; _} as op, res) -> - Some (op, res) - | _ -> None) - ~select: - (function - | Successful_manager_result (Reveal_result _ as op) -> Some op - | _ -> None) - ~kind: Kind.Reveal_manager_kind - ~proj: (function Reveal_result { consumed_gas } -> consumed_gas) - ~inj: (fun consumed_gas -> Reveal_result { consumed_gas }) + ~op_case:Operation.Encoding.Manager_operations.reveal_case + ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero)) + ~iselect:(function + | Internal_operation_result (({operation = Reveal _; _} as op), res) -> + Some (op, res) + | _ -> + None) + ~select:(function + | Successful_manager_result (Reveal_result _ as op) -> + Some op + | _ -> + None) + ~kind:Kind.Reveal_manager_kind + ~proj:(function Reveal_result {consumed_gas} -> consumed_gas) + ~inj:(fun consumed_gas -> Reveal_result {consumed_gas}) let transaction_case = make - ~op_case: Operation.Encoding.Manager_operations.transaction_case + ~op_case:Operation.Encoding.Manager_operations.transaction_case ~encoding: (obj8 (opt "storage" Script.expr_encoding) @@ -180,41 +197,60 @@ module Manager_result = struct (dft "storage_size" z Z.zero) (dft "paid_storage_size_diff" z Z.zero) (dft "allocated_destination_contract" bool false)) - ~iselect: - (function - | Internal_operation_result - ({ operation = Transaction _ ; _} as op, res) -> - Some (op, res) - | _ -> None) - ~select: - (function - | Successful_manager_result (Transaction_result _ as op) -> Some op - | _ -> None) - ~kind: Kind.Transaction_manager_kind - ~proj: - (function - | Transaction_result - { storage ; big_map_diff ; balance_updates ; - originated_contracts ; consumed_gas ; - storage_size ; paid_storage_size_diff ; - allocated_destination_contract } -> - (storage, big_map_diff, balance_updates, - originated_contracts, consumed_gas, - storage_size, paid_storage_size_diff, - allocated_destination_contract)) + ~iselect:(function + | Internal_operation_result + (({operation = Transaction _; _} as op), res) -> + Some (op, res) + | _ -> + None) + ~select:(function + | Successful_manager_result (Transaction_result _ as op) -> + Some op + | _ -> + None) + ~kind:Kind.Transaction_manager_kind + ~proj:(function + | Transaction_result + { storage; + big_map_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + allocated_destination_contract } -> + ( storage, + big_map_diff, + balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + allocated_destination_contract )) ~inj: - (fun (storage, big_map_diff, balance_updates, - originated_contracts, consumed_gas, - storage_size, paid_storage_size_diff, - allocated_destination_contract) -> - Transaction_result { storage ; big_map_diff ; balance_updates ; - originated_contracts ; consumed_gas ; - storage_size ; paid_storage_size_diff ; - allocated_destination_contract }) + (fun ( storage, + big_map_diff, + balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + allocated_destination_contract ) -> + Transaction_result + { + storage; + big_map_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + allocated_destination_contract; + }) let origination_case = make - ~op_case: Operation.Encoding.Manager_operations.origination_case + ~op_case:Operation.Encoding.Manager_operations.origination_case ~encoding: (obj6 (opt "big_map_diff" Contract.big_map_diff_encoding) @@ -223,352 +259,422 @@ module Manager_result = struct (dft "consumed_gas" z Z.zero) (dft "storage_size" z Z.zero) (dft "paid_storage_size_diff" z Z.zero)) - ~iselect: - (function - | Internal_operation_result - ({ operation = Origination _ ; _} as op, res) -> - Some (op, res) - | _ -> None) - ~select: - (function - | Successful_manager_result (Origination_result _ as op) -> Some op - | _ -> None) - ~proj: - (function - | Origination_result - { big_map_diff ; balance_updates ; - originated_contracts ; consumed_gas ; - storage_size ; paid_storage_size_diff } -> - (big_map_diff, balance_updates, - originated_contracts, consumed_gas, - storage_size, paid_storage_size_diff)) - ~kind: Kind.Origination_manager_kind + ~iselect:(function + | Internal_operation_result + (({operation = Origination _; _} as op), res) -> + Some (op, res) + | _ -> + None) + ~select:(function + | Successful_manager_result (Origination_result _ as op) -> + Some op + | _ -> + None) + ~proj:(function + | Origination_result + { big_map_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff } -> + ( big_map_diff, + balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff )) + ~kind:Kind.Origination_manager_kind ~inj: - (fun (big_map_diff, balance_updates, - originated_contracts, consumed_gas, - storage_size, paid_storage_size_diff) -> - Origination_result - { big_map_diff ; balance_updates ; - originated_contracts ; consumed_gas ; - storage_size ; paid_storage_size_diff }) + (fun ( big_map_diff, + balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff ) -> + Origination_result + { + big_map_diff; + balance_updates; + originated_contracts; + consumed_gas; + storage_size; + paid_storage_size_diff; + }) let delegation_case = make - ~op_case: Operation.Encoding.Manager_operations.delegation_case - ~encoding: Data_encoding.(obj1 (dft "consumed_gas" z Z.zero)) - ~iselect: - (function - | Internal_operation_result - ({ operation = Delegation _ ; _} as op, res) -> - Some (op, res) - | _ -> None) - ~select: - (function - | Successful_manager_result (Delegation_result _ as op) -> Some op - | _ -> None) - ~kind: Kind.Delegation_manager_kind - ~proj: (function Delegation_result { consumed_gas } -> consumed_gas) - ~inj: (fun consumed_gas -> Delegation_result { consumed_gas }) - + ~op_case:Operation.Encoding.Manager_operations.delegation_case + ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero)) + ~iselect:(function + | Internal_operation_result (({operation = Delegation _; _} as op), res) + -> + Some (op, res) + | _ -> + None) + ~select:(function + | Successful_manager_result (Delegation_result _ as op) -> + Some op + | _ -> + None) + ~kind:Kind.Delegation_manager_kind + ~proj:(function Delegation_result {consumed_gas} -> consumed_gas) + ~inj:(fun consumed_gas -> Delegation_result {consumed_gas}) end let internal_operation_result_encoding : - packed_internal_operation_result Data_encoding.t = + packed_internal_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) + let (Operation.Encoding.Manager_operations.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 - op_case.encoding - (obj1 (req "result" res_case.t)))) + (merge_objs op_case.encoding (obj1 (req "result" res_case.t)))) (fun op -> - match res_case.iselect op with - | Some (op, res) -> - Some (((), op.source, op.nonce), - (op_case.proj op.operation, res)) - | None -> None) + match res_case.iselect op with + | Some (op, res) -> + Some (((), op.source, op.nonce), (op_case.proj op.operation, res)) + | None -> + None) (fun (((), source, nonce), (op, res)) -> - let op = { source ; operation = op_case.inj op ; nonce } in - Internal_operation_result (op, res)) in - def "operation.alpha.internal_operation_result" @@ - union [ - make Manager_result.reveal_case ; - make Manager_result.transaction_case ; - make Manager_result.origination_case ; - make Manager_result.delegation_case ; - ] + let op = {source; operation = op_case.inj op; nonce} in + Internal_operation_result (op, res)) + in + def "operation.alpha.internal_operation_result" + @@ union + [ make Manager_result.reveal_case; + make Manager_result.transaction_case; + make Manager_result.origination_case; + make Manager_result.delegation_case ] type 'kind contents_result = - | Endorsement_result : - { balance_updates : Delegate.balance_updates ; - delegate : Signature.Public_key_hash.t ; - slots: int list ; - } -> Kind.endorsement contents_result + | Endorsement_result : { + balance_updates : Delegate.balance_updates; + delegate : Signature.Public_key_hash.t; + slots : int list; + } + -> Kind.endorsement contents_result | Seed_nonce_revelation_result : - Delegate.balance_updates -> Kind.seed_nonce_revelation contents_result + Delegate.balance_updates + -> Kind.seed_nonce_revelation contents_result | Double_endorsement_evidence_result : - Delegate.balance_updates -> Kind.double_endorsement_evidence contents_result + Delegate.balance_updates + -> Kind.double_endorsement_evidence contents_result | Double_baking_evidence_result : - Delegate.balance_updates -> Kind.double_baking_evidence contents_result + Delegate.balance_updates + -> Kind.double_baking_evidence contents_result | Activate_account_result : - Delegate.balance_updates -> Kind.activate_account contents_result + Delegate.balance_updates + -> Kind.activate_account contents_result | Proposals_result : Kind.proposals contents_result | Ballot_result : Kind.ballot contents_result - | Manager_operation_result : - { balance_updates : Delegate.balance_updates ; - operation_result : 'kind manager_operation_result ; - internal_operation_results : packed_internal_operation_result list ; - } -> 'kind Kind.manager contents_result + | Manager_operation_result : { + balance_updates : Delegate.balance_updates; + operation_result : 'kind manager_operation_result; + internal_operation_results : packed_internal_operation_result list; + } + -> 'kind Kind.manager contents_result type packed_contents_result = | Contents_result : 'kind contents_result -> packed_contents_result type packed_contents_and_result = | Contents_and_result : - 'kind Operation.contents * 'kind contents_result -> packed_contents_and_result + 'kind Operation.contents * 'kind contents_result + -> packed_contents_and_result type ('a, 'b) eq = Eq : ('a, 'a) eq -let equal_manager_kind - : type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option - = fun ka kb -> match ka, kb with - | Kind.Reveal_manager_kind, Kind.Reveal_manager_kind -> Some Eq - | Kind.Reveal_manager_kind, _ -> None - | Kind.Transaction_manager_kind, Kind.Transaction_manager_kind -> Some Eq - | Kind.Transaction_manager_kind, _ -> None - | Kind.Origination_manager_kind, Kind.Origination_manager_kind -> Some Eq - | Kind.Origination_manager_kind, _ -> None - | Kind.Delegation_manager_kind, Kind.Delegation_manager_kind -> Some Eq - | Kind.Delegation_manager_kind, _ -> None +let equal_manager_kind : + type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option = + fun ka kb -> + match (ka, kb) with + | (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) -> + Some Eq + | (Kind.Reveal_manager_kind, _) -> + None + | (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) -> + Some Eq + | (Kind.Transaction_manager_kind, _) -> + None + | (Kind.Origination_manager_kind, Kind.Origination_manager_kind) -> + Some Eq + | (Kind.Origination_manager_kind, _) -> + None + | (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) -> + Some Eq + | (Kind.Delegation_manager_kind, _) -> + None module Encoding = struct - type 'kind case = - Case : { op_case: 'kind Operation.Encoding.case ; - encoding: 'a Data_encoding.t ; - select: packed_contents_result -> 'kind contents_result option ; - mselect: packed_contents_and_result -> ('kind contents * 'kind contents_result) option ; - proj: 'kind contents_result -> 'a ; - inj: 'a -> 'kind contents_result ; - } -> 'kind case + | Case : { + op_case : 'kind Operation.Encoding.case; + encoding : 'a Data_encoding.t; + select : packed_contents_result -> 'kind contents_result option; + mselect : + packed_contents_and_result -> + ('kind contents * 'kind contents_result) option; + proj : 'kind contents_result -> 'a; + inj : 'a -> 'kind contents_result; + } + -> 'kind case let tagged_case tag name args proj inj = let open Data_encoding in - case tag + case + tag ~title:(String.capitalize_ascii name) - (merge_objs - (obj1 (req "kind" (constant name))) - args) + (merge_objs (obj1 (req "kind" (constant name))) args) (fun x -> match proj x with None -> None | Some x -> Some ((), x)) (fun ((), x) -> inj x) let endorsement_case = - Case { - op_case = Operation.Encoding.endorsement_case ; - encoding = - (obj3 - (req "balance_updates" Delegate.balance_updates_encoding) - (req "delegate" Signature.Public_key_hash.encoding) - (req "slots" (list uint8))); - select = - (function - | Contents_result (Endorsement_result _ as op) -> Some op - | _ -> None) ; - mselect = - (function - | Contents_and_result (Endorsement _ as op, res) -> Some (op, res) - | _ -> None) ; - proj = - (function - | Endorsement_result { balance_updates ; delegate ; slots } - -> (balance_updates, delegate, slots)) ; - inj = - (fun (balance_updates, delegate, slots) -> - Endorsement_result { balance_updates ; delegate ; slots }) - } + Case + { + op_case = Operation.Encoding.endorsement_case; + encoding = + obj3 + (req "balance_updates" Delegate.balance_updates_encoding) + (req "delegate" Signature.Public_key_hash.encoding) + (req "slots" (list uint8)); + select = + (function + | Contents_result (Endorsement_result _ as op) -> Some op | _ -> None); + mselect = + (function + | Contents_and_result ((Endorsement _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = + (function + | Endorsement_result {balance_updates; delegate; slots} -> + (balance_updates, delegate, slots)); + inj = + (fun (balance_updates, delegate, slots) -> + Endorsement_result {balance_updates; delegate; slots}); + } let seed_nonce_revelation_case = - Case { - op_case = Operation.Encoding.seed_nonce_revelation_case ; - encoding = - (obj1 - (req "balance_updates" Delegate.balance_updates_encoding)) ; - select = - (function - | Contents_result (Seed_nonce_revelation_result _ as op) -> Some op - | _ -> None) ; - mselect = - (function - | Contents_and_result (Seed_nonce_revelation _ as op, res) -> Some (op, res) - | _ -> None) ; - proj = (fun (Seed_nonce_revelation_result bus) -> bus) ; - inj = (fun bus -> Seed_nonce_revelation_result bus) ; - } + Case + { + op_case = Operation.Encoding.seed_nonce_revelation_case; + encoding = + obj1 (req "balance_updates" Delegate.balance_updates_encoding); + select = + (function + | Contents_result (Seed_nonce_revelation_result _ as op) -> + Some op + | _ -> + None); + mselect = + (function + | Contents_and_result ((Seed_nonce_revelation _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun (Seed_nonce_revelation_result bus) -> bus); + inj = (fun bus -> Seed_nonce_revelation_result bus); + } let double_endorsement_evidence_case = - Case { - op_case = Operation.Encoding.double_endorsement_evidence_case ; - encoding = - (obj1 - (req "balance_updates" Delegate.balance_updates_encoding)) ; - select = - (function - | Contents_result (Double_endorsement_evidence_result _ as op) -> Some op - | _ -> None) ; - mselect = - (function - | Contents_and_result (Double_endorsement_evidence _ as op, res) -> Some (op, res) - | _ -> None) ; - proj = - (fun (Double_endorsement_evidence_result bus) -> bus) ; - inj = (fun bus -> Double_endorsement_evidence_result bus) - } + Case + { + op_case = Operation.Encoding.double_endorsement_evidence_case; + encoding = + obj1 (req "balance_updates" Delegate.balance_updates_encoding); + select = + (function + | Contents_result (Double_endorsement_evidence_result _ as op) -> + Some op + | _ -> + None); + mselect = + (function + | Contents_and_result ((Double_endorsement_evidence _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun (Double_endorsement_evidence_result bus) -> bus); + inj = (fun bus -> Double_endorsement_evidence_result bus); + } let double_baking_evidence_case = - Case { - op_case = Operation.Encoding.double_baking_evidence_case ; - encoding = - (obj1 - (req "balance_updates" Delegate.balance_updates_encoding)) ; - select = - (function - | Contents_result (Double_baking_evidence_result _ as op) -> Some op - | _ -> None) ; - mselect = - (function - | Contents_and_result (Double_baking_evidence _ as op, res) -> Some (op, res) - | _ -> None) ; - proj = - (fun (Double_baking_evidence_result bus) -> bus) ; - inj = (fun bus -> Double_baking_evidence_result bus) ; - } + Case + { + op_case = Operation.Encoding.double_baking_evidence_case; + encoding = + obj1 (req "balance_updates" Delegate.balance_updates_encoding); + select = + (function + | Contents_result (Double_baking_evidence_result _ as op) -> + Some op + | _ -> + None); + mselect = + (function + | Contents_and_result ((Double_baking_evidence _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun (Double_baking_evidence_result bus) -> bus); + inj = (fun bus -> Double_baking_evidence_result bus); + } let activate_account_case = - Case { - op_case = Operation.Encoding.activate_account_case ; - encoding = - (obj1 - (req "balance_updates" Delegate.balance_updates_encoding)) ; - select = - (function - | Contents_result (Activate_account_result _ as op) -> Some op - | _ -> None) ; - mselect = - (function - | Contents_and_result (Activate_account _ as op, res) -> Some (op, res) - | _ -> None) ; - proj = (fun (Activate_account_result bus) -> bus) ; - inj = (fun bus -> Activate_account_result bus) ; - } + Case + { + op_case = Operation.Encoding.activate_account_case; + encoding = + obj1 (req "balance_updates" Delegate.balance_updates_encoding); + select = + (function + | Contents_result (Activate_account_result _ as op) -> + Some op + | _ -> + None); + mselect = + (function + | Contents_and_result ((Activate_account _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun (Activate_account_result bus) -> bus); + inj = (fun bus -> Activate_account_result bus); + } let proposals_case = - Case { - op_case = Operation.Encoding.proposals_case ; - encoding = Data_encoding.empty ; - select = - (function - | Contents_result (Proposals_result as op) -> Some op - | _ -> None) ; - mselect = - (function - | Contents_and_result (Proposals _ as op, res) -> Some (op, res) - | _ -> None) ; - proj = (fun Proposals_result -> ()) ; - inj = (fun () -> Proposals_result) ; - } + Case + { + op_case = Operation.Encoding.proposals_case; + encoding = Data_encoding.empty; + select = + (function + | Contents_result (Proposals_result as op) -> Some op | _ -> None); + mselect = + (function + | Contents_and_result ((Proposals _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun Proposals_result -> ()); + inj = (fun () -> Proposals_result); + } let ballot_case = - Case { - op_case = Operation.Encoding.ballot_case ; - encoding = Data_encoding.empty ; - select = - (function - | Contents_result (Ballot_result as op) -> Some op - | _ -> None) ; - mselect = - (function - | Contents_and_result (Ballot _ as op, res) -> Some (op, res) - | _ -> None) ; - proj = (fun Ballot_result -> ()) ; - inj = (fun () -> Ballot_result) ; - } + Case + { + op_case = Operation.Encoding.ballot_case; + encoding = Data_encoding.empty; + select = + (function + | Contents_result (Ballot_result as op) -> Some op | _ -> None); + mselect = + (function + | Contents_and_result ((Ballot _ as op), res) -> + Some (op, res) + | _ -> + None); + proj = (fun Ballot_result -> ()); + inj = (fun () -> Ballot_result); + } - 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 = - Case { - op_case = Operation.Encoding.Case op_case ; - encoding = - (obj3 - (req "balance_updates" Delegate.balance_updates_encoding) - (req "operation_result" res_case.t) - (dft "internal_operation_results" - (list internal_operation_result_encoding) [])) ; - select = - (function + 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 = + Case + { + op_case = Operation.Encoding.Case op_case; + encoding = + obj3 + (req "balance_updates" Delegate.balance_updates_encoding) + (req "operation_result" res_case.t) + (dft + "internal_operation_results" + (list internal_operation_result_encoding) + []); + select = + (function | Contents_result (Manager_operation_result - ({ operation_result = Applied res ; _ } as op)) -> begin - match res_case.select (Successful_manager_result res) with - | Some res -> - Some (Manager_operation_result - { op with operation_result = Applied res }) - | None -> None - end + ({operation_result = Applied res; _} as op)) -> ( + match res_case.select (Successful_manager_result res) with + | Some res -> + Some + (Manager_operation_result + {op with operation_result = Applied res}) + | None -> + None ) | Contents_result (Manager_operation_result - ({ operation_result = Backtracked (res, errs) ; _ } as op)) -> begin - match res_case.select (Successful_manager_result res) with - | Some res -> - Some (Manager_operation_result - { op with operation_result = Backtracked (res, errs) }) - | None -> None - end + ({operation_result = Backtracked (res, errs); _} as op)) -> ( + match res_case.select (Successful_manager_result res) with + | Some res -> + Some + (Manager_operation_result + {op with operation_result = Backtracked (res, errs)}) + | None -> + None ) | Contents_result (Manager_operation_result - ({ operation_result = Skipped kind ; _ } as op)) -> - begin match equal_manager_kind kind res_case.kind with - | None -> None - | Some Eq -> - Some (Manager_operation_result - { op with operation_result = Skipped kind }) - end + ({operation_result = Skipped kind; _} as op)) -> ( + match equal_manager_kind kind res_case.kind with + | None -> + None + | Some Eq -> + Some + (Manager_operation_result + {op with operation_result = Skipped kind}) ) | Contents_result (Manager_operation_result - ({ operation_result = Failed (kind, errs) ; _ } as op)) -> - begin match equal_manager_kind kind res_case.kind with - | None -> None - | Some Eq -> - Some (Manager_operation_result - { op with operation_result = Failed (kind, errs) }) - end - | Contents_result Ballot_result -> None - | Contents_result (Endorsement_result _) -> None - | Contents_result (Seed_nonce_revelation_result _) -> None - | Contents_result (Double_endorsement_evidence_result _) -> None - | Contents_result (Double_baking_evidence_result _) -> None - | Contents_result (Activate_account_result _) -> None - | Contents_result Proposals_result -> None) ; - mselect ; - proj = - (fun (Manager_operation_result - { balance_updates = bus ; operation_result = r ; - internal_operation_results = rs }) -> - (bus, r, rs)) ; - inj = - (fun (bus, r, rs) -> - Manager_operation_result - { balance_updates = bus ; operation_result = r ; - internal_operation_results = rs }) ; - } + ({operation_result = Failed (kind, errs); _} as op)) -> ( + match equal_manager_kind kind res_case.kind with + | None -> + None + | Some Eq -> + Some + (Manager_operation_result + {op with operation_result = Failed (kind, errs)}) ) + | Contents_result Ballot_result -> + None + | Contents_result (Endorsement_result _) -> + None + | Contents_result (Seed_nonce_revelation_result _) -> + None + | Contents_result (Double_endorsement_evidence_result _) -> + None + | Contents_result (Double_baking_evidence_result _) -> + None + | Contents_result (Activate_account_result _) -> + None + | Contents_result Proposals_result -> + None); + mselect; + proj = + (fun (Manager_operation_result + { balance_updates = bus; + operation_result = r; + internal_operation_results = rs }) -> + (bus, r, rs)); + inj = + (fun (bus, r, rs) -> + Manager_operation_result + { + balance_updates = bus; + operation_result = r; + internal_operation_results = rs; + }); + } let reveal_case = make_manager_case @@ -576,10 +682,10 @@ module Encoding = struct Manager_result.reveal_case (function | Contents_and_result - (Manager_operation - { operation = Reveal _ ; _ } as op, res) -> + ((Manager_operation {operation = Reveal _; _} as op), res) -> Some (op, res) - | _ -> None) + | _ -> + None) let transaction_case = make_manager_case @@ -587,10 +693,10 @@ module Encoding = struct Manager_result.transaction_case (function | Contents_and_result - (Manager_operation - { operation = Transaction _ ; _ } as op, res) -> + ((Manager_operation {operation = Transaction _; _} as op), res) -> Some (op, res) - | _ -> None) + | _ -> + None) let origination_case = make_manager_case @@ -598,10 +704,10 @@ module Encoding = struct Manager_result.origination_case (function | Contents_and_result - (Manager_operation - { operation = Origination _ ; _ } as op, res) -> + ((Manager_operation {operation = Origination _; _} as op), res) -> Some (op, res) - | _ -> None) + | _ -> + None) let delegation_case = make_manager_case @@ -609,382 +715,473 @@ module Encoding = struct Manager_result.delegation_case (function | Contents_and_result - (Manager_operation - { operation = Delegation _ ; _ } as op, res) -> + ((Manager_operation {operation = Delegation _; _} as op), res) -> Some (op, res) - | _ -> None) - + | _ -> + None) end let contents_result_encoding = let open Encoding in - let make (Case { op_case = Operation.Encoding.Case { tag ; name ; _ } ; - encoding ; mselect = _ ; select ; proj ; inj }) = + let make + (Case + { op_case = Operation.Encoding.Case {tag; name; _}; + encoding; + mselect = _; + select; + proj; + inj }) = let proj x = - match select x with - | None -> None - | Some x -> Some (proj x) in + 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 [ - make endorsement_case ; - make seed_nonce_revelation_case ; - make double_endorsement_evidence_case ; - make double_baking_evidence_case ; - make activate_account_case ; - make proposals_case ; - make ballot_case ; - make reveal_case ; - make transaction_case ; - make origination_case ; - make delegation_case ; - ] + tagged_case (Tag tag) name encoding proj inj + in + def "operation.alpha.contents_result" + @@ union + [ make endorsement_case; + make seed_nonce_revelation_case; + make double_endorsement_evidence_case; + make double_baking_evidence_case; + make activate_account_case; + make proposals_case; + make ballot_case; + make reveal_case; + make transaction_case; + make origination_case; + make delegation_case ] let contents_and_result_encoding = let open Encoding in let make - (Case { op_case = Operation.Encoding.Case { tag ; name ; encoding ; proj ; inj ; _ } ; - mselect ; encoding = meta_encoding ; proj = meta_proj ; inj = meta_inj ; _ }) = + (Case + { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _}; + mselect; + encoding = meta_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 + | 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 [ - make endorsement_case ; - make seed_nonce_revelation_case ; - make double_endorsement_evidence_case ; - make double_baking_evidence_case ; - make activate_account_case ; - make proposals_case ; - make ballot_case ; - make reveal_case ; - make transaction_case ; - make origination_case ; - make delegation_case ; - ] + 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 + [ make endorsement_case; + make seed_nonce_revelation_case; + make double_endorsement_evidence_case; + make double_baking_evidence_case; + make activate_account_case; + make proposals_case; + make ballot_case; + make reveal_case; + make transaction_case; + make origination_case; + make delegation_case ] type 'kind contents_result_list = | Single_result : 'kind contents_result -> 'kind contents_result_list | Cons_result : - 'kind Kind.manager contents_result * 'rest Kind.manager contents_result_list -> - (('kind * 'rest) Kind.manager ) contents_result_list + 'kind Kind.manager contents_result + * 'rest Kind.manager contents_result_list + -> ('kind * 'rest) Kind.manager contents_result_list type packed_contents_result_list = - Contents_result_list : 'kind contents_result_list -> packed_contents_result_list + | Contents_result_list : + 'kind contents_result_list + -> packed_contents_result_list let contents_result_list_encoding = let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] + | 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 + Contents_result o :: to_list (Contents_result_list os) + in let rec of_list = function - | [] -> Pervasives.failwith "cannot decode empty operation result" - | [Contents_result o] -> Contents_result_list (Single_result o) - | (Contents_result o) :: os -> - let Contents_result_list os = of_list os in - match o, os with - | Manager_operation_result _, Single_result (Manager_operation_result _) -> + | [] -> + Pervasives.failwith "cannot decode empty operation result" + | [Contents_result o] -> + Contents_result_list (Single_result o) + | Contents_result o :: os -> ( + let (Contents_result_list os) = of_list os in + match (o, os) with + | ( Manager_operation_result _, + Single_result (Manager_operation_result _) ) -> Contents_result_list (Cons_result (o, os)) - | Manager_operation_result _, Cons_result _ -> + | (Manager_operation_result _, Cons_result _) -> Contents_result_list (Cons_result (o, os)) - | _ -> Pervasives.failwith "cannot decode ill-formed operation result" in - def "operation.alpha.contents_list_result" @@ - conv to_list of_list (list contents_result_encoding) + | _ -> + Pervasives.failwith "cannot decode ill-formed operation result" ) + in + def "operation.alpha.contents_list_result" + @@ conv to_list of_list (list contents_result_encoding) type 'kind contents_and_result_list = - | Single_and_result : 'kind Alpha_context.contents * 'kind contents_result -> 'kind contents_and_result_list - | Cons_and_result : 'kind Kind.manager Alpha_context.contents * 'kind Kind.manager contents_result * 'rest Kind.manager contents_and_result_list -> ('kind * 'rest) Kind.manager contents_and_result_list + | Single_and_result : + 'kind Alpha_context.contents * 'kind contents_result + -> 'kind contents_and_result_list + | Cons_and_result : + 'kind Kind.manager Alpha_context.contents + * 'kind Kind.manager contents_result + * 'rest Kind.manager contents_and_result_list + -> ('kind * 'rest) Kind.manager contents_and_result_list type packed_contents_and_result_list = - | Contents_and_result_list : 'kind contents_and_result_list -> packed_contents_and_result_list + | Contents_and_result_list : + 'kind contents_and_result_list + -> packed_contents_and_result_list 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 + Contents_and_result (op, res) + :: to_list (Contents_and_result_list rest) + in let rec of_list = function - | [] -> Pervasives.failwith "cannot decode empty combined operation result" + | [] -> + Pervasives.failwith "cannot decode empty combined operation result" | [Contents_and_result (op, res)] -> Contents_and_result_list (Single_and_result (op, res)) - | (Contents_and_result (op, res)) :: rest -> - let Contents_and_result_list rest = of_list rest in - match op, rest with - | Manager_operation _, Single_and_result (Manager_operation _, _) -> + | Contents_and_result (op, res) :: rest -> ( + let (Contents_and_result_list rest) = of_list rest in + match (op, rest) with + | (Manager_operation _, Single_and_result (Manager_operation _, _)) -> Contents_and_result_list (Cons_and_result (op, res, rest)) - | Manager_operation _, Cons_and_result (_, _, _) -> + | (Manager_operation _, Cons_and_result (_, _, _)) -> Contents_and_result_list (Cons_and_result (op, res, rest)) - | _ -> Pervasives.failwith "cannot decode ill-formed combined operation result" in + | _ -> + Pervasives.failwith + "cannot decode ill-formed combined operation result" ) + in conv to_list of_list (Variable.list contents_and_result_encoding) -type 'kind operation_metadata = { - contents: 'kind contents_result_list ; -} +type 'kind operation_metadata = {contents : 'kind contents_result_list} type packed_operation_metadata = | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata | No_operation_metadata : packed_operation_metadata let operation_metadata_encoding = - def "operation.alpha.result" @@ - union [ - case (Tag 0) - ~title:"Operation_metadata" - contents_result_list_encoding - (function - | Operation_metadata { contents } -> - Some (Contents_result_list contents) - | _ -> None) - (fun (Contents_result_list contents) -> Operation_metadata { contents }) ; - case (Tag 1) - ~title:"No_operation_metadata" - empty - (function - | No_operation_metadata -> Some () - | _ -> None) - (fun () -> No_operation_metadata) ; - ] + def "operation.alpha.result" + @@ union + [ case + (Tag 0) + ~title:"Operation_metadata" + contents_result_list_encoding + (function + | Operation_metadata {contents} -> + Some (Contents_result_list contents) + | _ -> + None) + (fun (Contents_result_list contents) -> + Operation_metadata {contents}); + case + (Tag 1) + ~title:"No_operation_metadata" + empty + (function No_operation_metadata -> Some () | _ -> None) + (fun () -> No_operation_metadata) ] -let kind_equal - : type kind kind2. kind contents -> kind2 contents_result -> (kind, kind2) eq option = - fun op res -> - match op, res with - | Endorsement _, Endorsement_result _ -> Some Eq - | Endorsement _, _ -> None - | Seed_nonce_revelation _, Seed_nonce_revelation_result _ -> Some Eq - | Seed_nonce_revelation _, _ -> None - | Double_endorsement_evidence _, Double_endorsement_evidence_result _ -> Some Eq - | Double_endorsement_evidence _, _ -> None - | Double_baking_evidence _, Double_baking_evidence_result _ -> Some Eq - | Double_baking_evidence _, _ -> None - | Activate_account _, Activate_account_result _ -> Some Eq - | Activate_account _, _ -> None - | Proposals _, Proposals_result -> Some Eq - | Proposals _, _ -> None - | Ballot _, Ballot_result -> Some Eq - | Ballot _, _ -> None - | Manager_operation - { operation = Reveal _ ; _ }, +let kind_equal : + type kind kind2. + kind contents -> kind2 contents_result -> (kind, kind2) eq option = + fun op res -> + match (op, res) with + | (Endorsement _, Endorsement_result _) -> + Some Eq + | (Endorsement _, _) -> + None + | (Seed_nonce_revelation _, Seed_nonce_revelation_result _) -> + Some Eq + | (Seed_nonce_revelation _, _) -> + None + | (Double_endorsement_evidence _, Double_endorsement_evidence_result _) -> + Some Eq + | (Double_endorsement_evidence _, _) -> + None + | (Double_baking_evidence _, Double_baking_evidence_result _) -> + Some Eq + | (Double_baking_evidence _, _) -> + None + | (Activate_account _, Activate_account_result _) -> + Some Eq + | (Activate_account _, _) -> + None + | (Proposals _, Proposals_result) -> + Some Eq + | (Proposals _, _) -> + None + | (Ballot _, Ballot_result) -> + Some Eq + | (Ballot _, _) -> + None + | ( Manager_operation {operation = Reveal _; _}, + Manager_operation_result {operation_result = Applied (Reveal_result _); _} + ) -> + Some Eq + | ( Manager_operation {operation = Reveal _; _}, Manager_operation_result - { operation_result = Applied (Reveal_result _); _ } -> Some Eq - | Manager_operation - { operation = Reveal _ ; _ }, + {operation_result = Backtracked (Reveal_result _, _); _} ) -> + Some Eq + | ( Manager_operation {operation = Reveal _; _}, Manager_operation_result - { operation_result = Backtracked (Reveal_result _, _) ; _ } -> Some Eq - | Manager_operation - { operation = Reveal _ ; _ }, + { operation_result = Failed (Alpha_context.Kind.Reveal_manager_kind, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Reveal _; _}, + Manager_operation_result + {operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _} + ) -> + Some Eq + | (Manager_operation {operation = Reveal _; _}, _) -> + None + | ( Manager_operation {operation = Transaction _; _}, + Manager_operation_result + {operation_result = Applied (Transaction_result _); _} ) -> + Some Eq + | ( Manager_operation {operation = Transaction _; _}, + Manager_operation_result + {operation_result = Backtracked (Transaction_result _, _); _} ) -> + Some Eq + | ( Manager_operation {operation = Transaction _; _}, Manager_operation_result { operation_result = - Failed (Alpha_context.Kind.Reveal_manager_kind, _); _ } -> Some Eq - | Manager_operation - { operation = Reveal _ ; _ }, + Failed (Alpha_context.Kind.Transaction_manager_kind, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Transaction _; _}, + Manager_operation_result + { operation_result = Skipped Alpha_context.Kind.Transaction_manager_kind; + _ } ) -> + Some Eq + | (Manager_operation {operation = Transaction _; _}, _) -> + None + | ( Manager_operation {operation = Origination _; _}, + Manager_operation_result + {operation_result = Applied (Origination_result _); _} ) -> + Some Eq + | ( Manager_operation {operation = Origination _; _}, + Manager_operation_result + {operation_result = Backtracked (Origination_result _, _); _} ) -> + Some Eq + | ( Manager_operation {operation = Origination _; _}, Manager_operation_result { operation_result = - Skipped (Alpha_context.Kind.Reveal_manager_kind); _ } -> Some Eq - | Manager_operation { operation = Reveal _ ; _ }, _ -> None - | Manager_operation - { operation = Transaction _ ; _ }, + Failed (Alpha_context.Kind.Origination_manager_kind, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Origination _; _}, Manager_operation_result - { operation_result = Applied (Transaction_result _); _ } -> Some Eq - | Manager_operation - { operation = Transaction _ ; _ }, + { operation_result = Skipped Alpha_context.Kind.Origination_manager_kind; + _ } ) -> + Some Eq + | (Manager_operation {operation = Origination _; _}, _) -> + None + | ( Manager_operation {operation = Delegation _; _}, Manager_operation_result - { operation_result = Backtracked (Transaction_result _, _); _ } -> Some Eq - | Manager_operation - { operation = Transaction _ ; _ }, + {operation_result = Applied (Delegation_result _); _} ) -> + Some Eq + | ( Manager_operation {operation = Delegation _; _}, + Manager_operation_result + {operation_result = Backtracked (Delegation_result _, _); _} ) -> + Some Eq + | ( Manager_operation {operation = Delegation _; _}, Manager_operation_result { operation_result = - Failed (Alpha_context.Kind.Transaction_manager_kind, _); _ } -> Some Eq - | Manager_operation - { operation = Transaction _ ; _ }, + Failed (Alpha_context.Kind.Delegation_manager_kind, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Delegation _; _}, Manager_operation_result - { operation_result = - Skipped (Alpha_context.Kind.Transaction_manager_kind); _ } -> Some Eq - | Manager_operation { operation = Transaction _ ; _ }, _ -> None - | Manager_operation - { operation = Origination _ ; _ }, - Manager_operation_result - { operation_result = Applied (Origination_result _); _ } -> Some Eq - | Manager_operation - { operation = Origination _ ; _ }, - Manager_operation_result - { operation_result = Backtracked (Origination_result _, _); _ } -> Some Eq - | Manager_operation - { operation = Origination _ ; _ }, - Manager_operation_result - { operation_result = - Failed (Alpha_context.Kind.Origination_manager_kind, _); _ } -> Some Eq - | Manager_operation - { operation = Origination _ ; _ }, - Manager_operation_result - { operation_result = - Skipped (Alpha_context.Kind.Origination_manager_kind); _ } -> Some Eq - | Manager_operation { operation = Origination _ ; _ }, _ -> None - | Manager_operation - { operation = Delegation _ ; _ }, - Manager_operation_result - { operation_result = Applied (Delegation_result _) ; _ } -> Some Eq - | Manager_operation - { operation = Delegation _ ; _ }, - Manager_operation_result - { operation_result = Backtracked (Delegation_result _, _) ; _ } -> Some Eq - | Manager_operation - { operation = Delegation _ ; _ }, - Manager_operation_result - { operation_result = - Failed (Alpha_context.Kind.Delegation_manager_kind, _); _ } -> Some Eq - | Manager_operation - { operation = Delegation _ ; _ }, - Manager_operation_result - { operation_result = - Skipped (Alpha_context.Kind.Delegation_manager_kind); _ } -> Some Eq - | Manager_operation { operation = Delegation _ ; _ }, _ -> None + { operation_result = Skipped Alpha_context.Kind.Delegation_manager_kind; + _ } ) -> + Some Eq + | (Manager_operation {operation = Delegation _; _}, _) -> + None -let rec kind_equal_list - : type kind kind2. kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option = - fun contents res -> - match contents, res with - | Single op, Single_result res -> begin - match kind_equal op res with - | None -> None - | Some Eq -> Some Eq - end - | Cons (op, ops), Cons_result (res, ress) -> begin - match kind_equal op res with - | None -> None - | Some Eq -> - match kind_equal_list ops ress with - | None -> None - | Some Eq -> Some Eq - end - | _ -> None +let rec kind_equal_list : + type kind kind2. + kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option + = + fun contents res -> + match (contents, res) with + | (Single op, Single_result res) -> ( + match kind_equal op res with None -> None | Some Eq -> Some Eq ) + | (Cons (op, ops), Cons_result (res, ress)) -> ( + match kind_equal op res with + | None -> + None + | Some Eq -> ( + match kind_equal_list ops ress with None -> None | Some Eq -> Some Eq ) ) + | _ -> + None let rec pack_contents_list : - type kind. kind contents_list -> kind contents_result_list -> kind contents_and_result_list = - fun contents res -> begin - match 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) - | Single (Manager_operation _), - Cons_result (Manager_operation_result _, Single_result _) -> . - | Cons (_, _), - Single_result (Manager_operation_result - { operation_result = Failed _ ; _}) -> . - | Cons (_, _), - Single_result (Manager_operation_result - { operation_result = Skipped _ ; _}) -> . - | Cons (_, _), - Single_result (Manager_operation_result - { operation_result = Applied _ ; _}) -> . - | Cons (_, _), - Single_result (Manager_operation_result - { operation_result = Backtracked _ ; _}) -> . - | Single _, Cons_result _ -> . - end + type kind. + kind contents_list -> + kind contents_result_list -> + kind contents_and_result_list = + fun contents res -> + match (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) + | ( Single (Manager_operation _), + Cons_result (Manager_operation_result _, Single_result _) ) -> + . + | ( Cons (_, _), + Single_result (Manager_operation_result {operation_result = Failed _; _}) + ) -> + . + | ( Cons (_, _), + Single_result + (Manager_operation_result {operation_result = Skipped _; _}) ) -> + . + | ( Cons (_, _), + Single_result + (Manager_operation_result {operation_result = Applied _; _}) ) -> + . + | ( Cons (_, _), + Single_result + (Manager_operation_result {operation_result = Backtracked _; _}) ) -> + . + | (Single _, Cons_result _) -> + . let rec unpack_contents_list : - type kind. kind contents_and_result_list -> - (kind contents_list * kind contents_result_list) = - function - | Single_and_result (op, res) -> Single op, Single_result res + type kind. + kind contents_and_result_list -> + kind contents_list * kind contents_result_list = function + | Single_and_result (op, res) -> + (Single op, Single_result res) | Cons_and_result (op, res, rest) -> - let ops, ress = unpack_contents_list rest in - Cons (op, ops), Cons_result (res, ress) + 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 (Single_result o) -> + [Contents_result o] | Contents_result_list (Cons_result (o, os)) -> Contents_result o :: to_list (Contents_result_list os) let rec of_list = function - | [] -> assert false - | [Contents_result o] -> Contents_result_list (Single_result o) - | (Contents_result o) :: os -> - let Contents_result_list os = of_list os in - match o, os with - | Manager_operation_result _, Single_result (Manager_operation_result _) -> + | [] -> + assert false + | [Contents_result o] -> + Contents_result_list (Single_result o) + | Contents_result o :: os -> ( + let (Contents_result_list os) = of_list os in + match (o, os) with + | (Manager_operation_result _, Single_result (Manager_operation_result _)) + -> Contents_result_list (Cons_result (o, os)) - | Manager_operation_result _, Cons_result _ -> + | (Manager_operation_result _, Cons_result _) -> Contents_result_list (Cons_result (o, os)) | _ -> - Pervasives.failwith "Operation result list of length > 1 \ - should only contains manager operations result." + Pervasives.failwith + "Operation result list of length > 1 should only contains manager \ + operations result." ) let operation_data_and_metadata_encoding = - def "operation.alpha.operation_with_metadata" @@ - union [ - case (Tag 0) - ~title:"Operation_with_metadata" - (obj2 - (req "contents" (dynamic_size contents_and_result_list_encoding)) - (opt "signature" Signature.encoding)) - (function - | (Operation_data _, No_operation_metadata) -> None - | (Operation_data op, Operation_metadata res) -> - match kind_equal_list op.contents res.contents with - | None -> Pervasives.failwith "cannot decode inconsistent combined operation result" - | Some Eq -> - Some - (Contents_and_result_list - (pack_contents_list op.contents res.contents), - op.signature)) - (fun (Contents_and_result_list contents, signature) -> - let op_contents, res_contents = unpack_contents_list contents in - (Operation_data { contents = op_contents ; signature }, - Operation_metadata { contents = res_contents })) ; - case (Tag 1) - ~title:"Operation_without_metadata" - (obj2 - (req "contents" (dynamic_size Operation.contents_list_encoding)) - (opt "signature" Signature.encoding)) - (function - | (Operation_data op, No_operation_metadata) -> - Some (Contents_list op.contents, op.signature) - | (Operation_data _, Operation_metadata _) -> - None) - (fun (Contents_list contents, signature) -> - (Operation_data { contents ; signature }, No_operation_metadata)) - ] + def "operation.alpha.operation_with_metadata" + @@ union + [ case + (Tag 0) + ~title:"Operation_with_metadata" + (obj2 + (req "contents" (dynamic_size contents_and_result_list_encoding)) + (opt "signature" Signature.encoding)) + (function + | (Operation_data _, No_operation_metadata) -> + None + | (Operation_data op, Operation_metadata res) -> ( + match kind_equal_list op.contents res.contents with + | None -> + Pervasives.failwith + "cannot decode inconsistent combined operation result" + | Some Eq -> + Some + ( Contents_and_result_list + (pack_contents_list op.contents res.contents), + op.signature ) )) + (fun (Contents_and_result_list contents, signature) -> + let (op_contents, res_contents) = unpack_contents_list contents in + ( Operation_data {contents = op_contents; signature}, + Operation_metadata {contents = res_contents} )); + case + (Tag 1) + ~title:"Operation_without_metadata" + (obj2 + (req "contents" (dynamic_size Operation.contents_list_encoding)) + (opt "signature" Signature.encoding)) + (function + | (Operation_data op, No_operation_metadata) -> + Some (Contents_list op.contents, op.signature) + | (Operation_data _, Operation_metadata _) -> + None) + (fun (Contents_list contents, signature) -> + (Operation_data {contents; signature}, No_operation_metadata)) ] type block_metadata = { - baker: Signature.Public_key_hash.t ; - level: Level.t ; - voting_period_kind: Voting_period.kind ; - nonce_hash: Nonce_hash.t option ; - consumed_gas: Z.t ; - deactivated: Signature.Public_key_hash.t list ; - balance_updates: Delegate.balance_updates ; + baker : Signature.Public_key_hash.t; + level : Level.t; + voting_period_kind : Voting_period.kind; + nonce_hash : Nonce_hash.t option; + consumed_gas : Z.t; + deactivated : Signature.Public_key_hash.t list; + balance_updates : Delegate.balance_updates; } let block_metadata_encoding = let open Data_encoding in - def "block_header.alpha.metadata" @@ - conv - (fun { baker ; level ; voting_period_kind ; nonce_hash ; - consumed_gas ; deactivated ; balance_updates } -> - ( baker, level, voting_period_kind, nonce_hash, - consumed_gas, deactivated, balance_updates )) - (fun ( baker, level, voting_period_kind, nonce_hash, - consumed_gas, deactivated, balance_updates ) -> - { baker ; level ; voting_period_kind ; nonce_hash ; - consumed_gas ; deactivated ; balance_updates }) - (obj7 - (req "baker" Signature.Public_key_hash.encoding) - (req "level" Level.encoding) - (req "voting_period_kind" Voting_period.kind_encoding) - (req "nonce_hash" (option Nonce_hash.encoding)) - (req "consumed_gas" (check_size 10 n)) - (req "deactivated" (list Signature.Public_key_hash.encoding)) - (req "balance_updates" Delegate.balance_updates_encoding)) + def "block_header.alpha.metadata" + @@ conv + (fun { baker; + level; + voting_period_kind; + nonce_hash; + consumed_gas; + deactivated; + balance_updates } -> + ( baker, + level, + voting_period_kind, + nonce_hash, + consumed_gas, + deactivated, + balance_updates )) + (fun ( baker, + level, + voting_period_kind, + nonce_hash, + consumed_gas, + deactivated, + balance_updates ) -> + { + baker; + level; + voting_period_kind; + nonce_hash; + consumed_gas; + deactivated; + balance_updates; + }) + (obj7 + (req "baker" Signature.Public_key_hash.encoding) + (req "level" Level.encoding) + (req "voting_period_kind" Voting_period.kind_encoding) + (req "nonce_hash" (option Nonce_hash.encoding)) + (req "consumed_gas" (check_size 10 n)) + (req "deactivated" (list Signature.Public_key_hash.encoding)) + (req "balance_updates" Delegate.balance_updates_encoding)) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli index a5f17d2ef..92e43f0ea 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/apply_results.mli @@ -31,9 +31,7 @@ open Alpha_context (** Result of applying a {!Operation.t}. Follows the same structure. *) -type 'kind operation_metadata = { - contents: 'kind contents_result_list ; -} +type 'kind operation_metadata = {contents : 'kind contents_result_list} and packed_operation_metadata = | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata @@ -43,34 +41,43 @@ and packed_operation_metadata = and 'kind contents_result_list = | Single_result : 'kind contents_result -> 'kind contents_result_list | Cons_result : - 'kind Kind.manager contents_result * 'rest Kind.manager contents_result_list -> - (('kind * 'rest) Kind.manager ) contents_result_list + 'kind Kind.manager contents_result + * 'rest Kind.manager contents_result_list + -> ('kind * 'rest) Kind.manager contents_result_list and packed_contents_result_list = - | Contents_result_list : 'kind contents_result_list -> packed_contents_result_list + | Contents_result_list : + 'kind contents_result_list + -> packed_contents_result_list (** Result of applying an {!Operation.contents}. Follows the same structure. *) and 'kind contents_result = - | Endorsement_result : - { balance_updates : Delegate.balance_updates ; - delegate : Signature.Public_key_hash.t ; - slots: int list ; - } -> Kind.endorsement contents_result + | Endorsement_result : { + balance_updates : Delegate.balance_updates; + delegate : Signature.Public_key_hash.t; + slots : int list; + } + -> Kind.endorsement contents_result | Seed_nonce_revelation_result : - Delegate.balance_updates -> Kind.seed_nonce_revelation contents_result + Delegate.balance_updates + -> Kind.seed_nonce_revelation contents_result | Double_endorsement_evidence_result : - Delegate.balance_updates -> Kind.double_endorsement_evidence contents_result + Delegate.balance_updates + -> Kind.double_endorsement_evidence contents_result | Double_baking_evidence_result : - Delegate.balance_updates -> Kind.double_baking_evidence contents_result + Delegate.balance_updates + -> Kind.double_baking_evidence contents_result | Activate_account_result : - Delegate.balance_updates -> Kind.activate_account contents_result + Delegate.balance_updates + -> Kind.activate_account contents_result | Proposals_result : Kind.proposals contents_result | Ballot_result : Kind.ballot contents_result - | Manager_operation_result : - { balance_updates : Delegate.balance_updates ; - operation_result : 'kind manager_operation_result ; - internal_operation_results : packed_internal_operation_result list ; - } -> 'kind Kind.manager contents_result + | Manager_operation_result : { + balance_updates : Delegate.balance_updates; + operation_result : 'kind manager_operation_result; + internal_operation_results : packed_internal_operation_result list; + } + -> 'kind Kind.manager contents_result and packed_contents_result = | Contents_result : 'kind contents_result -> packed_contents_result @@ -79,90 +86,105 @@ and packed_contents_result = always be at the tail, and after a single [Failed]. *) and 'kind manager_operation_result = | Applied of 'kind successful_manager_operation_result - | Backtracked of 'kind successful_manager_operation_result * error list option + | Backtracked of + 'kind successful_manager_operation_result * error list option | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result | Skipped : 'kind Kind.manager -> 'kind manager_operation_result (** Result of applying a {!manager_operation_content}, either internal or external. *) and _ successful_manager_operation_result = - | Reveal_result : - { consumed_gas : Z.t - } -> Kind.reveal successful_manager_operation_result - | Transaction_result : - { storage : Script.expr option ; - big_map_diff : Contract.big_map_diff option ; - balance_updates : Delegate.balance_updates ; - originated_contracts : Contract.t list ; - consumed_gas : Z.t ; - storage_size : Z.t ; - paid_storage_size_diff : Z.t ; - allocated_destination_contract : bool ; - } -> Kind.transaction successful_manager_operation_result - | Origination_result : - { big_map_diff : Contract.big_map_diff option ; - balance_updates : Delegate.balance_updates ; - originated_contracts : Contract.t list ; - consumed_gas : Z.t ; - storage_size : Z.t ; - paid_storage_size_diff : Z.t ; - } -> Kind.origination successful_manager_operation_result - | Delegation_result : - { consumed_gas : Z.t - } -> Kind.delegation successful_manager_operation_result + | Reveal_result : { + consumed_gas : Z.t; + } + -> Kind.reveal successful_manager_operation_result + | Transaction_result : { + storage : Script.expr option; + big_map_diff : Contract.big_map_diff option; + balance_updates : Delegate.balance_updates; + originated_contracts : Contract.t list; + consumed_gas : Z.t; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + allocated_destination_contract : bool; + } + -> Kind.transaction successful_manager_operation_result + | Origination_result : { + big_map_diff : Contract.big_map_diff option; + balance_updates : Delegate.balance_updates; + originated_contracts : Contract.t list; + consumed_gas : Z.t; + storage_size : Z.t; + paid_storage_size_diff : Z.t; + } + -> Kind.origination successful_manager_operation_result + | Delegation_result : { + consumed_gas : Z.t; + } + -> Kind.delegation successful_manager_operation_result and packed_successful_manager_operation_result = | Successful_manager_result : - 'kind successful_manager_operation_result -> packed_successful_manager_operation_result + 'kind successful_manager_operation_result + -> packed_successful_manager_operation_result and packed_internal_operation_result = | Internal_operation_result : - 'kind internal_operation * 'kind manager_operation_result -> - packed_internal_operation_result + 'kind internal_operation * 'kind manager_operation_result + -> packed_internal_operation_result (** Serializer for {!packed_operation_result}. *) val operation_metadata_encoding : packed_operation_metadata Data_encoding.t -val operation_data_and_metadata_encoding - : (Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t - - +val operation_data_and_metadata_encoding : + (Operation.packed_protocol_data * packed_operation_metadata) Data_encoding.t type 'kind contents_and_result_list = - | Single_and_result : 'kind Alpha_context.contents * 'kind contents_result -> 'kind contents_and_result_list - | Cons_and_result : 'kind Kind.manager Alpha_context.contents * 'kind Kind.manager contents_result * 'rest Kind.manager contents_and_result_list -> ('kind * 'rest) Kind.manager contents_and_result_list + | Single_and_result : + 'kind Alpha_context.contents * 'kind contents_result + -> 'kind contents_and_result_list + | Cons_and_result : + 'kind Kind.manager Alpha_context.contents + * 'kind Kind.manager contents_result + * 'rest Kind.manager contents_and_result_list + -> ('kind * 'rest) Kind.manager contents_and_result_list type packed_contents_and_result_list = - | Contents_and_result_list : 'kind contents_and_result_list -> packed_contents_and_result_list + | Contents_and_result_list : + 'kind contents_and_result_list + -> packed_contents_and_result_list val contents_and_result_list_encoding : packed_contents_and_result_list Data_encoding.t val pack_contents_list : - 'kind contents_list -> 'kind contents_result_list -> + 'kind contents_list -> + 'kind contents_result_list -> 'kind contents_and_result_list 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 to_list : packed_contents_result_list -> packed_contents_result list -val of_list : - packed_contents_result list -> packed_contents_result_list +val of_list : packed_contents_result list -> packed_contents_result_list type ('a, 'b) eq = Eq : ('a, 'a) eq + val kind_equal_list : - 'kind contents_list -> 'kind2 contents_result_list -> ('kind, 'kind2) eq option + 'kind contents_list -> + 'kind2 contents_result_list -> + ('kind, 'kind2) eq option type block_metadata = { - baker: Signature.Public_key_hash.t ; - level: Level.t ; - voting_period_kind: Voting_period.kind ; - nonce_hash: Nonce_hash.t option ; - consumed_gas: Z.t ; - deactivated: Signature.Public_key_hash.t list ; - balance_updates: Delegate.balance_updates ; + baker : Signature.Public_key_hash.t; + level : Level.t; + voting_period_kind : Voting_period.kind; + nonce_hash : Nonce_hash.t option; + consumed_gas : Z.t; + deactivated : Signature.Public_key_hash.t list; + balance_updates : Delegate.balance_updates; } -val block_metadata_encoding: block_metadata Data_encoding.encoding + +val block_metadata_encoding : block_metadata Data_encoding.encoding diff --git a/vendors/ligo-utils/tezos-protocol-alpha/baking.ml b/vendors/ligo-utils/tezos-protocol-alpha/baking.ml index 168e70708..d55e209ca 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/baking.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/baking.ml @@ -23,31 +23,45 @@ (* *) (*****************************************************************************) - open Alpha_context open Misc type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *) -type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *) + +type error += Timestamp_too_early of Timestamp.t * Timestamp.t + +(* `Permanent *) + type error += Unexpected_endorsement (* `Permanent *) -type error += Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t (* `Permanent *) -type error += Invalid_signature (* `Permanent *) -type error += Invalid_stamp (* `Permanent *) + +type error += + | Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t + +(* `Permanent *) + +type error += Invalid_signature (* `Permanent *) + +type error += Invalid_stamp (* `Permanent *) let () = register_error_kind `Permanent ~id:"baking.timestamp_too_early" ~title:"Block forged too early" - ~description:"The block timestamp is before the first slot \ - for this baker at this level" + ~description: + "The block timestamp is before the first slot for this baker at this \ + level" ~pp:(fun ppf (r, p) -> - Format.fprintf ppf "Block forged too early (%a is before %a)" - Time.pp_hum p Time.pp_hum r) - Data_encoding.(obj2 - (req "minimum" Time.encoding) - (req "provided" Time.encoding)) - (function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None) + Format.fprintf + ppf + "Block forged too early (%a is before %a)" + Time.pp_hum + p + Time.pp_hum + r) + Data_encoding.( + obj2 (req "minimum" Time.encoding) (req "provided" Time.encoding)) + (function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None) (fun (r, p) -> Timestamp_too_early (r, p)) ; register_error_kind `Permanent @@ -55,35 +69,36 @@ let () = ~title:"Invalid fitness gap" ~description:"The gap of fitness is out of bounds" ~pp:(fun ppf (m, g) -> - Format.fprintf ppf - "The gap of fitness %Ld is not between 0 and %Ld" g m) - Data_encoding.(obj2 - (req "maximum" int64) - (req "provided" int64)) - (function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None) + Format.fprintf ppf "The gap of fitness %Ld is not between 0 and %Ld" g m) + Data_encoding.(obj2 (req "maximum" int64) (req "provided" int64)) + (function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None) (fun (m, g) -> Invalid_fitness_gap (m, g)) ; register_error_kind `Permanent ~id:"baking.invalid_block_signature" ~title:"Invalid block signature" - ~description: - "A block was not signed with the expected private key." + ~description:"A block was not signed with the expected private key." ~pp:(fun ppf (block, pkh) -> - Format.fprintf ppf "Invalid signature for block %a. Expected: %a." - Block_hash.pp_short block - Signature.Public_key_hash.pp_short pkh) - Data_encoding.(obj2 - (req "block" Block_hash.encoding) - (req "expected" Signature.Public_key_hash.encoding)) - (function Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None) - (fun (block, pkh) -> Invalid_block_signature (block, pkh)); + Format.fprintf + ppf + "Invalid signature for block %a. Expected: %a." + Block_hash.pp_short + block + Signature.Public_key_hash.pp_short + pkh) + Data_encoding.( + obj2 + (req "block" Block_hash.encoding) + (req "expected" Signature.Public_key_hash.encoding)) + (function + | Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None) + (fun (block, pkh) -> Invalid_block_signature (block, pkh)) ; register_error_kind `Permanent ~id:"baking.invalid_signature" ~title:"Invalid block signature" ~description:"The block's signature is invalid" - ~pp:(fun ppf () -> - Format.fprintf ppf "Invalid block signature") + ~pp:(fun ppf () -> Format.fprintf ppf "Invalid block signature") Data_encoding.empty (function Invalid_signature -> Some () | _ -> None) (fun () -> Invalid_signature) ; @@ -92,8 +107,7 @@ let () = ~id:"baking.insufficient_proof_of_work" ~title:"Insufficient block proof-of-work stamp" ~description:"The block's proof-of-work stamp is insufficient" - ~pp:(fun ppf () -> - Format.fprintf ppf "Insufficient proof-of-work stamp") + ~pp:(fun ppf () -> Format.fprintf ppf "Insufficient proof-of-work stamp") Data_encoding.empty (function Invalid_stamp -> Some () | _ -> None) (fun () -> Invalid_stamp) ; @@ -101,10 +115,12 @@ let () = `Permanent ~id:"baking.unexpected_endorsement" ~title:"Endorsement from unexpected delegate" - ~description:"The operation is signed by a delegate without endorsement rights." + ~description: + "The operation is signed by a delegate without endorsement rights." ~pp:(fun ppf () -> - Format.fprintf ppf - "The endorsement is signed by a delegate without endorsement rights.") + Format.fprintf + ppf + "The endorsement is signed by a delegate without endorsement rights.") Data_encoding.unit (function Unexpected_endorsement -> Some () | _ -> None) (fun () -> Unexpected_endorsement) @@ -112,20 +128,24 @@ let () = let minimal_time c priority pred_timestamp = let priority = Int32.of_int priority in let rec cumsum_time_between_blocks acc durations p = - if Compare.Int32.(<=) p 0l then - ok acc - else match durations with - | [] -> cumsum_time_between_blocks acc [ Period.one_minute ] p - | [ last ] -> - Period.mult p last >>? fun period -> - Timestamp.(acc +? period) + if Compare.Int32.( <= ) p 0l then ok acc + else + match durations with + | [] -> + cumsum_time_between_blocks acc [Period.one_minute] p + | [last] -> + Period.mult p last >>? fun period -> Timestamp.(acc +? period) | first :: durations -> - Timestamp.(acc +? first) >>? fun acc -> + Timestamp.(acc +? first) + >>? fun acc -> let p = Int32.pred p in - cumsum_time_between_blocks acc durations p in + cumsum_time_between_blocks acc durations p + in Lwt.return (cumsum_time_between_blocks - pred_timestamp (Constants.time_between_blocks c) (Int32.succ priority)) + pred_timestamp + (Constants.time_between_blocks c) + (Int32.succ priority)) let earlier_predecessor_timestamp ctxt level = let current = Level.current ctxt in @@ -135,25 +155,29 @@ let earlier_predecessor_timestamp ctxt level = if Compare.Int32.(gap < 1l) then failwith "Baking.earlier_block_timestamp: past block." else - Lwt.return (Period.mult (Int32.pred gap) step) >>=? fun delay -> - Lwt.return Timestamp.(current_timestamp +? delay) >>=? fun result -> - return result + Lwt.return (Period.mult (Int32.pred gap) step) + >>=? fun delay -> + Lwt.return Timestamp.(current_timestamp +? delay) + >>=? fun result -> return result let check_timestamp c priority pred_timestamp = - minimal_time c priority pred_timestamp >>=? fun minimal_time -> + minimal_time c priority pred_timestamp + >>=? fun minimal_time -> let timestamp = Alpha_context.Timestamp.current c in Lwt.return - (record_trace (Timestamp_too_early (minimal_time, timestamp)) + (record_trace + (Timestamp_too_early (minimal_time, timestamp)) Timestamp.(timestamp -? minimal_time)) -let check_baking_rights c { Block_header.priority ; _ } - pred_timestamp = +let check_baking_rights c {Block_header.priority; _} pred_timestamp = let level = Level.current c in - Roll.baking_rights_owner c level ~priority >>=? fun delegate -> - check_timestamp c priority pred_timestamp >>=? fun block_delay -> - return (delegate, block_delay) + Roll.baking_rights_owner c level ~priority + >>=? fun delegate -> + check_timestamp c priority pred_timestamp + >>=? fun block_delay -> return (delegate, block_delay) type error += Incorrect_priority (* `Permanent *) + type error += Incorrect_number_of_endorsements (* `Permanent *) let () = @@ -163,14 +187,16 @@ let () = ~title:"Incorrect priority" ~description:"Block priority must be non-negative." ~pp:(fun ppf () -> - Format.fprintf ppf "The block priority must be non-negative.") + Format.fprintf ppf "The block priority must be non-negative.") Data_encoding.unit (function Incorrect_priority -> Some () | _ -> None) (fun () -> Incorrect_priority) let () = - let description = "The number of endorsements must be non-negative and \ - at most the endosers_per_block constant." in + let description = + "The number of endorsements must be non-negative and at most the \ + endosers_per_block constant." + in register_error_kind `Permanent ~id:"incorrect_number_of_endorsements" @@ -181,89 +207,109 @@ let () = (function Incorrect_number_of_endorsements -> Some () | _ -> None) (fun () -> Incorrect_number_of_endorsements) -let baking_reward ctxt ~block_priority:prio ~included_endorsements:num_endo = - fail_unless Compare.Int.(prio >= 0) Incorrect_priority >>=? fun () -> - let max_endorsements = Constants.endorsers_per_block ctxt in - fail_unless Compare.Int.(num_endo >= 0 && num_endo <= max_endorsements) - Incorrect_number_of_endorsements >>=? fun () -> - let prio_factor_denominator = Int64.(succ (of_int prio)) in - let endo_factor_numerator = Int64.of_int (8 + 2 * num_endo / max_endorsements) in - let endo_factor_denominator = 10L in - Lwt.return - Tez.( - Constants.block_reward ctxt *? endo_factor_numerator >>? fun val1 -> - val1 /? endo_factor_denominator >>? fun val2 -> - val2 /? prio_factor_denominator) +let rec reward_for_priority reward_per_prio prio = + match reward_per_prio with + | [] -> + (* Empty reward list in parameters means no rewards *) + Tez.zero + | [last] -> + last + | first :: rest -> + if Compare.Int.(prio <= 0) then first + else reward_for_priority rest (pred prio) -let endorsing_reward ctxt ~block_priority:prio n = - if Compare.Int.(prio >= 0) - then - Lwt.return - Tez.(Constants.endorsement_reward ctxt /? (Int64.(succ (of_int prio)))) >>=? fun tez -> - Lwt.return Tez.(tez *? Int64.of_int n) - else fail Incorrect_priority +let baking_reward ctxt ~block_priority ~included_endorsements = + fail_unless Compare.Int.(block_priority >= 0) Incorrect_priority + >>=? fun () -> + fail_unless + Compare.Int.( + included_endorsements >= 0 + && included_endorsements <= Constants.endorsers_per_block ctxt) + Incorrect_number_of_endorsements + >>=? fun () -> + let reward_per_endorsement = + reward_for_priority + (Constants.baking_reward_per_endorsement ctxt) + block_priority + in + Lwt.return Tez.(reward_per_endorsement *? Int64.of_int included_endorsements) + +let endorsing_reward ctxt ~block_priority num_slots = + fail_unless Compare.Int.(block_priority >= 0) Incorrect_priority + >>=? fun () -> + let reward_per_endorsement = + reward_for_priority (Constants.endorsement_reward ctxt) block_priority + in + Lwt.return Tez.(reward_per_endorsement *? Int64.of_int num_slots) let baking_priorities c level = let rec f priority = - Roll.baking_rights_owner c level ~priority >>=? fun delegate -> - return (LCons (delegate, (fun () -> f (succ priority)))) + Roll.baking_rights_owner c level ~priority + >>=? fun delegate -> return (LCons (delegate, fun () -> f (succ priority))) in f 0 -let endorsement_rights c level = +let endorsement_rights ctxt level = fold_left_s (fun acc slot -> - Roll.endorsement_rights_owner c level ~slot >>=? fun pk -> - let pkh = Signature.Public_key.hash pk in - let right = - match Signature.Public_key_hash.Map.find_opt pkh acc with - | None -> (pk, [slot], false) - | Some (pk, slots, used) -> (pk, slot :: slots, used) in - return (Signature.Public_key_hash.Map.add pkh right acc)) + Roll.endorsement_rights_owner ctxt level ~slot + >>=? fun pk -> + let pkh = Signature.Public_key.hash pk in + let right = + match Signature.Public_key_hash.Map.find_opt pkh acc with + | None -> + (pk, [slot], false) + | Some (pk, slots, used) -> + (pk, slot :: slots, used) + in + return (Signature.Public_key_hash.Map.add pkh right acc)) Signature.Public_key_hash.Map.empty - (0 --> (Constants.endorsers_per_block c - 1)) + (0 --> (Constants.endorsers_per_block ctxt - 1)) -let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t) = +let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t) + = let current_level = Level.current ctxt in - let Single (Endorsement { level ; _ }) = op.protocol_data.contents in - begin - if Raw_level.(succ level = current_level.level) then - return (Alpha_context.allowed_endorsements ctxt) - else - endorsement_rights ctxt (Level.from_raw ctxt level) - end >>=? fun endorsements -> + let (Single (Endorsement {level; _})) = op.protocol_data.contents in + ( if Raw_level.(succ level = current_level.level) then + return (Alpha_context.allowed_endorsements ctxt) + else endorsement_rights ctxt (Level.from_raw ctxt level) ) + >>=? fun endorsements -> match Signature.Public_key_hash.Map.fold (* no find_first *) (fun pkh (pk, slots, used) acc -> - match Operation.check_signature_sync pk chain_id op with - | Error _ -> acc - | Ok () -> Some (pkh, slots, used)) - endorsements None + match Operation.check_signature_sync pk chain_id op with + | Error _ -> + acc + | Ok () -> + Some (pkh, slots, used)) + endorsements + None with - | None -> fail Unexpected_endorsement - | Some v -> return v + | None -> + fail Unexpected_endorsement + | Some v -> + return v let select_delegate delegate delegate_list max_priority = let rec loop acc l n = - if Compare.Int.(n >= max_priority) - then return (List.rev acc) + if Compare.Int.(n >= max_priority) then return (List.rev acc) else - let LCons (pk, t) = l in + let (LCons (pk, t)) = l in let acc = - if Signature.Public_key_hash.equal delegate (Signature.Public_key.hash pk) + if + Signature.Public_key_hash.equal + delegate + (Signature.Public_key.hash pk) then n :: acc - else acc in - t () >>=? fun t -> - loop acc t (succ n) + else acc + in + t () >>=? fun t -> loop acc t (succ n) in loop [] delegate_list 0 -let first_baking_priorities - ctxt - ?(max_priority = 32) - delegate level = - baking_priorities ctxt level >>=? fun delegate_list -> - select_delegate delegate delegate_list max_priority +let first_baking_priorities ctxt ?(max_priority = 32) delegate level = + baking_priorities ctxt level + >>=? fun delegate_list -> select_delegate delegate delegate_list max_priority let check_hash hash stamp_threshold = let bytes = Block_hash.to_bytes hash in @@ -273,84 +319,89 @@ let check_hash hash stamp_threshold = let check_header_proof_of_work_stamp shell contents stamp_threshold = let hash = Block_header.hash - { shell ; protocol_data = { contents ; signature = Signature.zero } } in + {shell; protocol_data = {contents; signature = Signature.zero}} + in check_hash hash stamp_threshold let check_proof_of_work_stamp ctxt block = let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in - if check_header_proof_of_work_stamp + if + check_header_proof_of_work_stamp block.Block_header.shell block.protocol_data.contents - proof_of_work_threshold then - return_unit - else - fail Invalid_stamp + proof_of_work_threshold + then return_unit + else fail Invalid_stamp let check_signature block chain_id key = let check_signature key - { Block_header.shell ; protocol_data = { contents ; signature } } = + {Block_header.shell; protocol_data = {contents; signature}} = let unsigned_header = Data_encoding.Binary.to_bytes_exn Block_header.unsigned_encoding - (shell, contents) in - Signature.check ~watermark:(Block_header chain_id) key signature unsigned_header in - if check_signature key block then - return_unit + (shell, contents) + in + Signature.check + ~watermark:(Block_header chain_id) + key + signature + unsigned_header + in + if check_signature key block then return_unit else - fail (Invalid_block_signature (Block_header.hash block, - Signature.Public_key.hash key)) + fail + (Invalid_block_signature + (Block_header.hash block, Signature.Public_key.hash key)) let max_fitness_gap _ctxt = 1L let check_fitness_gap ctxt (block : Block_header.t) = let current_fitness = Fitness.current ctxt in - Lwt.return (Fitness.to_int64 block.shell.fitness) >>=? fun announced_fitness -> + Lwt.return (Fitness.to_int64 block.shell.fitness) + >>=? fun announced_fitness -> let gap = Int64.sub announced_fitness current_fitness in if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap)) - else - return_unit + else return_unit let last_of_a_cycle ctxt l = - Compare.Int32.(Int32.succ l.Level.cycle_position = - Constants.blocks_per_cycle ctxt) + Compare.Int32.( + Int32.succ l.Level.cycle_position = Constants.blocks_per_cycle ctxt) let dawn_of_a_new_cycle ctxt = let level = Level.current ctxt in - if last_of_a_cycle ctxt level then - return_some level.cycle - else - return_none + if last_of_a_cycle ctxt level then return_some level.cycle else return_none let minimum_allowed_endorsements ctxt ~block_delay = let minimum = Constants.initial_endorsers ctxt in let delay_per_missing_endorsement = Int64.to_int - (Period.to_seconds - (Constants.delay_per_missing_endorsement ctxt)) + (Period.to_seconds (Constants.delay_per_missing_endorsement ctxt)) in let reduced_time_constraint = let delay = Int64.to_int (Period.to_seconds block_delay) in - if Compare.Int.(delay_per_missing_endorsement = 0) then - delay - else - delay / delay_per_missing_endorsement + if Compare.Int.(delay_per_missing_endorsement = 0) then delay + else delay / delay_per_missing_endorsement in Compare.Int.max 0 (minimum - reduced_time_constraint) let minimal_valid_time ctxt ~priority ~endorsing_power = let predecessor_timestamp = Timestamp.current ctxt in - minimal_time ctxt - priority predecessor_timestamp >>=? fun minimal_time -> + minimal_time ctxt priority predecessor_timestamp + >>=? fun minimal_time -> let minimal_required_endorsements = Constants.initial_endorsers ctxt in let delay_per_missing_endorsement = Constants.delay_per_missing_endorsement ctxt in let missing_endorsements = - Compare.Int.max 0 (minimal_required_endorsements - endorsing_power) in - match Period.mult - (Int32.of_int missing_endorsements) - delay_per_missing_endorsement with + Compare.Int.max 0 (minimal_required_endorsements - endorsing_power) + in + match + Period.mult + (Int32.of_int missing_endorsements) + delay_per_missing_endorsement + with | Ok delay -> return (Time.add minimal_time (Period.to_seconds delay)) - | Error _ as err -> Lwt.return err + | Error _ as err -> + Lwt.return err diff --git a/vendors/ligo-utils/tezos-protocol-alpha/baking.mli b/vendors/ligo-utils/tezos-protocol-alpha/baking.mli index 39cc2e8e2..eb6f1f6fe 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/baking.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/baking.mli @@ -23,67 +23,81 @@ (* *) (*****************************************************************************) - open Alpha_context open Misc type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *) -type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *) -type error += Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t (* `Permanent *) + +type error += Timestamp_too_early of Timestamp.t * Timestamp.t + +(* `Permanent *) + +type error += + | Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t + +(* `Permanent *) + type error += Unexpected_endorsement -type error += Invalid_signature (* `Permanent *) -type error += Invalid_stamp (* `Permanent *) + +type error += Invalid_signature (* `Permanent *) + +type error += Invalid_stamp (* `Permanent *) (** [minimal_time ctxt priority pred_block_time] returns the minimal time, given the predecessor block timestamp [pred_block_time], after which a baker with priority [priority] is allowed to bake. Fail with [Invalid_time_between_blocks_constant] if the minimal time cannot be computed. *) -val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t +val minimal_time : context -> int -> Time.t -> Time.t tzresult Lwt.t (** [check_baking_rights ctxt block pred_timestamp] verifies that: * the contract that owned the roll at cycle start has the block signer as delegate. * the timestamp is coherent with the announced slot. *) -val check_baking_rights: - context -> Block_header.contents -> Time.t -> +val check_baking_rights : + context -> + Block_header.contents -> + Time.t -> (public_key * Period.t) tzresult Lwt.t (** For a given level computes who has the right to include an endorsement in the next block. The result can be stored in Alpha_context.allowed_endorsements *) -val endorsement_rights: +val endorsement_rights : context -> Level.t -> (public_key * int list * bool) Signature.Public_key_hash.Map.t tzresult Lwt.t (** Check that the operation was signed by a delegate allowed to endorse at the level specified by the endorsement. *) -val check_endorsement_rights: - context -> Chain_id.t -> Kind.endorsement Operation.t -> +val check_endorsement_rights : + context -> + Chain_id.t -> + Kind.endorsement Operation.t -> (public_key_hash * int list * bool) tzresult Lwt.t (** Returns the baking reward calculated w.r.t a given priority [p] and a - number [e] of included endorsements as follows: - (block_reward / (p+1)) * (0.8 + 0.2 * e / endorsers_per_block) -*) -val baking_reward: context -> - block_priority:int -> included_endorsements:int -> Tez.t tzresult Lwt.t + number [e] of included endorsements *) +val baking_reward : + context -> + block_priority:int -> + included_endorsements:int -> + Tez.t tzresult Lwt.t (** Returns the endorsing reward calculated w.r.t a given priority. *) -val endorsing_reward: context -> block_priority:int -> int -> Tez.t tzresult Lwt.t +val endorsing_reward : + context -> block_priority:int -> int -> Tez.t tzresult Lwt.t (** [baking_priorities ctxt level] is the lazy list of contract's public key hashes that are allowed to bake for [level]. *) -val baking_priorities: - context -> Level.t -> public_key lazy_list +val baking_priorities : context -> Level.t -> public_key lazy_list (** [first_baking_priorities ctxt ?max_priority contract_hash level] is a list of priorities of max [?max_priority] elements, where the delegate of [contract_hash] is allowed to bake for [level]. If [?max_priority] is [None], a sensible number of priorities is returned. *) -val first_baking_priorities: +val first_baking_priorities : context -> ?max_priority:int -> public_key_hash -> @@ -92,27 +106,28 @@ val first_baking_priorities: (** [check_signature ctxt chain_id block id] check if the block is signed with the given key, and belongs to the given [chain_id] *) -val check_signature: Block_header.t -> Chain_id.t -> public_key -> unit tzresult Lwt.t +val check_signature : + Block_header.t -> Chain_id.t -> public_key -> unit tzresult Lwt.t (** Checks if the header that would be built from the given components is valid for the given diffculty. The signature is not passed as it is does not impact the proof-of-work stamp. The stamp is checked on the hash of a block header whose signature has been zeroed-out. *) -val check_header_proof_of_work_stamp: +val check_header_proof_of_work_stamp : Block_header.shell_header -> Block_header.contents -> int64 -> bool (** verify if the proof of work stamp is valid *) -val check_proof_of_work_stamp: +val check_proof_of_work_stamp : context -> Block_header.t -> unit tzresult Lwt.t (** check if the gap between the fitness of the current context and the given block is within the protocol parameters *) -val check_fitness_gap: - context -> Block_header.t -> unit tzresult Lwt.t +val check_fitness_gap : context -> Block_header.t -> unit tzresult Lwt.t -val dawn_of_a_new_cycle: context -> Cycle.t option tzresult Lwt.t +val dawn_of_a_new_cycle : context -> Cycle.t option tzresult Lwt.t -val earlier_predecessor_timestamp: context -> Level.t -> Timestamp.t tzresult Lwt.t +val earlier_predecessor_timestamp : + context -> Level.t -> Timestamp.t tzresult Lwt.t (** Since Emmy+ @@ -138,14 +153,11 @@ val earlier_predecessor_timestamp: context -> Level.t -> Timestamp.t tzresult Lw time to bake at the block's priority (as returned by `minimum_time`), it returns the minimum number of endorsements that the block has to contain *) -val minimum_allowed_endorsements: context -> block_delay:Period.t -> int +val minimum_allowed_endorsements : context -> block_delay:Period.t -> int (** This is the somehow the dual of the previous function. Given a block priority and a number of endorsement slots (given by the `endorsing_power` argument), it returns the minimum time at which the next block can be baked. *) -val minimal_valid_time: - context -> - priority:int -> - endorsing_power: int -> - Time.t tzresult Lwt.t +val minimal_valid_time : + context -> priority:int -> endorsing_power:int -> Time.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml index b18824748..4152c33e9 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.ml @@ -23,24 +23,30 @@ (* *) (*****************************************************************************) -module H = Blake2B.Make(Base58)(struct - let name = "Blinded public key hash" - let title = "A blinded public key hash" - let b58check_prefix = "\001\002\049\223" - let size = Some Ed25519.Public_key_hash.size - end) +module H = + Blake2B.Make + (Base58) + (struct + let name = "Blinded public key hash" + + let title = "A blinded public key hash" + + let b58check_prefix = "\001\002\049\223" + + let size = Some Ed25519.Public_key_hash.size + end) include H -let () = - Base58.check_encoded_prefix b58check_encoding "btz1" 37 +let () = Base58.check_encoded_prefix b58check_encoding "btz1" 37 let of_ed25519_pkh activation_code pkh = - hash_bytes ~key:activation_code [ Ed25519.Public_key_hash.to_bytes pkh ] + hash_bytes ~key:activation_code [Ed25519.Public_key_hash.to_bytes pkh] type activation_code = MBytes.t let activation_code_size = Ed25519.Public_key_hash.size + let activation_code_encoding = Data_encoding.Fixed.bytes activation_code_size let activation_code_of_hex h = diff --git a/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli b/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli index c9306c867..75cd58758 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/blinded_public_key_hash.mli @@ -26,9 +26,11 @@ include S.HASH val encoding : t Data_encoding.t + val rpc_arg : t RPC_arg.t type activation_code + val activation_code_encoding : activation_code Data_encoding.t val of_ed25519_pkh : activation_code -> Ed25519.Public_key_hash.t -> t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml index 7fb78dedf..b75ba5d6d 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.ml @@ -25,114 +25,106 @@ (** Block header *) -type t = { - shell: Block_header.shell_header ; - protocol_data: protocol_data ; -} +type t = {shell : Block_header.shell_header; protocol_data : protocol_data} -and protocol_data = { - contents: contents ; - signature: Signature.t ; -} +and protocol_data = {contents : contents; signature : Signature.t} and contents = { - priority: int ; - seed_nonce_hash: Nonce_hash.t option ; - proof_of_work_nonce: MBytes.t ; + priority : int; + seed_nonce_hash : Nonce_hash.t option; + proof_of_work_nonce : MBytes.t; } type block_header = t type raw = Block_header.t + type shell_header = Block_header.shell_header let raw_encoding = Block_header.encoding + let shell_header_encoding = Block_header.shell_header_encoding let contents_encoding = let open Data_encoding in - def "block_header.alpha.unsigned_contents" @@ - conv - (fun { priority ; seed_nonce_hash ; proof_of_work_nonce } -> - (priority, proof_of_work_nonce, seed_nonce_hash)) - (fun (priority, proof_of_work_nonce, seed_nonce_hash) -> - { priority ; seed_nonce_hash ; proof_of_work_nonce }) - (obj3 - (req "priority" uint16) - (req "proof_of_work_nonce" - (Fixed.bytes Constants_repr.proof_of_work_nonce_size)) - (opt "seed_nonce_hash" Nonce_hash.encoding)) + def "block_header.alpha.unsigned_contents" + @@ conv + (fun {priority; seed_nonce_hash; proof_of_work_nonce} -> + (priority, proof_of_work_nonce, seed_nonce_hash)) + (fun (priority, proof_of_work_nonce, seed_nonce_hash) -> + {priority; seed_nonce_hash; proof_of_work_nonce}) + (obj3 + (req "priority" uint16) + (req + "proof_of_work_nonce" + (Fixed.bytes Constants_repr.proof_of_work_nonce_size)) + (opt "seed_nonce_hash" Nonce_hash.encoding)) let protocol_data_encoding = let open Data_encoding in - def "block_header.alpha.signed_contents" @@ - conv - (fun { contents ; signature } -> (contents, signature)) - (fun (contents, signature) -> { contents ; signature }) - (merge_objs - contents_encoding - (obj1 (req "signature" Signature.encoding))) + def "block_header.alpha.signed_contents" + @@ conv + (fun {contents; signature} -> (contents, signature)) + (fun (contents, signature) -> {contents; signature}) + (merge_objs + contents_encoding + (obj1 (req "signature" Signature.encoding))) -let raw { shell ; protocol_data ; } = +let raw {shell; protocol_data} = let protocol_data = - Data_encoding.Binary.to_bytes_exn - protocol_data_encoding - protocol_data in - { Block_header.shell ; protocol_data } + Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data + in + {Block_header.shell; protocol_data} let unsigned_encoding = let open Data_encoding in - merge_objs - Block_header.shell_header_encoding - contents_encoding + merge_objs Block_header.shell_header_encoding contents_encoding let encoding = let open Data_encoding in - def "block_header.alpha.full_header" @@ - conv - (fun { shell ; protocol_data } -> - (shell, protocol_data)) - (fun (shell, protocol_data) -> - { shell ; protocol_data }) - (merge_objs - Block_header.shell_header_encoding - protocol_data_encoding) + def "block_header.alpha.full_header" + @@ conv + (fun {shell; protocol_data} -> (shell, protocol_data)) + (fun (shell, protocol_data) -> {shell; protocol_data}) + (merge_objs Block_header.shell_header_encoding protocol_data_encoding) (** Constants *) let max_header_length = - let fake_shell = { - Block_header.level = 0l ; - proto_level = 0 ; - predecessor = Block_hash.zero ; - timestamp = Time.of_seconds 0L ; - validation_passes = 0 ; - operations_hash = Operation_list_list_hash.zero ; - fitness = Fitness_repr.from_int64 0L ; - context = Context_hash.zero ; - } + let fake_shell = + { + Block_header.level = 0l; + proto_level = 0; + predecessor = Block_hash.zero; + timestamp = Time.of_seconds 0L; + validation_passes = 0; + operations_hash = Operation_list_list_hash.zero; + fitness = Fitness_repr.from_int64 0L; + context = Context_hash.zero; + } and fake_contents = - { priority = 0 ; + { + priority = 0; proof_of_work_nonce = - MBytes.create Constants_repr.proof_of_work_nonce_size ; - seed_nonce_hash = Some Nonce_hash.zero - } in + MBytes.create Constants_repr.proof_of_work_nonce_size; + seed_nonce_hash = Some Nonce_hash.zero; + } + in Data_encoding.Binary.length encoding - { shell = fake_shell ; - protocol_data = { - contents = fake_contents ; - signature = Signature.zero ; - } + { + shell = fake_shell; + protocol_data = {contents = fake_contents; signature = Signature.zero}; } (** Header parsing entry point *) let hash_raw = Block_header.hash -let hash { shell ; protocol_data } = + +let hash {shell; protocol_data} = Block_header.hash - { shell ; + { + shell; protocol_data = - Data_encoding.Binary.to_bytes_exn - protocol_data_encoding - protocol_data } + Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data; + } diff --git a/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli index 9ce44a3d5..bbbcae80c 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/block_header_repr.mli @@ -23,38 +23,39 @@ (* *) (*****************************************************************************) -type t = { - shell: Block_header.shell_header ; - protocol_data: protocol_data ; -} +type t = {shell : Block_header.shell_header; protocol_data : protocol_data} -and protocol_data = { - contents: contents ; - signature: Signature.t ; -} +and protocol_data = {contents : contents; signature : Signature.t} and contents = { - priority: int ; - seed_nonce_hash: Nonce_hash.t option ; - proof_of_work_nonce: MBytes.t ; + priority : int; + seed_nonce_hash : Nonce_hash.t option; + proof_of_work_nonce : MBytes.t; } type block_header = t type raw = Block_header.t + type shell_header = Block_header.shell_header -val raw: block_header -> raw +val raw : block_header -> raw -val encoding: block_header Data_encoding.encoding -val raw_encoding: raw Data_encoding.t -val contents_encoding: contents Data_encoding.t -val unsigned_encoding: (Block_header.shell_header * contents) Data_encoding.t -val protocol_data_encoding: protocol_data Data_encoding.encoding -val shell_header_encoding: shell_header Data_encoding.encoding +val encoding : block_header Data_encoding.encoding + +val raw_encoding : raw Data_encoding.t + +val contents_encoding : contents Data_encoding.t + +val unsigned_encoding : (Block_header.shell_header * contents) Data_encoding.t + +val protocol_data_encoding : protocol_data Data_encoding.encoding + +val shell_header_encoding : shell_header Data_encoding.encoding -val max_header_length: int (** The maximum size of block headers in bytes *) +val max_header_length : int -val hash: block_header -> Block_hash.t -val hash_raw: raw -> Block_hash.t +val hash : block_header -> Block_hash.t + +val hash_raw : raw -> Block_hash.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml index 8e0b46abc..f21ebc257 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.ml @@ -26,100 +26,128 @@ open Misc let init_account ctxt - ({ public_key_hash ; public_key ; amount }: Parameters_repr.bootstrap_account) = + ({public_key_hash; public_key; amount} : Parameters_repr.bootstrap_account) + = let contract = Contract_repr.implicit_contract public_key_hash in - Contract_storage.credit ctxt contract amount >>=? fun ctxt -> + Contract_storage.credit ctxt contract amount + >>=? fun ctxt -> match public_key with | Some public_key -> - Contract_storage.reveal_manager_key ctxt public_key_hash public_key >>=? fun ctxt -> - Delegate_storage.set ctxt contract (Some public_key_hash) >>=? fun ctxt -> + Contract_storage.reveal_manager_key ctxt public_key_hash public_key + >>=? fun ctxt -> + Delegate_storage.set ctxt contract (Some public_key_hash) + >>=? fun ctxt -> return ctxt + | None -> return ctxt - | None -> return ctxt let init_contract ~typecheck ctxt - ({ delegate ; amount ; script }: Parameters_repr.bootstrap_contract) = - Contract_storage.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - typecheck ctxt script >>=? fun (script, ctxt) -> - Contract_storage.originate ctxt contract + ({delegate; amount; script} : Parameters_repr.bootstrap_contract) = + Contract_storage.fresh_contract_from_current_nonce ctxt + >>=? fun (ctxt, contract) -> + typecheck ctxt script + >>=? fun (script, ctxt) -> + Contract_storage.originate + ctxt + contract ~balance:amount ~prepaid_bootstrap_storage:true ~script - ~delegate:(Some delegate) >>=? fun ctxt -> - return ctxt + ~delegate:(Some delegate) + >>=? fun ctxt -> return ctxt let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts = let nonce = - Operation_hash.hash_bytes - [ MBytes.of_string "Un festival de GADT." ] in + Operation_hash.hash_bytes [MBytes.of_string "Un festival de GADT."] + in let ctxt = Raw_context.init_origination_nonce ctxt nonce in - fold_left_s init_account ctxt accounts >>=? fun ctxt -> - fold_left_s (init_contract ~typecheck) ctxt contracts >>=? fun ctxt -> - begin - match no_reward_cycles with - | None -> return ctxt - | Some cycles -> - (* Store pending ramp ups. *) - let constants = Raw_context.constants ctxt in - (* Start without reward *) - Raw_context.patch_constants ctxt - (fun c -> - { c with - block_reward = Tez_repr.zero ; - endorsement_reward = Tez_repr.zero }) >>= fun ctxt -> - (* Store the final reward. *) - Storage.Ramp_up.Rewards.init ctxt - (Cycle_repr.of_int32_exn (Int32.of_int cycles)) - (constants.block_reward, - constants.endorsement_reward) - end >>=? fun ctxt -> - match ramp_up_cycles with - | None -> return ctxt + fold_left_s init_account ctxt accounts + >>=? fun ctxt -> + fold_left_s (init_contract ~typecheck) ctxt contracts + >>=? fun ctxt -> + ( match no_reward_cycles with + | None -> + return ctxt | Some cycles -> (* Store pending ramp ups. *) let constants = Raw_context.constants ctxt in - Lwt.return Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles) >>=? fun block_step -> - Lwt.return Tez_repr.(constants.endorsement_security_deposit /? Int64.of_int cycles) >>=? fun endorsement_step -> + (* Start without rewards *) + Raw_context.patch_constants ctxt (fun c -> + { + c with + baking_reward_per_endorsement = [Tez_repr.zero]; + endorsement_reward = [Tez_repr.zero]; + }) + >>= fun ctxt -> + (* Store the final reward. *) + Storage.Ramp_up.Rewards.init + ctxt + (Cycle_repr.of_int32_exn (Int32.of_int cycles)) + (constants.baking_reward_per_endorsement, constants.endorsement_reward) + ) + >>=? fun ctxt -> + match ramp_up_cycles with + | None -> + return ctxt + | Some cycles -> + (* Store pending ramp ups. *) + let constants = Raw_context.constants ctxt in + Lwt.return + Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles) + >>=? fun block_step -> + Lwt.return + Tez_repr.( + constants.endorsement_security_deposit /? Int64.of_int cycles) + >>=? fun endorsement_step -> (* Start without security_deposit *) - Raw_context.patch_constants ctxt - (fun c -> - { c with - block_security_deposit = Tez_repr.zero ; - endorsement_security_deposit = Tez_repr.zero }) >>= fun ctxt -> + Raw_context.patch_constants ctxt (fun c -> + { + c with + block_security_deposit = Tez_repr.zero; + endorsement_security_deposit = Tez_repr.zero; + }) + >>= fun ctxt -> fold_left_s (fun ctxt cycle -> - Lwt.return Tez_repr.(block_step *? Int64.of_int cycle) >>=? fun block_security_deposit -> - Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle) >>=? fun endorsement_security_deposit -> - let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in - Storage.Ramp_up.Security_deposits.init ctxt cycle - (block_security_deposit, endorsement_security_deposit)) + Lwt.return Tez_repr.(block_step *? Int64.of_int cycle) + >>=? fun block_security_deposit -> + Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle) + >>=? fun endorsement_security_deposit -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in + Storage.Ramp_up.Security_deposits.init + ctxt + cycle + (block_security_deposit, endorsement_security_deposit)) ctxt - (1 --> (cycles - 1)) >>=? fun ctxt -> + (1 --> (cycles - 1)) + >>=? fun ctxt -> (* Store the final security deposits. *) - Storage.Ramp_up.Security_deposits.init ctxt + Storage.Ramp_up.Security_deposits.init + ctxt (Cycle_repr.of_int32_exn (Int32.of_int cycles)) - (constants.block_security_deposit, - constants.endorsement_security_deposit) >>=? fun ctxt -> - return ctxt + ( constants.block_security_deposit, + constants.endorsement_security_deposit ) + >>=? fun ctxt -> return ctxt let cycle_end ctxt last_cycle = let next_cycle = Cycle_repr.succ last_cycle in - begin - Storage.Ramp_up.Rewards.get_option ctxt next_cycle >>=? function - | None -> return ctxt - | Some (block_reward, endorsement_reward) -> - Storage.Ramp_up.Rewards.delete ctxt next_cycle >>=? fun ctxt -> - Raw_context.patch_constants ctxt - (fun c -> - { c with block_reward ; - endorsement_reward }) >>= fun ctxt -> - return ctxt - end >>=? fun ctxt -> - Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle >>=? function - | None -> return ctxt - | Some (block_security_deposit, endorsement_security_deposit) -> - Storage.Ramp_up.Security_deposits.delete ctxt next_cycle >>=? fun ctxt -> - Raw_context.patch_constants ctxt - (fun c -> - { c with block_security_deposit ; - endorsement_security_deposit }) >>= fun ctxt -> + Storage.Ramp_up.Rewards.get_option ctxt next_cycle + >>=? (function + | None -> + return ctxt + | Some (baking_reward_per_endorsement, endorsement_reward) -> + Storage.Ramp_up.Rewards.delete ctxt next_cycle + >>=? fun ctxt -> + Raw_context.patch_constants ctxt (fun c -> + {c with baking_reward_per_endorsement; endorsement_reward}) + >>= fun ctxt -> return ctxt) + >>=? fun ctxt -> + Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle + >>=? function + | None -> return ctxt + | Some (block_security_deposit, endorsement_security_deposit) -> + Storage.Ramp_up.Security_deposits.delete ctxt next_cycle + >>=? fun ctxt -> + Raw_context.patch_constants ctxt (fun c -> + {c with block_security_deposit; endorsement_security_deposit}) + >>= fun ctxt -> return ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli index b489228a4..1b4cf8cf8 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/bootstrap_storage.mli @@ -23,18 +23,18 @@ (* *) (*****************************************************************************) -val init: +val init : Raw_context.t -> - typecheck:(Raw_context.t -> Script_repr.t -> - ((Script_repr.t * Contract_storage.big_map_diff option) * Raw_context.t) - tzresult Lwt.t) -> + typecheck:(Raw_context.t -> + Script_repr.t -> + ( (Script_repr.t * Contract_storage.big_map_diff option) + * Raw_context.t ) + tzresult + Lwt.t) -> ?ramp_up_cycles:int -> ?no_reward_cycles:int -> Parameters_repr.bootstrap_account list -> Parameters_repr.bootstrap_contract list -> Raw_context.t tzresult Lwt.t -val cycle_end: - Raw_context.t -> - Cycle_repr.t -> - Raw_context.t tzresult Lwt.t +val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml index 89b9272de..e64be9c01 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.ml @@ -24,17 +24,15 @@ (*****************************************************************************) type t = { - blinded_public_key_hash : Blinded_public_key_hash.t ; - amount : Tez_repr.t + blinded_public_key_hash : Blinded_public_key_hash.t; + amount : Tez_repr.t; } let encoding = let open Data_encoding in conv - (fun { blinded_public_key_hash ; amount } -> - ( blinded_public_key_hash, amount )) - (fun ( blinded_public_key_hash, amount) -> - { blinded_public_key_hash ; amount }) - (tup2 - Blinded_public_key_hash.encoding - Tez_repr.encoding) + (fun {blinded_public_key_hash; amount} -> + (blinded_public_key_hash, amount)) + (fun (blinded_public_key_hash, amount) -> + {blinded_public_key_hash; amount}) + (tup2 Blinded_public_key_hash.encoding Tez_repr.encoding) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli index 4bd74810a..edca4134d 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/commitment_repr.mli @@ -24,8 +24,8 @@ (*****************************************************************************) type t = { - blinded_public_key_hash : Blinded_public_key_hash.t ; - amount : Tez_repr.t ; + blinded_public_key_hash : Blinded_public_key_hash.t; + amount : Tez_repr.t; } val encoding : t Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml index a8680b976..21a500b62 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.ml @@ -24,10 +24,11 @@ (*****************************************************************************) let get_opt = Storage.Commitments.get_option + let delete = Storage.Commitments.delete -let init ctxt commitments = - let init_commitment ctxt Commitment_repr.{ blinded_public_key_hash ; amount } = - Storage.Commitments.init ctxt blinded_public_key_hash amount in - fold_left_s init_commitment ctxt commitments >>=? fun ctxt -> - return ctxt +let init ctxt commitments = + let init_commitment ctxt Commitment_repr.{blinded_public_key_hash; amount} = + Storage.Commitments.init ctxt blinded_public_key_hash amount + in + fold_left_s init_commitment ctxt commitments >>=? fun ctxt -> return ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli index 1e5be6dc5..1591cbebb 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/commitment_storage.mli @@ -23,15 +23,13 @@ (* *) (*****************************************************************************) -val init: - Raw_context.t -> - Commitment_repr.t list -> - Raw_context.t tzresult Lwt.t +val init : + Raw_context.t -> Commitment_repr.t list -> Raw_context.t tzresult Lwt.t -val get_opt: - Raw_context.t -> Blinded_public_key_hash.t -> +val get_opt : + Raw_context.t -> + Blinded_public_key_hash.t -> Tez_repr.t option tzresult Lwt.t -val delete: - Raw_context.t -> Blinded_public_key_hash.t -> - Raw_context.t tzresult Lwt.t +val delete : + Raw_context.t -> Blinded_public_key_hash.t -> Raw_context.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml index 6ad7b1526..d1b8246f9 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_repr.ml @@ -24,41 +24,48 @@ (*****************************************************************************) let version_number_004 = "\000" + let version_number = "\001" + let proof_of_work_nonce_size = 8 + let nonce_length = 32 + let max_revelations_per_block = 32 + let max_proposals_per_delegate = 20 + let max_operation_data_length = 16 * 1024 (* 16kB *) type fixed = { - proof_of_work_nonce_size : int ; - nonce_length : int ; - max_revelations_per_block : int ; - max_operation_data_length : int ; - max_proposals_per_delegate : int ; + proof_of_work_nonce_size : int; + nonce_length : int; + max_revelations_per_block : int; + max_operation_data_length : int; + max_proposals_per_delegate : int; } let fixed_encoding = let open Data_encoding in conv (fun c -> - (c.proof_of_work_nonce_size, + ( c.proof_of_work_nonce_size, c.nonce_length, c.max_revelations_per_block, c.max_operation_data_length, - c.max_proposals_per_delegate)) - (fun (proof_of_work_nonce_size, - nonce_length, - max_revelations_per_block, - max_operation_data_length, - max_proposals_per_delegate) -> - { proof_of_work_nonce_size ; - nonce_length ; - max_revelations_per_block ; - max_operation_data_length ; - max_proposals_per_delegate ; - } ) + c.max_proposals_per_delegate )) + (fun ( proof_of_work_nonce_size, + nonce_length, + max_revelations_per_block, + max_operation_data_length, + max_proposals_per_delegate ) -> + { + proof_of_work_nonce_size; + nonce_length; + max_revelations_per_block; + max_operation_data_length; + max_proposals_per_delegate; + }) (obj5 (req "proof_of_work_nonce_size" uint8) (req "nonce_length" uint8) @@ -66,48 +73,50 @@ let fixed_encoding = (req "max_operation_data_length" int31) (req "max_proposals_per_delegate" uint8)) -let fixed = { - proof_of_work_nonce_size ; - nonce_length ; - max_revelations_per_block ; - max_operation_data_length ; - max_proposals_per_delegate ; -} +let fixed = + { + proof_of_work_nonce_size; + nonce_length; + max_revelations_per_block; + max_operation_data_length; + max_proposals_per_delegate; + } type parametric = { - preserved_cycles: int ; - blocks_per_cycle: int32 ; - blocks_per_commitment: int32 ; - blocks_per_roll_snapshot: int32 ; - blocks_per_voting_period: int32 ; - time_between_blocks: Period_repr.t list ; - endorsers_per_block: int ; - hard_gas_limit_per_operation: Z.t ; - hard_gas_limit_per_block: Z.t ; - proof_of_work_threshold: int64 ; - tokens_per_roll: Tez_repr.t ; - michelson_maximum_type_size: int; - seed_nonce_revelation_tip: Tez_repr.t ; - origination_size: int ; - block_security_deposit: Tez_repr.t ; - endorsement_security_deposit: Tez_repr.t ; - block_reward: Tez_repr.t ; - endorsement_reward: Tez_repr.t ; - cost_per_byte: Tez_repr.t ; - hard_storage_limit_per_operation: Z.t ; - test_chain_duration: int64 ; (* in seconds *) - quorum_min: int32 ; - quorum_max: int32 ; - min_proposal_quorum: int32 ; - initial_endorsers: int ; - delay_per_missing_endorsement: Period_repr.t ; + preserved_cycles : int; + blocks_per_cycle : int32; + blocks_per_commitment : int32; + blocks_per_roll_snapshot : int32; + blocks_per_voting_period : int32; + time_between_blocks : Period_repr.t list; + endorsers_per_block : int; + hard_gas_limit_per_operation : Z.t; + hard_gas_limit_per_block : Z.t; + proof_of_work_threshold : int64; + tokens_per_roll : Tez_repr.t; + michelson_maximum_type_size : int; + seed_nonce_revelation_tip : Tez_repr.t; + origination_size : int; + block_security_deposit : Tez_repr.t; + endorsement_security_deposit : Tez_repr.t; + baking_reward_per_endorsement : Tez_repr.t list; + endorsement_reward : Tez_repr.t list; + cost_per_byte : Tez_repr.t; + hard_storage_limit_per_operation : Z.t; + test_chain_duration : int64; + (* in seconds *) + quorum_min : int32; + quorum_max : int32; + min_proposal_quorum : int32; + initial_endorsers : int; + delay_per_missing_endorsement : Period_repr.t; } let parametric_encoding = let open Data_encoding in conv (fun c -> - (( c.preserved_cycles, + ( ( c.preserved_cycles, c.blocks_per_cycle, c.blocks_per_commitment, c.blocks_per_roll_snapshot, @@ -115,78 +124,78 @@ let parametric_encoding = c.time_between_blocks, c.endorsers_per_block, c.hard_gas_limit_per_operation, - c.hard_gas_limit_per_block), - ((c.proof_of_work_threshold, - c.tokens_per_roll, - c.michelson_maximum_type_size, - c.seed_nonce_revelation_tip, - c.origination_size, - c.block_security_deposit, - c.endorsement_security_deposit, - c.block_reward), - (c.endorsement_reward, - c.cost_per_byte, - c.hard_storage_limit_per_operation, - c.test_chain_duration, - c.quorum_min, - c.quorum_max, - c.min_proposal_quorum, - c.initial_endorsers, - c.delay_per_missing_endorsement - ))) ) - (fun (( preserved_cycles, - blocks_per_cycle, - blocks_per_commitment, - blocks_per_roll_snapshot, - blocks_per_voting_period, - time_between_blocks, - endorsers_per_block, - hard_gas_limit_per_operation, - hard_gas_limit_per_block), - ((proof_of_work_threshold, - tokens_per_roll, - michelson_maximum_type_size, - seed_nonce_revelation_tip, - origination_size, - block_security_deposit, - endorsement_security_deposit, - block_reward), - (endorsement_reward, - cost_per_byte, - hard_storage_limit_per_operation, - test_chain_duration, - quorum_min, - quorum_max, - min_proposal_quorum, - initial_endorsers, - delay_per_missing_endorsement))) -> - { preserved_cycles ; - blocks_per_cycle ; - blocks_per_commitment ; - blocks_per_roll_snapshot ; - blocks_per_voting_period ; - time_between_blocks ; - endorsers_per_block ; - hard_gas_limit_per_operation ; - hard_gas_limit_per_block ; - proof_of_work_threshold ; - tokens_per_roll ; - michelson_maximum_type_size ; - seed_nonce_revelation_tip ; - origination_size ; - block_security_deposit ; - endorsement_security_deposit ; - block_reward ; - endorsement_reward ; - cost_per_byte ; - hard_storage_limit_per_operation ; - test_chain_duration ; - quorum_min ; - quorum_max ; - min_proposal_quorum ; - initial_endorsers ; - delay_per_missing_endorsement ; - } ) + c.hard_gas_limit_per_block ), + ( ( c.proof_of_work_threshold, + c.tokens_per_roll, + c.michelson_maximum_type_size, + c.seed_nonce_revelation_tip, + c.origination_size, + c.block_security_deposit, + c.endorsement_security_deposit, + c.baking_reward_per_endorsement ), + ( c.endorsement_reward, + c.cost_per_byte, + c.hard_storage_limit_per_operation, + c.test_chain_duration, + c.quorum_min, + c.quorum_max, + c.min_proposal_quorum, + c.initial_endorsers, + c.delay_per_missing_endorsement ) ) )) + (fun ( ( preserved_cycles, + blocks_per_cycle, + blocks_per_commitment, + blocks_per_roll_snapshot, + blocks_per_voting_period, + time_between_blocks, + endorsers_per_block, + hard_gas_limit_per_operation, + hard_gas_limit_per_block ), + ( ( proof_of_work_threshold, + tokens_per_roll, + michelson_maximum_type_size, + seed_nonce_revelation_tip, + origination_size, + block_security_deposit, + endorsement_security_deposit, + baking_reward_per_endorsement ), + ( endorsement_reward, + cost_per_byte, + hard_storage_limit_per_operation, + test_chain_duration, + quorum_min, + quorum_max, + min_proposal_quorum, + initial_endorsers, + delay_per_missing_endorsement ) ) ) -> + { + preserved_cycles; + blocks_per_cycle; + blocks_per_commitment; + blocks_per_roll_snapshot; + blocks_per_voting_period; + time_between_blocks; + endorsers_per_block; + hard_gas_limit_per_operation; + hard_gas_limit_per_block; + proof_of_work_threshold; + tokens_per_roll; + michelson_maximum_type_size; + seed_nonce_revelation_tip; + origination_size; + block_security_deposit; + endorsement_security_deposit; + baking_reward_per_endorsement; + endorsement_reward; + cost_per_byte; + hard_storage_limit_per_operation; + test_chain_duration; + quorum_min; + quorum_max; + min_proposal_quorum; + initial_endorsers; + delay_per_missing_endorsement; + }) (merge_objs (obj9 (req "preserved_cycles" uint8) @@ -207,9 +216,9 @@ let parametric_encoding = (req "origination_size" int31) (req "block_security_deposit" Tez_repr.encoding) (req "endorsement_security_deposit" Tez_repr.encoding) - (req "block_reward" Tez_repr.encoding)) + (req "baking_reward_per_endorsement" (list Tez_repr.encoding))) (obj9 - (req "endorsement_reward" Tez_repr.encoding) + (req "endorsement_reward" (list Tez_repr.encoding)) (req "cost_per_byte" Tez_repr.encoding) (req "hard_storage_limit_per_operation" z) (req "test_chain_duration" int64) @@ -217,17 +226,161 @@ let parametric_encoding = (req "quorum_max" int32) (req "min_proposal_quorum" int32) (req "initial_endorsers" uint16) - (req "delay_per_missing_endorsement" Period_repr.encoding) - ))) + (req "delay_per_missing_endorsement" Period_repr.encoding)))) -type t = { - fixed : fixed ; - parametric : parametric ; -} +type t = {fixed : fixed; parametric : parametric} let encoding = let open Data_encoding in conv - (fun { fixed ; parametric } -> (fixed, parametric)) - (fun (fixed , parametric) -> { fixed ; parametric }) + (fun {fixed; parametric} -> (fixed, parametric)) + (fun (fixed, parametric) -> {fixed; parametric}) (merge_objs fixed_encoding parametric_encoding) + +module Proto_005 = struct + type parametric = { + preserved_cycles : int; + blocks_per_cycle : int32; + blocks_per_commitment : int32; + blocks_per_roll_snapshot : int32; + blocks_per_voting_period : int32; + time_between_blocks : Period_repr.t list; + endorsers_per_block : int; + hard_gas_limit_per_operation : Z.t; + hard_gas_limit_per_block : Z.t; + proof_of_work_threshold : int64; + tokens_per_roll : Tez_repr.t; + michelson_maximum_type_size : int; + seed_nonce_revelation_tip : Tez_repr.t; + origination_size : int; + block_security_deposit : Tez_repr.t; + endorsement_security_deposit : Tez_repr.t; + block_reward : Tez_repr.t; + endorsement_reward : Tez_repr.t; + cost_per_byte : Tez_repr.t; + hard_storage_limit_per_operation : Z.t; + test_chain_duration : int64; + (* in seconds *) + quorum_min : int32; + quorum_max : int32; + min_proposal_quorum : int32; + initial_endorsers : int; + delay_per_missing_endorsement : Period_repr.t; + } + + let parametric_encoding = + let open Data_encoding in + conv + (fun c -> + ( ( c.preserved_cycles, + c.blocks_per_cycle, + c.blocks_per_commitment, + c.blocks_per_roll_snapshot, + c.blocks_per_voting_period, + c.time_between_blocks, + c.endorsers_per_block, + c.hard_gas_limit_per_operation, + c.hard_gas_limit_per_block ), + ( ( c.proof_of_work_threshold, + c.tokens_per_roll, + c.michelson_maximum_type_size, + c.seed_nonce_revelation_tip, + c.origination_size, + c.block_security_deposit, + c.endorsement_security_deposit, + c.block_reward ), + ( c.endorsement_reward, + c.cost_per_byte, + c.hard_storage_limit_per_operation, + c.test_chain_duration, + c.quorum_min, + c.quorum_max, + c.min_proposal_quorum, + c.initial_endorsers, + c.delay_per_missing_endorsement ) ) )) + (fun ( ( preserved_cycles, + blocks_per_cycle, + blocks_per_commitment, + blocks_per_roll_snapshot, + blocks_per_voting_period, + time_between_blocks, + endorsers_per_block, + hard_gas_limit_per_operation, + hard_gas_limit_per_block ), + ( ( proof_of_work_threshold, + tokens_per_roll, + michelson_maximum_type_size, + seed_nonce_revelation_tip, + origination_size, + block_security_deposit, + endorsement_security_deposit, + block_reward ), + ( endorsement_reward, + cost_per_byte, + hard_storage_limit_per_operation, + test_chain_duration, + quorum_min, + quorum_max, + min_proposal_quorum, + initial_endorsers, + delay_per_missing_endorsement ) ) ) -> + { + preserved_cycles; + blocks_per_cycle; + blocks_per_commitment; + blocks_per_roll_snapshot; + blocks_per_voting_period; + time_between_blocks; + endorsers_per_block; + hard_gas_limit_per_operation; + hard_gas_limit_per_block; + proof_of_work_threshold; + tokens_per_roll; + michelson_maximum_type_size; + seed_nonce_revelation_tip; + origination_size; + block_security_deposit; + endorsement_security_deposit; + block_reward; + endorsement_reward; + cost_per_byte; + hard_storage_limit_per_operation; + test_chain_duration; + quorum_min; + quorum_max; + min_proposal_quorum; + initial_endorsers; + delay_per_missing_endorsement; + }) + (merge_objs + (obj9 + (req "preserved_cycles" uint8) + (req "blocks_per_cycle" int32) + (req "blocks_per_commitment" int32) + (req "blocks_per_roll_snapshot" int32) + (req "blocks_per_voting_period" int32) + (req "time_between_blocks" (list Period_repr.encoding)) + (req "endorsers_per_block" uint16) + (req "hard_gas_limit_per_operation" z) + (req "hard_gas_limit_per_block" z)) + (merge_objs + (obj8 + (req "proof_of_work_threshold" int64) + (req "tokens_per_roll" Tez_repr.encoding) + (req "michelson_maximum_type_size" uint16) + (req "seed_nonce_revelation_tip" Tez_repr.encoding) + (req "origination_size" int31) + (req "block_security_deposit" Tez_repr.encoding) + (req "endorsement_security_deposit" Tez_repr.encoding) + (req "block_reward" Tez_repr.encoding)) + (obj9 + (req "endorsement_reward" Tez_repr.encoding) + (req "cost_per_byte" Tez_repr.encoding) + (req "hard_storage_limit_per_operation" z) + (req "test_chain_duration" int64) + (req "quorum_min" int32) + (req "quorum_max" int32) + (req "min_proposal_quorum" int32) + (req "initial_endorsers" uint16) + (req "delay_per_missing_endorsement" Period_repr.encoding)))) +end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml index 8e07c7a87..f2b92f91c 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_services.ml @@ -26,40 +26,35 @@ open Alpha_context let custom_root = - (RPC_path.(open_root / "context" / "constants") : RPC_context.t RPC_path.context) + ( RPC_path.(open_root / "context" / "constants") + : RPC_context.t RPC_path.context ) module S = struct - open Data_encoding let errors = RPC_service.get_service - ~description: "Schema for all the RPC errors from this protocol version" - ~query: RPC_query.empty - ~output: json_schema + ~description:"Schema for all the RPC errors from this protocol version" + ~query:RPC_query.empty + ~output:json_schema RPC_path.(custom_root / "errors") let all = RPC_service.get_service - ~description: "All constants" - ~query: RPC_query.empty - ~output: Alpha_context.Constants.encoding + ~description:"All constants" + ~query:RPC_query.empty + ~output:Alpha_context.Constants.encoding custom_root - end let register () = let open Services_registration in - register0_noctxt S.errors begin fun () () -> - return (Data_encoding.Json.(schema error_encoding)) - end ; - register0 S.all begin fun ctxt () () -> - let open Constants in - return { fixed = fixed ; - parametric = parametric ctxt } - end + register0_noctxt S.errors (fun () () -> + return Data_encoding.Json.(schema error_encoding)) ; + register0 S.all (fun ctxt () () -> + let open Constants in + return {fixed; parametric = parametric ctxt}) -let errors ctxt block = - RPC_context.make_call0 S.errors ctxt block () () -let all ctxt block = - RPC_context.make_call0 S.all ctxt block () () +let errors ctxt block = RPC_context.make_call0 S.errors ctxt block () () + +let all ctxt block = RPC_context.make_call0 S.all ctxt block () () diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli index 5234cd843..243adcb1d 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_services.mli @@ -25,11 +25,12 @@ open Alpha_context -val errors: - 'a #RPC_context.simple -> 'a -> Data_encoding.json_schema shell_tzresult Lwt.t +val errors : + 'a #RPC_context.simple -> + 'a -> + Data_encoding.json_schema shell_tzresult Lwt.t (** Returns all the constants of the protocol *) -val all: - 'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t +val all : 'a #RPC_context.simple -> 'a -> Constants.t shell_tzresult Lwt.t -val register: unit -> unit +val register : unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml index c6b1dfd2a..65a1cc81d 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/constants_storage.ml @@ -26,80 +26,105 @@ let preserved_cycles c = let constants = Raw_context.constants c in constants.preserved_cycles + let blocks_per_cycle c = let constants = Raw_context.constants c in constants.blocks_per_cycle + let blocks_per_commitment c = let constants = Raw_context.constants c in constants.blocks_per_commitment + let blocks_per_roll_snapshot c = let constants = Raw_context.constants c in constants.blocks_per_roll_snapshot + let blocks_per_voting_period c = let constants = Raw_context.constants c in constants.blocks_per_voting_period + let time_between_blocks c = let constants = Raw_context.constants c in constants.time_between_blocks + let endorsers_per_block c = let constants = Raw_context.constants c in constants.endorsers_per_block + let initial_endorsers c = let constants = Raw_context.constants c in constants.initial_endorsers + let delay_per_missing_endorsement c = let constants = Raw_context.constants c in constants.delay_per_missing_endorsement + let hard_gas_limit_per_operation c = let constants = Raw_context.constants c in constants.hard_gas_limit_per_operation + let hard_gas_limit_per_block c = let constants = Raw_context.constants c in constants.hard_gas_limit_per_block + let cost_per_byte c = let constants = Raw_context.constants c in constants.cost_per_byte + let hard_storage_limit_per_operation c = let constants = Raw_context.constants c in constants.hard_storage_limit_per_operation + let proof_of_work_threshold c = let constants = Raw_context.constants c in constants.proof_of_work_threshold + let tokens_per_roll c = let constants = Raw_context.constants c in constants.tokens_per_roll + let michelson_maximum_type_size c = let constants = Raw_context.constants c in constants.michelson_maximum_type_size + let seed_nonce_revelation_tip c = let constants = Raw_context.constants c in constants.seed_nonce_revelation_tip + let origination_size c = let constants = Raw_context.constants c in constants.origination_size + let block_security_deposit c = let constants = Raw_context.constants c in constants.block_security_deposit + let endorsement_security_deposit c = let constants = Raw_context.constants c in constants.endorsement_security_deposit -let block_reward c = + +let baking_reward_per_endorsement c = let constants = Raw_context.constants c in - constants.block_reward + constants.baking_reward_per_endorsement + let endorsement_reward c = let constants = Raw_context.constants c in constants.endorsement_reward + let test_chain_duration c = let constants = Raw_context.constants c in constants.test_chain_duration + let quorum_min c = let constants = Raw_context.constants c in constants.quorum_min + let quorum_max c = let constants = Raw_context.constants c in constants.quorum_max + let min_proposal_quorum c = let constants = Raw_context.constants c in constants.min_proposal_quorum -let parametric c = - Raw_context.constants c + +let parametric c = Raw_context.constants c diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml index 74b2bbf54..40d94808d 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_hash.ml @@ -26,12 +26,16 @@ (* 20 *) let contract_hash = "\002\090\121" (* KT1(36) *) -include Blake2B.Make(Base58)(struct - let name = "Contract_hash" - let title = "A contract ID" - let b58check_prefix = contract_hash - let size = Some 20 - end) +include Blake2B.Make + (Base58) + (struct + let name = "Contract_hash" -let () = - Base58.check_encoded_prefix b58check_encoding "KT1" 36 + let title = "A contract ID" + + let b58check_prefix = contract_hash + + let size = Some 20 + end) + +let () = Base58.check_encoded_prefix b58check_encoding "KT1" 36 diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml index 89632c77a..f286a1bae 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.ml @@ -27,80 +27,98 @@ type t = | Implicit of Signature.Public_key_hash.t | Originated of Contract_hash.t -include Compare.Make(struct - type nonrec t = t - let compare l1 l2 = - match l1, l2 with - | Implicit pkh1, Implicit pkh2 -> - Signature.Public_key_hash.compare pkh1 pkh2 - | Originated h1, Originated h2 -> - Contract_hash.compare h1 h2 - | Implicit _, Originated _ -> -1 - | Originated _, Implicit _ -> 1 - end) +include Compare.Make (struct + type nonrec t = t + + let compare l1 l2 = + match (l1, l2) with + | (Implicit pkh1, Implicit pkh2) -> + Signature.Public_key_hash.compare pkh1 pkh2 + | (Originated h1, Originated h2) -> + Contract_hash.compare h1 h2 + | (Implicit _, Originated _) -> + -1 + | (Originated _, Implicit _) -> + 1 +end) type contract = t type error += Invalid_contract_notation of string (* `Permanent *) let to_b58check = function - | Implicit pbk -> Signature.Public_key_hash.to_b58check pbk - | Originated h -> Contract_hash.to_b58check h + | Implicit pbk -> + Signature.Public_key_hash.to_b58check pbk + | Originated h -> + Contract_hash.to_b58check h let of_b58check s = match Base58.decode s with - | Some (Ed25519.Public_key_hash.Data h) -> ok (Implicit (Signature.Ed25519 h)) - | Some (Secp256k1.Public_key_hash.Data h) -> ok (Implicit (Signature.Secp256k1 h)) - | Some (P256.Public_key_hash.Data h) -> ok (Implicit (Signature.P256 h)) - | Some (Contract_hash.Data h) -> ok (Originated h) - | _ -> error (Invalid_contract_notation s) + | Some (Ed25519.Public_key_hash.Data h) -> + ok (Implicit (Signature.Ed25519 h)) + | Some (Secp256k1.Public_key_hash.Data h) -> + ok (Implicit (Signature.Secp256k1 h)) + | Some (P256.Public_key_hash.Data h) -> + ok (Implicit (Signature.P256 h)) + | Some (Contract_hash.Data h) -> + ok (Originated h) + | _ -> + error (Invalid_contract_notation s) let pp ppf = function - | Implicit pbk -> Signature.Public_key_hash.pp ppf pbk - | Originated h -> Contract_hash.pp ppf h + | Implicit pbk -> + Signature.Public_key_hash.pp ppf pbk + | Originated h -> + Contract_hash.pp ppf h let pp_short ppf = function - | Implicit pbk -> Signature.Public_key_hash.pp_short ppf pbk - | Originated h -> Contract_hash.pp_short ppf h + | Implicit pbk -> + Signature.Public_key_hash.pp_short ppf pbk + | Originated h -> + Contract_hash.pp_short ppf h let encoding = let open Data_encoding in - def "contract_id" - ~title: - "A contract handle" + def + "contract_id" + ~title:"A contract handle" ~description: - "A contract notation as given to an RPC or inside scripts. \ - Can be a base58 implicit contract hash \ - or a base58 originated contract hash." @@ - splitted - ~binary: - (union ~tag_size:`Uint8 [ - case (Tag 0) - ~title:"Implicit" - Signature.Public_key_hash.encoding - (function Implicit k -> Some k | _ -> None) - (fun k -> Implicit k) ; - case (Tag 1) (Fixed.add_padding Contract_hash.encoding 1) - ~title:"Originated" - (function Originated k -> Some k | _ -> None) - (fun k -> Originated k) ; - ]) - ~json: - (conv - to_b58check - (fun s -> - match of_b58check s with - | Ok s -> s - | Error _ -> Json.cannot_destruct "Invalid contract notation.") - string) + "A contract notation as given to an RPC or inside scripts. Can be a \ + base58 implicit contract hash or a base58 originated contract hash." + @@ splitted + ~binary: + (union + ~tag_size:`Uint8 + [ case + (Tag 0) + ~title:"Implicit" + Signature.Public_key_hash.encoding + (function Implicit k -> Some k | _ -> None) + (fun k -> Implicit k); + case + (Tag 1) + (Fixed.add_padding Contract_hash.encoding 1) + ~title:"Originated" + (function Originated k -> Some k | _ -> None) + (fun k -> Originated k) ]) + ~json: + (conv + to_b58check + (fun s -> + match of_b58check s with + | Ok s -> + s + | Error _ -> + Json.cannot_destruct "Invalid contract notation.") + string) let () = let open Data_encoding in register_error_kind `Permanent ~id:"contract.invalid_contract_notation" - ~title: "Invalid contract notation" - ~pp: (fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x) + ~title:"Invalid contract notation" + ~pp:(fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x) ~description: "A malformed contract notation was given to an RPC or in a script." (obj1 (req "notation" string)) @@ -109,106 +127,104 @@ let () = let implicit_contract id = Implicit id -let originated_contract_004 id = Originated id +let is_implicit = function Implicit m -> Some m | Originated _ -> None -let is_implicit = function - | Implicit m -> Some m - | Originated _ -> None +let is_originated = function Implicit _ -> None | Originated h -> Some h -let is_originated = function - | Implicit _ -> None - | Originated h -> Some h - -type origination_nonce = - { operation_hash: Operation_hash.t ; - origination_index: int32 } +type origination_nonce = { + operation_hash : Operation_hash.t; + origination_index : int32; +} let origination_nonce_encoding = let open Data_encoding in conv - (fun { operation_hash ; origination_index } -> - (operation_hash, origination_index)) + (fun {operation_hash; origination_index} -> + (operation_hash, origination_index)) (fun (operation_hash, origination_index) -> - { operation_hash ; origination_index }) @@ - obj2 - (req "operation" Operation_hash.encoding) - (dft "index" int32 0l) + {operation_hash; origination_index}) + @@ obj2 (req "operation" Operation_hash.encoding) (dft "index" int32 0l) let originated_contract nonce = let data = - Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce in + Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce + in Originated (Contract_hash.hash_bytes [data]) let originated_contracts - ~since: { origination_index = first ; operation_hash = first_hash } - ~until: ({ origination_index = last ; operation_hash = last_hash } as origination_nonce) = + ~since:{origination_index = first; operation_hash = first_hash} + ~until:( {origination_index = last; operation_hash = last_hash} as + origination_nonce ) = assert (Operation_hash.equal first_hash last_hash) ; let rec contracts acc origination_index = - if Compare.Int32.(origination_index < first) then - acc + if Compare.Int32.(origination_index < first) then acc else - let origination_nonce = - { origination_nonce with origination_index } in + let origination_nonce = {origination_nonce with origination_index} in let acc = originated_contract origination_nonce :: acc in - contracts acc (Int32.pred origination_index) in + contracts acc (Int32.pred origination_index) + in contracts [] (Int32.pred last) let initial_origination_nonce operation_hash = - { operation_hash ; origination_index = 0l } + {operation_hash; origination_index = 0l} let incr_origination_nonce nonce = let origination_index = Int32.succ nonce.origination_index in - { nonce with origination_index } + {nonce with origination_index} let rpc_arg = let construct = to_b58check in let destruct hash = match of_b58check hash with - | Error _ -> Error "Cannot parse contract id" - | Ok contract -> Ok contract in + | Error _ -> + Error "Cannot parse contract id" + | Ok contract -> + Ok contract + in RPC_arg.make - ~descr: "A contract identifier encoded in b58check." - ~name: "contract_id" + ~descr:"A contract identifier encoded in b58check." + ~name:"contract_id" ~construct ~destruct () module Index = struct - type t = contract let path_length = 7 let to_path c l = let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in - let `Hex key = MBytes.to_hex raw_key in - let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in - String.sub index_key 0 2 :: - String.sub index_key 2 2 :: - String.sub index_key 4 2 :: - String.sub index_key 6 2 :: - String.sub index_key 8 2 :: - String.sub index_key 10 2 :: - key :: - l + let (`Hex key) = MBytes.to_hex raw_key in + let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + String.sub index_key 0 2 :: String.sub index_key 2 2 + :: String.sub index_key 4 2 :: String.sub index_key 6 2 + :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: key :: l let of_path = function - | [] | [_] | [_;_] | [_;_;_] | [_;_;_;_] | [_;_;_;_;_] | [_;_;_;_;_;_] - | _::_::_::_::_::_::_::_::_ -> + | [] + | [_] + | [_; _] + | [_; _; _] + | [_; _; _; _] + | [_; _; _; _; _] + | [_; _; _; _; _; _] + | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ -> None - | [ index1 ; index2 ; index3 ; index4 ; index5 ; index6 ; key ] -> + | [index1; index2; index3; index4; index5; index6; key] -> let raw_key = MBytes.of_hex (`Hex key) in - let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in - assert Compare.String.(String.sub index_key 0 2 = index1) ; - assert Compare.String.(String.sub index_key 2 2 = index2) ; - assert Compare.String.(String.sub index_key 4 2 = index3) ; - assert Compare.String.(String.sub index_key 6 2 = index4) ; - assert Compare.String.(String.sub index_key 8 2 = index5) ; - assert Compare.String.(String.sub index_key 10 2 = index6) ; + let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + assert (Compare.String.(String.sub index_key 0 2 = index1)) ; + assert (Compare.String.(String.sub index_key 2 2 = index2)) ; + assert (Compare.String.(String.sub index_key 4 2 = index3)) ; + assert (Compare.String.(String.sub index_key 6 2 = index4)) ; + assert (Compare.String.(String.sub index_key 8 2 = index5)) ; + assert (Compare.String.(String.sub index_key 10 2 = index6)) ; Data_encoding.Binary.of_bytes encoding raw_key let rpc_arg = rpc_arg - let encoding = encoding - let compare = compare + let encoding = encoding + + let compare = compare end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli index 37f5503f6..53935e460 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_repr.mli @@ -26,6 +26,7 @@ type t = private | Implicit of Signature.Public_key_hash.t | Originated of Contract_hash.t + type contract = t include Compare.S with type t := contract @@ -34,9 +35,6 @@ include Compare.S with type t := contract val implicit_contract : Signature.Public_key_hash.t -> contract -(** Only for migration from proto_004 *) -val originated_contract_004 : Contract_hash.t -> contract - val is_implicit : contract -> Signature.Public_key_hash.t option (** {2 Originated contracts} *) @@ -50,7 +48,8 @@ type origination_nonce val originated_contract : origination_nonce -> contract -val originated_contracts : since: origination_nonce -> until: origination_nonce -> contract list +val originated_contracts : + since:origination_nonce -> until:origination_nonce -> contract list val initial_origination_nonce : Operation_hash.t -> origination_nonce @@ -58,18 +57,17 @@ val incr_origination_nonce : origination_nonce -> origination_nonce val is_originated : contract -> Contract_hash.t option - (** {2 Human readable notation} *) type error += Invalid_contract_notation of string (* `Permanent *) -val to_b58check: contract -> string +val to_b58check : contract -> string -val of_b58check: string -> contract tzresult +val of_b58check : string -> contract tzresult -val pp: Format.formatter -> contract -> unit +val pp : Format.formatter -> contract -> unit -val pp_short: Format.formatter -> contract -> unit +val pp_short : Format.formatter -> contract -> unit (** {2 Serializers} *) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml index 5d57e0174..b350c9089 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.ml @@ -26,282 +26,349 @@ open Alpha_context let custom_root = - (RPC_path.(open_root / "context" / "contracts") : RPC_context.t RPC_path.context) + ( RPC_path.(open_root / "context" / "contracts") + : RPC_context.t RPC_path.context ) let big_map_root = - (RPC_path.(open_root / "context" / "big_maps") : RPC_context.t RPC_path.context) + ( RPC_path.(open_root / "context" / "big_maps") + : RPC_context.t RPC_path.context ) type info = { - balance: Tez.t ; - delegate: public_key_hash option ; - counter: counter option ; - script: Script.t option ; + balance : Tez.t; + delegate : public_key_hash option; + counter : counter option; + script : Script.t option; } let info_encoding = let open Data_encoding in conv - (fun {balance ; delegate ; script ; counter } -> + (fun {balance; delegate; script; counter} -> (balance, delegate, script, counter)) (fun (balance, delegate, script, counter) -> - {balance ; delegate ; script ; counter}) @@ - obj4 - (req "balance" Tez.encoding) - (opt "delegate" Signature.Public_key_hash.encoding) - (opt "script" Script.encoding) - (opt "counter" n) + {balance; delegate; script; counter}) + @@ obj4 + (req "balance" Tez.encoding) + (opt "delegate" Signature.Public_key_hash.encoding) + (opt "script" Script.encoding) + (opt "counter" n) module S = struct - open Data_encoding let balance = RPC_service.get_service - ~description: "Access the balance of a contract." - ~query: RPC_query.empty - ~output: Tez.encoding + ~description:"Access the balance of a contract." + ~query:RPC_query.empty + ~output:Tez.encoding RPC_path.(custom_root /: Contract.rpc_arg / "balance") let manager_key = RPC_service.get_service - ~description: "Access the manager of a contract." - ~query: RPC_query.empty - ~output: (option Signature.Public_key.encoding) + ~description:"Access the manager of a contract." + ~query:RPC_query.empty + ~output:(option Signature.Public_key.encoding) RPC_path.(custom_root /: Contract.rpc_arg / "manager_key") let delegate = RPC_service.get_service - ~description: "Access the delegate of a contract, if any." - ~query: RPC_query.empty - ~output: Signature.Public_key_hash.encoding + ~description:"Access the delegate of a contract, if any." + ~query:RPC_query.empty + ~output:Signature.Public_key_hash.encoding RPC_path.(custom_root /: Contract.rpc_arg / "delegate") let counter = RPC_service.get_service - ~description: "Access the counter of a contract, if any." - ~query: RPC_query.empty - ~output: z + ~description:"Access the counter of a contract, if any." + ~query:RPC_query.empty + ~output:z RPC_path.(custom_root /: Contract.rpc_arg / "counter") let script = RPC_service.get_service - ~description: "Access the code and data of the contract." - ~query: RPC_query.empty - ~output: Script.encoding + ~description:"Access the code and data of the contract." + ~query:RPC_query.empty + ~output:Script.encoding RPC_path.(custom_root /: Contract.rpc_arg / "script") let storage = RPC_service.get_service - ~description: "Access the data of the contract." - ~query: RPC_query.empty - ~output: Script.expr_encoding + ~description:"Access the data of the contract." + ~query:RPC_query.empty + ~output:Script.expr_encoding RPC_path.(custom_root /: Contract.rpc_arg / "storage") let entrypoint_type = RPC_service.get_service - ~description: "Return the type of the given entrypoint of the contract" - ~query: RPC_query.empty - ~output: Script.expr_encoding - RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string) - + ~description:"Return the type of the given entrypoint of the contract" + ~query:RPC_query.empty + ~output:Script.expr_encoding + RPC_path.( + custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string) let list_entrypoints = RPC_service.get_service - ~description: "Return the list of entrypoints of the contract" - ~query: RPC_query.empty - ~output: (obj2 - (dft "unreachable" - (Data_encoding.list - (obj1 (req "path" (Data_encoding.list Michelson_v1_primitives.prim_encoding)))) - []) - (req "entrypoints" - (assoc Script.expr_encoding))) + ~description:"Return the list of entrypoints of the contract" + ~query:RPC_query.empty + ~output: + (obj2 + (dft + "unreachable" + (Data_encoding.list + (obj1 + (req + "path" + (Data_encoding.list + Michelson_v1_primitives.prim_encoding)))) + []) + (req "entrypoints" (assoc Script.expr_encoding))) RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints") let contract_big_map_get_opt = - RPC_service.post_service - ~description: "Access the value associated with a key in a big map of the contract (deprecated)." - ~query: RPC_query.empty - ~input: (obj2 - (req "key" Script.expr_encoding) - (req "type" Script.expr_encoding)) - ~output: (option Script.expr_encoding) - RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get") + RPC_service.post_service + ~description: + "Access the value associated with a key in a big map of the contract \ + (deprecated)." + ~query:RPC_query.empty + ~input: + (obj2 + (req "key" Script.expr_encoding) + (req "type" Script.expr_encoding)) + ~output:(option Script.expr_encoding) + RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get") let big_map_get = RPC_service.get_service - ~description: "Access the value associated with a key in a big map." - ~query: RPC_query.empty - ~output: Script.expr_encoding + ~description:"Access the value associated with a key in a big map." + ~query:RPC_query.empty + ~output:Script.expr_encoding RPC_path.(big_map_root /: Big_map.rpc_arg /: Script_expr_hash.rpc_arg) let info = RPC_service.get_service - ~description: "Access the complete status of a contract." - ~query: RPC_query.empty - ~output: info_encoding + ~description:"Access the complete status of a contract." + ~query:RPC_query.empty + ~output:info_encoding RPC_path.(custom_root /: Contract.rpc_arg) let list = RPC_service.get_service ~description: "All existing contracts (including non-empty default contracts)." - ~query: RPC_query.empty - ~output: (list Contract.encoding) + ~query:RPC_query.empty + ~output:(list Contract.encoding) custom_root - end let register () = let open Services_registration in - register0 S.list begin fun ctxt () () -> - Contract.list ctxt >>= return - end ; + register0 S.list (fun ctxt () () -> Contract.list ctxt >>= return) ; let register_field s f = register1 s (fun ctxt contract () () -> - Contract.exists ctxt contract >>=? function - | true -> f ctxt contract - | false -> raise Not_found) in + Contract.exists ctxt contract + >>=? function true -> f ctxt contract | false -> raise Not_found) + in let register_opt_field s f = - register_field s - (fun ctxt a1 -> - f ctxt a1 >>=? function - | None -> raise Not_found - | Some v -> return v) in + register_field s (fun ctxt a1 -> + f ctxt a1 >>=? function None -> raise Not_found | Some v -> return v) + in let do_big_map_get ctxt id key = let open Script_ir_translator in let ctxt = Gas.set_unlimited ctxt in - Big_map.exists ctxt id >>=? fun (ctxt, types) -> + Big_map.exists ctxt id + >>=? fun (ctxt, types) -> match types with - | None -> raise Not_found - | Some (_, value_type) -> - Lwt.return (parse_ty ctxt - ~legacy:true ~allow_big_map:false ~allow_operation:false ~allow_contract:true - (Micheline.root value_type)) + | None -> + raise Not_found + | Some (_, value_type) -> ( + Lwt.return + (parse_ty + ctxt + ~legacy:true + ~allow_big_map:false + ~allow_operation:false + ~allow_contract:true + (Micheline.root value_type)) >>=? fun (Ex_ty value_type, ctxt) -> - Big_map.get_opt ctxt id key >>=? fun (_ctxt, value) -> + Big_map.get_opt ctxt id key + >>=? fun (_ctxt, value) -> match value with - | None -> raise Not_found + | None -> + raise Not_found | Some value -> - parse_data ctxt ~legacy:true value_type (Micheline.root value) >>=? fun (value, ctxt) -> - unparse_data ctxt Readable value_type value >>=? fun (value, _ctxt) -> - return (Micheline.strip_locations value) in + parse_data ctxt ~legacy:true value_type (Micheline.root value) + >>=? fun (value, ctxt) -> + unparse_data ctxt Readable value_type value + >>=? fun (value, _ctxt) -> return (Micheline.strip_locations value) + ) + in register_field S.balance Contract.get_balance ; - register1 S.manager_key - (fun ctxt contract () () -> - match Contract.is_implicit contract with - | None -> raise Not_found - | Some mgr -> - Contract.is_manager_key_revealed ctxt mgr >>=? function - | false -> return_none - | true -> Contract.get_manager_key ctxt mgr >>=? return_some) ; + register1 S.manager_key (fun ctxt contract () () -> + match Contract.is_implicit contract with + | None -> + raise Not_found + | Some mgr -> ( + Contract.is_manager_key_revealed ctxt mgr + >>=? function + | false -> + return_none + | true -> + Contract.get_manager_key ctxt mgr >>=? return_some )) ; register_opt_field S.delegate Delegate.get ; - register1 S.counter - (fun ctxt contract () () -> - match Contract.is_implicit contract with - | None -> raise Not_found - | Some mgr -> Contract.get_counter ctxt mgr) ; - register_opt_field S.script - (fun c v -> Contract.get_script c v >>=? fun (_, v) -> return v) ; + register1 S.counter (fun ctxt contract () () -> + match Contract.is_implicit contract with + | None -> + raise Not_found + | Some mgr -> + Contract.get_counter ctxt mgr) ; + register_opt_field S.script (fun c v -> + Contract.get_script c v >>=? fun (_, v) -> return v) ; register_opt_field S.storage (fun ctxt contract -> - Contract.get_script ctxt contract >>=? fun (ctxt, script) -> + Contract.get_script ctxt contract + >>=? fun (ctxt, script) -> match script with - | None -> return_none + | None -> + return_none | Some script -> let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in - parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) -> - unparse_script ctxt Readable script >>=? fun (script, ctxt) -> - Script.force_decode ctxt script.storage >>=? fun (storage, _ctxt) -> - return_some storage) ; - register2 S.entrypoint_type - (fun ctxt v entrypoint () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) -> + parse_script ctxt ~legacy:true script + >>=? fun (Ex_script script, ctxt) -> + unparse_script ctxt Readable script + >>=? fun (script, ctxt) -> + Script.force_decode ctxt script.storage + >>=? fun (storage, _ctxt) -> return_some storage) ; + register2 S.entrypoint_type (fun ctxt v entrypoint () () -> + Contract.get_script_code ctxt v + >>=? fun (_, expr) -> match expr with - | None -> raise Not_found - | Some expr -> + | None -> + raise Not_found + | Some expr -> ( let ctxt = Gas.set_unlimited ctxt in let legacy = true in let open Script_ir_translator in - Script.force_decode ctxt expr >>=? fun (expr, _) -> + Script.force_decode ctxt expr + >>=? fun (expr, _) -> Lwt.return - begin - parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> - parse_ty ctxt ~legacy - ~allow_big_map:true ~allow_operation:false - ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> - Script_ir_translator.find_entrypoint ~root_name arg_type - entrypoint - end >>= function - Ok (_f , Ex_ty ty)-> - unparse_ty ctxt ty >>=? fun (ty_node, _) -> + ( parse_toplevel ~legacy expr + >>? fun (arg_type, _, _, root_name) -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:false + ~allow_contract:true + arg_type + >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint + ) + >>= function + | Ok (_f, Ex_ty ty) -> + unparse_ty ctxt ty + >>=? fun (ty_node, _) -> return (Micheline.strip_locations ty_node) - | Error _ -> raise Not_found) ; - register1 S.list_entrypoints - (fun ctxt v () () -> Contract.get_script_code ctxt v >>=? fun (_, expr) -> + | Error _ -> + raise Not_found )) ; + register1 S.list_entrypoints (fun ctxt v () () -> + Contract.get_script_code ctxt v + >>=? fun (_, expr) -> match expr with - | None -> raise Not_found + | None -> + raise Not_found | Some expr -> let ctxt = Gas.set_unlimited ctxt in let legacy = true in let open Script_ir_translator in - Script.force_decode ctxt expr >>=? fun (expr, _) -> + Script.force_decode ctxt expr + >>=? fun (expr, _) -> Lwt.return - begin - parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> - parse_ty ctxt ~legacy - ~allow_big_map:true ~allow_operation:false - ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> - Script_ir_translator.list_entrypoints ~root_name arg_type ctxt - end >>=? fun (unreachable_entrypoint,map) -> + ( parse_toplevel ~legacy expr + >>? fun (arg_type, _, _, root_name) -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:false + ~allow_contract:true + arg_type + >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.list_entrypoints ~root_name arg_type ctxt ) + >>=? fun (unreachable_entrypoint, map) -> return - (unreachable_entrypoint, - Entrypoints_map.fold - begin fun entry (_,ty) acc -> - (entry , Micheline.strip_locations ty) ::acc end - map []) - ) ; + ( unreachable_entrypoint, + Entrypoints_map.fold + (fun entry (_, ty) acc -> + (entry, Micheline.strip_locations ty) :: acc) + map + [] )) ; register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) -> - Contract.get_script ctxt contract >>=? fun (ctxt, script) -> - Lwt.return (Script_ir_translator.parse_packable_ty ctxt ~legacy:true (Micheline.root key_type)) >>=? fun (Ex_ty key_type, ctxt) -> - Script_ir_translator.parse_data ctxt ~legacy:true key_type (Micheline.root key) >>=? fun (key, ctxt) -> - Script_ir_translator.hash_data ctxt key_type key >>=? fun (key, ctxt) -> + Contract.get_script ctxt contract + >>=? fun (ctxt, script) -> + Lwt.return + (Script_ir_translator.parse_packable_ty + ctxt + ~legacy:true + (Micheline.root key_type)) + >>=? fun (Ex_ty key_type, ctxt) -> + Script_ir_translator.parse_data + ctxt + ~legacy:true + key_type + (Micheline.root key) + >>=? fun (key, ctxt) -> + Script_ir_translator.hash_data ctxt key_type key + >>=? fun (key, ctxt) -> match script with - | None -> raise Not_found + | None -> + raise Not_found | Some script -> let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in - parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) -> - Script_ir_translator.collect_big_maps ctxt script.storage_type script.storage >>=? fun (ids, _ctxt) -> + parse_script ctxt ~legacy:true script + >>=? fun (Ex_script script, ctxt) -> + Script_ir_translator.collect_big_maps + ctxt + script.storage_type + script.storage + >>=? fun (ids, _ctxt) -> let ids = Script_ir_translator.list_of_big_map_ids ids in let rec find = function - | [] -> return_none - | (id : Z.t) :: ids -> try do_big_map_get ctxt id key >>=? return_some with Not_found -> find ids in + | [] -> + return_none + | (id : Z.t) :: ids -> ( + try do_big_map_get ctxt id key >>=? return_some + with Not_found -> find ids ) + in find ids) ; - register2 S.big_map_get (fun ctxt id key () () -> - do_big_map_get ctxt id key) ; + register2 S.big_map_get (fun ctxt id key () () -> do_big_map_get ctxt id key) ; register_field S.info (fun ctxt contract -> - Contract.get_balance ctxt contract >>=? fun balance -> - Delegate.get ctxt contract >>=? fun delegate -> - begin match Contract.is_implicit contract with - | Some manager -> - Contract.get_counter ctxt manager >>=? fun counter -> - return_some counter - | None -> return None - end >>=? fun counter -> - Contract.get_script ctxt contract >>=? fun (ctxt, script) -> - begin match script with - | None -> return (None, ctxt) - | Some script -> - let ctxt = Gas.set_unlimited ctxt in - let open Script_ir_translator in - parse_script ctxt ~legacy:true script >>=? fun (Ex_script script, ctxt) -> - unparse_script ctxt Readable script >>=? fun (script, ctxt) -> - return (Some script, ctxt) - end >>=? fun (script, _ctxt) -> - return { balance ; delegate ; script ; counter }) + Contract.get_balance ctxt contract + >>=? fun balance -> + Delegate.get ctxt contract + >>=? fun delegate -> + ( match Contract.is_implicit contract with + | Some manager -> + Contract.get_counter ctxt manager + >>=? fun counter -> return_some counter + | None -> + return None ) + >>=? fun counter -> + Contract.get_script ctxt contract + >>=? fun (ctxt, script) -> + ( match script with + | None -> + return (None, ctxt) + | Some script -> + let ctxt = Gas.set_unlimited ctxt in + let open Script_ir_translator in + parse_script ctxt ~legacy:true script + >>=? fun (Ex_script script, ctxt) -> + unparse_script ctxt Readable script + >>=? fun (script, ctxt) -> return (Some script, ctxt) ) + >>=? fun (script, _ctxt) -> return {balance; delegate; script; counter}) -let list ctxt block = - RPC_context.make_call0 S.list ctxt block () () +let list ctxt block = RPC_context.make_call0 S.list ctxt block () () let info ctxt block contract = RPC_context.make_call1 S.info ctxt block contract () () @@ -310,7 +377,13 @@ let balance ctxt block contract = RPC_context.make_call1 S.balance ctxt block contract () () let manager_key ctxt block mgr = - RPC_context.make_call1 S.manager_key ctxt block (Contract.implicit_contract mgr) () () + RPC_context.make_call1 + S.manager_key + ctxt + block + (Contract.implicit_contract mgr) + () + () let delegate ctxt block contract = RPC_context.make_call1 S.delegate ctxt block contract () () @@ -319,7 +392,13 @@ let delegate_opt ctxt block contract = RPC_context.make_opt_call1 S.delegate ctxt block contract () () let counter ctxt block mgr = - RPC_context.make_call1 S.counter ctxt block (Contract.implicit_contract mgr) () () + RPC_context.make_call1 + S.counter + ctxt + block + (Contract.implicit_contract mgr) + () + () let script ctxt block contract = RPC_context.make_call1 S.script ctxt block contract () () diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli index 7b638ebd7..3c3aab0ee 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_services.mli @@ -25,61 +25,95 @@ open Alpha_context -val list: - 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t +val list : 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t type info = { - balance: Tez.t ; - delegate: public_key_hash option ; - counter: counter option ; - script: Script.t option ; + balance : Tez.t; + delegate : public_key_hash option; + counter : counter option; + script : Script.t option; } -val info_encoding: info Data_encoding.t +val info_encoding : info Data_encoding.t -val info: +val info : 'a #RPC_context.simple -> 'a -> Contract.t -> info shell_tzresult Lwt.t -val balance: +val balance : 'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t -val manager_key: - 'a #RPC_context.simple -> 'a -> public_key_hash -> public_key option shell_tzresult Lwt.t +val manager_key : + 'a #RPC_context.simple -> + 'a -> + public_key_hash -> + public_key option shell_tzresult Lwt.t -val delegate: - 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t +val delegate : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + public_key_hash shell_tzresult Lwt.t -val delegate_opt: - 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash option shell_tzresult Lwt.t +val delegate_opt : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + public_key_hash option shell_tzresult Lwt.t -val counter: - 'a #RPC_context.simple -> 'a -> public_key_hash -> counter shell_tzresult Lwt.t +val counter : + 'a #RPC_context.simple -> + 'a -> + public_key_hash -> + counter shell_tzresult Lwt.t -val script: +val script : 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t -val script_opt: - 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t option shell_tzresult Lwt.t +val script_opt : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + Script.t option shell_tzresult Lwt.t -val storage: - 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t - -val entrypoint_type: - 'a #RPC_context.simple -> 'a -> Contract.t -> string -> Script.expr shell_tzresult Lwt.t - -val list_entrypoints: - 'a #RPC_context.simple -> 'a -> Contract.t -> - (Michelson_v1_primitives.prim list list * - (string * Script.expr) list) shell_tzresult Lwt.t - -val storage_opt: - 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr option shell_tzresult Lwt.t - -val big_map_get: - 'a #RPC_context.simple -> 'a -> Z.t -> Script_expr_hash.t -> +val storage : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> Script.expr shell_tzresult Lwt.t -val contract_big_map_get_opt: - 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr * Script.expr -> Script.expr option shell_tzresult Lwt.t +val entrypoint_type : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + string -> + Script.expr shell_tzresult Lwt.t -val register: unit -> unit +val list_entrypoints : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + (Michelson_v1_primitives.prim list list * (string * Script.expr) list) + shell_tzresult + Lwt.t + +val storage_opt : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + Script.expr option shell_tzresult Lwt.t + +val big_map_get : + 'a #RPC_context.simple -> + 'a -> + Z.t -> + Script_expr_hash.t -> + Script.expr shell_tzresult Lwt.t + +val contract_big_map_get_opt : + 'a #RPC_context.simple -> + 'a -> + Contract.t -> + Script.expr * Script.expr -> + Script.expr option shell_tzresult Lwt.t + +val register : unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml index 21a74782b..c63a9f283 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.ml @@ -24,44 +24,74 @@ (*****************************************************************************) type error += - | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t (* `Temporary *) - | Counter_in_the_past of Contract_repr.contract * Z.t * Z.t (* `Branch *) - | Counter_in_the_future of Contract_repr.contract * Z.t * Z.t (* `Temporary *) - | Unspendable_contract of Contract_repr.contract (* `Permanent *) - | Non_existing_contract of Contract_repr.contract (* `Temporary *) - | Empty_implicit_contract of Signature.Public_key_hash.t (* `Temporary *) - | Empty_transaction of Contract_repr.t (* `Temporary *) - | Inconsistent_hash of Signature.Public_key.t * Signature.Public_key_hash.t * Signature.Public_key_hash.t (* `Permanent *) - | Inconsistent_public_key of Signature.Public_key.t * Signature.Public_key.t (* `Permanent *) - | Failure of string (* `Permanent *) + | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t + | (* `Temporary *) + Counter_in_the_past of Contract_repr.contract * Z.t * Z.t + | (* `Branch *) + Counter_in_the_future of Contract_repr.contract * Z.t * Z.t + | (* `Temporary *) + Unspendable_contract of Contract_repr.contract + | (* `Permanent *) + Non_existing_contract of Contract_repr.contract + | (* `Temporary *) + Empty_implicit_contract of Signature.Public_key_hash.t + | (* `Temporary *) + Empty_implicit_delegated_contract of + Signature.Public_key_hash.t + | (* `Temporary *) + Empty_transaction of Contract_repr.t (* `Temporary *) + | Inconsistent_hash of + Signature.Public_key.t + * Signature.Public_key_hash.t + * Signature.Public_key_hash.t + | (* `Permanent *) + Inconsistent_public_key of + Signature.Public_key.t * Signature.Public_key.t + | (* `Permanent *) + Failure of string (* `Permanent *) | Previously_revealed_key of Contract_repr.t (* `Permanent *) - | Unrevealed_manager_key of Contract_repr.t (* `Permanent *) + | Unrevealed_manager_key of Contract_repr.t + +(* `Permanent *) let () = register_error_kind `Permanent ~id:"contract.unspendable_contract" ~title:"Unspendable contract" - ~description:"An operation tried to spend tokens from an unspendable contract" + ~description: + "An operation tried to spend tokens from an unspendable contract" ~pp:(fun ppf c -> - Format.fprintf ppf "The tokens of contract %a can only be spent by its script" - Contract_repr.pp c) + Format.fprintf + ppf + "The tokens of contract %a can only be spent by its script" + Contract_repr.pp + c) Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) - (function Unspendable_contract c -> Some c | _ -> None) + (function Unspendable_contract c -> Some c | _ -> None) (fun c -> Unspendable_contract c) ; register_error_kind `Temporary ~id:"contract.balance_too_low" ~title:"Balance too low" - ~description:"An operation tried to spend more tokens than the contract has" + ~description: + "An operation tried to spend more tokens than the contract has" ~pp:(fun ppf (c, b, a) -> - Format.fprintf ppf "Balance of contract %a too low (%a) to spend %a" - Contract_repr.pp c Tez_repr.pp b Tez_repr.pp a) - Data_encoding.(obj3 - (req "contract" Contract_repr.encoding) - (req "balance" Tez_repr.encoding) - (req "amount" Tez_repr.encoding)) - (function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None) + Format.fprintf + ppf + "Balance of contract %a too low (%a) to spend %a" + Contract_repr.pp + c + Tez_repr.pp + b + Tez_repr.pp + a) + Data_encoding.( + obj3 + (req "contract" Contract_repr.encoding) + (req "balance" Tez_repr.encoding) + (req "amount" Tez_repr.encoding)) + (function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None) (fun (c, b, a) -> Balance_too_low (c, b, a)) ; register_error_kind `Temporary @@ -69,16 +99,18 @@ let () = ~title:"Invalid counter (not yet reached) in a manager operation" ~description:"An operation assumed a contract counter in the future" ~pp:(fun ppf (contract, exp, found) -> - Format.fprintf ppf - "Counter %s not yet reached for contract %a (expected %s)" - (Z.to_string found) - Contract_repr.pp contract - (Z.to_string exp)) - Data_encoding. - (obj3 - (req "contract" Contract_repr.encoding) - (req "expected" z) - (req "found" z)) + Format.fprintf + ppf + "Counter %s not yet reached for contract %a (expected %s)" + (Z.to_string found) + Contract_repr.pp + contract + (Z.to_string exp)) + Data_encoding.( + obj3 + (req "contract" Contract_repr.encoding) + (req "expected" z) + (req "found" z)) (function Counter_in_the_future (c, x, y) -> Some (c, x, y) | _ -> None) (fun (c, x, y) -> Counter_in_the_future (c, x, y)) ; register_error_kind @@ -87,27 +119,29 @@ let () = ~title:"Invalid counter (already used) in a manager operation" ~description:"An operation assumed a contract counter in the past" ~pp:(fun ppf (contract, exp, found) -> - Format.fprintf ppf - "Counter %s already used for contract %a (expected %s)" - (Z.to_string found) - Contract_repr.pp contract - (Z.to_string exp)) - Data_encoding. - (obj3 - (req "contract" Contract_repr.encoding) - (req "expected" z) - (req "found" z)) + Format.fprintf + ppf + "Counter %s already used for contract %a (expected %s)" + (Z.to_string found) + Contract_repr.pp + contract + (Z.to_string exp)) + Data_encoding.( + obj3 + (req "contract" Contract_repr.encoding) + (req "expected" z) + (req "found" z)) (function Counter_in_the_past (c, x, y) -> Some (c, x, y) | _ -> None) (fun (c, x, y) -> Counter_in_the_past (c, x, y)) ; register_error_kind `Temporary ~id:"contract.non_existing_contract" ~title:"Non existing contract" - ~description:"A contract handle is not present in the context \ - (either it never was or it has been destroyed)" + ~description: + "A contract handle is not present in the context (either it never was \ + or it has been destroyed)" ~pp:(fun ppf contract -> - Format.fprintf ppf "Contract %a does not exist" - Contract_repr.pp contract) + Format.fprintf ppf "Contract %a does not exist" Contract_repr.pp contract) Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) (function Non_existing_contract c -> Some c | _ -> None) (fun c -> Non_existing_contract c) ; @@ -115,30 +149,41 @@ let () = `Permanent ~id:"contract.manager.inconsistent_hash" ~title:"Inconsistent public key hash" - ~description:"A revealed manager public key is inconsistent with the announced hash" + ~description: + "A revealed manager public key is inconsistent with the announced hash" ~pp:(fun ppf (k, eh, ph) -> - Format.fprintf ppf "The hash of the manager public key %s is not %a as announced but %a" - (Signature.Public_key.to_b58check k) - Signature.Public_key_hash.pp ph - Signature.Public_key_hash.pp eh) - Data_encoding.(obj3 - (req "public_key" Signature.Public_key.encoding) - (req "expected_hash" Signature.Public_key_hash.encoding) - (req "provided_hash" Signature.Public_key_hash.encoding)) + Format.fprintf + ppf + "The hash of the manager public key %s is not %a as announced but %a" + (Signature.Public_key.to_b58check k) + Signature.Public_key_hash.pp + ph + Signature.Public_key_hash.pp + eh) + Data_encoding.( + obj3 + (req "public_key" Signature.Public_key.encoding) + (req "expected_hash" Signature.Public_key_hash.encoding) + (req "provided_hash" Signature.Public_key_hash.encoding)) (function Inconsistent_hash (k, eh, ph) -> Some (k, eh, ph) | _ -> None) (fun (k, eh, ph) -> Inconsistent_hash (k, eh, ph)) ; register_error_kind `Permanent ~id:"contract.manager.inconsistent_public_key" ~title:"Inconsistent public key" - ~description:"A provided manager public key is different with the public key stored in the contract" + ~description: + "A provided manager public key is different with the public key stored \ + in the contract" ~pp:(fun ppf (eh, ph) -> - Format.fprintf ppf "Expected manager public key %s but %s was provided" - (Signature.Public_key.to_b58check ph) - (Signature.Public_key.to_b58check eh)) - Data_encoding.(obj2 - (req "public_key" Signature.Public_key.encoding) - (req "expected_public_key" Signature.Public_key.encoding)) + Format.fprintf + ppf + "Expected manager public key %s but %s was provided" + (Signature.Public_key.to_b58check ph) + (Signature.Public_key.to_b58check eh)) + Data_encoding.( + obj2 + (req "public_key" Signature.Public_key.encoding) + (req "expected_public_key" Signature.Public_key.encoding)) (function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None) (fun (eh, ph) -> Inconsistent_public_key (eh, ph)) ; register_error_kind @@ -155,11 +200,14 @@ let () = ~id:"contract.unrevealed_key" ~title:"Manager operation precedes key revelation" ~description: - "One tried to apply a manager operation \ - without revealing the manager public key" + "One tried to apply a manager operation without revealing the manager \ + public key" ~pp:(fun ppf s -> - Format.fprintf ppf "Unrevealed manager key for contract %a." - Contract_repr.pp s) + Format.fprintf + ppf + "Unrevealed manager key for contract %a." + Contract_repr.pp + s) Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) (function Unrevealed_manager_key s -> Some s | _ -> None) (fun s -> Unrevealed_manager_key s) ; @@ -167,11 +215,13 @@ let () = `Branch ~id:"contract.previously_revealed_key" ~title:"Manager operation already revealed" - ~description: - "One tried to revealed twice a manager public key" + ~description:"One tried to revealed twice a manager public key" ~pp:(fun ppf s -> - Format.fprintf ppf "Previously revealed manager key for contract %a." - Contract_repr.pp s) + Format.fprintf + ppf + "Previously revealed manager key for contract %a." + Contract_repr.pp + s) Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) (function Previously_revealed_key s -> Some s | _ -> None) (fun s -> Previously_revealed_key s) ; @@ -179,23 +229,43 @@ let () = `Branch ~id:"implicit.empty_implicit_contract" ~title:"Empty implicit contract" - ~description:"No manager operations are allowed on an empty implicit contract." + ~description: + "No manager operations are allowed on an empty implicit contract." ~pp:(fun ppf implicit -> - Format.fprintf ppf - "Empty implicit contract (%a)" - Signature.Public_key_hash.pp implicit) + Format.fprintf + ppf + "Empty implicit contract (%a)" + Signature.Public_key_hash.pp + implicit) Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding)) (function Empty_implicit_contract c -> Some c | _ -> None) (fun c -> Empty_implicit_contract c) ; + register_error_kind + `Branch + ~id:"implicit.empty_implicit_delegated_contract" + ~title:"Empty implicit delegated contract" + ~description:"Emptying an implicit delegated account is not allowed." + ~pp:(fun ppf implicit -> + Format.fprintf + ppf + "Emptying implicit delegated contract (%a)" + Signature.Public_key_hash.pp + implicit) + Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding)) + (function Empty_implicit_delegated_contract c -> Some c | _ -> None) + (fun c -> Empty_implicit_delegated_contract c) ; register_error_kind `Branch ~id:"contract.empty_transaction" ~title:"Empty transaction" ~description:"Forbidden to credit 0ꜩ to a contract without code." ~pp:(fun ppf contract -> - Format.fprintf ppf - "Transaction of 0ꜩ towards a contract without code are forbidden (%a)." - Contract_repr.pp contract) + Format.fprintf + ppf + "Transaction of 0ꜩ towards a contract without code are forbidden \ + (%a)." + Contract_repr.pp + contract) Data_encoding.(obj1 (req "contract" Contract_repr.encoding)) (function Empty_transaction c -> Some c | _ -> None) (fun c -> Empty_transaction c) @@ -222,7 +292,9 @@ type big_map_diff = big_map_diff_item list let big_map_diff_item_encoding = let open Data_encoding in union - [ case (Tag 0) ~title:"update" + [ case + (Tag 0) + ~title:"update" (obj5 (req "action" (constant "update")) (req "big_map" z) @@ -230,157 +302,196 @@ let big_map_diff_item_encoding = (req "key" Script_repr.expr_encoding) (opt "value" Script_repr.expr_encoding)) (function - | Update { big_map ; diff_key_hash ; diff_key ; diff_value } -> + | Update {big_map; diff_key_hash; diff_key; diff_value} -> Some ((), big_map, diff_key_hash, diff_key, diff_value) - | _ -> None ) + | _ -> + None) (fun ((), big_map, diff_key_hash, diff_key, diff_value) -> - Update { big_map ; diff_key_hash ; diff_key ; diff_value }) ; - case (Tag 1) ~title:"remove" - (obj2 - (req "action" (constant "remove")) - (req "big_map" z)) - (function - | Clear big_map -> - Some ((), big_map) - | _ -> None ) - (fun ((), big_map) -> - Clear big_map) ; - case (Tag 2) ~title:"copy" + Update {big_map; diff_key_hash; diff_key; diff_value}); + case + (Tag 1) + ~title:"remove" + (obj2 (req "action" (constant "remove")) (req "big_map" z)) + (function Clear big_map -> Some ((), big_map) | _ -> None) + (fun ((), big_map) -> Clear big_map); + case + (Tag 2) + ~title:"copy" (obj3 (req "action" (constant "copy")) (req "source_big_map" z) (req "destination_big_map" z)) - (function - | Copy (src, dst) -> - Some ((), src, dst) - | _ -> None ) - (fun ((), src, dst) -> - Copy (src, dst)) ; - case (Tag 3) ~title:"alloc" + (function Copy (src, dst) -> Some ((), src, dst) | _ -> None) + (fun ((), src, dst) -> Copy (src, dst)); + case + (Tag 3) + ~title:"alloc" (obj4 (req "action" (constant "alloc")) (req "big_map" z) (req "key_type" Script_repr.expr_encoding) (req "value_type" Script_repr.expr_encoding)) (function - | Alloc { big_map ; key_type ; value_type } -> + | Alloc {big_map; key_type; value_type} -> Some ((), big_map, key_type, value_type) - | _ -> None ) + | _ -> + None) (fun ((), big_map, key_type, value_type) -> - Alloc { big_map ; key_type ; value_type }) ] + Alloc {big_map; key_type; value_type}) ] let big_map_diff_encoding = let open Data_encoding in - def "contract.big_map_diff" @@ - list big_map_diff_item_encoding + def "contract.big_map_diff" @@ list big_map_diff_item_encoding let big_map_key_cost = 65 + let big_map_cost = 33 let update_script_big_map c = function - | None -> return (c, Z.zero) + | None -> + return (c, Z.zero) | Some diff -> - fold_left_s (fun (c, total) -> function - | Clear id -> - Storage.Big_map.Total_bytes.get c id >>=? fun size -> - Storage.Big_map.remove_rec c id >>= fun c -> - if Compare.Z.(id < Z.zero) then - return (c, total) - else - return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost)) + fold_left_s + (fun (c, total) -> function Clear id -> + Storage.Big_map.Total_bytes.get c id + >>=? fun size -> + Storage.Big_map.remove_rec c id + >>= fun c -> + if Compare.Z.(id < Z.zero) then return (c, total) + else return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost)) | Copy (from, to_) -> - Storage.Big_map.copy c ~from ~to_ >>=? fun c -> - if Compare.Z.(to_ < Z.zero) then - return (c, total) + Storage.Big_map.copy c ~from ~to_ + >>=? fun c -> + if Compare.Z.(to_ < Z.zero) then return (c, total) else - Storage.Big_map.Total_bytes.get c from >>=? fun size -> + Storage.Big_map.Total_bytes.get c from + >>=? fun size -> return (c, Z.add (Z.add total size) (Z.of_int big_map_cost)) - | Alloc { big_map ; key_type ; value_type } -> - Storage.Big_map.Total_bytes.init c big_map Z.zero >>=? fun c -> + | Alloc {big_map; key_type; value_type} -> + Storage.Big_map.Total_bytes.init c big_map Z.zero + >>=? fun c -> (* Annotations are erased to allow sharing on [Copy]. The types from the contract code are used, these ones are only used to make sure they are compatible during transmissions between contracts, and only need to be compatible, annotations nonwhistanding. *) - let key_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root key_type)) in - let value_type = Micheline.strip_locations (Script_repr.strip_annotations (Micheline.root value_type)) in - Storage.Big_map.Key_type.init c big_map key_type >>=? fun c -> - Storage.Big_map.Value_type.init c big_map value_type >>=? fun c -> - if Compare.Z.(big_map < Z.zero) then - return (c, total) - else - return (c, Z.add total (Z.of_int big_map_cost)) - | Update { big_map ; diff_key_hash ; diff_value = None } -> + let key_type = + Micheline.strip_locations + (Script_repr.strip_annotations (Micheline.root key_type)) + in + let value_type = + Micheline.strip_locations + (Script_repr.strip_annotations (Micheline.root value_type)) + in + Storage.Big_map.Key_type.init c big_map key_type + >>=? fun c -> + Storage.Big_map.Value_type.init c big_map value_type + >>=? fun c -> + if Compare.Z.(big_map < Z.zero) then return (c, total) + else return (c, Z.add total (Z.of_int big_map_cost)) + | Update {big_map; diff_key_hash; diff_value = None} -> Storage.Big_map.Contents.remove (c, big_map) diff_key_hash >>=? fun (c, freed, existed) -> - let freed = if existed then freed + big_map_key_cost else freed in - Storage.Big_map.Total_bytes.get c big_map >>=? fun size -> - Storage.Big_map.Total_bytes.set c big_map (Z.sub size (Z.of_int freed)) >>=? fun c -> - if Compare.Z.(big_map < Z.zero) then - return (c, total) - else - return (c, Z.sub total (Z.of_int freed)) - | Update { big_map ; diff_key_hash ; diff_value = Some v } -> + let freed = + if existed then freed + big_map_key_cost else freed + in + Storage.Big_map.Total_bytes.get c big_map + >>=? fun size -> + Storage.Big_map.Total_bytes.set + c + big_map + (Z.sub size (Z.of_int freed)) + >>=? fun c -> + if Compare.Z.(big_map < Z.zero) then return (c, total) + else return (c, Z.sub total (Z.of_int freed)) + | Update {big_map; diff_key_hash; diff_value = Some v} -> Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v >>=? fun (c, size_diff, existed) -> - let size_diff = if existed then size_diff else size_diff + big_map_key_cost in - Storage.Big_map.Total_bytes.get c big_map >>=? fun size -> - Storage.Big_map.Total_bytes.set c big_map (Z.add size (Z.of_int size_diff)) >>=? fun c -> - if Compare.Z.(big_map < Z.zero) then - return (c, total) - else - return (c, Z.add total (Z.of_int size_diff))) - (c, Z.zero) diff + let size_diff = + if existed then size_diff else size_diff + big_map_key_cost + in + Storage.Big_map.Total_bytes.get c big_map + >>=? fun size -> + Storage.Big_map.Total_bytes.set + c + big_map + (Z.add size (Z.of_int size_diff)) + >>=? fun c -> + if Compare.Z.(big_map < Z.zero) then return (c, total) + else return (c, Z.add total (Z.of_int size_diff))) + (c, Z.zero) + diff -let create_base c - ?(prepaid_bootstrap_storage=false) (* Free space for bootstrap contracts *) - contract - ~balance ~manager ~delegate ?script () = - begin match Contract_repr.is_implicit contract with - | None -> return c - | Some _ -> - Storage.Contract.Global_counter.get c >>=? fun counter -> - Storage.Contract.Counter.init c contract counter - end >>=? fun c -> - Storage.Contract.Balance.init c contract balance >>=? fun c -> - begin match manager with - | Some manager -> - Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) - | None -> return c - end >>=? fun c -> - begin - match delegate with - | None -> return c - | Some delegate -> - Delegate_storage.init c contract delegate - end >>=? fun c -> +let create_base c ?(prepaid_bootstrap_storage = false) + (* Free space for bootstrap contracts *) + contract ~balance ~manager ~delegate ?script () = + ( match Contract_repr.is_implicit contract with + | None -> + return c + | Some _ -> + Storage.Contract.Global_counter.get c + >>=? fun counter -> Storage.Contract.Counter.init c contract counter ) + >>=? fun c -> + Storage.Contract.Balance.init c contract balance + >>=? fun c -> + ( match manager with + | Some manager -> + Storage.Contract.Manager.init c contract (Manager_repr.Hash manager) + | None -> + return c ) + >>=? fun c -> + ( match delegate with + | None -> + return c + | Some delegate -> + Delegate_storage.init c contract delegate ) + >>=? fun c -> match script with - | Some ({ Script_repr.code ; storage }, big_map_diff) -> - Storage.Contract.Code.init c contract code >>=? fun (c, code_size) -> - Storage.Contract.Storage.init c contract storage >>=? fun (c, storage_size) -> - update_script_big_map c big_map_diff >>=? fun (c, big_map_size) -> - let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in - assert Compare.Z.(total_size >= Z.zero) ; - let prepaid_bootstrap_storage = - if prepaid_bootstrap_storage then - total_size - else - Z.zero + | Some ({Script_repr.code; storage}, big_map_diff) -> + Storage.Contract.Code.init c contract code + >>=? fun (c, code_size) -> + Storage.Contract.Storage.init c contract storage + >>=? fun (c, storage_size) -> + update_script_big_map c big_map_diff + >>=? fun (c, big_map_size) -> + let total_size = + Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size in - Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage >>=? fun c -> + assert (Compare.Z.(total_size >= Z.zero)) ; + let prepaid_bootstrap_storage = + if prepaid_bootstrap_storage then total_size else Z.zero + in + Storage.Contract.Paid_storage_space.init + c + contract + prepaid_bootstrap_storage + >>=? fun c -> Storage.Contract.Used_storage_space.init c contract total_size | None -> return c -let originate c ?prepaid_bootstrap_storage contract - ~balance ~script ~delegate = - create_base c ?prepaid_bootstrap_storage contract ~balance - ~manager:None ~delegate ~script () +let originate c ?prepaid_bootstrap_storage contract ~balance ~script ~delegate + = + create_base + c + ?prepaid_bootstrap_storage + contract + ~balance + ~manager:None + ~delegate + ~script + () let create_implicit c manager ~balance = - create_base c (Contract_repr.implicit_contract manager) - ~balance ~manager:(Some manager) ?script:None ~delegate:None () + create_base + c + (Contract_repr.implicit_contract manager) + ~balance + ~manager:(Some manager) + ?script:None + ~delegate:None + () let delete c contract = match Contract_repr.is_implicit contract with @@ -388,215 +499,255 @@ let delete c contract = (* For non implicit contract Big_map should be cleared *) failwith "Non implicit contracts cannot be removed" | Some _ -> - Delegate_storage.remove c contract >>=? fun c -> - Storage.Contract.Balance.delete c contract >>=? fun c -> - Storage.Contract.Manager.delete c contract >>=? fun c -> - Storage.Contract.Counter.delete c contract >>=? fun c -> - Storage.Contract.Code.remove c contract >>=? fun (c, _, _) -> - Storage.Contract.Storage.remove c contract >>=? fun (c, _, _) -> - Storage.Contract.Paid_storage_space.remove c contract >>= fun c -> - Storage.Contract.Used_storage_space.remove c contract >>= fun c -> - return c + Delegate_storage.remove c contract + >>=? fun c -> + Storage.Contract.Balance.delete c contract + >>=? fun c -> + Storage.Contract.Manager.delete c contract + >>=? fun c -> + Storage.Contract.Counter.delete c contract + >>=? fun c -> + Storage.Contract.Code.remove c contract + >>=? fun (c, _, _) -> + Storage.Contract.Storage.remove c contract + >>=? fun (c, _, _) -> + Storage.Contract.Paid_storage_space.remove c contract + >>= fun c -> + Storage.Contract.Used_storage_space.remove c contract + >>= fun c -> return c let allocated c contract = - Storage.Contract.Balance.get_option c contract >>=? function - | None -> return_false - | Some _ -> return_true + Storage.Contract.Balance.get_option c contract + >>=? function None -> return_false | Some _ -> return_true let exists c contract = match Contract_repr.is_implicit contract with - | Some _ -> return_true - | None -> allocated c contract + | Some _ -> + return_true + | None -> + allocated c contract let must_exist c contract = - exists c contract >>=? function - | true -> return_unit - | false -> fail (Non_existing_contract contract) + exists c contract + >>=? function + | true -> return_unit | false -> fail (Non_existing_contract contract) let must_be_allocated c contract = - allocated c contract >>=? function - | true -> return_unit - | false -> - match Contract_repr.is_implicit contract with - | Some pkh -> fail (Empty_implicit_contract pkh) - | None -> fail (Non_existing_contract contract) + allocated c contract + >>=? function + | true -> + return_unit + | false -> ( + match Contract_repr.is_implicit contract with + | Some pkh -> + fail (Empty_implicit_contract pkh) + | None -> + fail (Non_existing_contract contract) ) let list c = Storage.Contract.list c let fresh_contract_from_current_nonce c = - Lwt.return (Raw_context.increment_origination_nonce c) >>=? fun (c, nonce) -> - return (c, Contract_repr.originated_contract nonce) + Lwt.return (Raw_context.increment_origination_nonce c) + >>=? fun (c, nonce) -> return (c, Contract_repr.originated_contract nonce) -let originated_from_current_nonce ~since: ctxt_since ~until: ctxt_until = - Lwt.return (Raw_context.origination_nonce ctxt_since) >>=? fun since -> - Lwt.return (Raw_context.origination_nonce ctxt_until) >>=? fun until -> +let originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until = + Lwt.return (Raw_context.origination_nonce ctxt_since) + >>=? fun since -> + Lwt.return (Raw_context.origination_nonce ctxt_until) + >>=? fun until -> filter_map_s - (fun contract -> exists ctxt_until contract >>=? function - | true -> return_some contract - | false -> return_none) + (fun contract -> + exists ctxt_until contract + >>=? function true -> return_some contract | false -> return_none) (Contract_repr.originated_contracts ~since ~until) let check_counter_increment c manager counter = let contract = Contract_repr.implicit_contract manager in - Storage.Contract.Counter.get c contract >>=? fun contract_counter -> + Storage.Contract.Counter.get c contract + >>=? fun contract_counter -> let expected = Z.succ contract_counter in - if Compare.Z.(expected = counter) - then return_unit + if Compare.Z.(expected = counter) then return_unit else if Compare.Z.(expected > counter) then fail (Counter_in_the_past (contract, expected, counter)) - else - fail (Counter_in_the_future (contract, expected, counter)) + else fail (Counter_in_the_future (contract, expected, counter)) let increment_counter c manager = let contract = Contract_repr.implicit_contract manager in - Storage.Contract.Global_counter.get c >>=? fun global_counter -> - Storage.Contract.Global_counter.set c (Z.succ global_counter) >>=? fun c -> - Storage.Contract.Counter.get c contract >>=? fun contract_counter -> + Storage.Contract.Global_counter.get c + >>=? fun global_counter -> + Storage.Contract.Global_counter.set c (Z.succ global_counter) + >>=? fun c -> + Storage.Contract.Counter.get c contract + >>=? fun contract_counter -> Storage.Contract.Counter.set c contract (Z.succ contract_counter) -let get_script_code c contract = - Storage.Contract.Code.get_option c contract +let get_script_code c contract = Storage.Contract.Code.get_option c contract let get_script c contract = - Storage.Contract.Code.get_option c contract >>=? fun (c, code) -> - Storage.Contract.Storage.get_option c contract >>=? fun (c, storage) -> - match code, storage with - | None, None -> return (c, None) - | Some code, Some storage -> return (c, Some { Script_repr.code ; storage }) - | None, Some _ | Some _, None -> failwith "get_script" + Storage.Contract.Code.get_option c contract + >>=? fun (c, code) -> + Storage.Contract.Storage.get_option c contract + >>=? fun (c, storage) -> + match (code, storage) with + | (None, None) -> + return (c, None) + | (Some code, Some storage) -> + return (c, Some {Script_repr.code; storage}) + | (None, Some _) | (Some _, None) -> + failwith "get_script" let get_storage ctxt contract = - Storage.Contract.Storage.get_option ctxt contract >>=? function - | (ctxt, None) -> return (ctxt, None) + Storage.Contract.Storage.get_option ctxt contract + >>=? function + | (ctxt, None) -> + return (ctxt, None) | (ctxt, Some storage) -> - Lwt.return (Script_repr.force_decode storage) >>=? fun (storage, cost) -> - Lwt.return (Raw_context.consume_gas ctxt cost) >>=? fun ctxt -> - return (ctxt, Some storage) + Lwt.return (Script_repr.force_decode storage) + >>=? fun (storage, cost) -> + Lwt.return (Raw_context.consume_gas ctxt cost) + >>=? fun ctxt -> return (ctxt, Some storage) let get_counter c manager = let contract = Contract_repr.implicit_contract manager in - Storage.Contract.Counter.get_option c contract >>=? function - | None -> begin - match Contract_repr.is_implicit contract with - | Some _ -> Storage.Contract.Global_counter.get c - | None -> failwith "get_counter" - end - | Some v -> return v - -let get_manager_004 c contract = - Storage.Contract.Manager.get_option c contract >>=? function - | None -> begin - match Contract_repr.is_implicit contract with - | Some manager -> return manager - | None -> failwith "get_manager" - end - | Some (Manager_repr.Hash v) -> return v - | Some (Manager_repr.Public_key v) -> return (Signature.Public_key.hash v) + Storage.Contract.Counter.get_option c contract + >>=? function + | None -> ( + match Contract_repr.is_implicit contract with + | Some _ -> + Storage.Contract.Global_counter.get c + | None -> + failwith "get_counter" ) + | Some v -> + return v let get_manager_key c manager = let contract = Contract_repr.implicit_contract manager in - Storage.Contract.Manager.get_option c contract >>=? function - | None -> failwith "get_manager_key" - | Some (Manager_repr.Hash _) -> fail (Unrevealed_manager_key contract) - | Some (Manager_repr.Public_key v) -> return v + Storage.Contract.Manager.get_option c contract + >>=? function + | None -> + failwith "get_manager_key" + | Some (Manager_repr.Hash _) -> + fail (Unrevealed_manager_key contract) + | Some (Manager_repr.Public_key v) -> + return v let is_manager_key_revealed c manager = let contract = Contract_repr.implicit_contract manager in - Storage.Contract.Manager.get_option c contract >>=? function - | None -> return_false - | Some (Manager_repr.Hash _) -> return_false - | Some (Manager_repr.Public_key _) -> return_true + Storage.Contract.Manager.get_option c contract + >>=? function + | None -> + return_false + | Some (Manager_repr.Hash _) -> + return_false + | Some (Manager_repr.Public_key _) -> + return_true let reveal_manager_key c manager public_key = let contract = Contract_repr.implicit_contract manager in - Storage.Contract.Manager.get c contract >>=? function - | Public_key _ -> fail (Previously_revealed_key contract) + Storage.Contract.Manager.get c contract + >>=? function + | Public_key _ -> + fail (Previously_revealed_key contract) | Hash v -> let actual_hash = Signature.Public_key.hash public_key in - if (Signature.Public_key_hash.equal actual_hash v) then - let v = (Manager_repr.Public_key public_key) in - Storage.Contract.Manager.set c contract v >>=? fun c -> - return c - else fail (Inconsistent_hash (public_key,v,actual_hash)) + if Signature.Public_key_hash.equal actual_hash v then + let v = Manager_repr.Public_key public_key in + Storage.Contract.Manager.set c contract v >>=? fun c -> return c + else fail (Inconsistent_hash (public_key, v, actual_hash)) let get_balance c contract = - Storage.Contract.Balance.get_option c contract >>=? function - | None -> begin - match Contract_repr.is_implicit contract with - | Some _ -> return Tez_repr.zero - | None -> failwith "get_balance" - end - | Some v -> return v + Storage.Contract.Balance.get_option c contract + >>=? function + | None -> ( + match Contract_repr.is_implicit contract with + | Some _ -> + return Tez_repr.zero + | None -> + failwith "get_balance" ) + | Some v -> + return v let update_script_storage c contract storage big_map_diff = let storage = Script_repr.lazy_expr storage in - update_script_big_map c big_map_diff >>=? fun (c, big_map_size_diff) -> - Storage.Contract.Storage.set c contract storage >>=? fun (c, size_diff) -> - Storage.Contract.Used_storage_space.get c contract >>=? fun previous_size -> - let new_size = Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff)) in + update_script_big_map c big_map_diff + >>=? fun (c, big_map_size_diff) -> + Storage.Contract.Storage.set c contract storage + >>=? fun (c, size_diff) -> + Storage.Contract.Used_storage_space.get c contract + >>=? fun previous_size -> + let new_size = + Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff)) + in Storage.Contract.Used_storage_space.set c contract new_size let spend c contract amount = - Storage.Contract.Balance.get c contract >>=? fun balance -> + Storage.Contract.Balance.get c contract + >>=? fun balance -> match Tez_repr.(balance -? amount) with | Error _ -> fail (Balance_too_low (contract, balance, amount)) - | Ok new_balance -> - Storage.Contract.Balance.set c contract new_balance >>=? fun c -> - Roll_storage.Contract.remove_amount c contract amount >>=? fun c -> - if Tez_repr.(new_balance > Tez_repr.zero) then - return c - else match Contract_repr.is_implicit contract with - | None -> return c (* Never delete originated contracts *) - | Some pkh -> - Delegate_storage.get c contract >>=? function + | Ok new_balance -> ( + Storage.Contract.Balance.set c contract new_balance + >>=? fun c -> + Roll_storage.Contract.remove_amount c contract amount + >>=? fun c -> + if Tez_repr.(new_balance > Tez_repr.zero) then return c + else + match Contract_repr.is_implicit contract with + | None -> + return c (* Never delete originated contracts *) + | Some pkh -> ( + Delegate_storage.get c contract + >>=? function | Some pkh' -> - (* Don't delete "delegate" contract *) - assert (Signature.Public_key_hash.equal pkh pkh') ; - return c + if Signature.Public_key_hash.equal pkh pkh' then return c + else + (* Delegated implicit accounts cannot be emptied *) + fail (Empty_implicit_delegated_contract pkh) | None -> (* Delete empty implicit contract *) - delete c contract + delete c contract ) ) let credit c contract amount = - begin - if Tez_repr.(amount <> Tez_repr.zero) then - return c - else - Storage.Contract.Code.mem c contract >>=? fun (c, target_has_code) -> - fail_unless target_has_code (Empty_transaction contract) >>=? fun () -> - return c - end >>=? fun c -> - Storage.Contract.Balance.get_option c contract >>=? function - | None -> begin - match Contract_repr.is_implicit contract with - | None -> fail (Non_existing_contract contract) - | Some manager -> - create_implicit c manager ~balance:amount - end + ( if Tez_repr.(amount <> Tez_repr.zero) then return c + else + Storage.Contract.Code.mem c contract + >>=? fun (c, target_has_code) -> + fail_unless target_has_code (Empty_transaction contract) + >>=? fun () -> return c ) + >>=? fun c -> + Storage.Contract.Balance.get_option c contract + >>=? function + | None -> ( + match Contract_repr.is_implicit contract with + | None -> + fail (Non_existing_contract contract) + | Some manager -> + create_implicit c manager ~balance:amount ) | Some balance -> - Lwt.return Tez_repr.(amount +? balance) >>=? fun balance -> - Storage.Contract.Balance.set c contract balance >>=? fun c -> - Roll_storage.Contract.add_amount c contract amount + Lwt.return Tez_repr.(amount +? balance) + >>=? fun balance -> + Storage.Contract.Balance.set c contract balance + >>=? fun c -> Roll_storage.Contract.add_amount c contract amount let init c = Storage.Contract.Global_counter.init c Z.zero + >>=? fun c -> Storage.Big_map.Next.init c let used_storage_space c contract = - Storage.Contract.Used_storage_space.get_option c contract >>=? function - | None -> return Z.zero - | Some fees -> return fees + Storage.Contract.Used_storage_space.get_option c contract + >>=? function None -> return Z.zero | Some fees -> return fees let paid_storage_space c contract = - Storage.Contract.Paid_storage_space.get_option c contract >>=? function - | None -> return Z.zero - | Some paid_space -> return paid_space + Storage.Contract.Paid_storage_space.get_option c contract + >>=? function None -> return Z.zero | Some paid_space -> return paid_space -let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space = - Storage.Contract.Paid_storage_space.get c contract >>=? fun already_paid_space -> - if Compare.Z.(already_paid_space >= new_storage_space) then - return (Z.zero, c) +let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space + = + Storage.Contract.Paid_storage_space.get c contract + >>=? fun already_paid_space -> + if Compare.Z.(already_paid_space >= new_storage_space) then return (Z.zero, c) else let to_pay = Z.sub new_storage_space already_paid_space in - Storage.Contract.Paid_storage_space.set c contract new_storage_space >>=? fun c -> - return (to_pay, c) + Storage.Contract.Paid_storage_space.set c contract new_storage_space + >>=? fun c -> return (to_pay, c) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli index a8c1747e1..450b58ac1 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/contract_storage.mli @@ -24,60 +24,89 @@ (*****************************************************************************) type error += - | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t (* `Temporary *) - | Counter_in_the_past of Contract_repr.contract * Z.t * Z.t (* `Branch *) - | Counter_in_the_future of Contract_repr.contract * Z.t * Z.t (* `Temporary *) - | Unspendable_contract of Contract_repr.contract (* `Permanent *) - | Non_existing_contract of Contract_repr.contract (* `Temporary *) - | Empty_implicit_contract of Signature.Public_key_hash.t (* `Temporary *) - | Empty_transaction of Contract_repr.t (* `Temporary *) - | Inconsistent_hash of Signature.Public_key.t * Signature.Public_key_hash.t * Signature.Public_key_hash.t (* `Permanent *) - | Inconsistent_public_key of Signature.Public_key.t * Signature.Public_key.t (* `Permanent *) - | Failure of string (* `Permanent *) + | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t + | (* `Temporary *) + Counter_in_the_past of Contract_repr.contract * Z.t * Z.t + | (* `Branch *) + Counter_in_the_future of Contract_repr.contract * Z.t * Z.t + | (* `Temporary *) + Unspendable_contract of Contract_repr.contract + | (* `Permanent *) + Non_existing_contract of Contract_repr.contract + | (* `Temporary *) + Empty_implicit_contract of Signature.Public_key_hash.t + | (* `Temporary *) + Empty_implicit_delegated_contract of + Signature.Public_key_hash.t + | (* `Temporary *) + Empty_transaction of Contract_repr.t (* `Temporary *) + | Inconsistent_hash of + Signature.Public_key.t + * Signature.Public_key_hash.t + * Signature.Public_key_hash.t + | (* `Permanent *) + Inconsistent_public_key of + Signature.Public_key.t * Signature.Public_key.t + | (* `Permanent *) + Failure of string (* `Permanent *) | Previously_revealed_key of Contract_repr.t (* `Permanent *) - | Unrevealed_manager_key of Contract_repr.t (* `Permanent *) + | Unrevealed_manager_key of Contract_repr.t -val exists: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t -val must_exist: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t +(* `Permanent *) -val allocated: Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t -val must_be_allocated: Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t +val exists : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t +val must_exist : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t -val list: Raw_context.t -> Contract_repr.t list Lwt.t +val allocated : Raw_context.t -> Contract_repr.t -> bool tzresult Lwt.t -val check_counter_increment: +val must_be_allocated : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t + +val list : Raw_context.t -> Contract_repr.t list Lwt.t + +val check_counter_increment : Raw_context.t -> Signature.Public_key_hash.t -> Z.t -> unit tzresult Lwt.t -val increment_counter: +val increment_counter : Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t -val get_manager_004: - Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t tzresult Lwt.t +val get_manager_key : + Raw_context.t -> + Signature.Public_key_hash.t -> + Signature.Public_key.t tzresult Lwt.t -val get_manager_key: - Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t tzresult Lwt.t -val is_manager_key_revealed: +val is_manager_key_revealed : Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t -val reveal_manager_key: - Raw_context.t -> Signature.Public_key_hash.t -> Signature.Public_key.t -> +val reveal_manager_key : + Raw_context.t -> + Signature.Public_key_hash.t -> + Signature.Public_key.t -> Raw_context.t tzresult Lwt.t -val get_balance: Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t -val get_counter: Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t +val get_balance : Raw_context.t -> Contract_repr.t -> Tez_repr.t tzresult Lwt.t -val get_script_code: - Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t -val get_script: - Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.t option) tzresult Lwt.t -val get_storage: - Raw_context.t -> Contract_repr.t -> (Raw_context.t * Script_repr.expr option) tzresult Lwt.t +val get_counter : + Raw_context.t -> Signature.Public_key_hash.t -> Z.t tzresult Lwt.t +val get_script_code : + Raw_context.t -> + Contract_repr.t -> + (Raw_context.t * Script_repr.lazy_expr option) tzresult Lwt.t + +val get_script : + Raw_context.t -> + Contract_repr.t -> + (Raw_context.t * Script_repr.t option) tzresult Lwt.t + +val get_storage : + Raw_context.t -> + Contract_repr.t -> + (Raw_context.t * Script_repr.expr option) tzresult Lwt.t type big_map_diff_item = | Update of { - big_map : Z.t ; + big_map : Z.t; diff_key : Script_repr.expr; diff_key_hash : Script_expr_hash.t; diff_value : Script_repr.expr option; @@ -94,38 +123,50 @@ type big_map_diff = big_map_diff_item list val big_map_diff_encoding : big_map_diff Data_encoding.t -val update_script_storage: - Raw_context.t -> Contract_repr.t -> - Script_repr.expr -> big_map_diff option -> +val update_script_storage : + Raw_context.t -> + Contract_repr.t -> + Script_repr.expr -> + big_map_diff option -> Raw_context.t tzresult Lwt.t -val credit: - Raw_context.t -> Contract_repr.t -> Tez_repr.t -> +val credit : + Raw_context.t -> + Contract_repr.t -> + Tez_repr.t -> Raw_context.t tzresult Lwt.t -val spend: - Raw_context.t -> Contract_repr.t -> Tez_repr.t -> +val spend : + Raw_context.t -> + Contract_repr.t -> + Tez_repr.t -> Raw_context.t tzresult Lwt.t -val originate: +val originate : Raw_context.t -> ?prepaid_bootstrap_storage:bool -> Contract_repr.t -> balance:Tez_repr.t -> - script:(Script_repr.t * big_map_diff option) -> + script:Script_repr.t * big_map_diff option -> delegate:Signature.Public_key_hash.t option -> Raw_context.t tzresult Lwt.t val fresh_contract_from_current_nonce : Raw_context.t -> (Raw_context.t * Contract_repr.t) tzresult Lwt.t + val originated_from_current_nonce : - since: Raw_context.t -> - until: Raw_context.t -> + since:Raw_context.t -> + until:Raw_context.t -> Contract_repr.t list tzresult Lwt.t -val init: - Raw_context.t -> Raw_context.t tzresult Lwt.t +val init : Raw_context.t -> Raw_context.t tzresult Lwt.t -val used_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t -val paid_storage_space: Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t -val set_paid_storage_space_and_return_fees_to_pay: Raw_context.t -> Contract_repr.t -> Z.t -> (Z.t * Raw_context.t) tzresult Lwt.t +val used_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t + +val paid_storage_space : Raw_context.t -> Contract_repr.t -> Z.t tzresult Lwt.t + +val set_paid_storage_space_and_return_fees_to_pay : + Raw_context.t -> + Contract_repr.t -> + Z.t -> + (Z.t * Raw_context.t) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml index 5c24319e8..153c3f765 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.ml @@ -24,18 +24,23 @@ (*****************************************************************************) type t = int32 + type cycle = t let encoding = Data_encoding.int32 + let rpc_arg = let construct = Int32.to_string in let destruct str = match Int32.of_string str with - | exception _ -> Error "Cannot parse cycle" - | cycle -> Ok cycle in + | exception _ -> + Error "Cannot parse cycle" + | cycle -> + Ok cycle + in RPC_arg.make ~descr:"A cycle integer" - ~name: "block_cycle" + ~name:"block_cycle" ~construct ~destruct () @@ -44,42 +49,45 @@ let pp ppf cycle = Format.fprintf ppf "%ld" cycle include (Compare.Int32 : Compare.S with type t := t) -module Map = Map.Make(Compare.Int32) +module Map = Map.Make (Compare.Int32) let root = 0l + let succ = Int32.succ -let pred = function - | 0l -> None - | i -> Some (Int32.pred i) + +let pred = function 0l -> None | i -> Some (Int32.pred i) let add c i = - assert Compare.Int.(i > 0) ; + assert (Compare.Int.(i > 0)) ; Int32.add c (Int32.of_int i) let sub c i = - assert Compare.Int.(i > 0) ; + assert (Compare.Int.(i > 0)) ; let r = Int32.sub c (Int32.of_int i) in if Compare.Int32.(r < 0l) then None else Some r let to_int32 i = i let of_int32_exn l = - if Compare.Int32.(l >= 0l) - then l + if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.Cycle.of_int32" module Index = struct type t = cycle + let path_length = 1 - let to_path c l = - Int32.to_string (to_int32 c) :: l + + let to_path c l = Int32.to_string (to_int32 c) :: l + let of_path = function - | [s] -> begin - try Some (Int32.of_string s) - with _ -> None - end - | _ -> None + | [s] -> ( + try Some (Int32.of_string s) with _ -> None ) + | _ -> + None + let rpc_arg = rpc_arg + let encoding = encoding + let compare = compare end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli index c3502f665..241992c70 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/cycle_repr.mli @@ -24,20 +24,30 @@ (*****************************************************************************) type t + type cycle = t + include Compare.S with type t := t -val encoding: cycle Data_encoding.t -val rpc_arg: cycle RPC_arg.arg -val pp: Format.formatter -> cycle -> unit -val root: cycle -val pred: cycle -> cycle option -val add: cycle -> int -> cycle -val sub: cycle -> int -> cycle option -val succ: cycle -> cycle +val encoding : cycle Data_encoding.t -val to_int32: cycle -> int32 -val of_int32_exn: int32 -> cycle +val rpc_arg : cycle RPC_arg.arg + +val pp : Format.formatter -> cycle -> unit + +val root : cycle + +val pred : cycle -> cycle option + +val add : cycle -> int -> cycle + +val sub : cycle -> int -> cycle option + +val succ : cycle -> cycle + +val to_int32 : cycle -> int32 + +val of_int32_exn : int32 -> cycle module Map : S.MAP with type key = cycle diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml index 0e54e0afc..b6b2899ba 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.ml @@ -26,31 +26,53 @@ open Alpha_context type info = { - balance: Tez.t ; - frozen_balance: Tez.t ; - frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; - staking_balance: Tez.t ; - delegated_contracts: Contract_repr.t list ; - delegated_balance: Tez.t ; - deactivated: bool ; - grace_period: Cycle.t ; + balance : Tez.t; + frozen_balance : Tez.t; + frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t; + staking_balance : Tez.t; + delegated_contracts : Contract_repr.t list; + delegated_balance : Tez.t; + deactivated : bool; + grace_period : Cycle.t; } let info_encoding = let open Data_encoding in conv - (fun { balance ; frozen_balance ; frozen_balance_by_cycle ; - staking_balance ; delegated_contracts ; delegated_balance ; - deactivated ; grace_period } -> - (balance, frozen_balance, frozen_balance_by_cycle, - staking_balance, delegated_contracts, delegated_balance, - deactivated, grace_period)) - (fun (balance, frozen_balance, frozen_balance_by_cycle, - staking_balance, delegated_contracts, delegated_balance, - deactivated, grace_period) -> - { balance ; frozen_balance ; frozen_balance_by_cycle ; - staking_balance ; delegated_contracts ; delegated_balance ; - deactivated ; grace_period }) + (fun { balance; + frozen_balance; + frozen_balance_by_cycle; + staking_balance; + delegated_contracts; + delegated_balance; + deactivated; + grace_period } -> + ( balance, + frozen_balance, + frozen_balance_by_cycle, + staking_balance, + delegated_contracts, + delegated_balance, + deactivated, + grace_period )) + (fun ( balance, + frozen_balance, + frozen_balance_by_cycle, + staking_balance, + delegated_contracts, + delegated_balance, + deactivated, + grace_period ) -> + { + balance; + frozen_balance; + frozen_balance_by_cycle; + staking_balance; + delegated_contracts; + delegated_balance; + deactivated; + grace_period; + }) (obj8 (req "balance" Tez.encoding) (req "frozen_balance" Tez.encoding) @@ -62,188 +84,180 @@ let info_encoding = (req "grace_period" Cycle.encoding)) module S = struct - let path = RPC_path.(open_root / "context" / "delegates") open Data_encoding - type list_query = { - active: bool ; - inactive: bool ; - } - let list_query :list_query RPC_query.t = + type list_query = {active : bool; inactive : bool} + + let list_query : list_query RPC_query.t = let open RPC_query in - query (fun active inactive -> { active ; inactive }) + query (fun active inactive -> {active; inactive}) |+ flag "active" (fun t -> t.active) |+ flag "inactive" (fun t -> t.inactive) |> seal let list_delegate = RPC_service.get_service - ~description: - "Lists all registered delegates." - ~query: list_query - ~output: (list Signature.Public_key_hash.encoding) + ~description:"Lists all registered delegates." + ~query:list_query + ~output:(list Signature.Public_key_hash.encoding) path let path = RPC_path.(path /: Signature.Public_key_hash.rpc_arg) let info = RPC_service.get_service - ~description: - "Everything about a delegate." - ~query: RPC_query.empty - ~output: info_encoding + ~description:"Everything about a delegate." + ~query:RPC_query.empty + ~output:info_encoding path let balance = RPC_service.get_service ~description: - "Returns the full balance of a given delegate, \ - including the frozen balances." - ~query: RPC_query.empty - ~output: Tez.encoding + "Returns the full balance of a given delegate, including the frozen \ + balances." + ~query:RPC_query.empty + ~output:Tez.encoding RPC_path.(path / "balance") let frozen_balance = RPC_service.get_service ~description: - "Returns the total frozen balances of a given delegate, \ - this includes the frozen deposits, rewards and fees." - ~query: RPC_query.empty - ~output: Tez.encoding + "Returns the total frozen balances of a given delegate, this includes \ + the frozen deposits, rewards and fees." + ~query:RPC_query.empty + ~output:Tez.encoding RPC_path.(path / "frozen_balance") let frozen_balance_by_cycle = RPC_service.get_service ~description: - "Returns the frozen balances of a given delegate, \ - indexed by the cycle by which it will be unfrozen" - ~query: RPC_query.empty - ~output: Delegate.frozen_balance_by_cycle_encoding + "Returns the frozen balances of a given delegate, indexed by the \ + cycle by which it will be unfrozen" + ~query:RPC_query.empty + ~output:Delegate.frozen_balance_by_cycle_encoding RPC_path.(path / "frozen_balance_by_cycle") let staking_balance = RPC_service.get_service ~description: "Returns the total amount of tokens delegated to a given delegate. \ - This includes the balances of all the contracts that delegate \ - to it, but also the balance of the delegate itself and its frozen \ - fees and deposits. The rewards do not count in the delegated balance \ - until they are unfrozen." - ~query: RPC_query.empty - ~output: Tez.encoding + This includes the balances of all the contracts that delegate to it, \ + but also the balance of the delegate itself and its frozen fees and \ + deposits. The rewards do not count in the delegated balance until \ + they are unfrozen." + ~query:RPC_query.empty + ~output:Tez.encoding RPC_path.(path / "staking_balance") let delegated_contracts = RPC_service.get_service ~description: "Returns the list of contracts that delegate to a given delegate." - ~query: RPC_query.empty - ~output: (list Contract_repr.encoding) + ~query:RPC_query.empty + ~output:(list Contract_repr.encoding) RPC_path.(path / "delegated_contracts") let delegated_balance = RPC_service.get_service ~description: - "Returns the balances of all the contracts that delegate to a \ - given delegate. This excludes the delegate's own balance and \ - its frozen balances." - ~query: RPC_query.empty - ~output: Tez.encoding + "Returns the balances of all the contracts that delegate to a given \ + delegate. This excludes the delegate's own balance and its frozen \ + balances." + ~query:RPC_query.empty + ~output:Tez.encoding RPC_path.(path / "delegated_balance") let deactivated = RPC_service.get_service ~description: "Tells whether the delegate is currently tagged as deactivated or not." - ~query: RPC_query.empty - ~output: bool + ~query:RPC_query.empty + ~output:bool RPC_path.(path / "deactivated") let grace_period = RPC_service.get_service ~description: "Returns the cycle by the end of which the delegate might be \ - deactivated if she fails to execute any delegate action. \ - A deactivated delegate might be reactivated \ - (without loosing any rolls) by simply re-registering as a delegate. \ - For deactivated delegates, this value contains the cycle by which \ - they were deactivated." - ~query: RPC_query.empty - ~output: Cycle.encoding + deactivated if she fails to execute any delegate action. A \ + deactivated delegate might be reactivated (without loosing any \ + rolls) by simply re-registering as a delegate. For deactivated \ + delegates, this value contains the cycle by which they were \ + deactivated." + ~query:RPC_query.empty + ~output:Cycle.encoding RPC_path.(path / "grace_period") - end let register () = let open Services_registration in - register0 S.list_delegate begin fun ctxt q () -> - Delegate.list ctxt >>= fun delegates -> - if q.active && q.inactive then - return delegates - else if q.active then - filter_map_s - (fun pkh -> - Delegate.deactivated ctxt pkh >>=? function - | true -> return_none - | false -> return_some pkh) - delegates - else if q.inactive then - filter_map_s - (fun pkh -> - Delegate.deactivated ctxt pkh >>=? function - | false -> return_none - | true -> return_some pkh) - delegates - else - return_nil - end ; - register1 S.info begin fun ctxt pkh () () -> - Delegate.full_balance ctxt pkh >>=? fun balance -> - Delegate.frozen_balance ctxt pkh >>=? fun frozen_balance -> - Delegate.frozen_balance_by_cycle ctxt pkh >>= fun frozen_balance_by_cycle -> - Delegate.staking_balance ctxt pkh >>=? fun staking_balance -> - Delegate.delegated_contracts ctxt pkh >>= fun delegated_contracts -> - Delegate.delegated_balance ctxt pkh >>=? fun delegated_balance -> - Delegate.deactivated ctxt pkh >>=? fun deactivated -> - Delegate.grace_period ctxt pkh >>=? fun grace_period -> - return { - balance ; frozen_balance ; frozen_balance_by_cycle ; - staking_balance ; delegated_contracts ; delegated_balance ; - deactivated ; grace_period - } - end ; - register1 S.balance begin fun ctxt pkh () () -> - Delegate.full_balance ctxt pkh - end ; - register1 S.frozen_balance begin fun ctxt pkh () () -> - Delegate.frozen_balance ctxt pkh - end ; - register1 S.frozen_balance_by_cycle begin fun ctxt pkh () () -> - Delegate.frozen_balance_by_cycle ctxt pkh >>= return - end ; - register1 S.staking_balance begin fun ctxt pkh () () -> - Delegate.staking_balance ctxt pkh - end ; - register1 S.delegated_contracts begin fun ctxt pkh () () -> - Delegate.delegated_contracts ctxt pkh >>= return - end ; - register1 S.delegated_balance begin fun ctxt pkh () () -> - Delegate.delegated_balance ctxt pkh - end ; - register1 S.deactivated begin fun ctxt pkh () () -> - Delegate.deactivated ctxt pkh - end ; - register1 S.grace_period begin fun ctxt pkh () () -> - Delegate.grace_period ctxt pkh - end + register0 S.list_delegate (fun ctxt q () -> + Delegate.list ctxt + >>= fun delegates -> + if q.active && q.inactive then return delegates + else if q.active then + filter_map_s + (fun pkh -> + Delegate.deactivated ctxt pkh + >>=? function true -> return_none | false -> return_some pkh) + delegates + else if q.inactive then + filter_map_s + (fun pkh -> + Delegate.deactivated ctxt pkh + >>=? function false -> return_none | true -> return_some pkh) + delegates + else return_nil) ; + register1 S.info (fun ctxt pkh () () -> + Delegate.full_balance ctxt pkh + >>=? fun balance -> + Delegate.frozen_balance ctxt pkh + >>=? fun frozen_balance -> + Delegate.frozen_balance_by_cycle ctxt pkh + >>= fun frozen_balance_by_cycle -> + Delegate.staking_balance ctxt pkh + >>=? fun staking_balance -> + Delegate.delegated_contracts ctxt pkh + >>= fun delegated_contracts -> + Delegate.delegated_balance ctxt pkh + >>=? fun delegated_balance -> + Delegate.deactivated ctxt pkh + >>=? fun deactivated -> + Delegate.grace_period ctxt pkh + >>=? fun grace_period -> + return + { + balance; + frozen_balance; + frozen_balance_by_cycle; + staking_balance; + delegated_contracts; + delegated_balance; + deactivated; + grace_period; + }) ; + register1 S.balance (fun ctxt pkh () () -> Delegate.full_balance ctxt pkh) ; + register1 S.frozen_balance (fun ctxt pkh () () -> + Delegate.frozen_balance ctxt pkh) ; + register1 S.frozen_balance_by_cycle (fun ctxt pkh () () -> + Delegate.frozen_balance_by_cycle ctxt pkh >>= return) ; + register1 S.staking_balance (fun ctxt pkh () () -> + Delegate.staking_balance ctxt pkh) ; + register1 S.delegated_contracts (fun ctxt pkh () () -> + Delegate.delegated_contracts ctxt pkh >>= return) ; + register1 S.delegated_balance (fun ctxt pkh () () -> + Delegate.delegated_balance ctxt pkh) ; + register1 S.deactivated (fun ctxt pkh () () -> Delegate.deactivated ctxt pkh) ; + register1 S.grace_period (fun ctxt pkh () () -> + Delegate.grace_period ctxt pkh) let list ctxt block ?(active = true) ?(inactive = false) () = - RPC_context.make_call0 S.list_delegate ctxt block { active ; inactive } () + RPC_context.make_call0 S.list_delegate ctxt block {active; inactive} () -let info ctxt block pkh = - RPC_context.make_call1 S.info ctxt block pkh () () +let info ctxt block pkh = RPC_context.make_call1 S.info ctxt block pkh () () let balance ctxt block pkh = RPC_context.make_call1 S.balance ctxt block pkh () () @@ -270,44 +284,43 @@ let grace_period ctxt block pkh = RPC_context.make_call1 S.grace_period ctxt block pkh () () let requested_levels ~default ctxt cycles levels = - match levels, cycles with - | [], [] -> + match (levels, cycles) with + | ([], []) -> return [default] - | levels, cycles -> + | (levels, cycles) -> (* explicitly fail when requested levels or cycle are in the past... or too far in the future... *) let levels = List.sort_uniq Level.compare - (List.concat (List.map (Level.from_raw ctxt) levels :: - List.map (Level.levels_in_cycle ctxt) cycles)) in + (List.concat + ( List.map (Level.from_raw ctxt) levels + :: List.map (Level.levels_in_cycle ctxt) cycles )) + in map_s (fun level -> - let current_level = Level.current ctxt in - if Level.(level <= current_level) then - return (level, None) - else - Baking.earlier_predecessor_timestamp - ctxt level >>=? fun timestamp -> - return (level, Some timestamp)) + let current_level = Level.current ctxt in + if Level.(level <= current_level) then return (level, None) + else + Baking.earlier_predecessor_timestamp ctxt level + >>=? fun timestamp -> return (level, Some timestamp)) levels module Baking_rights = struct - type t = { - level: Raw_level.t ; - delegate: Signature.Public_key_hash.t ; - priority: int ; - timestamp: Timestamp.t option ; + level : Raw_level.t; + delegate : Signature.Public_key_hash.t; + priority : int; + timestamp : Timestamp.t option; } let encoding = let open Data_encoding in conv - (fun { level ; delegate ; priority ; timestamp } -> - (level, delegate, priority, timestamp)) + (fun {level; delegate; priority; timestamp} -> + (level, delegate, priority, timestamp)) (fun (level, delegate, priority, timestamp) -> - { level ; delegate ; priority ; timestamp }) + {level; delegate; priority; timestamp}) (obj4 (req "level" Raw_level.encoding) (req "delegate" Signature.Public_key_hash.encoding) @@ -315,27 +328,26 @@ module Baking_rights = struct (opt "estimated_time" Timestamp.encoding)) module S = struct - open Data_encoding - let custom_root = - RPC_path.(open_root / "helpers" / "baking_rights") + let custom_root = RPC_path.(open_root / "helpers" / "baking_rights") type baking_rights_query = { - levels: Raw_level.t list ; - cycles: Cycle.t list ; - delegates: Signature.Public_key_hash.t list ; - max_priority: int option ; - all: bool ; + levels : Raw_level.t list; + cycles : Cycle.t list; + delegates : Signature.Public_key_hash.t list; + max_priority : int option; + all : bool; } let baking_rights_query = let open RPC_query in query (fun levels cycles delegates max_priority all -> - { levels ; cycles ; delegates ; max_priority ; all }) + {levels; cycles; delegates; max_priority; all}) |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels) |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles) - |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> t.delegates) + |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> + t.delegates) |+ opt_field "max_priority" RPC_arg.int (fun t -> t.max_priority) |+ flag "all" (fun t -> t.all) |> seal @@ -344,112 +356,114 @@ module Baking_rights = struct RPC_service.get_service ~description: "Retrieves the list of delegates allowed to bake a block.\n\ - By default, it gives the best baking priorities for bakers \ - that have at least one opportunity below the 64th priority \ - for the next block.\n\ - Parameters `level` and `cycle` can be used to specify the \ - (valid) level(s) in the past or future at which the baking \ - rights have to be returned. Parameter `delegate` can be \ - used to restrict the results to the given delegates. If \ - parameter `all` is set, all the baking opportunities for \ - each baker at each level are returned, instead of just the \ - first one.\n\ + By default, it gives the best baking priorities for bakers that \ + have at least one opportunity below the 64th priority for the next \ + block.\n\ + Parameters `level` and `cycle` can be used to specify the (valid) \ + level(s) in the past or future at which the baking rights have to \ + be returned. Parameter `delegate` can be used to restrict the \ + results to the given delegates. If parameter `all` is set, all the \ + baking opportunities for each baker at each level are returned, \ + instead of just the first one.\n\ Returns the list of baking slots. Also returns the minimal \ - timestamps that correspond to these slots. The timestamps \ - are omitted for levels in the past, and are only estimates \ - for levels later that the next block, based on the \ - hypothesis that all predecessor blocks were baked at the \ - first priority." - ~query: baking_rights_query - ~output: (list encoding) + timestamps that correspond to these slots. The timestamps are \ + omitted for levels in the past, and are only estimates for levels \ + later that the next block, based on the hypothesis that all \ + predecessor blocks were baked at the first priority." + ~query:baking_rights_query + ~output:(list encoding) custom_root - end let baking_priorities ctxt max_prio (level, pred_timestamp) = - Baking.baking_priorities ctxt level >>=? fun contract_list -> + Baking.baking_priorities ctxt level + >>=? fun contract_list -> let rec loop l acc priority = - if Compare.Int.(priority >= max_prio) then - return (List.rev acc) + if Compare.Int.(priority > max_prio) then return (List.rev acc) else - let Misc.LCons (pk, next) = l in + let (Misc.LCons (pk, next)) = l in let delegate = Signature.Public_key.hash pk in - begin - match pred_timestamp with - | None -> return_none - | Some pred_timestamp -> - Baking.minimal_time ctxt priority pred_timestamp >>=? fun t -> - return_some t - end>>=? fun timestamp -> + ( match pred_timestamp with + | None -> + return_none + | Some pred_timestamp -> + Baking.minimal_time ctxt priority pred_timestamp + >>=? fun t -> return_some t ) + >>=? fun timestamp -> let acc = - { level = level.level ; delegate ; priority ; timestamp } :: acc in - next () >>=? fun l -> - loop l acc (priority+1) in + {level = level.level; delegate; priority; timestamp} :: acc + in + next () >>=? fun l -> loop l acc (priority + 1) + in loop contract_list [] 0 let remove_duplicated_delegates rights = - List.rev @@ fst @@ - List.fold_left - (fun (acc, previous) r -> - if Signature.Public_key_hash.Set.mem r.delegate previous then - (acc, previous) - else - (r :: acc, - Signature.Public_key_hash.Set.add r.delegate previous)) - ([], Signature.Public_key_hash.Set.empty) - rights + List.rev @@ fst + @@ List.fold_left + (fun (acc, previous) r -> + if Signature.Public_key_hash.Set.mem r.delegate previous then + (acc, previous) + else + (r :: acc, Signature.Public_key_hash.Set.add r.delegate previous)) + ([], Signature.Public_key_hash.Set.empty) + rights let register () = let open Services_registration in - register0 S.baking_rights begin fun ctxt q () -> - requested_levels - ~default: - (Level.succ ctxt (Level.current ctxt), Some (Timestamp.current ctxt)) - ctxt q.cycles q.levels >>=? fun levels -> - let max_priority = - match q.max_priority with - | None -> 64 - | Some max -> max in - map_s (baking_priorities ctxt max_priority) levels >>=? fun rights -> - let rights = - if q.all then - rights - else - List.map remove_duplicated_delegates rights in - let rights = List.concat rights in - match q.delegates with - | [] -> return rights - | _ :: _ as delegates -> - let is_requested p = - List.exists (Signature.Public_key_hash.equal p.delegate) delegates in - return (List.filter is_requested rights) - end + register0 S.baking_rights (fun ctxt q () -> + requested_levels + ~default: + ( Level.succ ctxt (Level.current ctxt), + Some (Timestamp.current ctxt) ) + ctxt + q.cycles + q.levels + >>=? fun levels -> + let max_priority = + match q.max_priority with None -> 64 | Some max -> max + in + map_s (baking_priorities ctxt max_priority) levels + >>=? fun rights -> + let rights = + if q.all then rights else List.map remove_duplicated_delegates rights + in + let rights = List.concat rights in + match q.delegates with + | [] -> + return rights + | _ :: _ as delegates -> + let is_requested p = + List.exists + (Signature.Public_key_hash.equal p.delegate) + delegates + in + return (List.filter is_requested rights)) - let get ctxt - ?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false) + let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false) ?max_priority block = - RPC_context.make_call0 S.baking_rights ctxt block - { levels ; cycles ; delegates ; max_priority ; all } + RPC_context.make_call0 + S.baking_rights + ctxt + block + {levels; cycles; delegates; max_priority; all} () - end module Endorsing_rights = struct - type t = { - level: Raw_level.t ; - delegate: Signature.Public_key_hash.t ; - slots: int list ; - estimated_time: Time.t option ; + level : Raw_level.t; + delegate : Signature.Public_key_hash.t; + slots : int list; + estimated_time : Time.t option; } let encoding = let open Data_encoding in conv - (fun { level ; delegate ; slots ; estimated_time } -> - (level, delegate, slots, estimated_time)) + (fun {level; delegate; slots; estimated_time} -> + (level, delegate, slots, estimated_time)) (fun (level, delegate, slots, estimated_time) -> - { level ; delegate ; slots ; estimated_time }) + {level; delegate; slots; estimated_time}) (obj4 (req "level" Raw_level.encoding) (req "delegate" Signature.Public_key_hash.encoding) @@ -457,94 +471,97 @@ module Endorsing_rights = struct (opt "estimated_time" Timestamp.encoding)) module S = struct - open Data_encoding - let custom_root = - RPC_path.(open_root / "helpers" / "endorsing_rights") + let custom_root = RPC_path.(open_root / "helpers" / "endorsing_rights") type endorsing_rights_query = { - levels: Raw_level.t list ; - cycles: Cycle.t list ; - delegates: Signature.Public_key_hash.t list ; + levels : Raw_level.t list; + cycles : Cycle.t list; + delegates : Signature.Public_key_hash.t list; } let endorsing_rights_query = let open RPC_query in - query (fun levels cycles delegates -> - { levels ; cycles ; delegates }) + query (fun levels cycles delegates -> {levels; cycles; delegates}) |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels) |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles) - |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> t.delegates) + |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t -> + t.delegates) |> seal let endorsing_rights = RPC_service.get_service ~description: "Retrieves the delegates allowed to endorse a block.\n\ - By default, it gives the endorsement slots for delegates that \ - have at least one in the next block.\n\ - Parameters `level` and `cycle` can be used to specify the \ - (valid) level(s) in the past or future at which the \ - endorsement rights have to be returned. Parameter \ - `delegate` can be used to restrict the results to the given \ - delegates.\n\ - Returns the list of endorsement slots. Also returns the \ - minimal timestamps that correspond to these slots. The \ - timestamps are omitted for levels in the past, and are only \ - estimates for levels later that the next block, based on \ - the hypothesis that all predecessor blocks were baked at \ - the first priority." - ~query: endorsing_rights_query - ~output: (list encoding) + By default, it gives the endorsement slots for delegates that have \ + at least one in the next block.\n\ + Parameters `level` and `cycle` can be used to specify the (valid) \ + level(s) in the past or future at which the endorsement rights \ + have to be returned. Parameter `delegate` can be used to restrict \ + the results to the given delegates.\n\ + Returns the list of endorsement slots. Also returns the minimal \ + timestamps that correspond to these slots. The timestamps are \ + omitted for levels in the past, and are only estimates for levels \ + later that the next block, based on the hypothesis that all \ + predecessor blocks were baked at the first priority." + ~query:endorsing_rights_query + ~output:(list encoding) custom_root - end let endorsement_slots ctxt (level, estimated_time) = - Baking.endorsement_rights ctxt level >>=? fun rights -> + Baking.endorsement_rights ctxt level + >>=? fun rights -> return (Signature.Public_key_hash.Map.fold - (fun delegate (_, slots, _) acc -> { - level = level.level ; delegate ; slots ; estimated_time - } :: acc) - rights []) + (fun delegate (_, slots, _) acc -> + {level = level.level; delegate; slots; estimated_time} :: acc) + rights + []) let register () = let open Services_registration in - register0 S.endorsing_rights begin fun ctxt q () -> - requested_levels - ~default: (Level.current ctxt, Some (Timestamp.current ctxt)) - ctxt q.cycles q.levels >>=? fun levels -> - map_s (endorsement_slots ctxt) levels >>=? fun rights -> - let rights = List.concat rights in - match q.delegates with - | [] -> return rights - | _ :: _ as delegates -> - let is_requested p = - List.exists (Signature.Public_key_hash.equal p.delegate) delegates in - return (List.filter is_requested rights) - end + register0 S.endorsing_rights (fun ctxt q () -> + requested_levels + ~default:(Level.current ctxt, Some (Timestamp.current ctxt)) + ctxt + q.cycles + q.levels + >>=? fun levels -> + map_s (endorsement_slots ctxt) levels + >>=? fun rights -> + let rights = List.concat rights in + match q.delegates with + | [] -> + return rights + | _ :: _ as delegates -> + let is_requested p = + List.exists + (Signature.Public_key_hash.equal p.delegate) + delegates + in + return (List.filter is_requested rights)) - let get ctxt - ?(levels = []) ?(cycles = []) ?(delegates = []) block = - RPC_context.make_call0 S.endorsing_rights ctxt block - { levels ; cycles ; delegates } + let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) block = + RPC_context.make_call0 + S.endorsing_rights + ctxt + block + {levels; cycles; delegates} () - end module Endorsing_power = struct - let endorsing_power ctxt (operation, chain_id) = - let Operation_data data = operation.protocol_data in + let (Operation_data data) = operation.protocol_data in match data.contents with - | Single Endorsement _ -> - Baking.check_endorsement_rights ctxt chain_id { - shell = operation.shell ; - protocol_data = data ; - } >>=? fun (_, slots, _) -> - return (List.length slots) + | Single (Endorsement _) -> + Baking.check_endorsement_rights + ctxt + chain_id + {shell = operation.shell; protocol_data = data} + >>=? fun (_, slots, _) -> return (List.length slots) | _ -> failwith "Operation is not an endorsement" @@ -552,101 +569,98 @@ module Endorsing_power = struct let endorsing_power = let open Data_encoding in RPC_service.post_service - ~description:"Get the endorsing power of an endorsement, that is, \ - the number of slots that the endorser has" - ~query: RPC_query.empty - ~input: (obj2 - (req "endorsement_operation" Operation.encoding) - (req "chain_id" Chain_id.encoding)) - ~output: int31 + ~description: + "Get the endorsing power of an endorsement, that is, the number of \ + slots that the endorser has" + ~query:RPC_query.empty + ~input: + (obj2 + (req "endorsement_operation" Operation.encoding) + (req "chain_id" Chain_id.encoding)) + ~output:int31 RPC_path.(open_root / "endorsing_power") end let register () = let open Services_registration in - register0 S.endorsing_power begin fun ctxt () (op, chain_id) -> - endorsing_power ctxt (op, chain_id) - end + register0 S.endorsing_power (fun ctxt () (op, chain_id) -> + endorsing_power ctxt (op, chain_id)) let get ctxt block op chain_id = RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id) - end module Required_endorsements = struct - let required_endorsements ctxt block_delay = return (Baking.minimum_allowed_endorsements ctxt ~block_delay) module S = struct - - type t = { block_delay : Period.t } + type t = {block_delay : Period.t} let required_endorsements_query = let open RPC_query in - query (fun block_delay -> { block_delay }) - |+ field "block_delay" Period.rpc_arg Period.zero (fun t -> t.block_delay) + query (fun block_delay -> {block_delay}) + |+ field "block_delay" Period.rpc_arg Period.zero (fun t -> + t.block_delay) |> seal let required_endorsements = let open Data_encoding in RPC_service.get_service - ~description:"Minimum number of endorsements for a block to be \ - valid, given a delay of the block's timestamp with \ - respect to the minimum time to bake at the \ - block's priority" - ~query: required_endorsements_query - ~output: int31 + ~description: + "Minimum number of endorsements for a block to be valid, given a \ + delay of the block's timestamp with respect to the minimum time to \ + bake at the block's priority" + ~query:required_endorsements_query + ~output:int31 RPC_path.(open_root / "required_endorsements") end let register () = let open Services_registration in - register0 S.required_endorsements begin fun ctxt ({ block_delay }) () -> - required_endorsements ctxt block_delay - end + register0 S.required_endorsements (fun ctxt {block_delay} () -> + required_endorsements ctxt block_delay) let get ctxt block block_delay = - RPC_context.make_call0 S.required_endorsements ctxt block { block_delay } () - + RPC_context.make_call0 S.required_endorsements ctxt block {block_delay} () end module Minimal_valid_time = struct - let minimal_valid_time ctxt ~priority ~endorsing_power = - Baking.minimal_valid_time ctxt - ~priority ~endorsing_power + Baking.minimal_valid_time ctxt ~priority ~endorsing_power module S = struct - - type t = { priority : int ; - endorsing_power : int } + type t = {priority : int; endorsing_power : int} let minimal_valid_time_query = let open RPC_query in - query (fun priority endorsing_power -> - { priority ; endorsing_power }) + query (fun priority endorsing_power -> {priority; endorsing_power}) |+ field "priority" RPC_arg.int 0 (fun t -> t.priority) |+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power) |> seal let minimal_valid_time = RPC_service.get_service - ~description: "Minimal valid time for a block given a priority \ - and an endorsing power." - ~query: minimal_valid_time_query - ~output: Time.encoding + ~description: + "Minimal valid time for a block given a priority and an endorsing \ + power." + ~query:minimal_valid_time_query + ~output:Time.encoding RPC_path.(open_root / "minimal_valid_time") end let register () = let open Services_registration in - register0 S.minimal_valid_time begin fun ctxt { priority ; endorsing_power } () -> - minimal_valid_time ctxt ~priority ~endorsing_power - end + register0 S.minimal_valid_time (fun ctxt {priority; endorsing_power} () -> + minimal_valid_time ctxt ~priority ~endorsing_power) let get ctxt block priority endorsing_power = - RPC_context.make_call0 S.minimal_valid_time ctxt block { priority ; endorsing_power } () + RPC_context.make_call0 + S.minimal_valid_time + ctxt + block + {priority; endorsing_power} + () end let register () = @@ -658,17 +672,20 @@ let register () = Minimal_valid_time.register () let endorsement_rights ctxt level = - Endorsing_rights.endorsement_slots ctxt (level, None) >>=? fun l -> - return (List.map (fun { Endorsing_rights.delegate ; _ } -> delegate) l) + Endorsing_rights.endorsement_slots ctxt (level, None) + >>=? fun l -> + return (List.map (fun {Endorsing_rights.delegate; _} -> delegate) l) let baking_rights ctxt max_priority = let max = match max_priority with None -> 64 | Some m -> m in let level = Level.current ctxt in - Baking_rights.baking_priorities ctxt max (level, None) >>=? fun l -> - return (level.level, - List.map - (fun { Baking_rights.delegate ; timestamp ; _ } -> - (delegate, timestamp)) l) + Baking_rights.baking_priorities ctxt max (level, None) + >>=? fun l -> + return + ( level.level, + List.map + (fun {Baking_rights.delegate; timestamp; _} -> (delegate, timestamp)) + l ) let endorsing_power ctxt operation = Endorsing_power.endorsing_power ctxt operation diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli index 74b282b98..d2f7b5e7f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_services.mli @@ -25,78 +25,87 @@ open Alpha_context -val list: - 'a #RPC_context.simple -> 'a -> +val list : + 'a #RPC_context.simple -> + 'a -> ?active:bool -> ?inactive:bool -> - unit -> Signature.Public_key_hash.t list shell_tzresult Lwt.t + unit -> + Signature.Public_key_hash.t list shell_tzresult Lwt.t type info = { - balance: Tez.t ; - frozen_balance: Tez.t ; - frozen_balance_by_cycle: Delegate.frozen_balance Cycle.Map.t ; - staking_balance: Tez.t ; - delegated_contracts: Contract_repr.t list ; - delegated_balance: Tez.t ; - deactivated: bool ; - grace_period: Cycle.t ; + balance : Tez.t; + frozen_balance : Tez.t; + frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t; + staking_balance : Tez.t; + delegated_contracts : Contract_repr.t list; + delegated_balance : Tez.t; + deactivated : bool; + grace_period : Cycle.t; } -val info_encoding: info Data_encoding.t +val info_encoding : info Data_encoding.t -val info: - 'a #RPC_context.simple -> 'a -> +val info : + 'a #RPC_context.simple -> + 'a -> Signature.Public_key_hash.t -> info shell_tzresult Lwt.t -val balance: - 'a #RPC_context.simple -> 'a -> +val balance : + 'a #RPC_context.simple -> + 'a -> Signature.Public_key_hash.t -> Tez.t shell_tzresult Lwt.t -val frozen_balance: - 'a #RPC_context.simple -> 'a -> +val frozen_balance : + 'a #RPC_context.simple -> + 'a -> Signature.Public_key_hash.t -> Tez.t shell_tzresult Lwt.t -val frozen_balance_by_cycle: - 'a #RPC_context.simple -> 'a -> +val frozen_balance_by_cycle : + 'a #RPC_context.simple -> + 'a -> Signature.Public_key_hash.t -> Delegate.frozen_balance Cycle.Map.t shell_tzresult Lwt.t -val staking_balance: - 'a #RPC_context.simple -> 'a -> +val staking_balance : + 'a #RPC_context.simple -> + 'a -> Signature.Public_key_hash.t -> Tez.t shell_tzresult Lwt.t -val delegated_contracts: - 'a #RPC_context.simple -> 'a -> +val delegated_contracts : + 'a #RPC_context.simple -> + 'a -> Signature.Public_key_hash.t -> Contract_repr.t list shell_tzresult Lwt.t -val delegated_balance: - 'a #RPC_context.simple -> 'a -> +val delegated_balance : + 'a #RPC_context.simple -> + 'a -> Signature.Public_key_hash.t -> Tez.t shell_tzresult Lwt.t -val deactivated: - 'a #RPC_context.simple -> 'a -> +val deactivated : + 'a #RPC_context.simple -> + 'a -> Signature.Public_key_hash.t -> bool shell_tzresult Lwt.t -val grace_period: - 'a #RPC_context.simple -> 'a -> +val grace_period : + 'a #RPC_context.simple -> + 'a -> Signature.Public_key_hash.t -> Cycle.t shell_tzresult Lwt.t - module Baking_rights : sig - type t = { - level: Raw_level.t ; - delegate: Signature.Public_key_hash.t ; - priority: int ; - timestamp: Timestamp.t option ; + level : Raw_level.t; + delegate : Signature.Public_key_hash.t; + priority : int; + timestamp : Timestamp.t option; } (** Retrieves the list of delegates allowed to bake a block. @@ -117,24 +126,23 @@ module Baking_rights : sig omitted for levels in the past, and are only estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority. *) - val get: + val get : 'a #RPC_context.simple -> - ?levels: Raw_level.t list -> - ?cycles: Cycle.t list -> - ?delegates: Signature.public_key_hash list -> - ?all: bool -> - ?max_priority: int -> - 'a -> t list shell_tzresult Lwt.t - + ?levels:Raw_level.t list -> + ?cycles:Cycle.t list -> + ?delegates:Signature.public_key_hash list -> + ?all:bool -> + ?max_priority:int -> + 'a -> + t list shell_tzresult Lwt.t end module Endorsing_rights : sig - type t = { - level: Raw_level.t ; - delegate: Signature.Public_key_hash.t ; - slots: int list ; - estimated_time: Timestamp.t option ; + level : Raw_level.t; + delegate : Signature.Public_key_hash.t; + slots : int list; + estimated_time : Timestamp.t option; } (** Retrieves the delegates allowed to endorse a block. @@ -153,66 +161,51 @@ module Endorsing_rights : sig estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority. *) - val get: + val get : 'a #RPC_context.simple -> - ?levels: Raw_level.t list -> - ?cycles: Cycle.t list -> - ?delegates: Signature.public_key_hash list -> - 'a -> t list shell_tzresult Lwt.t - + ?levels:Raw_level.t list -> + ?cycles:Cycle.t list -> + ?delegates:Signature.public_key_hash list -> + 'a -> + t list shell_tzresult Lwt.t end module Endorsing_power : sig - - val get: - 'a #RPC_context.simple -> 'a -> + val get : + 'a #RPC_context.simple -> + 'a -> Alpha_context.packed_operation -> Chain_id.t -> int shell_tzresult Lwt.t - end module Required_endorsements : sig - - val get: - 'a #RPC_context.simple -> 'a -> - Period.t -> int shell_tzresult Lwt.t - + val get : + 'a #RPC_context.simple -> 'a -> Period.t -> int shell_tzresult Lwt.t end module Minimal_valid_time : sig - - val get: - 'a #RPC_context.simple -> 'a -> - int -> int -> Time.t shell_tzresult Lwt.t - + val get : + 'a #RPC_context.simple -> 'a -> int -> int -> Time.t shell_tzresult Lwt.t end (* temporary export for deprecated unit test *) -val endorsement_rights: - Alpha_context.t -> - Level.t -> - public_key_hash list tzresult Lwt.t +val endorsement_rights : + Alpha_context.t -> Level.t -> public_key_hash list tzresult Lwt.t -val baking_rights: +val baking_rights : Alpha_context.t -> int option -> (Raw_level.t * (public_key_hash * Time.t option) list) tzresult Lwt.t -val endorsing_power: +val endorsing_power : Alpha_context.t -> - (Alpha_context.packed_operation * Chain_id.t) -> + Alpha_context.packed_operation * Chain_id.t -> int tzresult Lwt.t -val required_endorsements: - Alpha_context.t -> - Alpha_context.Period.t -> - int tzresult Lwt.t +val required_endorsements : + Alpha_context.t -> Alpha_context.Period.t -> int tzresult Lwt.t -val minimal_valid_time: - Alpha_context.t -> - int -> - int -> - Time.t tzresult Lwt.t +val minimal_valid_time : Alpha_context.t -> int -> int -> Time.t tzresult Lwt.t -val register: unit -> unit +val register : unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml index c8d5e878b..0515b47b6 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.ml @@ -31,92 +31,101 @@ type balance = let balance_encoding = let open Data_encoding in - def "operation_metadata.alpha.balance" @@ - union - [ case (Tag 0) - ~title:"Contract" - (obj2 - (req "kind" (constant "contract")) - (req "contract" Contract_repr.encoding)) - (function Contract c -> Some ((), c) | _ -> None ) - (fun ((), c) -> (Contract c)) ; - case (Tag 1) - ~title:"Rewards" - (obj4 - (req "kind" (constant "freezer")) - (req "category" (constant "rewards")) - (req "delegate" Signature.Public_key_hash.encoding) - (req "cycle" Cycle_repr.encoding)) - (function Rewards (d, l) -> Some ((), (), d, l) | _ -> None) - (fun ((), (), d, l) -> Rewards (d, l)) ; - case (Tag 2) - ~title:"Fees" - (obj4 - (req "kind" (constant "freezer")) - (req "category" (constant "fees")) - (req "delegate" Signature.Public_key_hash.encoding) - (req "cycle" Cycle_repr.encoding)) - (function Fees (d, l) -> Some ((), (), d, l) | _ -> None) - (fun ((), (), d, l) -> Fees (d, l)) ; - case (Tag 3) - ~title:"Deposits" - (obj4 - (req "kind" (constant "freezer")) - (req "category" (constant "deposits")) - (req "delegate" Signature.Public_key_hash.encoding) - (req "cycle" Cycle_repr.encoding)) - (function Deposits (d, l) -> Some ((), (), d, l) | _ -> None) - (fun ((), (), d, l) -> Deposits (d, l)) ] + def "operation_metadata.alpha.balance" + @@ union + [ case + (Tag 0) + ~title:"Contract" + (obj2 + (req "kind" (constant "contract")) + (req "contract" Contract_repr.encoding)) + (function Contract c -> Some ((), c) | _ -> None) + (fun ((), c) -> Contract c); + case + (Tag 1) + ~title:"Rewards" + (obj4 + (req "kind" (constant "freezer")) + (req "category" (constant "rewards")) + (req "delegate" Signature.Public_key_hash.encoding) + (req "cycle" Cycle_repr.encoding)) + (function Rewards (d, l) -> Some ((), (), d, l) | _ -> None) + (fun ((), (), d, l) -> Rewards (d, l)); + case + (Tag 2) + ~title:"Fees" + (obj4 + (req "kind" (constant "freezer")) + (req "category" (constant "fees")) + (req "delegate" Signature.Public_key_hash.encoding) + (req "cycle" Cycle_repr.encoding)) + (function Fees (d, l) -> Some ((), (), d, l) | _ -> None) + (fun ((), (), d, l) -> Fees (d, l)); + case + (Tag 3) + ~title:"Deposits" + (obj4 + (req "kind" (constant "freezer")) + (req "category" (constant "deposits")) + (req "delegate" Signature.Public_key_hash.encoding) + (req "cycle" Cycle_repr.encoding)) + (function Deposits (d, l) -> Some ((), (), d, l) | _ -> None) + (fun ((), (), d, l) -> Deposits (d, l)) ] -type balance_update = - | Debited of Tez_repr.t - | Credited of Tez_repr.t +type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t let balance_update_encoding = let open Data_encoding in - def "operation_metadata.alpha.balance_update" @@ - obj1 - (req "change" - (conv - (function - | Credited v -> Tez_repr.to_mutez v - | Debited v -> Int64.neg (Tez_repr.to_mutez v)) - (Json.wrap_error @@ - fun v -> - if Compare.Int64.(v < 0L) then - match Tez_repr.of_mutez (Int64.neg v) with - | Some v -> Debited v - | None -> failwith "Qty.of_mutez" - else - match Tez_repr.of_mutez v with - | Some v -> Credited v - | None -> failwith "Qty.of_mutez") - int64)) + def "operation_metadata.alpha.balance_update" + @@ obj1 + (req + "change" + (conv + (function + | Credited v -> + Tez_repr.to_mutez v + | Debited v -> + Int64.neg (Tez_repr.to_mutez v)) + ( Json.wrap_error + @@ fun v -> + if Compare.Int64.(v < 0L) then + match Tez_repr.of_mutez (Int64.neg v) with + | Some v -> + Debited v + | None -> + failwith "Qty.of_mutez" + else + match Tez_repr.of_mutez v with + | Some v -> + Credited v + | None -> + failwith "Qty.of_mutez" ) + int64)) type balance_updates = (balance * balance_update) list let balance_updates_encoding = let open Data_encoding in - def "operation_metadata.alpha.balance_updates" @@ - list (merge_objs balance_encoding balance_update_encoding) + def "operation_metadata.alpha.balance_updates" + @@ list (merge_objs balance_encoding balance_update_encoding) let cleanup_balance_updates balance_updates = List.filter (fun (_, (Credited update | Debited update)) -> - not (Tez_repr.equal update Tez_repr.zero)) + not (Tez_repr.equal update Tez_repr.zero)) balance_updates type frozen_balance = { - deposit : Tez_repr.t ; - fees : Tez_repr.t ; - rewards : Tez_repr.t ; + deposit : Tez_repr.t; + fees : Tez_repr.t; + rewards : Tez_repr.t; } let frozen_balance_encoding = let open Data_encoding in conv - (fun { deposit ; fees ; rewards } -> (deposit, fees, rewards)) - (fun (deposit, fees, rewards) -> { deposit ; fees ; rewards }) + (fun {deposit; fees; rewards} -> (deposit, fees, rewards)) + (fun (deposit, fees, rewards) -> {deposit; fees; rewards}) (obj3 (req "deposit" Tez_repr.encoding) (req "fees" Tez_repr.encoding) @@ -127,10 +136,13 @@ type error += | Active_delegate (* `Temporary *) | Current_delegate (* `Temporary *) | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *) - | Balance_too_low_for_deposit of - { delegate : Signature.Public_key_hash.t ; - deposit : Tez_repr.t ; - balance : Tez_repr.t } (* `Temporary *) + | Balance_too_low_for_deposit of { + delegate : Signature.Public_key_hash.t; + deposit : Tez_repr.t; + balance : Tez_repr.t; + } + +(* `Temporary *) let () = register_error_kind @@ -139,8 +151,11 @@ let () = ~title:"Forbidden delegate deletion" ~description:"Tried to unregister a delegate" ~pp:(fun ppf delegate -> - Format.fprintf ppf "Delegate deletion is forbidden (%a)" - Signature.Public_key_hash.pp delegate) + Format.fprintf + ppf + "Delegate deletion is forbidden (%a)" + Signature.Public_key_hash.pp + delegate) Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) (function No_deletion c -> Some c | _ -> None) (fun c -> No_deletion c) ; @@ -150,8 +165,7 @@ let () = ~title:"Delegate already active" ~description:"Useless delegate reactivation" ~pp:(fun ppf () -> - Format.fprintf ppf - "The delegate is still active, no need to refresh it") + Format.fprintf ppf "The delegate is still active, no need to refresh it") Data_encoding.empty (function Active_delegate -> Some () | _ -> None) (fun () -> Active_delegate) ; @@ -161,8 +175,9 @@ let () = ~title:"Unchanged delegated" ~description:"Contract already delegated to the given delegate" ~pp:(fun ppf () -> - Format.fprintf ppf - "The contract is already delegated to the same delegate") + Format.fprintf + ppf + "The contract is already delegated to the same delegate") Data_encoding.empty (function Current_delegate -> Some () | _ -> None) (fun () -> Current_delegate) ; @@ -170,12 +185,15 @@ let () = `Permanent ~id:"delegate.empty_delegate_account" ~title:"Empty delegate account" - ~description:"Cannot register a delegate when its implicit account is empty" + ~description: + "Cannot register a delegate when its implicit account is empty" ~pp:(fun ppf delegate -> - Format.fprintf ppf - "Delegate registration is forbidden when the delegate - implicit account is empty (%a)" - Signature.Public_key_hash.pp delegate) + Format.fprintf + ppf + "Delegate registration is forbidden when the delegate\n\ + \ implicit account is empty (%a)" + Signature.Public_key_hash.pp + delegate) Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) (function Empty_delegate_account c -> Some c | _ -> None) (fun c -> Empty_delegate_account c) ; @@ -185,392 +203,474 @@ let () = ~title:"Balance too low for deposit" ~description:"Cannot freeze deposit when the balance is too low" ~pp:(fun ppf (delegate, balance, deposit) -> - Format.fprintf ppf - "Delegate %a has a too low balance (%a) to deposit %a" - Signature.Public_key_hash.pp delegate - Tez_repr.pp balance - Tez_repr.pp deposit) - Data_encoding. - (obj3 - (req "delegate" Signature.Public_key_hash.encoding) - (req "balance" Tez_repr.encoding) - (req "deposit" Tez_repr.encoding)) - (function Balance_too_low_for_deposit { delegate ; balance ; deposit } -> - Some (delegate, balance, deposit) | _ -> None) - (fun (delegate, balance, deposit) -> Balance_too_low_for_deposit { delegate ; balance ; deposit } ) + Format.fprintf + ppf + "Delegate %a has a too low balance (%a) to deposit %a" + Signature.Public_key_hash.pp + delegate + Tez_repr.pp + balance + Tez_repr.pp + deposit) + Data_encoding.( + obj3 + (req "delegate" Signature.Public_key_hash.encoding) + (req "balance" Tez_repr.encoding) + (req "deposit" Tez_repr.encoding)) + (function + | Balance_too_low_for_deposit {delegate; balance; deposit} -> + Some (delegate, balance, deposit) + | _ -> + None) + (fun (delegate, balance, deposit) -> + Balance_too_low_for_deposit {delegate; balance; deposit}) let link c contract delegate = - Storage.Contract.Balance.get c contract >>=? fun balance -> - Roll_storage.Delegate.add_amount c delegate balance >>=? fun c -> - Storage.Contract.Delegated.add (c, Contract_repr.implicit_contract delegate) contract >>= fun c -> - return c + Storage.Contract.Balance.get c contract + >>=? fun balance -> + Roll_storage.Delegate.add_amount c delegate balance + >>=? fun c -> + Storage.Contract.Delegated.add + (c, Contract_repr.implicit_contract delegate) + contract + >>= fun c -> return c let unlink c contract = - Storage.Contract.Balance.get c contract >>=? fun balance -> - Storage.Contract.Delegate.get_option c contract >>=? function - | None -> return c + Storage.Contract.Balance.get c contract + >>=? fun balance -> + Storage.Contract.Delegate.get_option c contract + >>=? function + | None -> + return c | Some delegate -> (* Removes the balance of the contract from the delegate *) - Roll_storage.Delegate.remove_amount c delegate balance >>=? fun c -> - Storage.Contract.Delegated.del (c, Contract_repr.implicit_contract delegate) contract >>= fun c -> - return c + Roll_storage.Delegate.remove_amount c delegate balance + >>=? fun c -> + Storage.Contract.Delegated.del + (c, Contract_repr.implicit_contract delegate) + contract + >>= fun c -> return c let known c delegate = Storage.Contract.Manager.get_option - c (Contract_repr.implicit_contract delegate) >>=? function - | None | Some (Manager_repr.Hash _) -> return_false - | Some (Manager_repr.Public_key _) -> return_true + c + (Contract_repr.implicit_contract delegate) + >>=? function + | None | Some (Manager_repr.Hash _) -> + return_false + | Some (Manager_repr.Public_key _) -> + return_true (* A delegate is registered if its "implicit account" delegates to itself. *) let registered c delegate = Storage.Contract.Delegate.get_option - c (Contract_repr.implicit_contract delegate) >>=? function + c + (Contract_repr.implicit_contract delegate) + >>=? function | Some current_delegate -> return @@ Signature.Public_key_hash.equal delegate current_delegate | None -> return_false let init ctxt contract delegate = - known ctxt delegate >>=? fun known_delegate -> - fail_unless - known_delegate - (Roll_storage.Unregistered_delegate delegate) >>=? fun () -> - registered ctxt delegate >>=? fun is_registered -> - fail_unless - is_registered - (Roll_storage.Unregistered_delegate delegate) >>=? fun () -> - Storage.Contract.Delegate.init ctxt contract delegate >>=? fun ctxt -> - link ctxt contract delegate + known ctxt delegate + >>=? fun known_delegate -> + fail_unless known_delegate (Roll_storage.Unregistered_delegate delegate) + >>=? fun () -> + registered ctxt delegate + >>=? fun is_registered -> + fail_unless is_registered (Roll_storage.Unregistered_delegate delegate) + >>=? fun () -> + Storage.Contract.Delegate.init ctxt contract delegate + >>=? fun ctxt -> link ctxt contract delegate let get = Roll_storage.get_contract_delegate let set c contract delegate = match delegate with - | None -> begin + | None -> ( let delete () = - unlink c contract >>=? fun c -> - Storage.Contract.Delegate.remove c contract >>= fun c -> - return c in + unlink c contract + >>=? fun c -> + Storage.Contract.Delegate.remove c contract >>= fun c -> return c + in match Contract_repr.is_implicit contract with | Some pkh -> (* check if contract is a registered delegate *) - registered c pkh >>=? fun is_registered -> - if is_registered then - fail (No_deletion pkh) - else - delete () - | None -> delete () - end + registered c pkh + >>=? fun is_registered -> + if is_registered then fail (No_deletion pkh) else delete () + | None -> + delete () ) | Some delegate -> - known c delegate >>=? fun known_delegate -> - registered c delegate >>=? fun registered_delegate -> + known c delegate + >>=? fun known_delegate -> + registered c delegate + >>=? fun registered_delegate -> let self_delegation = match Contract_repr.is_implicit contract with - | Some pkh -> Signature.Public_key_hash.equal pkh delegate - | None -> false in - if not known_delegate || not (registered_delegate || self_delegation) then - fail (Roll_storage.Unregistered_delegate delegate) + | Some pkh -> + Signature.Public_key_hash.equal pkh delegate + | None -> + false + in + if (not known_delegate) || not (registered_delegate || self_delegation) + then fail (Roll_storage.Unregistered_delegate delegate) else - begin - Storage.Contract.Delegate.get_option c contract >>=? function - | Some current_delegate - when Signature.Public_key_hash.equal delegate current_delegate -> - if self_delegation then - Roll_storage.Delegate.is_inactive c delegate >>=? function - | true -> return_unit - | false -> fail Active_delegate - else - fail Current_delegate - | None | Some _ -> return_unit - end >>=? fun () -> + Storage.Contract.Delegate.get_option c contract + >>=? (function + | Some current_delegate + when Signature.Public_key_hash.equal delegate current_delegate + -> + if self_delegation then + Roll_storage.Delegate.is_inactive c delegate + >>=? function + | true -> return_unit | false -> fail Active_delegate + else fail Current_delegate + | None | Some _ -> + return_unit) + >>=? fun () -> (* check if contract is a registered delegate *) - begin - match Contract_repr.is_implicit contract with - | Some pkh -> - registered c pkh >>=? fun is_registered -> - (* allow self-delegation to re-activate *) - if not self_delegation && is_registered then - fail (No_deletion pkh) - else - return_unit - | None -> - return_unit - end >>=? fun () -> - Storage.Contract.Balance.mem c contract >>= fun exists -> + ( match Contract_repr.is_implicit contract with + | Some pkh -> + registered c pkh + >>=? fun is_registered -> + (* allow self-delegation to re-activate *) + if (not self_delegation) && is_registered then + fail (No_deletion pkh) + else return_unit + | None -> + return_unit ) + >>=? fun () -> + Storage.Contract.Balance.mem c contract + >>= fun exists -> fail_when (self_delegation && not exists) - (Empty_delegate_account delegate) >>=? fun () -> - unlink c contract >>=? fun c -> - Storage.Contract.Delegate.init_set c contract delegate >>= fun c -> - link c contract delegate >>=? fun c -> - begin - if self_delegation then - Storage.Delegates.add c delegate >>= fun c -> - Roll_storage.Delegate.set_active c delegate >>=? fun c -> - return c - else - return c - end >>=? fun c -> - return c + (Empty_delegate_account delegate) + >>=? fun () -> + unlink c contract + >>=? fun c -> + Storage.Contract.Delegate.init_set c contract delegate + >>= fun c -> + link c contract delegate + >>=? fun c -> + ( if self_delegation then + Storage.Delegates.add c delegate + >>= fun c -> + Roll_storage.Delegate.set_active c delegate >>=? fun c -> return c + else return c ) + >>=? fun c -> return c -let remove ctxt contract = - unlink ctxt contract +let remove ctxt contract = unlink ctxt contract let delegated_contracts ctxt delegate = let contract = Contract_repr.implicit_contract delegate in Storage.Contract.Delegated.elements (ctxt, contract) let get_frozen_deposit ctxt contract cycle = - Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle >>=? function - | None -> return Tez_repr.zero - | Some frozen -> return frozen + Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle + >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen let credit_frozen_deposit ctxt delegate cycle amount = let contract = Contract_repr.implicit_contract delegate in - get_frozen_deposit ctxt contract cycle >>=? fun old_amount -> - Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount -> - Storage.Contract.Frozen_deposits.init_set - (ctxt, contract) cycle new_amount >>= fun ctxt -> - Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt -> - return ctxt + get_frozen_deposit ctxt contract cycle + >>=? fun old_amount -> + Lwt.return Tez_repr.(old_amount +? amount) + >>=? fun new_amount -> + Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle new_amount + >>= fun ctxt -> + Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate + >>= fun ctxt -> return ctxt let freeze_deposit ctxt delegate amount = - let { Level_repr.cycle ; _ } = Level_storage.current ctxt in - Roll_storage.Delegate.set_active ctxt delegate >>=? fun ctxt -> + let {Level_repr.cycle; _} = Level_storage.current ctxt in + Roll_storage.Delegate.set_active ctxt delegate + >>=? fun ctxt -> let contract = Contract_repr.implicit_contract delegate in - Storage.Contract.Balance.get ctxt contract >>=? fun balance -> + Storage.Contract.Balance.get ctxt contract + >>=? fun balance -> Lwt.return - (record_trace (Balance_too_low_for_deposit { delegate; deposit = amount; balance }) - Tez_repr.(balance -? amount)) >>=? fun new_balance -> - Storage.Contract.Balance.set ctxt contract new_balance >>=? fun ctxt -> - credit_frozen_deposit ctxt delegate cycle amount + (record_trace + (Balance_too_low_for_deposit {delegate; deposit = amount; balance}) + Tez_repr.(balance -? amount)) + >>=? fun new_balance -> + Storage.Contract.Balance.set ctxt contract new_balance + >>=? fun ctxt -> credit_frozen_deposit ctxt delegate cycle amount let get_frozen_fees ctxt contract cycle = - Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle >>=? function - | None -> return Tez_repr.zero - | Some frozen -> return frozen + Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle + >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen let credit_frozen_fees ctxt delegate cycle amount = let contract = Contract_repr.implicit_contract delegate in - get_frozen_fees ctxt contract cycle >>=? fun old_amount -> - Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount -> - Storage.Contract.Frozen_fees.init_set - (ctxt, contract) cycle new_amount >>= fun ctxt -> - Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt -> - return ctxt + get_frozen_fees ctxt contract cycle + >>=? fun old_amount -> + Lwt.return Tez_repr.(old_amount +? amount) + >>=? fun new_amount -> + Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount + >>= fun ctxt -> + Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate + >>= fun ctxt -> return ctxt let freeze_fees ctxt delegate amount = - let { Level_repr.cycle ; _ } = Level_storage.current ctxt in - Roll_storage.Delegate.add_amount ctxt delegate amount >>=? fun ctxt -> - credit_frozen_fees ctxt delegate cycle amount + let {Level_repr.cycle; _} = Level_storage.current ctxt in + Roll_storage.Delegate.add_amount ctxt delegate amount + >>=? fun ctxt -> credit_frozen_fees ctxt delegate cycle amount let burn_fees ctxt delegate cycle amount = let contract = Contract_repr.implicit_contract delegate in - get_frozen_fees ctxt contract cycle >>=? fun old_amount -> - begin - match Tez_repr.(old_amount -? amount) with - | Ok new_amount -> - Roll_storage.Delegate.remove_amount - ctxt delegate amount >>=? fun ctxt -> - return (new_amount, ctxt) - | Error _ -> - Roll_storage.Delegate.remove_amount - ctxt delegate old_amount >>=? fun ctxt -> - return (Tez_repr.zero, ctxt) - end >>=? fun (new_amount, ctxt) -> - Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount >>= fun ctxt -> - return ctxt - + get_frozen_fees ctxt contract cycle + >>=? fun old_amount -> + ( match Tez_repr.(old_amount -? amount) with + | Ok new_amount -> + Roll_storage.Delegate.remove_amount ctxt delegate amount + >>=? fun ctxt -> return (new_amount, ctxt) + | Error _ -> + Roll_storage.Delegate.remove_amount ctxt delegate old_amount + >>=? fun ctxt -> return (Tez_repr.zero, ctxt) ) + >>=? fun (new_amount, ctxt) -> + Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount + >>= fun ctxt -> return ctxt let get_frozen_rewards ctxt contract cycle = - Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle >>=? function - | None -> return Tez_repr.zero - | Some frozen -> return frozen + Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle + >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen let credit_frozen_rewards ctxt delegate cycle amount = let contract = Contract_repr.implicit_contract delegate in - get_frozen_rewards ctxt contract cycle >>=? fun old_amount -> - Lwt.return Tez_repr.(old_amount +? amount) >>=? fun new_amount -> - Storage.Contract.Frozen_rewards.init_set - (ctxt, contract) cycle new_amount >>= fun ctxt -> - Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate >>= fun ctxt -> - return ctxt + get_frozen_rewards ctxt contract cycle + >>=? fun old_amount -> + Lwt.return Tez_repr.(old_amount +? amount) + >>=? fun new_amount -> + Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount + >>= fun ctxt -> + Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate + >>= fun ctxt -> return ctxt let freeze_rewards ctxt delegate amount = - let { Level_repr.cycle ; _ } = Level_storage.current ctxt in + let {Level_repr.cycle; _} = Level_storage.current ctxt in credit_frozen_rewards ctxt delegate cycle amount let burn_rewards ctxt delegate cycle amount = let contract = Contract_repr.implicit_contract delegate in - get_frozen_rewards ctxt contract cycle >>=? fun old_amount -> + get_frozen_rewards ctxt contract cycle + >>=? fun old_amount -> let new_amount = match Tez_repr.(old_amount -? amount) with - | Error _ -> Tez_repr.zero - | Ok new_amount -> new_amount in - Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount >>= fun ctxt -> - return ctxt - - + | Error _ -> + Tez_repr.zero + | Ok new_amount -> + new_amount + in + Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount + >>= fun ctxt -> return ctxt let unfreeze ctxt delegate cycle = let contract = Contract_repr.implicit_contract delegate in - get_frozen_deposit ctxt contract cycle >>=? fun deposit -> - get_frozen_fees ctxt contract cycle >>=? fun fees -> - get_frozen_rewards ctxt contract cycle >>=? fun rewards -> - Storage.Contract.Balance.get ctxt contract >>=? fun balance -> - Lwt.return Tez_repr.(deposit +? fees) >>=? fun unfrozen_amount -> - Lwt.return Tez_repr.(unfrozen_amount +? rewards) >>=? fun unfrozen_amount -> - Lwt.return Tez_repr.(balance +? unfrozen_amount) >>=? fun balance -> - Storage.Contract.Balance.set ctxt contract balance >>=? fun ctxt -> - Roll_storage.Delegate.add_amount ctxt delegate rewards >>=? fun ctxt -> - Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle >>= fun ctxt -> - Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle >>= fun ctxt -> - Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle >>= fun ctxt -> - return (ctxt, (cleanup_balance_updates - [(Deposits (delegate, cycle), Debited deposit) ; - (Fees (delegate, cycle), Debited fees) ; - (Rewards (delegate, cycle), Debited rewards) ; - (Contract (Contract_repr.implicit_contract delegate), Credited unfrozen_amount)])) + get_frozen_deposit ctxt contract cycle + >>=? fun deposit -> + get_frozen_fees ctxt contract cycle + >>=? fun fees -> + get_frozen_rewards ctxt contract cycle + >>=? fun rewards -> + Storage.Contract.Balance.get ctxt contract + >>=? fun balance -> + Lwt.return Tez_repr.(deposit +? fees) + >>=? fun unfrozen_amount -> + Lwt.return Tez_repr.(unfrozen_amount +? rewards) + >>=? fun unfrozen_amount -> + Lwt.return Tez_repr.(balance +? unfrozen_amount) + >>=? fun balance -> + Storage.Contract.Balance.set ctxt contract balance + >>=? fun ctxt -> + Roll_storage.Delegate.add_amount ctxt delegate rewards + >>=? fun ctxt -> + Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle + >>= fun ctxt -> + Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle + >>= fun ctxt -> + Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle + >>= fun ctxt -> + return + ( ctxt, + cleanup_balance_updates + [ (Deposits (delegate, cycle), Debited deposit); + (Fees (delegate, cycle), Debited fees); + (Rewards (delegate, cycle), Debited rewards); + ( Contract (Contract_repr.implicit_contract delegate), + Credited unfrozen_amount ) ] ) let cycle_end ctxt last_cycle unrevealed = let preserved = Constants_storage.preserved_cycles ctxt in - begin - match Cycle_repr.pred last_cycle with - | None -> return (ctxt,[]) - | Some revealed_cycle -> - List.fold_left - (fun acc (u : Nonce_storage.unrevealed) -> - acc >>=? fun (ctxt, balance_updates) -> - burn_fees - ctxt u.delegate revealed_cycle u.fees >>=? fun ctxt -> - burn_rewards - ctxt u.delegate revealed_cycle u.rewards >>=? fun ctxt -> - let bus = [(Fees (u.delegate, revealed_cycle), Debited u.fees); - (Rewards (u.delegate, revealed_cycle), Debited u.rewards)] in - return (ctxt, bus @ balance_updates)) - (return (ctxt,[])) unrevealed - end >>=? fun (ctxt, balance_updates) -> + ( match Cycle_repr.pred last_cycle with + | None -> + return (ctxt, []) + | Some revealed_cycle -> + List.fold_left + (fun acc (u : Nonce_storage.unrevealed) -> + acc + >>=? fun (ctxt, balance_updates) -> + burn_fees ctxt u.delegate revealed_cycle u.fees + >>=? fun ctxt -> + burn_rewards ctxt u.delegate revealed_cycle u.rewards + >>=? fun ctxt -> + let bus = + [ (Fees (u.delegate, revealed_cycle), Debited u.fees); + (Rewards (u.delegate, revealed_cycle), Debited u.rewards) ] + in + return (ctxt, bus @ balance_updates)) + (return (ctxt, [])) + unrevealed ) + >>=? fun (ctxt, balance_updates) -> match Cycle_repr.sub last_cycle preserved with - | None -> return (ctxt, balance_updates, []) + | None -> + return (ctxt, balance_updates, []) | Some unfrozen_cycle -> - Storage.Delegates_with_frozen_balance.fold (ctxt, unfrozen_cycle) + Storage.Delegates_with_frozen_balance.fold + (ctxt, unfrozen_cycle) ~init:(Ok (ctxt, balance_updates)) ~f:(fun delegate acc -> - Lwt.return acc >>=? fun (ctxt, bus) -> - unfreeze ctxt - delegate unfrozen_cycle >>=? fun (ctxt, balance_updates) -> - return (ctxt, balance_updates @ bus)) >>=? fun (ctxt, balance_updates) -> - Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle) >>= fun ctxt -> - Storage.Active_delegates_with_rolls.fold ctxt + Lwt.return acc + >>=? fun (ctxt, bus) -> + unfreeze ctxt delegate unfrozen_cycle + >>=? fun (ctxt, balance_updates) -> + return (ctxt, balance_updates @ bus)) + >>=? fun (ctxt, balance_updates) -> + Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle) + >>= fun ctxt -> + Storage.Active_delegates_with_rolls.fold + ctxt ~init:(Ok (ctxt, [])) ~f:(fun delegate acc -> - Lwt.return acc >>=? fun (ctxt, deactivated) -> - Storage.Contract.Delegate_desactivation.get ctxt - (Contract_repr.implicit_contract delegate) >>=? fun cycle -> - if Cycle_repr.(cycle <= last_cycle) then - Roll_storage.Delegate.set_inactive ctxt delegate >>=? fun ctxt -> - return (ctxt, delegate :: deactivated) - else - return (ctxt, deactivated)) >>=? fun (ctxt, deactivated) -> + Lwt.return acc + >>=? fun (ctxt, deactivated) -> + Storage.Contract.Delegate_desactivation.get + ctxt + (Contract_repr.implicit_contract delegate) + >>=? fun cycle -> + if Cycle_repr.(cycle <= last_cycle) then + Roll_storage.Delegate.set_inactive ctxt delegate + >>=? fun ctxt -> return (ctxt, delegate :: deactivated) + else return (ctxt, deactivated)) + >>=? fun (ctxt, deactivated) -> return (ctxt, balance_updates, deactivated) let punish ctxt delegate cycle = let contract = Contract_repr.implicit_contract delegate in - get_frozen_deposit ctxt contract cycle >>=? fun deposit -> - get_frozen_fees ctxt contract cycle >>=? fun fees -> - get_frozen_rewards ctxt contract cycle >>=? fun rewards -> - Roll_storage.Delegate.remove_amount ctxt delegate deposit >>=? fun ctxt -> - Roll_storage.Delegate.remove_amount ctxt delegate fees >>=? fun ctxt -> + get_frozen_deposit ctxt contract cycle + >>=? fun deposit -> + get_frozen_fees ctxt contract cycle + >>=? fun fees -> + get_frozen_rewards ctxt contract cycle + >>=? fun rewards -> + Roll_storage.Delegate.remove_amount ctxt delegate deposit + >>=? fun ctxt -> + Roll_storage.Delegate.remove_amount ctxt delegate fees + >>=? fun ctxt -> (* Rewards are not accounted in the delegate's rolls yet... *) - Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle >>= fun ctxt -> - Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle >>= fun ctxt -> - Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle >>= fun ctxt -> - return (ctxt, { deposit ; fees ; rewards }) - + Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle + >>= fun ctxt -> + Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle + >>= fun ctxt -> + Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle + >>= fun ctxt -> return (ctxt, {deposit; fees; rewards}) let has_frozen_balance ctxt delegate cycle = let contract = Contract_repr.implicit_contract delegate in - get_frozen_deposit ctxt contract cycle >>=? fun deposit -> + get_frozen_deposit ctxt contract cycle + >>=? fun deposit -> if Tez_repr.(deposit <> zero) then return_true else - get_frozen_fees ctxt contract cycle >>=? fun fees -> + get_frozen_fees ctxt contract cycle + >>=? fun fees -> if Tez_repr.(fees <> zero) then return_true else - get_frozen_rewards ctxt contract cycle >>=? fun rewards -> - return Tez_repr.(rewards <> zero) + get_frozen_rewards ctxt contract cycle + >>=? fun rewards -> return Tez_repr.(rewards <> zero) let frozen_balance_by_cycle_encoding = let open Data_encoding in conv - (Cycle_repr.Map.bindings) + Cycle_repr.Map.bindings (List.fold_left (fun m (c, b) -> Cycle_repr.Map.add c b m) Cycle_repr.Map.empty) - (list (merge_objs - (obj1 (req "cycle" Cycle_repr.encoding)) - frozen_balance_encoding)) + (list + (merge_objs + (obj1 (req "cycle" Cycle_repr.encoding)) + frozen_balance_encoding)) let empty_frozen_balance = - { deposit = Tez_repr.zero ; - fees = Tez_repr.zero ; - rewards = Tez_repr.zero } + {deposit = Tez_repr.zero; fees = Tez_repr.zero; rewards = Tez_repr.zero} let frozen_balance_by_cycle ctxt delegate = let contract = Contract_repr.implicit_contract delegate in let map = Cycle_repr.Map.empty in Storage.Contract.Frozen_deposits.fold - (ctxt, contract) ~init:map + (ctxt, contract) + ~init:map ~f:(fun cycle amount map -> - Lwt.return - (Cycle_repr.Map.add cycle - { empty_frozen_balance with deposit = amount } map)) >>= fun map -> + Lwt.return + (Cycle_repr.Map.add + cycle + {empty_frozen_balance with deposit = amount} + map)) + >>= fun map -> Storage.Contract.Frozen_fees.fold - (ctxt, contract) ~init:map + (ctxt, contract) + ~init:map ~f:(fun cycle amount map -> - let balance = - match Cycle_repr.Map.find_opt cycle map with - | None -> empty_frozen_balance - | Some balance -> balance in - Lwt.return - (Cycle_repr.Map.add cycle - { balance with fees = amount } map)) >>= fun map -> + let balance = + match Cycle_repr.Map.find_opt cycle map with + | None -> + empty_frozen_balance + | Some balance -> + balance + in + Lwt.return (Cycle_repr.Map.add cycle {balance with fees = amount} map)) + >>= fun map -> Storage.Contract.Frozen_rewards.fold - (ctxt, contract) ~init:map + (ctxt, contract) + ~init:map ~f:(fun cycle amount map -> - let balance = - match Cycle_repr.Map.find_opt cycle map with - | None -> empty_frozen_balance - | Some balance -> balance in - Lwt.return - (Cycle_repr.Map.add cycle - { balance with rewards = amount } map)) >>= fun map -> - Lwt.return map + let balance = + match Cycle_repr.Map.find_opt cycle map with + | None -> + empty_frozen_balance + | Some balance -> + balance + in + Lwt.return (Cycle_repr.Map.add cycle {balance with rewards = amount} map)) + >>= fun map -> Lwt.return map let frozen_balance ctxt delegate = let contract = Contract_repr.implicit_contract delegate in let balance = Ok Tez_repr.zero in Storage.Contract.Frozen_deposits.fold - (ctxt, contract) ~init:balance + (ctxt, contract) + ~init:balance ~f:(fun _cycle amount acc -> - Lwt.return acc >>=? fun acc -> - Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance -> + Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount)) + >>= fun balance -> Storage.Contract.Frozen_fees.fold - (ctxt, contract) ~init:balance + (ctxt, contract) + ~init:balance ~f:(fun _cycle amount acc -> - Lwt.return acc >>=? fun acc -> - Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance -> + Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount)) + >>= fun balance -> Storage.Contract.Frozen_rewards.fold - (ctxt, contract) ~init:balance + (ctxt, contract) + ~init:balance ~f:(fun _cycle amount acc -> - Lwt.return acc >>=? fun acc -> - Lwt.return (Tez_repr.(acc +? amount))) >>= fun balance -> - Lwt.return balance + Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount)) + >>= fun balance -> Lwt.return balance let full_balance ctxt delegate = let contract = Contract_repr.implicit_contract delegate in - frozen_balance ctxt delegate >>=? fun frozen_balance -> - Storage.Contract.Balance.get ctxt contract >>=? fun balance -> - Lwt.return Tez_repr.(frozen_balance +? balance) + frozen_balance ctxt delegate + >>=? fun frozen_balance -> + Storage.Contract.Balance.get ctxt contract + >>=? fun balance -> Lwt.return Tez_repr.(frozen_balance +? balance) let deactivated = Roll_storage.Delegate.is_inactive @@ -580,27 +680,34 @@ let grace_period ctxt delegate = let staking_balance ctxt delegate = let token_per_rolls = Constants_storage.tokens_per_roll ctxt in - Roll_storage.get_rolls ctxt delegate >>=? fun rolls -> - Roll_storage.get_change ctxt delegate >>=? fun change -> + Roll_storage.get_rolls ctxt delegate + >>=? fun rolls -> + Roll_storage.get_change ctxt delegate + >>=? fun change -> let rolls = Int64.of_int (List.length rolls) in - Lwt.return Tez_repr.(token_per_rolls *? rolls) >>=? fun balance -> - Lwt.return Tez_repr.(balance +? change) + Lwt.return Tez_repr.(token_per_rolls *? rolls) + >>=? fun balance -> Lwt.return Tez_repr.(balance +? change) let delegated_balance ctxt delegate = let contract = Contract_repr.implicit_contract delegate in - staking_balance ctxt delegate >>=? fun staking_balance -> - Storage.Contract.Balance.get ctxt contract >>= fun self_staking_balance -> + staking_balance ctxt delegate + >>=? fun staking_balance -> + Storage.Contract.Balance.get ctxt contract + >>= fun self_staking_balance -> Storage.Contract.Frozen_deposits.fold - (ctxt, contract) ~init:self_staking_balance + (ctxt, contract) + ~init:self_staking_balance ~f:(fun _cycle amount acc -> - Lwt.return acc >>=? fun acc -> - Lwt.return (Tez_repr.(acc +? amount))) >>= fun self_staking_balance -> + Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount)) + >>= fun self_staking_balance -> Storage.Contract.Frozen_fees.fold - (ctxt, contract) ~init:self_staking_balance + (ctxt, contract) + ~init:self_staking_balance ~f:(fun _cycle amount acc -> - Lwt.return acc >>=? fun acc -> - Lwt.return (Tez_repr.(acc +? amount))) >>=? fun self_staking_balance -> + Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount)) + >>=? fun self_staking_balance -> Lwt.return Tez_repr.(staking_balance -? self_staking_balance) let fold = Storage.Delegates.fold + let list = Storage.Delegates.elements diff --git a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli index 730cde305..36ab69612 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/delegate_storage.mli @@ -31,9 +31,7 @@ type balance = | Deposits of Signature.Public_key_hash.t * Cycle_repr.t (** A credit or debit of tezzies to a balance. *) -type balance_update = - | Debited of Tez_repr.t - | Credited of Tez_repr.t +type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t (** A list of balance updates. Duplicates may happen. *) type balance_updates = (balance * balance_update) list @@ -44,26 +42,29 @@ val balance_updates_encoding : balance_updates Data_encoding.t val cleanup_balance_updates : balance_updates -> balance_updates type frozen_balance = { - deposit : Tez_repr.t ; - fees : Tez_repr.t ; - rewards : Tez_repr.t ; + deposit : Tez_repr.t; + fees : Tez_repr.t; + rewards : Tez_repr.t; } (** Allow to register a delegate when creating an account. *) -val init: - Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t -> +val init : + Raw_context.t -> + Contract_repr.t -> + Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t (** Cleanup delegation when deleting a contract. *) -val remove: - Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t +val remove : Raw_context.t -> Contract_repr.t -> Raw_context.t tzresult Lwt.t (** Reading the current delegate of a contract. *) -val get: - Raw_context.t -> Contract_repr.t -> +val get : + Raw_context.t -> + Contract_repr.t -> Signature.Public_key_hash.t option tzresult Lwt.t -val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t +val registered : + Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t (** Updating the delegate of a contract. @@ -71,8 +72,10 @@ val registered: Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lw the delegate to the contract manager registers it as a delegate. One cannot unregister a delegate for now. The associate contract is now 'undeletable'. *) -val set: - Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option -> +val set : + Raw_context.t -> + Contract_repr.t -> + Signature.Public_key_hash.t option -> Raw_context.t tzresult Lwt.t type error += @@ -80,34 +83,44 @@ type error += | Active_delegate (* `Temporary *) | Current_delegate (* `Temporary *) | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *) - | Balance_too_low_for_deposit of - { delegate : Signature.Public_key_hash.t ; - deposit : Tez_repr.t ; - balance : Tez_repr.t } (* `Temporary *) + | Balance_too_low_for_deposit of { + delegate : Signature.Public_key_hash.t; + deposit : Tez_repr.t; + balance : Tez_repr.t; + } + +(* `Temporary *) (** Iterate on all registered delegates. *) -val fold: +val fold : Raw_context.t -> init:'a -> - f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t + f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) -> + 'a Lwt.t (** List all registered delegates. *) -val list: Raw_context.t -> Signature.Public_key_hash.t list Lwt.t +val list : Raw_context.t -> Signature.Public_key_hash.t list Lwt.t (** Various functions to 'freeze' tokens. A frozen 'deposit' keeps its associated rolls. When frozen, 'fees' may trigger new rolls allocation. Rewards won't trigger new rolls allocation until unfrozen. *) -val freeze_deposit: - Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> +val freeze_deposit : + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> Raw_context.t tzresult Lwt.t -val freeze_fees: - Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> +val freeze_fees : + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> Raw_context.t tzresult Lwt.t -val freeze_rewards: - Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> +val freeze_rewards : + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> Raw_context.t tzresult Lwt.t (** Trigger the context maintenance at the end of cycle 'n', i.e.: @@ -115,62 +128,64 @@ val freeze_rewards: provided unrevealed seeds (tipically seed from cycle 'n - 1'). Returns a list of account with the amount that was unfrozen for each and the list of deactivated delegates. *) -val cycle_end: - Raw_context.t -> Cycle_repr.t -> Nonce_storage.unrevealed list -> - (Raw_context.t * balance_updates * Signature.Public_key_hash.t list) tzresult Lwt.t +val cycle_end : + Raw_context.t -> + Cycle_repr.t -> + Nonce_storage.unrevealed list -> + (Raw_context.t * balance_updates * Signature.Public_key_hash.t list) tzresult + Lwt.t (** Burn all then frozen deposit/fees/rewards for a delegate at a given cycle. Returns the burned amounts. *) -val punish: - Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t -> +val punish : + Raw_context.t -> + Signature.Public_key_hash.t -> + Cycle_repr.t -> (Raw_context.t * frozen_balance) tzresult Lwt.t (** Has the given key some frozen tokens in its implicit contract? *) -val has_frozen_balance: - Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t -> +val has_frozen_balance : + Raw_context.t -> + Signature.Public_key_hash.t -> + Cycle_repr.t -> bool tzresult Lwt.t (** Returns the amount of frozen deposit, fees and rewards associated to a given delegate. *) -val frozen_balance: - Raw_context.t -> Signature.Public_key_hash.t -> - Tez_repr.t tzresult Lwt.t +val frozen_balance : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t -val frozen_balance_encoding: frozen_balance Data_encoding.t -val frozen_balance_by_cycle_encoding: +val frozen_balance_encoding : frozen_balance Data_encoding.t + +val frozen_balance_by_cycle_encoding : frozen_balance Cycle_repr.Map.t Data_encoding.t (** Returns the amount of frozen deposit, fees and rewards associated to a given delegate, indexed by the cycle by which at the end the balance will be unfrozen. *) -val frozen_balance_by_cycle: - Raw_context.t -> Signature.Public_key_hash.t -> +val frozen_balance_by_cycle : + Raw_context.t -> + Signature.Public_key_hash.t -> frozen_balance Cycle_repr.Map.t Lwt.t (** Returns the full 'balance' of the implicit contract associated to a given key, i.e. the sum of the spendable balance and of the frozen balance. *) -val full_balance: - Raw_context.t -> Signature.Public_key_hash.t -> - Tez_repr.t tzresult Lwt.t +val full_balance : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t -val staking_balance: - Raw_context.t -> Signature.Public_key_hash.t -> - Tez_repr.t tzresult Lwt.t +val staking_balance : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t (** Returns the list of contracts (implicit or originated) that delegated towards a given delegate *) -val delegated_contracts: - Raw_context.t -> Signature.Public_key_hash.t -> - Contract_repr.t list Lwt.t +val delegated_contracts : + Raw_context.t -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t -val delegated_balance: - Raw_context.t -> Signature.Public_key_hash.t -> - Tez_repr.t tzresult Lwt.t +val delegated_balance : + Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t -val deactivated: - Raw_context.t -> Signature.Public_key_hash.t -> - bool tzresult Lwt.t +val deactivated : + Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t -val grace_period: - Raw_context.t -> Signature.Public_key_hash.t -> - Cycle_repr.t tzresult Lwt.t +val grace_period : + Raw_context.t -> Signature.Public_key_hash.t -> Cycle_repr.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml index 67640e855..1a12e6c20 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.ml @@ -24,7 +24,9 @@ (*****************************************************************************) type error += Cannot_pay_storage_fee (* `Temporary *) + type error += Operation_quota_exceeded (* `Temporary *) + type error += Storage_limit_too_high (* `Permanent *) let () = @@ -41,19 +43,18 @@ let () = register_error_kind `Temporary ~id:"storage_exhausted.operation" - ~title: "Storage quota exceeded for the operation" + ~title:"Storage quota exceeded for the operation" ~description: - "A script or one of its callee wrote more \ - bytes than the operation said it would" + "A script or one of its callee wrote more bytes than the operation said \ + it would" Data_encoding.empty (function Operation_quota_exceeded -> Some () | _ -> None) (fun () -> Operation_quota_exceeded) ; register_error_kind `Permanent ~id:"storage_limit_too_high" - ~title: "Storage limit out of protocol hard bounds" - ~description: - "A transaction tried to exceed the hard limit on storage" + ~title:"Storage limit out of protocol hard bounds" + ~description:"A transaction tried to exceed the hard limit on storage" empty (function Storage_limit_too_high -> Some () | _ -> None) (fun () -> Storage_limit_too_high) @@ -62,50 +63,59 @@ let origination_burn c = let origination_size = Constants_storage.origination_size c in let cost_per_byte = Constants_storage.cost_per_byte c in (* the origination burn, measured in bytes *) - Lwt.return - Tez_repr.(cost_per_byte *? (Int64.of_int origination_size)) >>=? fun to_be_paid -> - return (Raw_context.update_allocated_contracts_count c, - to_be_paid) + Lwt.return Tez_repr.(cost_per_byte *? Int64.of_int origination_size) + >>=? fun to_be_paid -> + return (Raw_context.update_allocated_contracts_count c, to_be_paid) let record_paid_storage_space c contract = - Contract_storage.used_storage_space c contract >>=? fun size -> - Contract_storage.set_paid_storage_space_and_return_fees_to_pay c contract size >>=? fun (to_be_paid, c) -> + Contract_storage.used_storage_space c contract + >>=? fun size -> + Contract_storage.set_paid_storage_space_and_return_fees_to_pay + c + contract + size + >>=? fun (to_be_paid, c) -> let c = Raw_context.update_storage_space_to_pay c to_be_paid in let cost_per_byte = Constants_storage.cost_per_byte c in - Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 to_be_paid))) >>=? fun to_burn -> - return (c, size, to_be_paid, to_burn) + Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 to_be_paid) + >>=? fun to_burn -> return (c, size, to_be_paid, to_burn) let burn_storage_fees c ~storage_limit ~payer = let origination_size = Constants_storage.origination_size c in - let c, storage_space_to_pay, allocated_contracts = - Raw_context.clear_storage_space_to_pay c in + let (c, storage_space_to_pay, allocated_contracts) = + Raw_context.clear_storage_space_to_pay c + in let storage_space_for_allocated_contracts = - Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size) in + Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size) + in let consumed = - Z.add storage_space_to_pay storage_space_for_allocated_contracts in + Z.add storage_space_to_pay storage_space_for_allocated_contracts + in let remaining = Z.sub storage_limit consumed in - if Compare.Z.(remaining < Z.zero) then - fail Operation_quota_exceeded + if Compare.Z.(remaining < Z.zero) then fail Operation_quota_exceeded else let cost_per_byte = Constants_storage.cost_per_byte c in - Lwt.return (Tez_repr.(cost_per_byte *? (Z.to_int64 consumed))) >>=? fun to_burn -> + Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 consumed) + >>=? fun to_burn -> (* Burning the fees... *) if Tez_repr.(to_burn = Tez_repr.zero) then (* If the payer was was deleted by transfering all its balance, and no space was used, burning zero would fail *) return c else - trace Cannot_pay_storage_fee - (Contract_storage.must_exist c payer >>=? fun () -> - Contract_storage.spend c payer to_burn) >>=? fun c -> - return c + trace + Cannot_pay_storage_fee + ( Contract_storage.must_exist c payer + >>=? fun () -> Contract_storage.spend c payer to_burn ) + >>=? fun c -> return c let check_storage_limit c ~storage_limit = - if Compare.Z.(storage_limit > (Raw_context.constants c).hard_storage_limit_per_operation) - || Compare.Z.(storage_limit < Z.zero)then - error Storage_limit_too_high - else - ok () + if + Compare.Z.( + storage_limit + > (Raw_context.constants c).hard_storage_limit_per_operation) + || Compare.Z.(storage_limit < Z.zero) + then error Storage_limit_too_high + else ok () -let start_counting_storage_fees c = - Raw_context.init_storage_space_to_pay c +let start_counting_storage_fees c = Raw_context.init_storage_space_to_pay c diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli index f46f7df87..5e3fc06e0 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/fees_storage.mli @@ -24,23 +24,27 @@ (*****************************************************************************) type error += Cannot_pay_storage_fee (* `Temporary *) + type error += Operation_quota_exceeded (* `Temporary *) + type error += Storage_limit_too_high (* `Permanent *) (** Does not burn, only adds the burn to storage space to be paid *) -val origination_burn: +val origination_burn : Raw_context.t -> (Raw_context.t * Tez_repr.t) tzresult Lwt.t (** The returned Tez quantity is for logging purpose only *) -val record_paid_storage_space: - Raw_context.t -> Contract_repr.t -> +val record_paid_storage_space : + Raw_context.t -> + Contract_repr.t -> (Raw_context.t * Z.t * Z.t * Tez_repr.t) tzresult Lwt.t -val check_storage_limit: - Raw_context.t -> storage_limit:Z.t -> unit tzresult +val check_storage_limit : Raw_context.t -> storage_limit:Z.t -> unit tzresult -val start_counting_storage_fees : - Raw_context.t -> Raw_context.t +val start_counting_storage_fees : Raw_context.t -> Raw_context.t -val burn_storage_fees: - Raw_context.t -> storage_limit:Z.t -> payer:Contract_repr.t -> Raw_context.t tzresult Lwt.t +val burn_storage_fees : + Raw_context.t -> + storage_limit:Z.t -> + payer:Contract_repr.t -> + Raw_context.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml index 9bbc19e74..24d7295b4 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/fitness_repr.ml @@ -38,29 +38,25 @@ let () = let int64_to_bytes i = let b = MBytes.create 8 in - MBytes.set_int64 b 0 i; - b + MBytes.set_int64 b 0 i ; b let int64_of_bytes b = - if Compare.Int.(MBytes.length b <> 8) then - error Invalid_fitness - else - ok (MBytes.get_int64 b 0) + if Compare.Int.(MBytes.length b <> 8) then error Invalid_fitness + else ok (MBytes.get_int64 b 0) let from_int64 fitness = - [ MBytes.of_string Constants_repr.version_number ; - int64_to_bytes fitness ] + [MBytes.of_string Constants_repr.version_number; int64_to_bytes fitness] let to_int64 = function - | [ version ; - fitness ] - when Compare.String. - (MBytes.to_string version = Constants_repr.version_number) -> + | [version; fitness] + when Compare.String.( + MBytes.to_string version = Constants_repr.version_number) -> int64_of_bytes fitness - | [ version ; - _fitness (* ignored since higher version takes priority *) ] - when Compare.String. - (MBytes.to_string version = Constants_repr.version_number_004) -> + | [version; _fitness (* ignored since higher version takes priority *)] + when Compare.String.( + MBytes.to_string version = Constants_repr.version_number_004) -> ok 0L - | [] -> ok 0L - | _ -> error Invalid_fitness + | [] -> + ok 0L + | _ -> + error Invalid_fitness diff --git a/vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml index e8853db8e..173ac9ab1 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/fitness_storage.ml @@ -24,6 +24,7 @@ (*****************************************************************************) let current = Raw_context.current_fitness + let increase ?(gap = 1) ctxt = let fitness = current ctxt in Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml index 2d935809e..aa22db39f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.ml @@ -23,29 +23,30 @@ (* *) (*****************************************************************************) -type t = - | Unaccounted - | Limited of { remaining : Z.t } +type t = Unaccounted | Limited of {remaining : Z.t} type internal_gas = Z.t -type cost = - { allocations : Z.t ; - steps : Z.t ; - reads : Z.t ; - writes : Z.t ; - bytes_read : Z.t ; - bytes_written : Z.t } +type cost = { + allocations : Z.t; + steps : Z.t; + reads : Z.t; + writes : Z.t; + bytes_read : Z.t; + bytes_written : Z.t; +} let encoding = let open Data_encoding in union - [ case (Tag 0) + [ case + (Tag 0) ~title:"Limited" z - (function Limited { remaining } -> Some remaining | _ -> None) - (fun remaining -> Limited { remaining }) ; - case (Tag 1) + (function Limited {remaining} -> Some remaining | _ -> None) + (fun remaining -> Limited {remaining}); + case + (Tag 1) ~title:"Unaccounted" (constant "unaccounted") (function Unaccounted -> Some () | _ -> None) @@ -54,16 +55,16 @@ let encoding = let pp ppf = function | Unaccounted -> Format.fprintf ppf "unaccounted" - | Limited { remaining } -> + | Limited {remaining} -> Format.fprintf ppf "%s units remaining" (Z.to_string remaining) let cost_encoding = let open Data_encoding in conv - (fun { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } -> - (allocations, steps, reads, writes, bytes_read, bytes_written)) + (fun {allocations; steps; reads; writes; bytes_read; bytes_written} -> + (allocations, steps, reads, writes, bytes_read, bytes_written)) (fun (allocations, steps, reads, writes, bytes_read, bytes_written) -> - { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written }) + {allocations; steps; reads; writes; bytes_read; bytes_written}) (obj6 (req "allocations" z) (req "steps" z) @@ -72,8 +73,10 @@ let cost_encoding = (req "bytes_read" z) (req "bytes_written" z)) -let pp_cost ppf { allocations ; steps ; reads ; writes ; bytes_read ; bytes_written } = - Format.fprintf ppf +let pp_cost ppf {allocations; steps; reads; writes; bytes_read; bytes_written} + = + Format.fprintf + ppf "(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))" (Z.to_string steps) (Z.to_string allocations) @@ -83,20 +86,27 @@ let pp_cost ppf { allocations ; steps ; reads ; writes ; bytes_read ; bytes_writ (Z.to_string bytes_written) type error += Block_quota_exceeded (* `Temporary *) + type error += Operation_quota_exceeded (* `Temporary *) let allocation_weight = Z.of_int 2 + let step_weight = Z.of_int 1 + let read_base_weight = Z.of_int 100 + let write_base_weight = Z.of_int 160 + let byte_read_weight = Z.of_int 10 + let byte_written_weight = Z.of_int 15 let rescaling_bits = 7 -let rescaling_mask = - Z.sub (Z.shift_left Z.one rescaling_bits) Z.one + +let rescaling_mask = Z.sub (Z.shift_left Z.one rescaling_bits) Z.one let scale (z : Z.t) = Z.shift_left z rescaling_bits + let rescale (z : Z.t) = Z.shift_right z rescaling_bits let cost_to_internal_gas (cost : cost) : internal_gas = @@ -113,30 +123,26 @@ let cost_to_internal_gas (cost : cost) : internal_gas = (Z.mul cost.bytes_written byte_written_weight))) let internal_gas_to_gas internal_gas : Z.t * internal_gas = - let gas = rescale internal_gas in + let gas = rescale internal_gas in let rest = Z.logand internal_gas rescaling_mask in (gas, rest) let consume block_gas operation_gas internal_gas cost = match operation_gas with - | Unaccounted -> ok (block_gas, Unaccounted, internal_gas) - | Limited { remaining } -> - let cost_internal_gas = cost_to_internal_gas cost in - let total_internal_gas = - Z.add cost_internal_gas internal_gas in - let gas, rest = internal_gas_to_gas total_internal_gas in + | Unaccounted -> + ok (block_gas, Unaccounted, internal_gas) + | Limited {remaining} -> + let cost_internal_gas = cost_to_internal_gas cost in + let total_internal_gas = Z.add cost_internal_gas internal_gas in + let (gas, rest) = internal_gas_to_gas total_internal_gas in if Compare.Z.(gas > Z.zero) then - let remaining = - Z.sub remaining gas in - let block_remaining = - Z.sub block_gas gas in - if Compare.Z.(remaining < Z.zero) - then error Operation_quota_exceeded - else if Compare.Z.(block_remaining < Z.zero) - then error Block_quota_exceeded - else ok (block_remaining, Limited { remaining }, rest) - else - ok (block_gas, operation_gas, total_internal_gas) + let remaining = Z.sub remaining gas in + let block_remaining = Z.sub block_gas gas in + if Compare.Z.(remaining < Z.zero) then error Operation_quota_exceeded + else if Compare.Z.(block_remaining < Z.zero) then + error Block_quota_exceeded + else ok (block_remaining, Limited {remaining}, rest) + else ok (block_gas, operation_gas, total_internal_gas) let check_enough block_gas operation_gas internal_gas cost = consume block_gas operation_gas internal_gas cost @@ -145,97 +151,110 @@ let check_enough block_gas operation_gas internal_gas cost = let internal_gas_zero : internal_gas = Z.zero let alloc_cost n = - { allocations = scale (Z.of_int (n + 1)) ; - steps = Z.zero ; - reads = Z.zero ; - writes = Z.zero ; - bytes_read = Z.zero ; - bytes_written = Z.zero } + { + allocations = scale (Z.of_int (n + 1)); + steps = Z.zero; + reads = Z.zero; + writes = Z.zero; + bytes_read = Z.zero; + bytes_written = Z.zero; + } -let alloc_bytes_cost n = - alloc_cost ((n + 7) / 8) +let alloc_bytes_cost n = alloc_cost ((n + 7) / 8) -let alloc_bits_cost n = - alloc_cost ((n + 63) / 64) +let alloc_bits_cost n = alloc_cost ((n + 63) / 64) let atomic_step_cost n = - { allocations = Z.zero ; - steps = Z.of_int (2 * n) ; - reads = Z.zero ; - writes = Z.zero ; - bytes_read = Z.zero ; - bytes_written = Z.zero } + { + allocations = Z.zero; + steps = Z.of_int (2 * n); + reads = Z.zero; + writes = Z.zero; + bytes_read = Z.zero; + bytes_written = Z.zero; + } let step_cost n = - { allocations = Z.zero ; - steps = scale (Z.of_int n) ; - reads = Z.zero ; - writes = Z.zero ; - bytes_read = Z.zero ; - bytes_written = Z.zero } + { + allocations = Z.zero; + steps = scale (Z.of_int n); + reads = Z.zero; + writes = Z.zero; + bytes_read = Z.zero; + bytes_written = Z.zero; + } let free = - { allocations = Z.zero ; - steps = Z.zero ; - reads = Z.zero ; - writes = Z.zero ; - bytes_read = Z.zero ; - bytes_written = Z.zero } + { + allocations = Z.zero; + steps = Z.zero; + reads = Z.zero; + writes = Z.zero; + bytes_read = Z.zero; + bytes_written = Z.zero; + } let read_bytes_cost n = - { allocations = Z.zero ; - steps = Z.zero ; - reads = scale Z.one ; - writes = Z.zero ; - bytes_read = scale n ; - bytes_written = Z.zero } + { + allocations = Z.zero; + steps = Z.zero; + reads = scale Z.one; + writes = Z.zero; + bytes_read = scale n; + bytes_written = Z.zero; + } let write_bytes_cost n = - { allocations = Z.zero ; - steps = Z.zero ; - reads = Z.zero ; - writes = Z.one ; - bytes_read = Z.zero ; - bytes_written = scale n } + { + allocations = Z.zero; + steps = Z.zero; + reads = Z.zero; + writes = Z.one; + bytes_read = Z.zero; + bytes_written = scale n; + } let ( +@ ) x y = - { allocations = Z.add x.allocations y.allocations ; - steps = Z.add x.steps y.steps ; - reads = Z.add x.reads y.reads ; - writes = Z.add x.writes y.writes ; - bytes_read = Z.add x.bytes_read y.bytes_read ; - bytes_written = Z.add x.bytes_written y.bytes_written } + { + allocations = Z.add x.allocations y.allocations; + steps = Z.add x.steps y.steps; + reads = Z.add x.reads y.reads; + writes = Z.add x.writes y.writes; + bytes_read = Z.add x.bytes_read y.bytes_read; + bytes_written = Z.add x.bytes_written y.bytes_written; + } let ( *@ ) x y = - { allocations = Z.mul (Z.of_int x) y.allocations ; - steps = Z.mul (Z.of_int x) y.steps ; - reads = Z.mul (Z.of_int x) y.reads ; - writes = Z.mul (Z.of_int x) y.writes ; - bytes_read = Z.mul (Z.of_int x) y.bytes_read ; - bytes_written = Z.mul (Z.of_int x) y.bytes_written } + { + allocations = Z.mul (Z.of_int x) y.allocations; + steps = Z.mul (Z.of_int x) y.steps; + reads = Z.mul (Z.of_int x) y.reads; + writes = Z.mul (Z.of_int x) y.writes; + bytes_read = Z.mul (Z.of_int x) y.bytes_read; + bytes_written = Z.mul (Z.of_int x) y.bytes_written; + } -let alloc_mbytes_cost n = - alloc_cost 12 +@ alloc_bytes_cost n +let alloc_mbytes_cost n = alloc_cost 12 +@ alloc_bytes_cost n let () = let open Data_encoding in register_error_kind `Temporary ~id:"gas_exhausted.operation" - ~title: "Gas quota exceeded for the operation" + ~title:"Gas quota exceeded for the operation" ~description: - "A script or one of its callee took more \ - time than the operation said it would" + "A script or one of its callee took more time than the operation said \ + it would" empty (function Operation_quota_exceeded -> Some () | _ -> None) (fun () -> Operation_quota_exceeded) ; register_error_kind `Temporary ~id:"gas_exhausted.block" - ~title: "Gas quota exceeded for the block" + ~title:"Gas quota exceeded for the block" ~description: - "The sum of gas consumed by all the operations in the block \ - exceeds the hard gas limit per block" + "The sum of gas consumed by all the operations in the block exceeds the \ + hard gas limit per block" empty (function Block_quota_exceeded -> Some () | _ -> None) - (fun () -> Block_quota_exceeded) ; + (fun () -> Block_quota_exceeded) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli index d5b58c203..d7acd523c 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/gas_limit_repr.mli @@ -23,37 +23,49 @@ (* *) (*****************************************************************************) -type t = - | Unaccounted - | Limited of { remaining : Z.t } +type t = Unaccounted | Limited of {remaining : Z.t} type internal_gas val encoding : t Data_encoding.encoding + val pp : Format.formatter -> t -> unit type cost val cost_encoding : cost Data_encoding.encoding + val pp_cost : Format.formatter -> cost -> unit type error += Block_quota_exceeded (* `Temporary *) + type error += Operation_quota_exceeded (* `Temporary *) -val consume : Z.t -> t -> internal_gas -> cost -> (Z.t * t * internal_gas) tzresult +val consume : + Z.t -> t -> internal_gas -> cost -> (Z.t * t * internal_gas) tzresult + val check_enough : Z.t -> t -> internal_gas -> cost -> unit tzresult val internal_gas_zero : internal_gas val free : cost + val atomic_step_cost : int -> cost + val step_cost : int -> cost + val alloc_cost : int -> cost + val alloc_bytes_cost : int -> cost + val alloc_mbytes_cost : int -> cost + val alloc_bits_cost : int -> cost + val read_bytes_cost : Z.t -> cost + val write_bytes_cost : Z.t -> cost val ( *@ ) : int -> cost -> cost + val ( +@ ) : cost -> cost -> cost diff --git a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml index a44c6c7f3..c63ed1035 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml @@ -32,381 +32,515 @@ let () = `Branch ~id:"operation.cannot_parse" ~title:"Cannot parse operation" - ~description:"The operation is ill-formed \ - or for another protocol version" - ~pp:(fun ppf () -> - Format.fprintf ppf "The operation cannot be parsed") + ~description:"The operation is ill-formed or for another protocol version" + ~pp:(fun ppf () -> Format.fprintf ppf "The operation cannot be parsed") Data_encoding.unit (function Cannot_parse_operation -> Some () | _ -> None) (fun () -> Cannot_parse_operation) -let parse_operation (op: Operation.raw) = - match Data_encoding.Binary.of_bytes - Operation.protocol_data_encoding - op.proto with +let parse_operation (op : Operation.raw) = + match + Data_encoding.Binary.of_bytes Operation.protocol_data_encoding op.proto + with | Some protocol_data -> - ok { shell = op.shell ; protocol_data } - | None -> error Cannot_parse_operation + ok {shell = op.shell; protocol_data} + | None -> + error Cannot_parse_operation let path = RPC_path.(open_root / "helpers") module Scripts = struct - module S = struct - open Data_encoding let path = RPC_path.(path / "scripts") let run_code_input_encoding = - (obj9 - (req "script" Script.expr_encoding) - (req "storage" Script.expr_encoding) - (req "input" Script.expr_encoding) - (req "amount" Tez.encoding) - (req "chain_id" Chain_id.encoding) - (opt "source" Contract.encoding) - (opt "payer" Contract.encoding) - (opt "gas" z) - (dft "entrypoint" string "default")) + obj9 + (req "script" Script.expr_encoding) + (req "storage" Script.expr_encoding) + (req "input" Script.expr_encoding) + (req "amount" Tez.encoding) + (req "chain_id" Chain_id.encoding) + (opt "source" Contract.encoding) + (opt "payer" Contract.encoding) + (opt "gas" z) + (dft "entrypoint" string "default") let trace_encoding = - def "scripted.trace" @@ - (list @@ obj3 - (req "location" Script.location_encoding) - (req "gas" Gas.encoding) - (req "stack" - (list - (obj2 - (req "item" (Script.expr_encoding)) - (opt "annot" string))))) + def "scripted.trace" @@ list + @@ obj3 + (req "location" Script.location_encoding) + (req "gas" Gas.encoding) + (req + "stack" + (list + (obj2 (req "item" Script.expr_encoding) (opt "annot" string)))) let run_code = RPC_service.post_service - ~description: "Run a piece of code in the current context" - ~query: RPC_query.empty - ~input: run_code_input_encoding - ~output: (obj3 - (req "storage" Script.expr_encoding) - (req "operations" (list Operation.internal_operation_encoding)) - (opt "big_map_diff" Contract.big_map_diff_encoding)) + ~description:"Run a piece of code in the current context" + ~query:RPC_query.empty + ~input:run_code_input_encoding + ~output: + (obj3 + (req "storage" Script.expr_encoding) + (req "operations" (list Operation.internal_operation_encoding)) + (opt "big_map_diff" Contract.big_map_diff_encoding)) RPC_path.(path / "run_code") let trace_code = RPC_service.post_service - ~description: "Run a piece of code in the current context, \ - keeping a trace" - ~query: RPC_query.empty - ~input: run_code_input_encoding - ~output: (obj4 - (req "storage" Script.expr_encoding) - (req "operations" (list Operation.internal_operation_encoding)) - (req "trace" trace_encoding) - (opt "big_map_diff" Contract.big_map_diff_encoding)) + ~description: + "Run a piece of code in the current context, keeping a trace" + ~query:RPC_query.empty + ~input:run_code_input_encoding + ~output: + (obj4 + (req "storage" Script.expr_encoding) + (req "operations" (list Operation.internal_operation_encoding)) + (req "trace" trace_encoding) + (opt "big_map_diff" Contract.big_map_diff_encoding)) RPC_path.(path / "trace_code") let typecheck_code = RPC_service.post_service - ~description: "Typecheck a piece of code in the current context" - ~query: RPC_query.empty - ~input: (obj2 - (req "program" Script.expr_encoding) - (opt "gas" z)) - ~output: (obj2 - (req "type_map" Script_tc_errors_registration.type_map_enc) - (req "gas" Gas.encoding)) + ~description:"Typecheck a piece of code in the current context" + ~query:RPC_query.empty + ~input:(obj2 (req "program" Script.expr_encoding) (opt "gas" z)) + ~output: + (obj2 + (req "type_map" Script_tc_errors_registration.type_map_enc) + (req "gas" Gas.encoding)) RPC_path.(path / "typecheck_code") let typecheck_data = RPC_service.post_service - ~description: "Check that some data expression is well formed \ - and of a given type in the current context" - ~query: RPC_query.empty - ~input: (obj3 - (req "data" Script.expr_encoding) - (req "type" Script.expr_encoding) - (opt "gas" z)) - ~output: (obj1 (req "gas" Gas.encoding)) + ~description: + "Check that some data expression is well formed and of a given type \ + in the current context" + ~query:RPC_query.empty + ~input: + (obj3 + (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding) + (opt "gas" z)) + ~output:(obj1 (req "gas" Gas.encoding)) RPC_path.(path / "typecheck_data") let pack_data = RPC_service.post_service - ~description: "Computes the serialized version of some data expression \ - using the same algorithm as script instruction PACK" - - ~input: (obj3 - (req "data" Script.expr_encoding) - (req "type" Script.expr_encoding) - (opt "gas" z)) - ~output: (obj2 - (req "packed" bytes) - (req "gas" Gas.encoding)) - ~query: RPC_query.empty + ~description: + "Computes the serialized version of some data expression using the \ + same algorithm as script instruction PACK" + ~input: + (obj3 + (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding) + (opt "gas" z)) + ~output:(obj2 (req "packed" bytes) (req "gas" Gas.encoding)) + ~query:RPC_query.empty RPC_path.(path / "pack_data") let run_operation = RPC_service.post_service - ~description: - "Run an operation without signature checks" - ~query: RPC_query.empty - ~input: (obj2 - (req "operation" Operation.encoding) - (req "chain_id" Chain_id.encoding)) - ~output: Apply_results.operation_data_and_metadata_encoding + ~description:"Run an operation without signature checks" + ~query:RPC_query.empty + ~input: + (obj2 + (req "operation" Operation.encoding) + (req "chain_id" Chain_id.encoding)) + ~output:Apply_results.operation_data_and_metadata_encoding RPC_path.(path / "run_operation") let entrypoint_type = RPC_service.post_service - ~description: "Return the type of the given entrypoint" - ~query: RPC_query.empty - ~input: (obj2 - (req "script" Script.expr_encoding) - (dft "entrypoint" string "default")) - ~output: (obj1 - (req "entrypoint_type" Script.expr_encoding)) + ~description:"Return the type of the given entrypoint" + ~query:RPC_query.empty + ~input: + (obj2 + (req "script" Script.expr_encoding) + (dft "entrypoint" string "default")) + ~output:(obj1 (req "entrypoint_type" Script.expr_encoding)) RPC_path.(path / "entrypoint") - let list_entrypoints = RPC_service.post_service - ~description: "Return the list of entrypoints of the given script" - ~query: RPC_query.empty - ~input: (obj1 - (req "script" Script.expr_encoding)) - ~output: (obj2 - (dft "unreachable" - (Data_encoding.list - (obj1 (req "path" (Data_encoding.list Michelson_v1_primitives.prim_encoding)))) - []) - (req "entrypoints" - (assoc Script.expr_encoding))) + ~description:"Return the list of entrypoints of the given script" + ~query:RPC_query.empty + ~input:(obj1 (req "script" Script.expr_encoding)) + ~output: + (obj2 + (dft + "unreachable" + (Data_encoding.list + (obj1 + (req + "path" + (Data_encoding.list + Michelson_v1_primitives.prim_encoding)))) + []) + (req "entrypoints" (assoc Script.expr_encoding))) RPC_path.(path / "entrypoints") - end let register () = let open Services_registration in let originate_dummy_contract ctxt script = let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, dummy_contract) -> - let balance = match Tez.of_mutez 4_000_000_000_000L with - | Some balance -> balance - | None -> assert false in - Contract.originate ctxt dummy_contract + Contract.fresh_contract_from_current_nonce ctxt + >>=? fun (ctxt, dummy_contract) -> + let balance = + match Tez.of_mutez 4_000_000_000_000L with + | Some balance -> + balance + | None -> + assert false + in + Contract.originate + ctxt + dummy_contract ~balance - ~delegate: None - ~script: (script, None) >>=? fun ctxt -> - return (ctxt, dummy_contract) in - register0 S.run_code begin fun ctxt () - (code, storage, parameter, amount, chain_id, source, payer, gas, entrypoint) -> - let storage = Script.lazy_expr storage in - let code = Script.lazy_expr code in - originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) -> - let source, payer = match source, payer with - | Some source, Some payer -> source, payer - | Some source, None -> source, source - | None, Some payer -> payer, payer - | None, None -> dummy_contract, dummy_contract in - let gas = match gas with - | Some gas -> gas - | None -> Constants.hard_gas_limit_per_operation ctxt in - let ctxt = Gas.set_limit ctxt gas in - let step_constants = - let open Script_interpreter in - { source ; - payer ; - self = dummy_contract ; - amount ; - chain_id } in - Script_interpreter.execute - ctxt Readable - step_constants - ~script:{ storage ; code } - ~entrypoint - ~parameter - >>=? fun { Script_interpreter.storage ; operations ; big_map_diff ; _ } -> - return (storage, operations, big_map_diff) - end ; - register0 S.trace_code begin fun ctxt () - (code, storage, parameter, amount, chain_id, source, payer, gas, entrypoint) -> - let storage = Script.lazy_expr storage in - let code = Script.lazy_expr code in - originate_dummy_contract ctxt { storage ; code } >>=? fun (ctxt, dummy_contract) -> - let source, payer = match source, payer with - | Some source, Some payer -> source, payer - | Some source, None -> source, source - | None, Some payer -> payer, payer - | None, None -> dummy_contract, dummy_contract in - let gas = match gas with - | Some gas -> gas - | None -> Constants.hard_gas_limit_per_operation ctxt in - let ctxt = Gas.set_limit ctxt gas in - let step_constants = - let open Script_interpreter in - { source ; - payer ; - self = dummy_contract ; - amount ; - chain_id } in - Script_interpreter.trace - ctxt Readable - step_constants - ~script:{ storage ; code } - ~entrypoint - ~parameter - >>=? fun ({ Script_interpreter.storage ; operations ; big_map_diff ; _ }, trace) -> - return (storage, operations, trace, big_map_diff) - end ; - register0 S.typecheck_code begin fun ctxt () (expr, maybe_gas) -> - let ctxt = match maybe_gas with - | None -> Gas.set_unlimited ctxt - | Some gas -> Gas.set_limit ctxt gas in - Script_ir_translator.typecheck_code ctxt expr >>=? fun (res, ctxt) -> - return (res, Gas.level ctxt) - end ; - register0 S.typecheck_data begin fun ctxt () (data, ty, maybe_gas) -> - let ctxt = match maybe_gas with - | None -> Gas.set_unlimited ctxt - | Some gas -> Gas.set_limit ctxt gas in - Script_ir_translator.typecheck_data ctxt (data, ty) >>=? fun ctxt -> - return (Gas.level ctxt) - end ; - register0 S.pack_data begin fun ctxt () (expr, typ, maybe_gas) -> - let open Script_ir_translator in - let ctxt = match maybe_gas with - | None -> Gas.set_unlimited ctxt - | Some gas -> Gas.set_limit ctxt gas in - Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ)) >>=? fun (Ex_ty typ, ctxt) -> - parse_data ctxt ~legacy:true typ (Micheline.root expr) >>=? fun (data, ctxt) -> - Script_ir_translator.pack_data ctxt typ data >>=? fun (bytes, ctxt) -> - return (bytes, Gas.level ctxt) - end ; - register0 S.run_operation begin fun ctxt () - ({ shell ; protocol_data = Operation_data protocol_data }, chain_id) -> - (* this code is a duplicate of Apply without signature check *) - let partial_precheck_manager_contents - (type kind) ctxt (op : kind Kind.manager contents) - : context tzresult Lwt.t = - let Manager_operation { source ; fee ; counter ; operation ; gas_limit ; storage_limit } = op in - Lwt.return (Gas.check_limit ctxt gas_limit) >>=? fun () -> - let ctxt = Gas.set_limit ctxt gas_limit in - Lwt.return (Fees.check_storage_limit ctxt storage_limit) >>=? fun () -> - Contract.must_be_allocated ctxt (Contract.implicit_contract source) >>=? fun () -> - Contract.check_counter_increment ctxt source counter >>=? fun () -> - begin - match operation with + ~delegate:None + ~script:(script, None) + >>=? fun ctxt -> return (ctxt, dummy_contract) + in + register0 + S.run_code + (fun ctxt + () + ( code, + storage, + parameter, + amount, + chain_id, + source, + payer, + gas, + entrypoint ) + -> + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in + originate_dummy_contract ctxt {storage; code} + >>=? fun (ctxt, dummy_contract) -> + let (source, payer) = + match (source, payer) with + | (Some source, Some payer) -> + (source, payer) + | (Some source, None) -> + (source, source) + | (None, Some payer) -> + (payer, payer) + | (None, None) -> + (dummy_contract, dummy_contract) + in + let gas = + match gas with + | Some gas -> + gas + | None -> + Constants.hard_gas_limit_per_operation ctxt + in + let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + {source; payer; self = dummy_contract; amount; chain_id} + in + Script_interpreter.execute + ctxt + Readable + step_constants + ~script:{storage; code} + ~entrypoint + ~parameter + >>=? fun {Script_interpreter.storage; operations; big_map_diff; _} -> + return (storage, operations, big_map_diff)) ; + register0 + S.trace_code + (fun ctxt + () + ( code, + storage, + parameter, + amount, + chain_id, + source, + payer, + gas, + entrypoint ) + -> + let storage = Script.lazy_expr storage in + let code = Script.lazy_expr code in + originate_dummy_contract ctxt {storage; code} + >>=? fun (ctxt, dummy_contract) -> + let (source, payer) = + match (source, payer) with + | (Some source, Some payer) -> + (source, payer) + | (Some source, None) -> + (source, source) + | (None, Some payer) -> + (payer, payer) + | (None, None) -> + (dummy_contract, dummy_contract) + in + let gas = + match gas with + | Some gas -> + gas + | None -> + Constants.hard_gas_limit_per_operation ctxt + in + let ctxt = Gas.set_limit ctxt gas in + let step_constants = + let open Script_interpreter in + {source; payer; self = dummy_contract; amount; chain_id} + in + Script_interpreter.trace + ctxt + Readable + step_constants + ~script:{storage; code} + ~entrypoint + ~parameter + >>=? fun ( {Script_interpreter.storage; operations; big_map_diff; _}, + trace ) -> + return (storage, operations, trace, big_map_diff)) ; + register0 S.typecheck_code (fun ctxt () (expr, maybe_gas) -> + let ctxt = + match maybe_gas with + | None -> + Gas.set_unlimited ctxt + | Some gas -> + Gas.set_limit ctxt gas + in + Script_ir_translator.typecheck_code ctxt expr + >>=? fun (res, ctxt) -> return (res, Gas.level ctxt)) ; + register0 S.typecheck_data (fun ctxt () (data, ty, maybe_gas) -> + let ctxt = + match maybe_gas with + | None -> + Gas.set_unlimited ctxt + | Some gas -> + Gas.set_limit ctxt gas + in + Script_ir_translator.typecheck_data ctxt (data, ty) + >>=? fun ctxt -> return (Gas.level ctxt)) ; + register0 S.pack_data (fun ctxt () (expr, typ, maybe_gas) -> + let open Script_ir_translator in + let ctxt = + match maybe_gas with + | None -> + Gas.set_unlimited ctxt + | Some gas -> + Gas.set_limit ctxt gas + in + Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ)) + >>=? fun (Ex_ty typ, ctxt) -> + parse_data ctxt ~legacy:true typ (Micheline.root expr) + >>=? fun (data, ctxt) -> + Script_ir_translator.pack_data ctxt typ data + >>=? fun (bytes, ctxt) -> return (bytes, Gas.level ctxt)) ; + register0 + S.run_operation + (fun ctxt + () + ({shell; protocol_data = Operation_data protocol_data}, chain_id) + -> + (* this code is a duplicate of Apply without signature check *) + let partial_precheck_manager_contents (type kind) ctxt + (op : kind Kind.manager contents) : context tzresult Lwt.t = + let (Manager_operation + {source; fee; counter; operation; gas_limit; storage_limit}) = + op + in + Lwt.return (Gas.check_limit ctxt gas_limit) + >>=? fun () -> + let ctxt = Gas.set_limit ctxt gas_limit in + Lwt.return (Fees.check_storage_limit ctxt storage_limit) + >>=? fun () -> + Contract.must_be_allocated ctxt (Contract.implicit_contract source) + >>=? fun () -> + Contract.check_counter_increment ctxt source counter + >>=? fun () -> + ( match operation with | Reveal pk -> Contract.reveal_manager_key ctxt source pk - | Transaction { parameters ; _ } -> + | Transaction {parameters; _} -> (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) - let arg_bytes = Data_encoding.Binary.to_bytes_exn Script.lazy_expr_encoding parameters in - let arg = match Data_encoding.Binary.of_bytes Script.lazy_expr_encoding arg_bytes with - | Some arg -> arg - | None -> assert false in + let arg_bytes = + Data_encoding.Binary.to_bytes_exn + Script.lazy_expr_encoding + parameters + in + let arg = + match + Data_encoding.Binary.of_bytes + Script.lazy_expr_encoding + arg_bytes + with + | Some arg -> + arg + | None -> + assert false + in (* Fail quickly if not enough gas for minimal deserialization cost *) - Lwt.return @@ record_trace Apply.Gas_quota_exceeded_init_deserialize @@ - Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) >>=? fun () -> + Lwt.return + @@ record_trace Apply.Gas_quota_exceeded_init_deserialize + @@ Gas.check_enough ctxt (Script.minimal_deserialize_cost arg) + >>=? fun () -> (* Fail if not enough gas for complete deserialization cost *) - trace Apply.Gas_quota_exceeded_init_deserialize @@ - Script.force_decode ctxt arg >>|? fun (_arg, ctxt) -> ctxt - | Origination { script = script ; _ } -> + trace Apply.Gas_quota_exceeded_init_deserialize + @@ Script.force_decode ctxt arg + >>|? fun (_arg, ctxt) -> ctxt + | Origination {script; _} -> (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *) - let script_bytes = Data_encoding.Binary.to_bytes_exn Script.encoding script in - let script = match Data_encoding.Binary.of_bytes Script.encoding script_bytes with - | Some script -> script - | None -> assert false in + let script_bytes = + Data_encoding.Binary.to_bytes_exn Script.encoding script + in + let script = + match + Data_encoding.Binary.of_bytes Script.encoding script_bytes + with + | Some script -> + script + | None -> + assert false + in (* Fail quickly if not enough gas for minimal deserialization cost *) - Lwt.return @@ record_trace Apply.Gas_quota_exceeded_init_deserialize @@ - (Gas.consume ctxt (Script.minimal_deserialize_cost script.code) >>? fun ctxt -> - Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)) >>=? fun () -> + Lwt.return + @@ record_trace Apply.Gas_quota_exceeded_init_deserialize + @@ ( Gas.consume + ctxt + (Script.minimal_deserialize_cost script.code) + >>? fun ctxt -> + Gas.check_enough + ctxt + (Script.minimal_deserialize_cost script.storage) ) + >>=? fun () -> (* Fail if not enough gas for complete deserialization cost *) - trace Apply.Gas_quota_exceeded_init_deserialize @@ - Script.force_decode ctxt script.code >>=? fun (_code, ctxt) -> - trace Apply.Gas_quota_exceeded_init_deserialize @@ - Script.force_decode ctxt script.storage >>|? fun (_storage, ctxt) -> ctxt - | _ -> return ctxt - end >>=? fun ctxt -> - Contract.get_manager_key ctxt source >>=? fun _public_key -> - (* signature check unplugged from here *) - Contract.increment_counter ctxt source >>=? fun ctxt -> - Contract.spend ctxt (Contract.implicit_contract source) fee >>=? fun ctxt -> - return ctxt in - let rec partial_precheck_manager_contents_list - : type kind. - Alpha_context.t -> kind Kind.manager contents_list -> - context tzresult Lwt.t = - fun ctxt contents_list -> + trace Apply.Gas_quota_exceeded_init_deserialize + @@ Script.force_decode ctxt script.code + >>=? fun (_code, ctxt) -> + trace Apply.Gas_quota_exceeded_init_deserialize + @@ Script.force_decode ctxt script.storage + >>|? fun (_storage, ctxt) -> ctxt + | _ -> + return ctxt ) + >>=? fun ctxt -> + Contract.get_manager_key ctxt source + >>=? fun _public_key -> + (* signature check unplugged from here *) + Contract.increment_counter ctxt source + >>=? fun ctxt -> + Contract.spend ctxt (Contract.implicit_contract source) fee + >>=? fun ctxt -> return ctxt + in + let rec partial_precheck_manager_contents_list : + type kind. + Alpha_context.t -> + kind Kind.manager contents_list -> + context tzresult Lwt.t = + fun ctxt contents_list -> match contents_list with | Single (Manager_operation _ as op) -> partial_precheck_manager_contents ctxt op - | Cons (Manager_operation _ as op, rest) -> - partial_precheck_manager_contents ctxt op >>=? fun ctxt -> - partial_precheck_manager_contents_list ctxt rest in - let return contents = - return (Operation_data protocol_data, - Apply_results.Operation_metadata { contents }) in - let operation : _ operation = { shell ; protocol_data } in - let hash = Operation.hash { shell ; protocol_data } in - let ctxt = Contract.init_origination_nonce ctxt hash in - let baker = Signature.Public_key_hash.zero in - match protocol_data.contents with - | Single (Manager_operation _) as op -> - partial_precheck_manager_contents_list ctxt op >>=? fun ctxt -> - Apply.apply_manager_contents_list ctxt Optimized baker chain_id op >>= fun (_ctxt, result) -> - return result - | Cons (Manager_operation _, _) as op -> - partial_precheck_manager_contents_list ctxt op >>=? fun ctxt -> - Apply.apply_manager_contents_list ctxt Optimized baker chain_id op >>= fun (_ctxt, result) -> - return result - | _ -> - Apply.apply_contents_list - ctxt chain_id Optimized shell.branch baker operation - operation.protocol_data.contents >>=? fun (_ctxt, result) -> - return result - end; - register0 S.entrypoint_type begin fun ctxt () (expr, entrypoint) -> - let ctxt = Gas.set_unlimited ctxt in - let legacy = false in - let open Script_ir_translator in - Lwt.return - begin - parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> - parse_ty ctxt ~legacy - ~allow_big_map:true ~allow_operation:false - ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> - Script_ir_translator.find_entrypoint ~root_name arg_type - entrypoint - end >>=? fun (_f , Ex_ty ty)-> - unparse_ty ctxt ty >>=? fun (ty_node, _) -> - return (Micheline.strip_locations ty_node) - end ; - register0 S.list_entrypoints begin fun ctxt () expr -> - let ctxt = Gas.set_unlimited ctxt in - let legacy = false in - let open Script_ir_translator in - Lwt.return - begin - parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) -> - parse_ty ctxt ~legacy - ~allow_big_map:true ~allow_operation:false - ~allow_contract:true arg_type >>? fun (Ex_ty arg_type, _) -> - Script_ir_translator.list_entrypoints ~root_name arg_type ctxt - end >>=? fun (unreachable_entrypoint,map) -> - return - (unreachable_entrypoint, - Entrypoints_map.fold - begin fun entry (_,ty) acc -> - (entry , Micheline.strip_locations ty) ::acc end - map []) - end + | Cons ((Manager_operation _ as op), rest) -> + partial_precheck_manager_contents ctxt op + >>=? fun ctxt -> partial_precheck_manager_contents_list ctxt rest + in + let return contents = + return + ( Operation_data protocol_data, + Apply_results.Operation_metadata {contents} ) + in + let operation : _ operation = {shell; protocol_data} in + let hash = Operation.hash {shell; protocol_data} in + let ctxt = Contract.init_origination_nonce ctxt hash in + let baker = Signature.Public_key_hash.zero in + match protocol_data.contents with + | Single (Manager_operation _) as op -> + partial_precheck_manager_contents_list ctxt op + >>=? fun ctxt -> + Apply.apply_manager_contents_list ctxt Optimized baker chain_id op + >>= fun (_ctxt, result) -> return result + | Cons (Manager_operation _, _) as op -> + partial_precheck_manager_contents_list ctxt op + >>=? fun ctxt -> + Apply.apply_manager_contents_list ctxt Optimized baker chain_id op + >>= fun (_ctxt, result) -> return result + | _ -> + Apply.apply_contents_list + ctxt + chain_id + Optimized + shell.branch + baker + operation + operation.protocol_data.contents + >>=? fun (_ctxt, result) -> return result) ; + register0 S.entrypoint_type (fun ctxt () (expr, entrypoint) -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = false in + let open Script_ir_translator in + Lwt.return + ( parse_toplevel ~legacy expr + >>? fun (arg_type, _, _, root_name) -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:false + ~allow_contract:true + arg_type + >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint + ) + >>=? fun (_f, Ex_ty ty) -> + unparse_ty ctxt ty + >>=? fun (ty_node, _) -> return (Micheline.strip_locations ty_node)) ; + register0 S.list_entrypoints (fun ctxt () expr -> + let ctxt = Gas.set_unlimited ctxt in + let legacy = false in + let open Script_ir_translator in + Lwt.return + ( parse_toplevel ~legacy expr + >>? fun (arg_type, _, _, root_name) -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:false + ~allow_contract:true + arg_type + >>? fun (Ex_ty arg_type, _) -> + Script_ir_translator.list_entrypoints ~root_name arg_type ctxt ) + >>=? fun (unreachable_entrypoint, map) -> + return + ( unreachable_entrypoint, + Entrypoints_map.fold + (fun entry (_, ty) acc -> + (entry, Micheline.strip_locations ty) :: acc) + map + [] )) - let run_code ctxt block code (storage, input, amount, chain_id, source, payer, gas, entrypoint) = - RPC_context.make_call0 S.run_code ctxt - block () (code, storage, input, amount, chain_id, source, payer, gas, entrypoint) + let run_code ctxt block code + (storage, input, amount, chain_id, source, payer, gas, entrypoint) = + RPC_context.make_call0 + S.run_code + ctxt + block + () + (code, storage, input, amount, chain_id, source, payer, gas, entrypoint) - let trace_code ctxt block code (storage, input, amount, chain_id, source, payer, gas, entrypoint) = - RPC_context.make_call0 S.trace_code ctxt - block () (code, storage, input, amount, chain_id, source, payer, gas, entrypoint) + let trace_code ctxt block code + (storage, input, amount, chain_id, source, payer, gas, entrypoint) = + RPC_context.make_call0 + S.trace_code + ctxt + block + () + (code, storage, input, amount, chain_id, source, payer, gas, entrypoint) let typecheck_code ctxt block = RPC_context.make_call0 S.typecheck_code ctxt block () @@ -414,8 +548,7 @@ module Scripts = struct let typecheck_data ctxt block = RPC_context.make_call0 S.typecheck_data ctxt block () - let pack_data ctxt block = - RPC_context.make_call0 S.pack_data ctxt block () + let pack_data ctxt block = RPC_context.make_call0 S.pack_data ctxt block () let run_operation ctxt block = RPC_context.make_call0 S.run_operation ctxt block () @@ -425,14 +558,10 @@ module Scripts = struct let list_entrypoints ctxt block = RPC_context.make_call0 S.list_entrypoints ctxt block () - - end module Forge = struct - module S = struct - open Data_encoding let path = RPC_path.(path / "forge") @@ -440,158 +569,206 @@ module Forge = struct let operations = RPC_service.post_service ~description:"Forge an operation" - ~query: RPC_query.empty - ~input: Operation.unsigned_encoding - ~output: bytes - RPC_path.(path / "operations" ) + ~query:RPC_query.empty + ~input:Operation.unsigned_encoding + ~output:bytes + RPC_path.(path / "operations") let empty_proof_of_work_nonce = MBytes.of_string - (String.make Constants_repr.proof_of_work_nonce_size '\000') + (String.make Constants_repr.proof_of_work_nonce_size '\000') let protocol_data = RPC_service.post_service - ~description: "Forge the protocol-specific part of a block header" - ~query: RPC_query.empty + ~description:"Forge the protocol-specific part of a block header" + ~query:RPC_query.empty ~input: (obj3 (req "priority" uint16) (opt "nonce_hash" Nonce_hash.encoding) - (dft "proof_of_work_nonce" - (Fixed.bytes - Alpha_context.Constants.proof_of_work_nonce_size) + (dft + "proof_of_work_nonce" + (Fixed.bytes Alpha_context.Constants.proof_of_work_nonce_size) empty_proof_of_work_nonce)) - ~output: (obj1 (req "protocol_data" bytes)) + ~output:(obj1 (req "protocol_data" bytes)) RPC_path.(path / "protocol_data") - end let register () = let open Services_registration in - register0_noctxt S.operations begin fun () (shell, proto) -> - return (Data_encoding.Binary.to_bytes_exn - Operation.unsigned_encoding (shell, proto)) - end ; - register0_noctxt S.protocol_data begin fun () - (priority, seed_nonce_hash, proof_of_work_nonce) -> - return (Data_encoding.Binary.to_bytes_exn - Block_header.contents_encoding - { priority ; seed_nonce_hash ; proof_of_work_nonce }) - end + register0_noctxt S.operations (fun () (shell, proto) -> + return + (Data_encoding.Binary.to_bytes_exn + Operation.unsigned_encoding + (shell, proto))) ; + register0_noctxt + S.protocol_data + (fun () (priority, seed_nonce_hash, proof_of_work_nonce) -> + return + (Data_encoding.Binary.to_bytes_exn + Block_header.contents_encoding + {priority; seed_nonce_hash; proof_of_work_nonce})) module Manager = struct - - let operations ctxt - block ~branch ~source ?sourcePubKey ~counter ~fee + let operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee ~gas_limit ~storage_limit operations = - Contract_services.manager_key ctxt block source >>= function - | Error _ as e -> Lwt.return e + Contract_services.manager_key ctxt block source + >>= function + | Error _ as e -> + Lwt.return e | Ok revealed -> let ops = List.map (fun (Manager operation) -> - Contents - (Manager_operation { source ; - counter ; operation ; fee ; - gas_limit ; storage_limit })) - operations in + Contents + (Manager_operation + { + source; + counter; + operation; + fee; + gas_limit; + storage_limit; + })) + operations + in let ops = - match sourcePubKey, revealed with - | None, _ | _, Some _ -> ops - | Some pk, None -> + match (sourcePubKey, revealed) with + | (None, _) | (_, Some _) -> + ops + | (Some pk, None) -> let operation = Reveal pk in Contents - (Manager_operation { source ; - counter ; operation ; fee ; - gas_limit ; storage_limit }) :: ops in - RPC_context.make_call0 S.operations ctxt block - () ({ branch }, Operation.of_list ops) + (Manager_operation + { + source; + counter; + operation; + fee; + gas_limit; + storage_limit; + }) + :: ops + in + RPC_context.make_call0 + S.operations + ctxt + block + () + ({branch}, Operation.of_list ops) - let reveal ctxt - block ~branch ~source ~sourcePubKey ~counter ~fee () = - operations ctxt block ~branch ~source ~sourcePubKey ~counter ~fee - ~gas_limit:Z.zero ~storage_limit:Z.zero [] + let reveal ctxt block ~branch ~source ~sourcePubKey ~counter ~fee () = + operations + ctxt + block + ~branch + ~source + ~sourcePubKey + ~counter + ~fee + ~gas_limit:Z.zero + ~storage_limit:Z.zero + [] - let transaction ctxt - block ~branch ~source ?sourcePubKey ~counter - ~amount ~destination ?(entrypoint = "default") ?parameters - ~gas_limit ~storage_limit ~fee ()= - let parameters = Option.unopt_map ~f:Script.lazy_expr ~default:Script.unit_parameter parameters in - operations ctxt block ~branch ~source ?sourcePubKey ~counter - ~fee ~gas_limit ~storage_limit - [Manager (Transaction { amount ; parameters ; destination ; entrypoint })] + let transaction ctxt block ~branch ~source ?sourcePubKey ~counter ~amount + ~destination ?(entrypoint = "default") ?parameters ~gas_limit + ~storage_limit ~fee () = + let parameters = + Option.unopt_map + ~f:Script.lazy_expr + ~default:Script.unit_parameter + parameters + in + operations + ctxt + block + ~branch + ~source + ?sourcePubKey + ~counter + ~fee + ~gas_limit + ~storage_limit + [Manager (Transaction {amount; parameters; destination; entrypoint})] - let origination ctxt - block ~branch - ~source ?sourcePubKey ~counter - ~balance - ?delegatePubKey ~script - ~gas_limit ~storage_limit ~fee () = - operations ctxt block ~branch ~source ?sourcePubKey ~counter - ~fee ~gas_limit ~storage_limit - [Manager (Origination { delegate = delegatePubKey ; - script ; - credit = balance ; - preorigination = None })] + let origination ctxt block ~branch ~source ?sourcePubKey ~counter ~balance + ?delegatePubKey ~script ~gas_limit ~storage_limit ~fee () = + operations + ctxt + block + ~branch + ~source + ?sourcePubKey + ~counter + ~fee + ~gas_limit + ~storage_limit + [ Manager + (Origination + { + delegate = delegatePubKey; + script; + credit = balance; + preorigination = None; + }) ] - let delegation ctxt - block ~branch ~source ?sourcePubKey ~counter ~fee delegate = - operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee - ~gas_limit:Z.zero ~storage_limit:Z.zero + let delegation ctxt block ~branch ~source ?sourcePubKey ~counter ~fee + delegate = + operations + ctxt + block + ~branch + ~source + ?sourcePubKey + ~counter + ~fee + ~gas_limit:Z.zero + ~storage_limit:Z.zero [Manager (Delegation delegate)] - end - let operation ctxt - block ~branch operation = - RPC_context.make_call0 S.operations ctxt block - () ({ branch }, Contents_list (Single operation)) + let operation ctxt block ~branch operation = + RPC_context.make_call0 + S.operations + ctxt + block + () + ({branch}, Contents_list (Single operation)) - let endorsement ctxt - b ~branch ~level () = - operation ctxt b ~branch - (Endorsement { level }) + let endorsement ctxt b ~branch ~level () = + operation ctxt b ~branch (Endorsement {level}) - let proposals ctxt - b ~branch ~source ~period ~proposals () = - operation ctxt b ~branch - (Proposals { source ; period ; proposals }) + let proposals ctxt b ~branch ~source ~period ~proposals () = + operation ctxt b ~branch (Proposals {source; period; proposals}) - let ballot ctxt - b ~branch ~source ~period ~proposal ~ballot () = - operation ctxt b ~branch - (Ballot { source ; period ; proposal ; ballot }) + let ballot ctxt b ~branch ~source ~period ~proposal ~ballot () = + operation ctxt b ~branch (Ballot {source; period; proposal; ballot}) - let seed_nonce_revelation ctxt - block ~branch ~level ~nonce () = - operation ctxt block ~branch (Seed_nonce_revelation { level ; nonce }) + let seed_nonce_revelation ctxt block ~branch ~level ~nonce () = + operation ctxt block ~branch (Seed_nonce_revelation {level; nonce}) - let double_baking_evidence ctxt - block ~branch ~bh1 ~bh2 () = - operation ctxt block ~branch (Double_baking_evidence { bh1 ; bh2 }) + let double_baking_evidence ctxt block ~branch ~bh1 ~bh2 () = + operation ctxt block ~branch (Double_baking_evidence {bh1; bh2}) - let double_endorsement_evidence ctxt - block ~branch ~op1 ~op2 () = - operation ctxt block ~branch (Double_endorsement_evidence { op1 ; op2 }) + let double_endorsement_evidence ctxt block ~branch ~op1 ~op2 () = + operation ctxt block ~branch (Double_endorsement_evidence {op1; op2}) let empty_proof_of_work_nonce = MBytes.of_string - (String.make Constants_repr.proof_of_work_nonce_size '\000') + (String.make Constants_repr.proof_of_work_nonce_size '\000') - let protocol_data ctxt + let protocol_data ctxt block ~priority ?seed_nonce_hash + ?(proof_of_work_nonce = empty_proof_of_work_nonce) () = + RPC_context.make_call0 + S.protocol_data + ctxt block - ~priority ?seed_nonce_hash - ?(proof_of_work_nonce = empty_proof_of_work_nonce) - () = - RPC_context.make_call0 S.protocol_data - ctxt block () (priority, seed_nonce_hash, proof_of_work_nonce) - + () + (priority, seed_nonce_hash, proof_of_work_nonce) end module Parse = struct - module S = struct - open Data_encoding let path = RPC_path.(path / "parse") @@ -599,22 +776,21 @@ module Parse = struct let operations = RPC_service.post_service ~description:"Parse operations" - ~query: RPC_query.empty + ~query:RPC_query.empty ~input: (obj2 (req "operations" (list (dynamic_size Operation.raw_encoding))) (opt "check_signature" bool)) - ~output: (list (dynamic_size Operation.encoding)) - RPC_path.(path / "operations" ) + ~output:(list (dynamic_size Operation.encoding)) + RPC_path.(path / "operations") let block = RPC_service.post_service ~description:"Parse a block" - ~query: RPC_query.empty - ~input: Block_header.raw_encoding - ~output: Block_header.protocol_data_encoding - RPC_path.(path / "block" ) - + ~query:RPC_query.empty + ~input:Block_header.raw_encoding + ~output:Block_header.protocol_data_encoding + RPC_path.(path / "block") end let parse_protocol_data protocol_data = @@ -623,68 +799,70 @@ module Parse = struct Block_header.protocol_data_encoding protocol_data with - | None -> failwith "Cant_parse_protocol_data" - | Some protocol_data -> return protocol_data + | None -> + failwith "Cant_parse_protocol_data" + | Some protocol_data -> + return protocol_data let register () = let open Services_registration in - register0 S.operations begin fun _ctxt () (operations, check) -> - map_s begin fun raw -> - Lwt.return (parse_operation raw) >>=? fun op -> - begin match check with - | Some true -> - return_unit (* FIXME *) - (* I.check_signature ctxt *) - (* op.protocol_data.signature op.shell op.protocol_data.contents *) - | Some false | None -> return_unit - end >>|? fun () -> op - end operations - end ; - register0_noctxt S.block begin fun () raw_block -> - parse_protocol_data raw_block.protocol_data - end + register0 S.operations (fun _ctxt () (operations, check) -> + map_s + (fun raw -> + Lwt.return (parse_operation raw) + >>=? fun op -> + ( match check with + | Some true -> + return_unit (* FIXME *) + (* I.check_signature ctxt *) + (* op.protocol_data.signature op.shell op.protocol_data.contents *) + | Some false | None -> + return_unit ) + >>|? fun () -> op) + operations) ; + register0_noctxt S.block (fun () raw_block -> + parse_protocol_data raw_block.protocol_data) let operations ctxt block ?check operations = - RPC_context.make_call0 - S.operations ctxt block () (operations, check) + RPC_context.make_call0 S.operations ctxt block () (operations, check) + let block ctxt block shell protocol_data = RPC_context.make_call0 - S.block ctxt block () ({ shell ; protocol_data } : Block_header.raw) - + S.block + ctxt + block + () + ({shell; protocol_data} : Block_header.raw) end module S = struct - open Data_encoding - type level_query = { - offset: int32 ; - } + type level_query = {offset : int32} + let level_query : level_query RPC_query.t = let open RPC_query in - query (fun offset -> { offset }) + query (fun offset -> {offset}) |+ field "offset" RPC_arg.int32 0l (fun t -> t.offset) |> seal let current_level = RPC_service.get_service ~description: - "Returns the level of the interrogated block, or the one of a \ - block located `offset` blocks after in the chain (or before \ - when negative). For instance, the next block if `offset` is 1." - ~query: level_query - ~output: Level.encoding + "Returns the level of the interrogated block, or the one of a block \ + located `offset` blocks after in the chain (or before when \ + negative). For instance, the next block if `offset` is 1." + ~query:level_query + ~output:Level.encoding RPC_path.(path / "current_level") let levels_in_current_cycle = RPC_service.get_service - ~description: "Levels of a cycle" - ~query: level_query - ~output: (obj2 - (req "first" Raw_level.encoding) - (req "last" Raw_level.encoding)) + ~description:"Levels of a cycle" + ~query:level_query + ~output: + (obj2 (req "first" Raw_level.encoding) (req "last" Raw_level.encoding)) RPC_path.(path / "levels_in_current_cycle") - end let register () = @@ -692,22 +870,21 @@ let register () = Forge.register () ; Parse.register () ; let open Services_registration in - register0 S.current_level begin fun ctxt q () -> - let level = Level.current ctxt in - return (Level.from_raw ctxt ~offset:q.offset level.level) - end ; - register0 S.levels_in_current_cycle begin fun ctxt q () -> - let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in - match levels with - | [] -> raise Not_found - | _ -> - let first = List.hd (List.rev levels) in - let last = List.hd levels in - return (first.level, last.level) - end + register0 S.current_level (fun ctxt q () -> + let level = Level.current ctxt in + return (Level.from_raw ctxt ~offset:q.offset level.level)) ; + register0 S.levels_in_current_cycle (fun ctxt q () -> + let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in + match levels with + | [] -> + raise Not_found + | _ -> + let first = List.hd (List.rev levels) in + let last = List.hd levels in + return (first.level, last.level)) let current_level ctxt ?(offset = 0l) block = - RPC_context.make_call0 S.current_level ctxt block { offset } () + RPC_context.make_call0 S.current_level ctxt block {offset} () let levels_in_current_cycle ctxt ?(offset = 0l) block = - RPC_context.make_call0 S.levels_in_current_cycle ctxt block { offset } () + RPC_context.make_call0 S.levels_in_current_cycle ctxt block {offset} () diff --git a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli index fc205d97b..ba0150594 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.mli @@ -27,69 +27,99 @@ open Alpha_context type error += Cannot_parse_operation (* `Branch *) -val current_level: - 'a #RPC_context.simple -> - ?offset:int32 -> 'a -> Level.t shell_tzresult Lwt.t +val current_level : + 'a #RPC_context.simple -> ?offset:int32 -> 'a -> Level.t shell_tzresult Lwt.t -val levels_in_current_cycle: +val levels_in_current_cycle : 'a #RPC_context.simple -> - ?offset:int32 -> 'a -> (Raw_level.t * Raw_level.t) shell_tzresult Lwt.t + ?offset:int32 -> + 'a -> + (Raw_level.t * Raw_level.t) shell_tzresult Lwt.t module Scripts : sig - - val run_code: + val run_code : 'a #RPC_context.simple -> - 'a -> Script.expr -> - (Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) -> - (Script.expr * - packed_internal_operation list * - Contract.big_map_diff option) shell_tzresult Lwt.t + 'a -> + Script.expr -> + Script.expr + * Script.expr + * Tez.t + * Chain_id.t + * Contract.t option + * Contract.t option + * Z.t option + * string -> + ( Script.expr + * packed_internal_operation list + * Contract.big_map_diff option ) + shell_tzresult + Lwt.t - val trace_code: + val trace_code : 'a #RPC_context.simple -> - 'a -> Script.expr -> - (Script.expr * Script.expr * Tez.t * Chain_id.t * Contract.t option * Contract.t option * Z.t option * string) -> - (Script.expr * - packed_internal_operation list * - Script_interpreter.execution_trace * - Contract.big_map_diff option) shell_tzresult Lwt.t + 'a -> + Script.expr -> + Script.expr + * Script.expr + * Tez.t + * Chain_id.t + * Contract.t option + * Contract.t option + * Z.t option + * string -> + ( Script.expr + * packed_internal_operation list + * Script_interpreter.execution_trace + * Contract.big_map_diff option ) + shell_tzresult + Lwt.t - val typecheck_code: + val typecheck_code : 'a #RPC_context.simple -> - 'a -> (Script.expr * Z.t option) -> + 'a -> + Script.expr * Z.t option -> (Script_tc_errors.type_map * Gas.t) shell_tzresult Lwt.t - val typecheck_data: + val typecheck_data : 'a #RPC_context.simple -> - 'a -> Script.expr * Script.expr * Z.t option -> Gas.t shell_tzresult Lwt.t + 'a -> + Script.expr * Script.expr * Z.t option -> + Gas.t shell_tzresult Lwt.t - val pack_data: + val pack_data : 'a #RPC_context.simple -> - 'a -> Script.expr * Script.expr * Z.t option -> (MBytes.t * Gas.t) shell_tzresult Lwt.t + 'a -> + Script.expr * Script.expr * Z.t option -> + (MBytes.t * Gas.t) shell_tzresult Lwt.t - val run_operation: + val run_operation : 'a #RPC_context.simple -> - 'a -> packed_operation * Chain_id.t -> - (packed_protocol_data * Apply_results.packed_operation_metadata) shell_tzresult Lwt.t + 'a -> + packed_operation * Chain_id.t -> + (packed_protocol_data * Apply_results.packed_operation_metadata) + shell_tzresult + Lwt.t - val entrypoint_type: + val entrypoint_type : 'a #RPC_context.simple -> - 'a -> Script.expr * string -> Script.expr shell_tzresult Lwt.t + 'a -> + Script.expr * string -> + Script.expr shell_tzresult Lwt.t - val list_entrypoints: + val list_entrypoints : 'a #RPC_context.simple -> - 'a -> Script.expr -> - (Michelson_v1_primitives.prim list list * - (string * Script.expr) list) shell_tzresult Lwt.t - + 'a -> + Script.expr -> + (Michelson_v1_primitives.prim list list * (string * Script.expr) list) + shell_tzresult + Lwt.t end module Forge : sig - module Manager : sig - - val operations: - 'a #RPC_context.simple -> 'a -> + val operations : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> source:public_key_hash -> ?sourcePubKey:public_key -> @@ -97,19 +127,23 @@ module Forge : sig fee:Tez.t -> gas_limit:Z.t -> storage_limit:Z.t -> - packed_manager_operation list -> MBytes.t shell_tzresult Lwt.t + packed_manager_operation list -> + MBytes.t shell_tzresult Lwt.t - val reveal: - 'a #RPC_context.simple -> 'a -> + val reveal : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> source:public_key_hash -> sourcePubKey:public_key -> counter:counter -> fee:Tez.t -> - unit -> MBytes.t shell_tzresult Lwt.t + unit -> + MBytes.t shell_tzresult Lwt.t - val transaction: - 'a #RPC_context.simple -> 'a -> + val transaction : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> source:public_key_hash -> ?sourcePubKey:public_key -> @@ -121,24 +155,28 @@ module Forge : sig gas_limit:Z.t -> storage_limit:Z.t -> fee:Tez.t -> - unit -> MBytes.t shell_tzresult Lwt.t + unit -> + MBytes.t shell_tzresult Lwt.t - val origination: - 'a #RPC_context.simple -> 'a -> + val origination : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> source:public_key_hash -> ?sourcePubKey:public_key -> counter:counter -> balance:Tez.t -> - ?delegatePubKey: public_key_hash -> + ?delegatePubKey:public_key_hash -> script:Script.t -> gas_limit:Z.t -> storage_limit:Z.t -> - fee:Tez.t-> - unit -> MBytes.t shell_tzresult Lwt.t + fee:Tez.t -> + unit -> + MBytes.t shell_tzresult Lwt.t - val delegation: - 'a #RPC_context.simple -> 'a -> + val delegation : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> source:public_key_hash -> ?sourcePubKey:public_key -> @@ -146,74 +184,88 @@ module Forge : sig fee:Tez.t -> public_key_hash option -> MBytes.t shell_tzresult Lwt.t - end - val endorsement: - 'a #RPC_context.simple -> 'a -> + val endorsement : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> level:Raw_level.t -> - unit -> MBytes.t shell_tzresult Lwt.t + unit -> + MBytes.t shell_tzresult Lwt.t - val proposals: - 'a #RPC_context.simple -> 'a -> + val proposals : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> source:public_key_hash -> period:Voting_period.t -> proposals:Protocol_hash.t list -> - unit -> MBytes.t shell_tzresult Lwt.t + unit -> + MBytes.t shell_tzresult Lwt.t - val ballot: - 'a #RPC_context.simple -> 'a -> + val ballot : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> source:public_key_hash -> period:Voting_period.t -> proposal:Protocol_hash.t -> ballot:Vote.ballot -> - unit -> MBytes.t shell_tzresult Lwt.t + unit -> + MBytes.t shell_tzresult Lwt.t - val seed_nonce_revelation: - 'a #RPC_context.simple -> 'a -> + val seed_nonce_revelation : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> level:Raw_level.t -> nonce:Nonce.t -> - unit -> MBytes.t shell_tzresult Lwt.t + unit -> + MBytes.t shell_tzresult Lwt.t - val double_baking_evidence: - 'a #RPC_context.simple -> 'a -> + val double_baking_evidence : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> - bh1: Block_header.t -> - bh2: Block_header.t -> - unit -> MBytes.t shell_tzresult Lwt.t + bh1:Block_header.t -> + bh2:Block_header.t -> + unit -> + MBytes.t shell_tzresult Lwt.t - val double_endorsement_evidence: - 'a #RPC_context.simple -> 'a -> + val double_endorsement_evidence : + 'a #RPC_context.simple -> + 'a -> branch:Block_hash.t -> - op1: Kind.endorsement operation -> - op2: Kind.endorsement operation -> - unit -> MBytes.t shell_tzresult Lwt.t - - val protocol_data: - 'a #RPC_context.simple -> 'a -> - priority: int -> - ?seed_nonce_hash: Nonce_hash.t -> - ?proof_of_work_nonce: MBytes.t -> - unit -> MBytes.t shell_tzresult Lwt.t + op1:Kind.endorsement operation -> + op2:Kind.endorsement operation -> + unit -> + MBytes.t shell_tzresult Lwt.t + val protocol_data : + 'a #RPC_context.simple -> + 'a -> + priority:int -> + ?seed_nonce_hash:Nonce_hash.t -> + ?proof_of_work_nonce:MBytes.t -> + unit -> + MBytes.t shell_tzresult Lwt.t end module Parse : sig - - val operations: - 'a #RPC_context.simple -> 'a -> - ?check:bool -> Operation.raw list -> + val operations : + 'a #RPC_context.simple -> + 'a -> + ?check:bool -> + Operation.raw list -> Operation.packed list shell_tzresult Lwt.t - val block: - 'a #RPC_context.simple -> 'a -> - Block_header.shell_header -> MBytes.t -> + val block : + 'a #RPC_context.simple -> + 'a -> + Block_header.shell_header -> + MBytes.t -> Block_header.protocol_data shell_tzresult Lwt.t - end -val register: unit -> unit +val register : unit -> unit diff --git a/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml index 2a098b457..76d657cfb 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/init_storage.ml @@ -2,7 +2,6 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2019 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -24,355 +23,36 @@ (* *) (*****************************************************************************) -(* Delegated storage changed type of value from Contract_hash to - Contract_repr. Move all 'delegated' data into a storage with - the original type, then copy over into the new storage. *) -let migrate_delegated ctxt contract = - let path = "contracts" :: (* module Contract *) - "index" :: (* module Indexed_context *) - Contract_repr.Index.to_path contract [ - "delegated" ; (* module Delegated *) - ] in - let path_tmp = "contracts" :: (* module Contract *) - "index" :: (* module Indexed_context *) - Contract_repr.Index.to_path contract [ - "delegated_004" ; (* module Delegated *) - ] in - Raw_context.dir_mem ctxt path >>= fun exists -> - if exists then - Raw_context.copy ctxt path path_tmp >>=? fun ctxt -> - Raw_context.remove_rec ctxt path >>= fun ctxt -> - Storage.Contract.Delegated_004.fold (ctxt, contract) ~init:(Ok ctxt) ~f:(fun delegated ctxt -> - Lwt.return ctxt >>=? fun ctxt -> - let originated = Contract_repr.originated_contract_004 delegated in - Storage.Contract.Delegated.add (ctxt, contract) originated >>= fun ctxt -> - return ctxt - ) >>=? fun ctxt -> - Raw_context.remove_rec ctxt path_tmp >>= fun ctxt -> - return ctxt - else - return ctxt - -let transform_script: - (manager_pkh: Signature.Public_key_hash.t -> - script_code: Script_repr.lazy_expr -> - script_storage: Script_repr.lazy_expr -> - (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t) -> - manager_pkh: Signature.Public_key_hash.t -> - Raw_context.t -> - Contract_repr.t -> - Script_repr.lazy_expr -> - Raw_context.t tzresult Lwt.t = - fun transformation ~manager_pkh ctxt contract code -> - Storage.Contract.Storage.get ctxt contract >>=? fun (_ctxt, storage) -> - transformation manager_pkh code storage >>=? fun (migrated_code, migrated_storage) -> - (* Set the migrated script code for free *) - Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, code_size_diff) -> - (* Set the migrated script storage for free *) - Storage.Contract.Storage.set_free ctxt contract migrated_storage >>=? fun (ctxt, storage_size_diff) -> - Storage.Contract.Used_storage_space.get ctxt contract >>=? fun used_space -> - let total_size = Z.(add (of_int code_size_diff) (add (of_int storage_size_diff) used_space)) in - (* Free storage space for migrated contracts *) - Storage.Contract.Used_storage_space.set ctxt contract total_size >>=? fun ctxt -> - Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_space -> - if Compare.Z.(paid_space < total_size) then - Storage.Contract.Paid_storage_space.set ctxt contract total_size >>=? fun ctxt -> - return ctxt - else - return ctxt - -let manager_script_storage: Signature.Public_key_hash.t -> Script_repr.lazy_expr = - fun manager_pkh -> - let open Micheline in - Script_repr.lazy_expr @@ strip_locations @@ - (* store in optimized binary representation - as unparsed with [Optimized]. *) - let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh in - Bytes (0, bytes) - -(* If the given contract is not allocated, we'll allocate it with 1 mutez, - so that the migrated contracts' managers don't have to pay origination burn *) -let allocate_contract ctxt contract = - Contract_storage.allocated ctxt contract >>=? function - | true -> - return ctxt - | false -> - Contract_storage.credit ctxt contract Tez_repr.one_mutez - -(* Process an individual contract *) -let process_contract_add_manager contract ctxt = - let open Legacy_script_support_repr in - match Contract_repr.is_originated contract with - | None -> return ctxt (* Only process originated contracts *) - | Some _ -> begin - Storage.Contract.Counter.remove ctxt contract >>= fun ctxt -> - Storage.Contract.Spendable_004.mem ctxt contract >>= fun is_spendable -> - Storage.Contract.Delegatable_004.mem ctxt contract >>= fun is_delegatable -> - Storage.Contract.Spendable_004.del ctxt contract >>= fun ctxt -> - Storage.Contract.Delegatable_004.del ctxt contract >>= fun ctxt -> - (* Try to get script code (ignore ctxt update to discard the initialization) *) - Storage.Contract.Code.get_option ctxt contract >>=? fun (_ctxt, code) -> - (* Get the manager of the originated contract *) - Contract_storage.get_manager_004 ctxt contract >>=? fun manager_pkh -> - let manager = Contract_repr.implicit_contract manager_pkh in - Storage.Contract.Manager.remove ctxt contract >>= fun ctxt -> - match code with - | Some code -> - (* - | spendable | delegatable | template | - |-----------+-------------+------------------| - | true | true | add_do | - | true | false | add_do | - | false | true | add_set_delegate | - | false | false | nothing | - *) - if is_spendable then - transform_script add_do ~manager_pkh ctxt contract code >>=? fun ctxt -> - allocate_contract ctxt manager - else if is_delegatable then - transform_script add_set_delegate ~manager_pkh ctxt contract code >>=? fun ctxt -> - allocate_contract ctxt manager - else if has_default_entrypoint code then - transform_script - (fun ~manager_pkh:_ ~script_code ~script_storage -> - add_root_entrypoint script_code >>=? fun script_code -> - return (script_code, script_storage)) - ~manager_pkh ctxt contract code - else - return ctxt - | None -> begin - (* Initialize the script code for free *) - Storage.Contract.Code.init_free ctxt contract manager_script_code >>=? fun (ctxt, code_size) -> - let storage = manager_script_storage manager_pkh in - (* Initialize the script storage for free *) - Storage.Contract.Storage.init_free ctxt contract storage >>=? fun (ctxt, storage_size) -> - let total_size = Z.(add (of_int code_size) (of_int storage_size)) in - (* Free storage space for migrated contracts *) - Storage.Contract.Paid_storage_space.init_set ctxt contract total_size >>= fun ctxt -> - Storage.Contract.Used_storage_space.init_set ctxt contract total_size >>= fun ctxt -> - allocate_contract ctxt manager - end - end - -(* The [[update_contract_script]] function returns a copy of its - argument (the Micheline AST of a contract script) with "ADDRESS" - replaced by "ADDRESS; CHAIN_ID; PAIR". - - [[Micheline.strip_locations]] should be called on the resulting - Micheline AST to get meaningful locations. *) - -let rec update_contract_script : ('l, 'p) Micheline.node -> ('l, 'p) Micheline.node - = function - | Micheline.Seq (_, - Micheline.Prim (_, Michelson_v1_primitives.I_ADDRESS, [], []) :: - l) -> - Micheline.Seq (0, - Micheline.Prim (0, Michelson_v1_primitives.I_ADDRESS, [], []) :: - Micheline.Prim (0, Michelson_v1_primitives.I_CHAIN_ID, [], []) :: - Micheline.Prim (0, Michelson_v1_primitives.I_PAIR, [], []) :: l) - | Micheline.Seq (_, a :: l) -> - let a' = update_contract_script a in - let b = Micheline.Seq (0, l) in - let b' = update_contract_script b in - begin match b' with - | Micheline.Seq (_, l') -> - Micheline.Seq (0, a' :: l') - | _ -> assert false - end - | Micheline.Prim (_, p, l, annot) -> - Micheline.Prim (0, p, List.map update_contract_script l, annot) - | script -> script - -let migrate_multisig_script (ctxt : Raw_context.t) (contract : Contract_repr.t) - (code : Script_repr.expr) : Raw_context.t tzresult Lwt.t = - let migrated_code = - Script_repr.lazy_expr @@ Micheline.strip_locations @@ - update_contract_script @@ Micheline.root code - in - Storage.Contract.Code.set_free ctxt contract migrated_code >>=? fun (ctxt, _code_size_diff) -> - (* Set the spendable and delegatable flags to false so that no entrypoint gets added by - the [[process_contract_add_manager]] function. *) - Storage.Contract.Spendable_004.set ctxt contract false >>= fun ctxt -> - Storage.Contract.Delegatable_004.set ctxt contract false >>= fun ctxt -> - return ctxt - -(* The hash of the multisig contract; only contracts with this exact - hash are going to be updated by the [[update_contract_script]] - function. *) -let multisig_hash : Script_expr_hash.t = - Script_expr_hash.of_bytes_exn @@ - MBytes.of_hex @@ - `Hex "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31" - -let process_contract_multisig (contract : Contract_repr.t) (ctxt : Raw_context.t) = - Contract_storage.get_script ctxt contract >>=? fun (ctxt, script_opt) -> - match script_opt with - | None -> - (* Do nothing on scriptless contracts *) - return ctxt - | Some { Script_repr.code = code ; Script_repr.storage = _storage } -> - (* The contract has some script, only try to modify it if it has - the hash of the multisig contract *) - Lwt.return (Script_repr.force_decode code) >>=? fun (code, _gas_cost) -> - let bytes = - Data_encoding.Binary.to_bytes_exn Script_repr.expr_encoding code - in - let hash = Script_expr_hash.hash_bytes [ bytes ] in - if Script_expr_hash.(hash = multisig_hash) then - migrate_multisig_script ctxt contract code - else - return ctxt - -(* Process an individual contract *) -let process_contract contract ctxt = - process_contract_multisig contract ctxt >>=? fun ctxt -> - process_contract_add_manager contract ctxt >>=? fun ctxt -> - return ctxt - -let invoice_contract ctxt kt1_addr amount = - let amount = Tez_repr.of_mutez_exn (Int64.(mul 1_000_000L (of_int amount))) in - match Contract_repr.of_b58check kt1_addr with - | Ok recipient -> begin - Contract_storage.credit ctxt recipient amount >>= function - | Ok ctxt -> return ctxt - | Error _ -> return ctxt end - | Error _ -> return ctxt - -(* Extract Big_maps from their parent contract directory, - recompute their used space, and assign them an ID. *) -let migrate_contract_big_map ctxt contract = - Storage.Contract.Code.get_option ctxt contract >>=? function - | ctxt, None -> return ctxt - | ctxt, Some code -> - Storage.Contract.Storage.get ctxt contract >>=? fun (ctxt, storage) -> - let extract_big_map_types expr = - let open Michelson_v1_primitives in - let open Micheline in - match Micheline.root expr with - | Seq (_, [ Prim (_, K_storage, [ expr ], _) ; _ ; _ ]) - | Seq (_, [ _ ; Prim (_, K_storage, [ expr ], _) ; _ ]) - | Seq (_, [ _ ; _ ; Prim (_, K_storage, [ expr ], _) ]) -> - begin match expr with - | Prim (_, T_pair, [ Prim (_, T_big_map, [ kt ; vt ], _ ) ; _ ], _) -> Some (kt, vt) - | _ -> None - end - | _ -> None in - let rewrite_big_map expr id = - let open Michelson_v1_primitives in - let open Micheline in - match Micheline.root expr with - | Prim (_, D_Pair, [ Seq (_, _ (* ignore_unused_origination_literal *)) ; pannot ], sannot) -> - Micheline.strip_locations (Prim (0, D_Pair, [ Int (0, id) ; pannot ], sannot)) - | _ -> assert false in - Lwt.return (Script_repr.force_decode code) >>=? fun (code, _) -> - match extract_big_map_types code with - | None -> return ctxt - | Some (kt, vt) -> - Lwt.return (Script_repr.force_decode storage) >>=? fun (storage, _) -> - Storage.Big_map.Next.incr ctxt >>=? fun (ctxt, id) -> - let contract_path suffix = - "contracts" :: (* module Contract *) - "index" :: (* module Indexed_context *) - Contract_repr.Index.to_path contract suffix in - let old_path = contract_path [ "big_map" ] in - let storage = rewrite_big_map storage id in - Storage.Contract.Storage.set ctxt contract (Script_repr.lazy_expr storage) >>=? fun (ctxt, _) -> - let kt = Micheline.strip_locations (Script_repr.strip_annotations kt) in - let vt = Micheline.strip_locations (Script_repr.strip_annotations vt) in - Storage.Big_map.Key_type.init ctxt id kt >>=? fun ctxt -> - Storage.Big_map.Value_type.init ctxt id vt >>=? fun ctxt -> - Raw_context.dir_mem ctxt old_path >>= fun exists -> - if exists then - let read_size ctxt key = - Raw_context.get ctxt key >>=? fun len -> - match Data_encoding.(Binary.of_bytes int31) len with - | None -> assert false - | Some len -> return len in - let iter_sizes f (ctxt, acc) = - let rec dig i path (ctxt, acc) = - if Compare.Int.(i <= 0) then - Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc -> - Lwt.return acc >>=? fun (ctxt, acc) -> - match k with - | `Dir _ -> return (ctxt, acc) - | `Key file -> - match List.rev file with - | last :: _ when Compare.String.(last = "data") -> - return (ctxt, acc) - | last :: _ when Compare.String.(last = "len") -> - read_size ctxt file >>=? fun len -> - return (ctxt, f len acc) - | _ -> assert false - end - else - Raw_context.fold ctxt path ~init:(ok (ctxt, acc)) ~f:begin fun k acc -> - Lwt.return acc >>=? fun (ctxt, acc) -> - match k with - | `Dir k -> dig (i-1) k (ctxt, acc) - | `Key _ -> return (ctxt, acc) - end in - dig Script_expr_hash.path_length old_path (ctxt, acc) in - iter_sizes - (fun s acc -> (acc |> Z.add (Z.of_int s) |> Z.add (Z.of_int 65))) - (ctxt, (Z.of_int 0)) >>=? fun (ctxt, total_bytes) -> - Storage.Big_map.Total_bytes.init ctxt id total_bytes >>=? fun ctxt -> - let new_path = "big_maps" :: (* module Big_map *) - "index" :: (* module Indexed_context *) - Storage.Big_map.Index.to_path id [ - "contents" ; (* module Delegated *) - ] in - Raw_context.copy ctxt old_path new_path >>=? fun ctxt -> - Raw_context.remove_rec ctxt old_path >>= fun ctxt -> - read_size ctxt (contract_path [ "len" ; "code" ]) >>=? fun code_size -> - read_size ctxt (contract_path [ "len" ; "storage" ]) >>=? fun storage_size -> - let total_bytes = - total_bytes |> - Z.add (Z.of_int 33) |> - Z.add (Z.of_int code_size) |> - Z.add (Z.of_int storage_size) in - Storage.Contract.Used_storage_space.get ctxt contract >>=? fun previous_size -> - Storage.Contract.Paid_storage_space.get ctxt contract >>=? fun paid_bytes -> - let change = Z.sub paid_bytes previous_size in - Storage.Contract.Used_storage_space.set ctxt contract total_bytes >>=? fun ctxt -> - Storage.Contract.Paid_storage_space.set ctxt contract (Z.add total_bytes change) - else - Storage.Big_map.Total_bytes.init ctxt id Z.zero >>=? fun ctxt -> - return ctxt - +(* This is the genesis protocol: initialise the state *) let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = - Raw_context.prepare_first_block - ~level ~timestamp ~fitness ctxt >>=? fun (previous_protocol, ctxt) -> - Storage.Big_map.Next.init ctxt >>=? fun ctxt -> + Raw_context.prepare_first_block ~level ~timestamp ~fitness ctxt + >>=? fun (previous_protocol, ctxt) -> match previous_protocol with | Genesis param -> - Commitment_storage.init ctxt param.commitments >>=? fun ctxt -> - Roll_storage.init ctxt >>=? fun ctxt -> - Seed_storage.init ctxt >>=? fun ctxt -> - Contract_storage.init ctxt >>=? fun ctxt -> - Bootstrap_storage.init ctxt + Commitment_storage.init ctxt param.commitments + >>=? fun ctxt -> + Roll_storage.init ctxt + >>=? fun ctxt -> + Seed_storage.init ctxt + >>=? fun ctxt -> + Contract_storage.init ctxt + >>=? fun ctxt -> + Bootstrap_storage.init + ctxt ~typecheck ?ramp_up_cycles:param.security_deposit_ramp_up_cycles ?no_reward_cycles:param.no_reward_cycles param.bootstrap_accounts - param.bootstrap_contracts >>=? fun ctxt -> - Roll_storage.init_first_cycles ctxt >>=? fun ctxt -> - Vote_storage.init ctxt >>=? fun ctxt -> - Storage.Block_priority.init ctxt 0 >>=? fun ctxt -> - Vote_storage.freeze_listings ctxt >>=? fun ctxt -> - return ctxt - | Athens_004 -> - Storage.Vote.Current_quorum_004.get ctxt >>=? fun quorum -> - Storage.Vote.Participation_ema.init ctxt quorum >>=? fun ctxt -> - Storage.Vote.Current_quorum_004.delete ctxt >>=? fun ctxt -> - Storage.Block_priority.init ctxt 0 >>=? fun ctxt -> - Storage.Last_block_priority.delete ctxt >>=? fun ctxt -> - Storage.Contract.fold ctxt ~init:(Ok ctxt) - ~f:(fun contract ctxt -> - Lwt.return ctxt >>=? fun ctxt -> - migrate_delegated ctxt contract >>=? fun ctxt -> - migrate_contract_big_map ctxt contract >>=? fun ctxt -> - process_contract contract ctxt) + param.bootstrap_contracts >>=? fun ctxt -> - invoice_contract ctxt "KT1DUfaMfTRZZkvZAYQT5b3byXnvqoAykc43" 500 >>=? fun ctxt -> + Roll_storage.init_first_cycles ctxt + >>=? fun ctxt -> + Vote_storage.init ctxt + >>=? fun ctxt -> + Storage.Block_priority.init ctxt 0 + >>=? fun ctxt -> + Vote_storage.freeze_listings ctxt >>=? fun ctxt -> return ctxt + | Babylon_005 -> return ctxt let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness = diff --git a/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml index e9c74fae8..80de6f216 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.ml @@ -25,101 +25,129 @@ (* *) (*****************************************************************************) -let manager_script_code: Script_repr.lazy_expr = +let manager_script_code : Script_repr.lazy_expr = let open Micheline in let open Michelson_v1_primitives in - Script_repr.lazy_expr @@ strip_locations @@ - Seq (0, [ - Prim (0, K_parameter, [ - Prim (0, T_or, [ - Prim (0, T_lambda, [ - Prim (0, T_unit, [], []); - Prim (0, T_list, [ - Prim (0, T_operation, [], []) - ], []) - ], ["%do"]); - Prim (0, T_unit, [], ["%default"]) - ], []) - ], []); - Prim (0, K_storage, [ - Prim (0, T_key_hash, [], []) - ], []); - Prim (0, K_code, [ - Seq (0, [ - Seq (0, [ - Seq (0, [ - Prim (0, I_DUP, [], []); - Prim (0, I_CAR, [], []); - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_CDR, [], []) - ]) - ], []) - ]) - ]); - Prim (0, I_IF_LEFT, [ - Seq (0, [ - Prim (0, I_PUSH, [ - Prim (0, T_mutez, [], []); - Int (0, Z.zero) - ], []); - Prim (0, I_AMOUNT, [], []); - Seq (0, [ - Seq (0, [ - Prim (0, I_COMPARE, [], []); - Prim (0, I_EQ, [], []) - ]); - Prim (0, I_IF, [ - Seq (0, []); - Seq (0, [ - Seq (0, [ - Prim (0, I_UNIT, [], []); - Prim (0, I_FAILWITH, [], []) - ]) - ]) - ], []) - ]); - Seq (0, [ - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_DUP, [], []) - ]) - ], []); - Prim (0, I_SWAP, [], []) - ]); - Prim (0, I_IMPLICIT_ACCOUNT, [], []); - Prim (0, I_ADDRESS, [], []); - Prim (0, I_SENDER, [], []); - Seq (0, [ - Seq (0, [ - Prim (0, I_COMPARE, [], []); - Prim (0, I_EQ, [], []) - ]); - Prim (0, I_IF, [ - Seq (0, []); - Seq (0, [ - Seq (0, [ - Prim (0, I_UNIT, [], []); - Prim (0, I_FAILWITH, [], []) - ]) - ]) - ], []) - ]); - Prim (0, I_UNIT, [], []); - Prim (0, I_EXEC, [], []); - Prim (0, I_PAIR, [], []) - ]); - Seq (0, [ - Prim (0, I_DROP, [], []); - Prim (0, I_NIL, [ - Prim (0, T_operation, [], []) - ], []); - Prim (0, I_PAIR, [], []) - ]) - ], []) - ]) - ], []) - ]) + Script_repr.lazy_expr @@ strip_locations + @@ Seq + ( 0, + [ Prim + ( 0, + K_parameter, + [ Prim + ( 0, + T_or, + [ Prim + ( 0, + T_lambda, + [ Prim (0, T_unit, [], []); + Prim + (0, T_list, [Prim (0, T_operation, [], [])], []) + ], + ["%do"] ); + Prim (0, T_unit, [], ["%default"]) ], + [] ) ], + [] ); + Prim (0, K_storage, [Prim (0, T_key_hash, [], [])], []); + Prim + ( 0, + K_code, + [ Seq + ( 0, + [ Seq + ( 0, + [ Seq + ( 0, + [ Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim + ( 0, + I_DIP, + [Seq (0, [Prim (0, I_CDR, [], [])])], + [] ) ] ) ] ); + Prim + ( 0, + I_IF_LEFT, + [ Seq + ( 0, + [ Prim + ( 0, + I_PUSH, + [ Prim (0, T_mutez, [], []); + Int (0, Z.zero) ], + [] ); + Prim (0, I_AMOUNT, [], []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) ] ); + Prim + ( 0, + I_IF, + [ Seq (0, []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim + (0, I_UNIT, [], []); + Prim + ( 0, + I_FAILWITH, + [], + [] ) ] ) ] ) ], + [] ) ] ); + Seq + ( 0, + [ Prim + ( 0, + I_DIP, + [ Seq + (0, [Prim (0, I_DUP, [], [])]) + ], + [] ); + Prim (0, I_SWAP, [], []) ] ); + Prim (0, I_IMPLICIT_ACCOUNT, [], []); + Prim (0, I_ADDRESS, [], []); + Prim (0, I_SENDER, [], []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) ] ); + Prim + ( 0, + I_IF, + [ Seq (0, []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim + (0, I_UNIT, [], []); + Prim + ( 0, + I_FAILWITH, + [], + [] ) ] ) ] ) ], + [] ) ] ); + Prim (0, I_UNIT, [], []); + Prim (0, I_EXEC, [], []); + Prim (0, I_PAIR, [], []) ] ); + Seq + ( 0, + [ Prim (0, I_DROP, [], []); + Prim + ( 0, + I_NIL, + [Prim (0, T_operation, [], [])], + [] ); + Prim (0, I_PAIR, [], []) ] ) ], + [] ) ] ) ], + [] ) ] ) (* Find the toplevel expression with a given prim type from list, because they can be in arbitrary order. *) @@ -127,406 +155,674 @@ let find_toplevel toplevel exprs = let open Micheline in let rec iter toplevel = function | (Prim (_, prim, _, _) as found) :: _ - when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim) -> + when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim) + -> Some found | _ :: rest -> iter toplevel rest | [] -> - None in + None + in iter (Michelson_v1_primitives.string_of_prim toplevel) exprs -let add_do: - manager_pkh: Signature.Public_key_hash.t -> - script_code: Script_repr.lazy_expr -> - script_storage: Script_repr.lazy_expr -> - (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t = - fun ~manager_pkh ~script_code ~script_storage -> +let add_do : + manager_pkh:Signature.Public_key_hash.t -> + script_code:Script_repr.lazy_expr -> + script_storage:Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t = + fun ~manager_pkh ~script_code ~script_storage -> let open Micheline in let open Michelson_v1_primitives in - Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) -> - Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) -> + Lwt.return (Script_repr.force_decode script_code) + >>=? fun (script_code_expr, _gas_cost) -> + Lwt.return (Script_repr.force_decode script_storage) + >>|? fun (script_storage_expr, _gas_cost) -> let storage_expr = root script_storage_expr in match root script_code_expr with - | Seq (_, toplevel) - -> begin - match find_toplevel K_parameter toplevel, - find_toplevel K_storage toplevel, - find_toplevel K_code toplevel with - Some (Prim (_, K_parameter, [ - Prim (_, parameter_type, parameter_expr, parameter_annot) - ], prim_param_annot)), - Some (Prim (_, K_storage, [ - Prim (_, code_storage_type, code_storage_expr, code_storage_annot) - ], k_storage_annot)), - Some (Prim (_, K_code, [code_expr], code_annot)) -> - (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *) - - let migrated_code = - Seq (0, [ - Prim (0, K_parameter, [ - Prim (0, T_or, [ - Prim (0, T_lambda, [ - Prim (0, T_unit, [], []); - Prim (0, T_list, [ - Prim (0, T_operation, [], []) - ], []) - ], ["%do"]); - Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot) - ], []) - ], prim_param_annot); - Prim (0, K_storage, [ - Prim (0, T_pair, [ - Prim (0, T_key_hash, [], []); - Prim (0, code_storage_type, code_storage_expr, code_storage_annot) - ], []) - ], k_storage_annot); - Prim (0, K_code, [ - Seq (0, [ - Prim (0, I_DUP, [], []); - Prim (0, I_CAR, [], []); - Prim (0, I_IF_LEFT, [ - Seq (0, [ - Prim (0, I_PUSH, [ - Prim (0, T_mutez, [], []); - Int (0, Z.zero) - ], []); - Prim (0, I_AMOUNT, [], []); - Seq (0, [ - Seq (0, [ - Prim (0, I_COMPARE, [], []); - Prim (0, I_EQ, [], []) - ]); - Prim (0, I_IF, [ - Seq (0, []); - Seq (0, [ - Seq (0, [ - Prim (0, I_UNIT, [], []); - Prim (0, I_FAILWITH, [], []) - ]) - ]) - ], []) - ]); - Seq (0, [ - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_DUP, [], []) - ]) - ], []); - Prim (0, I_SWAP, [], []) - ]); - Prim (0, I_CDR, [], []); - Prim (0, I_CAR, [], []); - Prim (0, I_IMPLICIT_ACCOUNT, [], []); - Prim (0, I_ADDRESS, [], []); - Prim (0, I_SENDER, [], []); - Seq (0, [ - Prim (0, I_COMPARE, [], []); - Prim (0, I_NEQ, [], []); - Prim (0, I_IF, [ - Seq (0, [ - Prim (0, I_SENDER, [], []); - Prim (0, I_PUSH, [ - Prim (0, T_string, [], []); - String (0, "Only the owner can operate.") - ], []); - Prim (0, I_PAIR, [], []); - Prim (0, I_FAILWITH, [], []) - ]); - Seq (0, [ - Prim (0, I_UNIT, [], []); - Prim (0, I_EXEC, [], []); - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_CDR, [], []) - ]) - ], []); - Prim (0, I_PAIR, [], []) - ]) - ], []) - ]) - ]); - Seq (0, [ - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_CDR, [], []); - Prim (0, I_DUP, [], []); - Prim (0, I_CDR, [], []) - ]) - ], []); - Prim (0, I_PAIR, [], []); - - code_expr; - - Prim (0, I_SWAP, [], []); - Prim (0, I_CAR, [], []); - Prim (0, I_SWAP, [], []); - Seq (0, [ - Seq (0, [ - Prim (0, I_DUP, [], []); - Prim (0, I_CAR, [], []); - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_CDR, [], []) - ]) - ], []) - ]) - ]); - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_SWAP, [], []); - Prim (0, I_PAIR, [], []) - ]) - ], []); - Prim (0, I_PAIR, [], []) - ]) - ], []) - ]) - ], code_annot) - ]) - in - let migrated_storage = Prim (0, D_Pair, [ - (* Instead of + | Seq (_, toplevel) -> ( + match + ( find_toplevel K_parameter toplevel, + find_toplevel K_storage toplevel, + find_toplevel K_code toplevel ) + with + | ( Some + (Prim + ( _, + K_parameter, + [Prim (_, parameter_type, parameter_expr, parameter_annot)], + prim_param_annot )), + Some + (Prim + ( _, + K_storage, + [ Prim + (_, code_storage_type, code_storage_expr, code_storage_annot) + ], + k_storage_annot )), + Some (Prim (_, K_code, [code_expr], code_annot)) ) -> + (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *) + let migrated_code = + Seq + ( 0, + [ Prim + ( 0, + K_parameter, + [ Prim + ( 0, + T_or, + [ Prim + ( 0, + T_lambda, + [ Prim (0, T_unit, [], []); + Prim + ( 0, + T_list, + [Prim (0, T_operation, [], [])], + [] ) ], + ["%do"] ); + Prim + ( 0, + parameter_type, + parameter_expr, + "%default" :: parameter_annot ) ], + [] ) ], + prim_param_annot ); + Prim + ( 0, + K_storage, + [ Prim + ( 0, + T_pair, + [ Prim (0, T_key_hash, [], []); + Prim + ( 0, + code_storage_type, + code_storage_expr, + code_storage_annot ) ], + [] ) ], + k_storage_annot ); + Prim + ( 0, + K_code, + [ Seq + ( 0, + [ Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim + ( 0, + I_IF_LEFT, + [ Seq + ( 0, + [ Prim + ( 0, + I_PUSH, + [ Prim (0, T_mutez, [], []); + Int (0, Z.zero) ], + [] ); + Prim (0, I_AMOUNT, [], []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) ] ); + Prim + ( 0, + I_IF, + [ Seq (0, []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim + ( 0, + I_UNIT, + [], + [] ); + Prim + ( 0, + I_FAILWITH, + [], + [] ) ] ) ] + ) ], + [] ) ] ); + Seq + ( 0, + [ Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim + (0, I_DUP, [], []) + ] ) ], + [] ); + Prim (0, I_SWAP, [], []) ] ); + Prim (0, I_CDR, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IMPLICIT_ACCOUNT, [], []); + Prim (0, I_ADDRESS, [], []); + Prim (0, I_SENDER, [], []); + Seq + ( 0, + [ Prim (0, I_COMPARE, [], []); + Prim (0, I_NEQ, [], []); + Prim + ( 0, + I_IF, + [ Seq + ( 0, + [ Prim + ( 0, + I_SENDER, + [], + [] ); + Prim + ( 0, + I_PUSH, + [ Prim + ( 0, + T_string, + [], + [] ); + String + ( 0, + "Only the \ + owner \ + can \ + operate." + ) ], + [] ); + Prim + (0, I_PAIR, [], []); + Prim + ( 0, + I_FAILWITH, + [], + [] ) ] ); + Seq + ( 0, + [ Prim + (0, I_UNIT, [], []); + Prim + (0, I_EXEC, [], []); + Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim + ( 0, + I_CDR, + [], + [] ) + ] ) ], + [] ); + Prim + (0, I_PAIR, [], []) + ] ) ], + [] ) ] ) ] ); + Seq + ( 0, + [ Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim (0, I_CDR, [], []); + Prim (0, I_DUP, [], []); + Prim (0, I_CDR, [], []) ] + ) ], + [] ); + Prim (0, I_PAIR, [], []); + code_expr; + Prim (0, I_SWAP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_SWAP, [], []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim + ( 0, + I_CDR, + [], + [] ) ] ) ], + [] ) ] ) ] ); + Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim (0, I_SWAP, [], []); + Prim (0, I_PAIR, [], []) ] + ) ], + [] ); + Prim (0, I_PAIR, [], []) ] ) ], + [] ) ] ) ], + code_annot ) ] ) + in + let migrated_storage = + Prim + ( 0, + D_Pair, + [ (* Instead of `String (0, Signature.Public_key_hash.to_b58check manager_pkh)` the storage is written as unparsed with [Optimized] *) - Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ; - storage_expr - ], []) in - Script_repr.lazy_expr @@ strip_locations migrated_code, - Script_repr.lazy_expr @@ strip_locations migrated_storage - | _ -> - script_code, script_storage - end + Bytes + ( 0, + Data_encoding.Binary.to_bytes_exn + Signature.Public_key_hash.encoding + manager_pkh ); + storage_expr ], + [] ) + in + ( Script_repr.lazy_expr @@ strip_locations migrated_code, + Script_repr.lazy_expr @@ strip_locations migrated_storage ) + | _ -> + (script_code, script_storage) ) | _ -> - script_code, script_storage + (script_code, script_storage) - - -let add_set_delegate: - manager_pkh: Signature.Public_key_hash.t -> - script_code: Script_repr.lazy_expr -> - script_storage: Script_repr.lazy_expr -> - (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t = - fun ~manager_pkh ~script_code ~script_storage -> +let add_set_delegate : + manager_pkh:Signature.Public_key_hash.t -> + script_code:Script_repr.lazy_expr -> + script_storage:Script_repr.lazy_expr -> + (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t = + fun ~manager_pkh ~script_code ~script_storage -> let open Micheline in let open Michelson_v1_primitives in - Lwt.return (Script_repr.force_decode script_code) >>=? fun (script_code_expr, _gas_cost) -> - Lwt.return (Script_repr.force_decode script_storage) >>|? fun (script_storage_expr, _gas_cost) -> + Lwt.return (Script_repr.force_decode script_code) + >>=? fun (script_code_expr, _gas_cost) -> + Lwt.return (Script_repr.force_decode script_storage) + >>|? fun (script_storage_expr, _gas_cost) -> let storage_expr = root script_storage_expr in match root script_code_expr with - | Seq (_, toplevel) - -> begin - match find_toplevel K_parameter toplevel, - find_toplevel K_storage toplevel, - find_toplevel K_code toplevel with - Some (Prim (_, K_parameter, [ - Prim (_, parameter_type, parameter_expr, parameter_annot) - ], prim_param_annot)), - Some (Prim (_, K_storage, [ - Prim (_, code_storage_type, code_storage_expr, code_storage_annot) - ], k_storage_annot)), - Some (Prim (_, K_code, [code_expr], code_annot)) -> - (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *) - - let migrated_code = - Seq (0, [ - Prim (0, K_parameter, [ - Prim (0, T_or, [ - Prim (0, T_or, [ - Prim (0, T_key_hash, [], ["%set_delegate"]); - Prim (0, T_unit, [], ["%remove_delegate"]) - ], []); - Prim (0, parameter_type, parameter_expr, "%default" :: parameter_annot) - ], []) - ], prim_param_annot); - Prim (0, K_storage, [ - Prim (0, T_pair, [ - Prim (0, T_key_hash, [], []); - Prim (0, code_storage_type, code_storage_expr, code_storage_annot) - ], []) - ], k_storage_annot); - Prim (0, K_code, [ - Seq (0, [ - Prim (0, I_DUP, [], []); - Prim (0, I_CAR, [], []); - Prim (0, I_IF_LEFT, [ - Seq (0, [ - Prim (0, I_PUSH, [ - Prim (0, T_mutez, [], []); - Int (0, Z.zero) - ], []); - Prim (0, I_AMOUNT, [], []); - Seq (0, [ - Seq (0, [ - Prim (0, I_COMPARE, [], []); - Prim (0, I_EQ, [], []) - ]); - Prim (0, I_IF, [ - Seq (0, []); - Seq (0, [ - Seq (0, [ - Prim (0, I_UNIT, [], []); - Prim (0, I_FAILWITH, [], []) - ]) - ]) - ], []) - ]); - Seq (0, [ - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_DUP, [], []) - ]) - ], []); - Prim (0, I_SWAP, [], []) - ]); - Prim (0, I_CDR, [], []); - Prim (0, I_CAR, [], []); - Prim (0, I_IMPLICIT_ACCOUNT, [], []); - Prim (0, I_ADDRESS, [], []); - Prim (0, I_SENDER, [], []); - Seq (0, [ - Prim (0, I_COMPARE, [], []); - Prim (0, I_NEQ, [], []); - Prim (0, I_IF, [ - Seq (0, [ - Prim (0, I_SENDER, [], []); - Prim (0, I_PUSH, [ - Prim (0, T_string, [], []); - String (0, "Only the owner can operate.") - ], []); - Prim (0, I_PAIR, [], []); - Prim (0, I_FAILWITH, [], []) - ]); - Seq (0, [ - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_CDR, [], []); - Prim (0, I_NIL, [ - Prim (0, T_operation, [], []) - ], []) - ]) - ], []); - Prim (0, I_IF_LEFT, [ - Seq (0, [ - Prim (0, I_SOME, [], []); - Prim (0, I_SET_DELEGATE, [], []); - Prim (0, I_CONS, [], []); - Prim (0, I_PAIR, [], []) - ]); - Seq (0, [ - Prim (0, I_DROP, [], []); - Prim (0, I_NONE, [ - Prim (0, T_key_hash, [], []) - ], []); - Prim (0, I_SET_DELEGATE, [], []); - Prim (0, I_CONS, [], []); - Prim (0, I_PAIR, [], []) - ]) - ], []) - ]) - ], []) - ]) - ]); - Seq (0, [ - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_CDR, [], []); - Prim (0, I_DUP, [], []); - Prim (0, I_CDR, [], []) - ]) - ], []); - Prim (0, I_PAIR, [], []); - - code_expr; - - Prim (0, I_SWAP, [], []); - Prim (0, I_CAR, [], []); - Prim (0, I_SWAP, [], []); - Seq (0, [ - Seq (0, [ - Prim (0, I_DUP, [], []); - Prim (0, I_CAR, [], []); - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_CDR, [], []) - ]) - ], []) - ]) - ]); - Prim (0, I_DIP, [ - Seq (0, [ - Prim (0, I_SWAP, [], []); - Prim (0, I_PAIR, [], []) - ]) - ], []); - Prim (0, I_PAIR, [], []) - ]) - ], []) - ]) - ], code_annot) - ]) - in - let migrated_storage = Prim (0, D_Pair, [ - (* Instead of + | Seq (_, toplevel) -> ( + match + ( find_toplevel K_parameter toplevel, + find_toplevel K_storage toplevel, + find_toplevel K_code toplevel ) + with + | ( Some + (Prim + ( _, + K_parameter, + [Prim (_, parameter_type, parameter_expr, parameter_annot)], + prim_param_annot )), + Some + (Prim + ( _, + K_storage, + [ Prim + (_, code_storage_type, code_storage_expr, code_storage_annot) + ], + k_storage_annot )), + Some (Prim (_, K_code, [code_expr], code_annot)) ) -> + (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *) + let migrated_code = + Seq + ( 0, + [ Prim + ( 0, + K_parameter, + [ Prim + ( 0, + T_or, + [ Prim + ( 0, + T_or, + [ Prim (0, T_key_hash, [], ["%set_delegate"]); + Prim (0, T_unit, [], ["%remove_delegate"]) ], + [] ); + Prim + ( 0, + parameter_type, + parameter_expr, + "%default" :: parameter_annot ) ], + [] ) ], + prim_param_annot ); + Prim + ( 0, + K_storage, + [ Prim + ( 0, + T_pair, + [ Prim (0, T_key_hash, [], []); + Prim + ( 0, + code_storage_type, + code_storage_expr, + code_storage_annot ) ], + [] ) ], + k_storage_annot ); + Prim + ( 0, + K_code, + [ Seq + ( 0, + [ Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim + ( 0, + I_IF_LEFT, + [ Seq + ( 0, + [ Prim + ( 0, + I_PUSH, + [ Prim (0, T_mutez, [], []); + Int (0, Z.zero) ], + [] ); + Prim (0, I_AMOUNT, [], []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim (0, I_COMPARE, [], []); + Prim (0, I_EQ, [], []) ] ); + Prim + ( 0, + I_IF, + [ Seq (0, []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim + ( 0, + I_UNIT, + [], + [] ); + Prim + ( 0, + I_FAILWITH, + [], + [] ) ] ) ] + ) ], + [] ) ] ); + Seq + ( 0, + [ Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim + (0, I_DUP, [], []) + ] ) ], + [] ); + Prim (0, I_SWAP, [], []) ] ); + Prim (0, I_CDR, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_IMPLICIT_ACCOUNT, [], []); + Prim (0, I_ADDRESS, [], []); + Prim (0, I_SENDER, [], []); + Seq + ( 0, + [ Prim (0, I_COMPARE, [], []); + Prim (0, I_NEQ, [], []); + Prim + ( 0, + I_IF, + [ Seq + ( 0, + [ Prim + ( 0, + I_SENDER, + [], + [] ); + Prim + ( 0, + I_PUSH, + [ Prim + ( 0, + T_string, + [], + [] ); + String + ( 0, + "Only the \ + owner \ + can \ + operate." + ) ], + [] ); + Prim + (0, I_PAIR, [], []); + Prim + ( 0, + I_FAILWITH, + [], + [] ) ] ); + Seq + ( 0, + [ Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim + ( 0, + I_CDR, + [], + [] ); + Prim + ( 0, + I_NIL, + [ Prim + ( + 0, + T_operation, + [], + [] + ) + ], + [] ) + ] ) ], + [] ); + Prim + ( 0, + I_IF_LEFT, + [ Seq + ( 0, + [ Prim + ( 0, + I_SOME, + [], + [] ); + Prim + ( 0, + I_SET_DELEGATE, + [], + [] ); + Prim + ( 0, + I_CONS, + [], + [] ); + Prim + ( 0, + I_PAIR, + [], + [] ) + ] ); + Seq + ( 0, + [ Prim + ( 0, + I_DROP, + [], + [] ); + Prim + ( 0, + I_NONE, + [ Prim + ( + 0, + T_key_hash, + [], + [] + ) + ], + [] ); + Prim + ( 0, + I_SET_DELEGATE, + [], + [] ); + Prim + ( 0, + I_CONS, + [], + [] ); + Prim + ( 0, + I_PAIR, + [], + [] ) + ] ) ], + [] ) ] ) ], + [] ) ] ) ] ); + Seq + ( 0, + [ Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim (0, I_CDR, [], []); + Prim (0, I_DUP, [], []); + Prim (0, I_CDR, [], []) ] + ) ], + [] ); + Prim (0, I_PAIR, [], []); + code_expr; + Prim (0, I_SWAP, [], []); + Prim (0, I_CAR, [], []); + Prim (0, I_SWAP, [], []); + Seq + ( 0, + [ Seq + ( 0, + [ Prim (0, I_DUP, [], []); + Prim (0, I_CAR, [], []); + Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim + ( 0, + I_CDR, + [], + [] ) ] ) ], + [] ) ] ) ] ); + Prim + ( 0, + I_DIP, + [ Seq + ( 0, + [ Prim (0, I_SWAP, [], []); + Prim (0, I_PAIR, [], []) ] + ) ], + [] ); + Prim (0, I_PAIR, [], []) ] ) ], + [] ) ] ) ], + code_annot ) ] ) + in + let migrated_storage = + Prim + ( 0, + D_Pair, + [ (* Instead of `String (0, Signature.Public_key_hash.to_b58check manager_pkh)` the storage is written as unparsed with [Optimized] *) - Bytes (0, Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager_pkh) ; - storage_expr - ], []) in - Script_repr.lazy_expr @@ strip_locations migrated_code, - Script_repr.lazy_expr @@ strip_locations migrated_storage - | _ -> - script_code, script_storage - end + Bytes + ( 0, + Data_encoding.Binary.to_bytes_exn + Signature.Public_key_hash.encoding + manager_pkh ); + storage_expr ], + [] ) + in + ( Script_repr.lazy_expr @@ strip_locations migrated_code, + Script_repr.lazy_expr @@ strip_locations migrated_storage ) + | _ -> + (script_code, script_storage) ) | _ -> - script_code, script_storage + (script_code, script_storage) let has_default_entrypoint expr = let open Micheline in let open Michelson_v1_primitives in match Script_repr.force_decode expr with - | Error _ -> false - | Ok (expr, _) -> - match root expr with - | Seq (_, toplevel) -> begin - match find_toplevel K_parameter toplevel with - | Some (Prim (_, K_parameter, [ _ ], [ "%default" ])) -> false - | Some (Prim (_, K_parameter, [ parameter_expr ], _)) -> - let rec has_default = function - | Prim (_, T_or, [ l ; r ], annots) -> - List.exists (String.equal "%default") annots || has_default l || has_default r - | Prim (_, _, _, annots) -> - List.exists (String.equal "%default") annots - | _ -> false - in - has_default parameter_expr - | Some _ | None -> false - end - | _ -> false - -let add_root_entrypoint - : script_code: Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t - = fun ~script_code -> - let open Micheline in - let open Michelson_v1_primitives in - Lwt.return (Script_repr.force_decode script_code) >>|? fun (script_code_expr, _gas_cost) -> - match root script_code_expr with - | Seq (_, toplevel) -> - let migrated_code = - Seq (0, List.map (function - | Prim (_, K_parameter, [ parameter_expr ], _) -> - Prim (0, K_parameter, [ parameter_expr ], [ "%root" ]) - | Prim (_, K_code, exprs, annots) -> - let rec rewrite_self = function - | Int _ | String _ | Bytes _ | Prim (_, I_CREATE_CONTRACT, _, _) as leaf -> leaf - | Prim (_, I_SELF, [], annots) -> - Prim (0, I_SELF, [], "%root" :: annots) - | Prim (_, name, args, annots) -> - Prim (0, name, List.map rewrite_self args, annots) - | Seq (_, args) -> - Seq (0, List.map rewrite_self args) in - Prim (0, K_code, List.map rewrite_self exprs, annots) - | other -> other) - toplevel) in - Script_repr.lazy_expr @@ strip_locations migrated_code + | Error _ -> + false + | Ok (expr, _) -> ( + match root expr with + | Seq (_, toplevel) -> ( + match find_toplevel K_parameter toplevel with + | Some (Prim (_, K_parameter, [_], ["%default"])) -> + false + | Some (Prim (_, K_parameter, [parameter_expr], _)) -> + let rec has_default = function + | Prim (_, T_or, [l; r], annots) -> + List.exists (String.equal "%default") annots + || has_default l || has_default r + | Prim (_, _, _, annots) -> + List.exists (String.equal "%default") annots + | _ -> + false + in + has_default parameter_expr + | Some _ | None -> + false ) | _ -> - script_code + false ) + +let add_root_entrypoint : + script_code:Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t = + fun ~script_code -> + let open Micheline in + let open Michelson_v1_primitives in + Lwt.return (Script_repr.force_decode script_code) + >>|? fun (script_code_expr, _gas_cost) -> + match root script_code_expr with + | Seq (_, toplevel) -> + let migrated_code = + Seq + ( 0, + List.map + (function + | Prim (_, K_parameter, [parameter_expr], _) -> + Prim (0, K_parameter, [parameter_expr], ["%root"]) + | Prim (_, K_code, exprs, annots) -> + let rec rewrite_self = function + | ( Int _ + | String _ + | Bytes _ + | Prim (_, I_CREATE_CONTRACT, _, _) ) as leaf -> + leaf + | Prim (_, I_SELF, [], annots) -> + Prim (0, I_SELF, [], "%root" :: annots) + | Prim (_, name, args, annots) -> + Prim (0, name, List.map rewrite_self args, annots) + | Seq (_, args) -> + Seq (0, List.map rewrite_self args) + in + Prim (0, K_code, List.map rewrite_self exprs, annots) + | other -> + other) + toplevel ) + in + Script_repr.lazy_expr @@ strip_locations migrated_code + | _ -> + script_code diff --git a/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli index 0b69d3393..cbdfd459f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/legacy_script_support_repr.mli @@ -31,7 +31,7 @@ https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/manager.tz The formal proof is at: https://gitlab.com/nomadic-labs/mi-cho-coq/blob/a7603e12021166e15890f6d504feebec2f945502/src/contracts_coq/manager.v *) -val manager_script_code: Script_repr.lazy_expr +val manager_script_code : Script_repr.lazy_expr (** This code mimics the now defunct "spendable" flags of KT1s by adding a [do] entrypoint, preserving the original script's at @@ -39,10 +39,10 @@ val manager_script_code: Script_repr.lazy_expr The pseudo-code for the applied transformations is from: https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_do.tz *) -val add_do: - manager_pkh: Signature.Public_key_hash.t -> - script_code: Script_repr.lazy_expr -> - script_storage: Script_repr.lazy_expr -> +val add_do : + manager_pkh:Signature.Public_key_hash.t -> + script_code:Script_repr.lazy_expr -> + script_storage:Script_repr.lazy_expr -> (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t (** This code mimics the now defunct "spendable" flags of KT1s by @@ -51,19 +51,17 @@ val add_do: The pseudo-code for the applied transformations is from: https://gitlab.com/nomadic-labs/mi-cho-coq/blob/7b42f2e970e1541af54f8a9b6820b4f18e847575/src/contracts/transform/add_set_delegate.tz *) -val add_set_delegate: - manager_pkh: Signature.Public_key_hash.t -> - script_code: Script_repr.lazy_expr -> - script_storage: Script_repr.lazy_expr -> +val add_set_delegate : + manager_pkh:Signature.Public_key_hash.t -> + script_code:Script_repr.lazy_expr -> + script_storage:Script_repr.lazy_expr -> (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t (** Checks if a contract was declaring a default entrypoint somewhere else than at the root, in which case its type changes when entrypoints are activated. *) -val has_default_entrypoint: - Script_repr.lazy_expr -> bool +val has_default_entrypoint : Script_repr.lazy_expr -> bool (** Adds a [%root] annotation on the toplevel parameter construct. *) -val add_root_entrypoint: - script_code: Script_repr.lazy_expr -> - Script_repr.lazy_expr tzresult Lwt.t +val add_root_entrypoint : + script_code:Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml index 957e58883..5a8dca1cd 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/level_repr.ml @@ -24,125 +24,162 @@ (*****************************************************************************) type t = { - level: Raw_level_repr.t ; - level_position: int32 ; - cycle: Cycle_repr.t ; - cycle_position: int32 ; - voting_period: Voting_period_repr.t ; - voting_period_position: int32 ; - expected_commitment: bool ; + level : Raw_level_repr.t; + level_position : int32; + cycle : Cycle_repr.t; + cycle_position : int32; + voting_period : Voting_period_repr.t; + voting_period_position : int32; + expected_commitment : bool; } -include Compare.Make(struct - type nonrec t = t - let compare { level = l1 } { level = l2 } = Raw_level_repr.compare l1 l2 - end) +include Compare.Make (struct + type nonrec t = t + + let compare {level = l1} {level = l2} = Raw_level_repr.compare l1 l2 +end) type level = t -let pp ppf { level } = Raw_level_repr.pp ppf level +let pp ppf {level} = Raw_level_repr.pp ppf level let pp_full ppf l = - Format.fprintf ppf + Format.fprintf + ppf "%a.%ld (cycle %a.%ld) (vote %a.%ld)" - Raw_level_repr.pp l.level l.level_position - Cycle_repr.pp l.cycle l.cycle_position - Voting_period_repr.pp l.voting_period l.voting_period_position + Raw_level_repr.pp + l.level + l.level_position + Cycle_repr.pp + l.cycle + l.cycle_position + Voting_period_repr.pp + l.voting_period + l.voting_period_position let encoding = let open Data_encoding in conv - (fun { level ; level_position ; - cycle ; cycle_position ; - voting_period; voting_period_position ; + (fun { level; + level_position; + cycle; + cycle_position; + voting_period; + voting_period_position; expected_commitment } -> - (level, level_position, - cycle, cycle_position, - voting_period, voting_period_position, - expected_commitment)) - (fun (level, level_position, - cycle, cycle_position, - voting_period, voting_period_position, - expected_commitment) -> - { level ; level_position ; - cycle ; cycle_position ; - voting_period ; voting_period_position ; - expected_commitment }) + ( level, + level_position, + cycle, + cycle_position, + voting_period, + voting_period_position, + expected_commitment )) + (fun ( level, + level_position, + cycle, + cycle_position, + voting_period, + voting_period_position, + expected_commitment ) -> + { + level; + level_position; + cycle; + cycle_position; + voting_period; + voting_period_position; + expected_commitment; + }) (obj7 - (req "level" + (req + "level" ~description: - "The level of the block relative to genesis. This is also \ - the Shell's notion of level" + "The level of the block relative to genesis. This is also the \ + Shell's notion of level" Raw_level_repr.encoding) - (req "level_position" + (req + "level_position" ~description: "The level of the block relative to the block that starts \ - protocol alpha. This is specific to the protocol \ - alpha. Other protocols might or might not include a \ - similar notion." + protocol alpha. This is specific to the protocol alpha. Other \ + protocols might or might not include a similar notion." int32) - (req "cycle" + (req + "cycle" ~description: "The current cycle's number. Note that cycles are a \ - protocol-specific notion. As a result, the cycle number starts at 0 \ - with the first block of protocol alpha." + protocol-specific notion. As a result, the cycle number starts \ + at 0 with the first block of protocol alpha." Cycle_repr.encoding) - (req "cycle_position" + (req + "cycle_position" ~description: - "The current level of the block relative to the first \ - block of the current cycle." + "The current level of the block relative to the first block of \ + the current cycle." int32) - (req "voting_period" + (req + "voting_period" ~description: "The current voting period's index. Note that cycles are a \ - protocol-specific notion. As a result, the voting period \ - index starts at 0 with the first block of protocol alpha." + protocol-specific notion. As a result, the voting period index \ + starts at 0 with the first block of protocol alpha." Voting_period_repr.encoding) - (req "voting_period_position" + (req + "voting_period_position" ~description: - "The current level of the block relative to the first \ - block of the current voting period." + "The current level of the block relative to the first block of \ + the current voting period." int32) - (req "expected_commitment" + (req + "expected_commitment" ~description: - "Tells wether the baker of this block has to commit a seed \ - nonce hash." + "Tells wether the baker of this block has to commit a seed nonce \ + hash." bool)) let root first_level = - { level = first_level ; - level_position = 0l ; - cycle = Cycle_repr.root ; - cycle_position = 0l ; - voting_period = Voting_period_repr.root ; - voting_period_position = 0l ; - expected_commitment = false ; + { + level = first_level; + level_position = 0l; + cycle = Cycle_repr.root; + cycle_position = 0l; + voting_period = Voting_period_repr.root; + voting_period_position = 0l; + expected_commitment = false; } -let from_raw - ~first_level ~blocks_per_cycle ~blocks_per_voting_period - ~blocks_per_commitment - level = +let from_raw ~first_level ~blocks_per_cycle ~blocks_per_voting_period + ~blocks_per_commitment level = let raw_level = Raw_level_repr.to_int32 level in let first_level = Raw_level_repr.to_int32 first_level in let level_position = - Compare.Int32.max 0l (Int32.sub raw_level first_level) in + Compare.Int32.max 0l (Int32.sub raw_level first_level) + in let cycle = - Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle) in + Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle) + in let cycle_position = Int32.rem level_position blocks_per_cycle in let voting_period = Voting_period_repr.of_int32_exn - (Int32.div level_position blocks_per_voting_period) in + (Int32.div level_position blocks_per_voting_period) + in let voting_period_position = - Int32.rem level_position blocks_per_voting_period in + Int32.rem level_position blocks_per_voting_period + in let expected_commitment = - Compare.Int32.(Int32.rem cycle_position blocks_per_commitment = - Int32.pred blocks_per_commitment) in - { level ; level_position ; - cycle ; cycle_position ; - voting_period ; voting_period_position ; - expected_commitment } + Compare.Int32.( + Int32.rem cycle_position blocks_per_commitment + = Int32.pred blocks_per_commitment) + in + { + level; + level_position; + cycle; + cycle_position; + voting_period; + voting_period_position; + expected_commitment; + } -let diff { level = l1 ; _ } { level = l2 ; _ } = +let diff {level = l1; _} {level = l2; _} = Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2) - diff --git a/vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli index d0ac31664..eddda5ba4 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/level_repr.mli @@ -24,21 +24,25 @@ (*****************************************************************************) type t = private { - level: Raw_level_repr.t (** The level of the block relative to genesis. This - is also the Shell's notion of level. *); - level_position: int32 (** The level of the block relative to the block that + level : Raw_level_repr.t; + (** The level of the block relative to genesis. This + is also the Shell's notion of level. *) + level_position : int32; + (** The level of the block relative to the block that starts protocol alpha. This is specific to the protocol alpha. Other protocols might or might not - include a similar notion. *); - cycle: Cycle_repr.t (** The current cycle's number. Note that cycles are a + include a similar notion. *) + cycle : Cycle_repr.t; + (** The current cycle's number. Note that cycles are a protocol-specific notion. As a result, the cycle number starts at 0 with the first block of protocol - alpha. *); - cycle_position: int32 (** The current level of the block relative to the first - block of the current cycle. *); - voting_period: Voting_period_repr.t ; - voting_period_position: int32 ; - expected_commitment: bool ; + alpha. *) + cycle_position : int32; + (** The current level of the block relative to the first + block of the current cycle. *) + voting_period : Voting_period_repr.t; + voting_period_position : int32; + expected_commitment : bool; } (* Note that, the type `t` above must respect some invariants (hence the @@ -47,23 +51,24 @@ type t = private { level_position = cycle * blocks_per_cycle + cycle_position *) - - type level = t include Compare.S with type t := level -val encoding: level Data_encoding.t -val pp: Format.formatter -> level -> unit -val pp_full: Format.formatter -> level -> unit +val encoding : level Data_encoding.t -val root: Raw_level_repr.t -> level +val pp : Format.formatter -> level -> unit -val from_raw: +val pp_full : Format.formatter -> level -> unit + +val root : Raw_level_repr.t -> level + +val from_raw : first_level:Raw_level_repr.t -> blocks_per_cycle:int32 -> blocks_per_voting_period:int32 -> blocks_per_commitment:int32 -> - Raw_level_repr.t -> level + Raw_level_repr.t -> + level -val diff: level -> level -> int32 +val diff : level -> level -> int32 diff --git a/vendors/ligo-utils/tezos-protocol-alpha/level_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/level_storage.ml index 956234416..896391e5f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/level_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/level_storage.ml @@ -28,8 +28,11 @@ open Level_repr let from_raw c ?offset l = let l = match offset with - | None -> l - | Some o -> Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) in + | None -> + l + | Some o -> + Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) + in let constants = Raw_context.constants c in let first_level = Raw_context.first_level c in Level_repr.from_raw @@ -39,27 +42,32 @@ let from_raw c ?offset l = ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment l -let root c = - Level_repr.root (Raw_context.first_level c) +let root c = Level_repr.root (Raw_context.first_level c) let succ c l = from_raw c (Raw_level_repr.succ l.level) + let pred c l = match Raw_level_repr.pred l.Level_repr.level with - | None -> None - | Some l -> Some (from_raw c l) + | None -> + None + | Some l -> + Some (from_raw c l) let current ctxt = Raw_context.current_level ctxt let previous ctxt = let l = current ctxt in match pred ctxt l with - | None -> assert false (* We never validate the Genesis... *) - | Some p -> p + | None -> + assert false (* We never validate the Genesis... *) + | Some p -> + p let first_level_in_cycle ctxt c = let constants = Raw_context.constants ctxt in let first_level = Raw_context.first_level ctxt in - from_raw ctxt + from_raw + ctxt (Raw_level_repr.of_int32_exn (Int32.add (Raw_level_repr.to_int32 first_level) @@ -69,14 +77,15 @@ let first_level_in_cycle ctxt c = let last_level_in_cycle ctxt c = match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with - | None -> assert false - | Some x -> x + | None -> + assert false + | Some x -> + x let levels_in_cycle ctxt cycle = let first = first_level_in_cycle ctxt cycle in let rec loop n acc = - if Cycle_repr.(n.cycle = first.cycle) - then loop (succ ctxt n) (n :: acc) + if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc) else acc in loop first [] @@ -84,8 +93,7 @@ let levels_in_cycle ctxt cycle = let levels_in_current_cycle ctxt ?(offset = 0l) () = let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in let cycle = Int32.add current_cycle offset in - if Compare.Int32.(cycle < 0l) then - [] + if Compare.Int32.(cycle < 0l) then [] else let cycle = Cycle_repr.of_int32_exn cycle in levels_in_cycle ctxt cycle @@ -93,20 +101,18 @@ 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 rec loop n 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 + 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 else acc in loop first [] - let last_allowed_fork_level c = let level = Raw_context.current_level c in let preserved_cycles = Constants_storage.preserved_cycles c in match Cycle_repr.sub level.cycle preserved_cycles with - | None -> Raw_level_repr.root - | Some cycle -> (first_level_in_cycle c cycle).level + | None -> + Raw_level_repr.root + | Some cycle -> + (first_level_in_cycle c cycle).level diff --git a/vendors/ligo-utils/tezos-protocol-alpha/level_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/level_storage.mli index 03b2c2991..047fcbb40 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/level_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/level_storage.mli @@ -23,22 +23,29 @@ (* *) (*****************************************************************************) -val current: Raw_context.t -> Level_repr.t -val previous: Raw_context.t -> Level_repr.t +val current : Raw_context.t -> Level_repr.t -val root: Raw_context.t -> Level_repr.t +val previous : Raw_context.t -> Level_repr.t -val from_raw: Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t -val pred: Raw_context.t -> Level_repr.t -> Level_repr.t option -val succ: Raw_context.t -> Level_repr.t -> Level_repr.t +val root : Raw_context.t -> Level_repr.t -val first_level_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t -val last_level_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t -val levels_in_cycle: Raw_context.t -> Cycle_repr.t -> Level_repr.t list -val levels_in_current_cycle: +val from_raw : + Raw_context.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t + +val pred : Raw_context.t -> Level_repr.t -> Level_repr.t option + +val succ : Raw_context.t -> Level_repr.t -> Level_repr.t + +val first_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t + +val last_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t + +val levels_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t list + +val levels_in_current_cycle : Raw_context.t -> ?offset:int32 -> unit -> Level_repr.t list -val levels_with_commitments_in_cycle: +val levels_with_commitments_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t list -val last_allowed_fork_level: Raw_context.t -> Raw_level_repr.t +val last_allowed_fork_level : Raw_context.t -> Raw_level_repr.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/main.ml b/vendors/ligo-utils/tezos-protocol-alpha/main.ml index 61e5ba0f2..2065a9402 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/main.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/main.ml @@ -26,51 +26,66 @@ (* Tezos Protocol Implementation - Protocol Signature Instance *) type block_header_data = Alpha_context.Block_header.protocol_data + type block_header = Alpha_context.Block_header.t = { - shell: Block_header.shell_header ; - protocol_data: block_header_data ; + shell : Block_header.shell_header; + protocol_data : block_header_data; } -let block_header_data_encoding = Alpha_context.Block_header.protocol_data_encoding +let block_header_data_encoding = + Alpha_context.Block_header.protocol_data_encoding type block_header_metadata = Apply_results.block_metadata + let block_header_metadata_encoding = Apply_results.block_metadata_encoding type operation_data = Alpha_context.packed_protocol_data = - | Operation_data : 'kind Alpha_context.Operation.protocol_data -> operation_data + | Operation_data : + 'kind Alpha_context.Operation.protocol_data + -> operation_data + let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding type operation_receipt = Apply_results.packed_operation_metadata = - | Operation_metadata : 'kind Apply_results.operation_metadata -> operation_receipt - | No_operation_metadata: operation_receipt -let operation_receipt_encoding = - Apply_results.operation_metadata_encoding + | Operation_metadata : + 'kind Apply_results.operation_metadata + -> operation_receipt + | No_operation_metadata : operation_receipt + +let operation_receipt_encoding = Apply_results.operation_metadata_encoding let operation_data_and_receipt_encoding = Apply_results.operation_data_and_metadata_encoding type operation = Alpha_context.packed_operation = { - shell: Operation.shell_header ; - protocol_data: operation_data ; + shell : Operation.shell_header; + protocol_data : operation_data; } let acceptable_passes = Alpha_context.Operation.acceptable_passes -let max_block_length = - Alpha_context.Block_header.max_header_length +let max_block_length = Alpha_context.Block_header.max_header_length let max_operation_data_length = Alpha_context.Constants.max_operation_data_length let validation_passes = let max_anonymous_operations = - Alpha_context.Constants.max_revelations_per_block + - (* allow 100 wallet activations or denunciations per block *) 100 in - Updater.[ { max_size = 32 * 1024 ; max_op = Some 32 } ; (* 32 endorsements *) - { max_size = 32 * 1024 ; max_op = None } ; (* 32k of voting operations *) - { max_size = max_anonymous_operations * 1024 ; - max_op = Some max_anonymous_operations } ; - { max_size = 512 * 1024 ; max_op = None } ] (* 512kB *) + Alpha_context.Constants.max_revelations_per_block + + (* allow 100 wallet activations or denunciations per block *) 100 + in + Updater. + [ {max_size = 32 * 1024; max_op = Some 32}; + (* 32 endorsements *) + {max_size = 32 * 1024; max_op = None}; + (* 32k of voting operations *) + { + max_size = max_anonymous_operations * 1024; + max_op = Some max_anonymous_operations; + }; + {max_size = 512 * 1024; max_op = None} ] + +(* 512kB *) let rpc_services = Alpha_services.register () ; @@ -78,168 +93,186 @@ let rpc_services = type validation_mode = | Application of { - block_header : Alpha_context.Block_header.t ; - baker : Alpha_context.public_key_hash ; - block_delay : Alpha_context.Period.t ; + block_header : Alpha_context.Block_header.t; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; } | Partial_application of { - block_header : Alpha_context.Block_header.t ; - baker : Alpha_context.public_key_hash ; - block_delay : Alpha_context.Period.t ; - } - | Partial_construction of { - predecessor : Block_hash.t ; + block_header : Alpha_context.Block_header.t; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; } + | Partial_construction of {predecessor : Block_hash.t} | Full_construction of { - predecessor : Block_hash.t ; - protocol_data : Alpha_context.Block_header.contents ; - baker : Alpha_context.public_key_hash ; - block_delay : Alpha_context.Period.t ; + predecessor : Block_hash.t; + protocol_data : Alpha_context.Block_header.contents; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; } -type validation_state = - { mode : validation_mode ; - chain_id : Chain_id.t ; - ctxt : Alpha_context.t ; - op_count : int ; - } +type validation_state = { + mode : validation_mode; + chain_id : Chain_id.t; + ctxt : Alpha_context.t; + op_count : int; +} -let current_context { ctxt ; _ } = - return (Alpha_context.finalize ctxt).context +let current_context {ctxt; _} = return (Alpha_context.finalize ctxt).context -let begin_partial_application - ~chain_id - ~ancestor_context:ctxt - ~predecessor_timestamp - ~predecessor_fitness +let begin_partial_application ~chain_id ~ancestor_context:ctxt + ~predecessor_timestamp ~predecessor_fitness (block_header : Alpha_context.Block_header.t) = let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> - Apply.begin_application - ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) -> + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt + >>=? fun ctxt -> + Apply.begin_application ctxt chain_id block_header predecessor_timestamp + >>=? fun (ctxt, baker, block_delay) -> let mode = Partial_application - { block_header ; baker = Signature.Public_key.hash baker ; block_delay } in - return { mode ; chain_id ; ctxt ; op_count = 0 } + {block_header; baker = Signature.Public_key.hash baker; block_delay} + in + return {mode; chain_id; ctxt; op_count = 0} -let begin_application - ~chain_id - ~predecessor_context:ctxt - ~predecessor_timestamp - ~predecessor_fitness +let begin_application ~chain_id ~predecessor_context:ctxt + ~predecessor_timestamp ~predecessor_fitness (block_header : Alpha_context.Block_header.t) = let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> - Apply.begin_application - ctxt chain_id block_header predecessor_timestamp >>=? fun (ctxt, baker, block_delay) -> + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt + >>=? fun ctxt -> + Apply.begin_application ctxt chain_id block_header predecessor_timestamp + >>=? fun (ctxt, baker, block_delay) -> let mode = - Application { block_header ; baker = Signature.Public_key.hash baker ; block_delay } in - return { mode ; chain_id ; ctxt ; op_count = 0 } + Application + {block_header; baker = Signature.Public_key.hash baker; block_delay} + in + return {mode; chain_id; ctxt; op_count = 0} -let begin_construction - ~chain_id - ~predecessor_context:ctxt - ~predecessor_timestamp - ~predecessor_level:pred_level - ~predecessor_fitness:pred_fitness - ~predecessor - ~timestamp - ?(protocol_data : block_header_data option) - () = +let begin_construction ~chain_id ~predecessor_context:ctxt + ~predecessor_timestamp ~predecessor_level:pred_level + ~predecessor_fitness:pred_fitness ~predecessor ~timestamp + ?(protocol_data : block_header_data option) () = let level = Int32.succ pred_level in let fitness = pred_fitness in - Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> - begin - match protocol_data with - | None -> - Apply.begin_partial_construction ctxt >>=? fun ctxt -> - let mode = Partial_construction { predecessor } in - return (mode, ctxt) - | Some proto_header -> - Apply.begin_full_construction - ctxt predecessor_timestamp - proto_header.contents >>=? fun (ctxt, protocol_data, baker, block_delay) -> - let mode = - let baker = Signature.Public_key.hash baker in - Full_construction { predecessor ; baker ; protocol_data ; block_delay } in - return (mode, ctxt) - end >>=? fun (mode, ctxt) -> - return { mode ; chain_id ; ctxt ; op_count = 0 } + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt + >>=? fun ctxt -> + ( match protocol_data with + | None -> + Apply.begin_partial_construction ctxt + >>=? fun ctxt -> + let mode = Partial_construction {predecessor} in + return (mode, ctxt) + | Some proto_header -> + Apply.begin_full_construction + ctxt + predecessor_timestamp + proto_header.contents + >>=? fun (ctxt, protocol_data, baker, block_delay) -> + let mode = + let baker = Signature.Public_key.hash baker in + Full_construction {predecessor; baker; protocol_data; block_delay} + in + return (mode, ctxt) ) + >>=? fun (mode, ctxt) -> return {mode; chain_id; ctxt; op_count = 0} -let apply_operation - ({ mode ; chain_id ; ctxt ; op_count ; _ } as data) +let apply_operation ({mode; chain_id; ctxt; op_count; _} as data) (operation : Alpha_context.packed_operation) = match mode with - | Partial_application _ when - not (List.exists - (Compare.Int.equal 0) - (Alpha_context.Operation.acceptable_passes operation)) -> + | Partial_application _ + when not + (List.exists + (Compare.Int.equal 0) + (Alpha_context.Operation.acceptable_passes operation)) -> (* Multipass validation only considers operations in pass 0. *) let op_count = op_count + 1 in - return ({ data with ctxt ; op_count }, No_operation_metadata) + return ({data with ctxt; op_count}, No_operation_metadata) | _ -> - let { shell ; protocol_data = Operation_data protocol_data } = operation in - let operation : _ Alpha_context.operation = { shell ; protocol_data } in - let predecessor, baker = + let {shell; protocol_data = Operation_data protocol_data} = operation in + let operation : _ Alpha_context.operation = {shell; protocol_data} in + let (predecessor, baker) = match mode with | Partial_application - { block_header = { shell = { predecessor ; _ } ; _ } ; baker } - | Application - { block_header = { shell = { predecessor ; _ } ; _ } ; baker } - | Full_construction { predecessor ; baker ; _ } - -> predecessor, baker - | Partial_construction { predecessor } - -> predecessor, Signature.Public_key_hash.zero + {block_header = {shell = {predecessor; _}; _}; baker} + | Application {block_header = {shell = {predecessor; _}; _}; baker} + | Full_construction {predecessor; baker; _} -> + (predecessor, baker) + | Partial_construction {predecessor} -> + (predecessor, Signature.Public_key_hash.zero) in - Apply.apply_operation ctxt chain_id Optimized predecessor baker + Apply.apply_operation + ctxt + chain_id + Optimized + predecessor + baker (Alpha_context.Operation.hash operation) - operation >>=? fun (ctxt, result) -> + operation + >>=? fun (ctxt, result) -> let op_count = op_count + 1 in - return ({ data with ctxt ; op_count }, Operation_metadata result) + return ({data with ctxt; op_count}, Operation_metadata result) -let finalize_block { mode ; ctxt ; op_count } = +let finalize_block {mode; ctxt; op_count} = match mode with | Partial_construction _ -> let level = Alpha_context.Level.current ctxt in - Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind -> + Alpha_context.Vote.get_current_period_kind ctxt + >>=? fun voting_period_kind -> let baker = Signature.Public_key_hash.zero in Signature.Public_key_hash.Map.fold (fun delegate deposit ctxt -> - ctxt >>=? fun ctxt -> - Alpha_context.Delegate.freeze_deposit ctxt delegate deposit) + ctxt + >>=? fun ctxt -> + Alpha_context.Delegate.freeze_deposit ctxt delegate deposit) (Alpha_context.get_deposits ctxt) - (return ctxt) >>=? fun ctxt -> + (return ctxt) + >>=? fun ctxt -> let ctxt = Alpha_context.finalize ctxt in - return (ctxt, Apply_results.{ baker ; - level ; - voting_period_kind ; - nonce_hash = None ; - consumed_gas = Z.zero ; - deactivated = []; - balance_updates = []}) - | Partial_application { block_header ; baker ; block_delay } -> + return + ( ctxt, + Apply_results. + { + baker; + level; + voting_period_kind; + nonce_hash = None; + consumed_gas = Z.zero; + deactivated = []; + balance_updates = []; + } ) + | Partial_application {block_header; baker; block_delay} -> let level = Alpha_context.Level.current ctxt in let included_endorsements = Alpha_context.included_endorsements ctxt in - Apply.check_minimum_endorsements ctxt + Apply.check_minimum_endorsements + ctxt block_header.protocol_data.contents - block_delay included_endorsements >>=? fun () -> - Alpha_context.Vote.get_current_period_kind ctxt >>=? fun voting_period_kind -> + block_delay + included_endorsements + >>=? fun () -> + Alpha_context.Vote.get_current_period_kind ctxt + >>=? fun voting_period_kind -> let ctxt = Alpha_context.finalize ctxt in - return (ctxt, Apply_results.{ baker ; - level ; - voting_period_kind ; - nonce_hash = None ; - consumed_gas = Z.zero ; - deactivated = []; - balance_updates = []}) + return + ( ctxt, + Apply_results. + { + baker; + level; + voting_period_kind; + nonce_hash = None; + consumed_gas = Z.zero; + deactivated = []; + balance_updates = []; + } ) | Application - { baker ; block_delay ; block_header = { protocol_data = { contents = protocol_data ; _ } ; _ } } - | Full_construction { protocol_data ; baker ; block_delay ; _ } -> - Apply.finalize_application ctxt protocol_data baker ~block_delay >>=? fun (ctxt, receipt) -> + { baker; + block_delay; + block_header = {protocol_data = {contents = protocol_data; _}; _} } + | Full_construction {protocol_data; baker; block_delay; _} -> + Apply.finalize_application ctxt protocol_data baker ~block_delay + >>=? fun (ctxt, receipt) -> let level = Alpha_context.Level.current ctxt in let priority = protocol_data.priority in let raw_level = Alpha_context.Raw_level.to_int32 level.level in @@ -247,69 +280,101 @@ let finalize_block { mode ; ctxt ; op_count } = let commit_message = Format.asprintf "lvl %ld, fit 1:%Ld, prio %d, %d ops" - raw_level fitness priority op_count in + raw_level + fitness + priority + op_count + in let ctxt = Alpha_context.finalize ~commit_message ctxt in return (ctxt, receipt) let compare_operations op1 op2 = let open Alpha_context in - let Operation_data op1 = op1.protocol_data in - let Operation_data op2 = op2.protocol_data in - match op1.contents, op2.contents with - | Single (Endorsement _), Single (Endorsement _) -> 0 - | _, Single (Endorsement _) -> 1 - | Single (Endorsement _), _ -> -1 - - | Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _) -> 0 - | _, Single (Seed_nonce_revelation _) -> 1 - | Single (Seed_nonce_revelation _), _ -> -1 - - | Single (Double_endorsement_evidence _), Single (Double_endorsement_evidence _) -> 0 - | _, Single (Double_endorsement_evidence _) -> 1 - | Single (Double_endorsement_evidence _), _ -> -1 - - | Single (Double_baking_evidence _), Single (Double_baking_evidence _) -> 0 - | _, Single (Double_baking_evidence _) -> 1 - | Single (Double_baking_evidence _), _ -> -1 - - | Single (Activate_account _), Single (Activate_account _) -> 0 - | _, Single (Activate_account _) -> 1 - | Single (Activate_account _), _ -> -1 - - | Single (Proposals _), Single (Proposals _) -> 0 - | _, Single (Proposals _) -> 1 - | Single (Proposals _), _ -> -1 - - | Single (Ballot _), Single (Ballot _) -> 0 - | _, Single (Ballot _) -> 1 - | Single (Ballot _), _ -> -1 - + let (Operation_data op1) = op1.protocol_data in + let (Operation_data op2) = op2.protocol_data in + match (op1.contents, op2.contents) with + | (Single (Endorsement _), Single (Endorsement _)) -> + 0 + | (_, Single (Endorsement _)) -> + 1 + | (Single (Endorsement _), _) -> + -1 + | (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) -> + 0 + | (_, Single (Seed_nonce_revelation _)) -> + 1 + | (Single (Seed_nonce_revelation _), _) -> + -1 + | ( Single (Double_endorsement_evidence _), + Single (Double_endorsement_evidence _) ) -> + 0 + | (_, Single (Double_endorsement_evidence _)) -> + 1 + | (Single (Double_endorsement_evidence _), _) -> + -1 + | (Single (Double_baking_evidence _), Single (Double_baking_evidence _)) -> + 0 + | (_, Single (Double_baking_evidence _)) -> + 1 + | (Single (Double_baking_evidence _), _) -> + -1 + | (Single (Activate_account _), Single (Activate_account _)) -> + 0 + | (_, Single (Activate_account _)) -> + 1 + | (Single (Activate_account _), _) -> + -1 + | (Single (Proposals _), Single (Proposals _)) -> + 0 + | (_, Single (Proposals _)) -> + 1 + | (Single (Proposals _), _) -> + -1 + | (Single (Ballot _), Single (Ballot _)) -> + 0 + | (_, Single (Ballot _)) -> + 1 + | (Single (Ballot _), _) -> + -1 (* Manager operations with smaller counter are pre-validated first. *) - | Single (Manager_operation op1), Single (Manager_operation op2) -> + | (Single (Manager_operation op1), Single (Manager_operation op2)) -> Z.compare op1.counter op2.counter - | Cons (Manager_operation op1, _), Single (Manager_operation op2) -> + | (Cons (Manager_operation op1, _), Single (Manager_operation op2)) -> Z.compare op1.counter op2.counter - | Single (Manager_operation op1), Cons (Manager_operation op2, _) -> + | (Single (Manager_operation op1), Cons (Manager_operation op2, _)) -> Z.compare op1.counter op2.counter - | Cons (Manager_operation op1, _), Cons (Manager_operation op2, _) -> + | (Cons (Manager_operation op1, _), Cons (Manager_operation op2, _)) -> Z.compare op1.counter op2.counter let init ctxt block_header = let level = block_header.Block_header.level in let fitness = block_header.fitness in let timestamp = block_header.timestamp in - let typecheck (ctxt:Alpha_context.context) (script:Alpha_context.Script.t) = - Script_ir_translator.parse_script ctxt ~legacy:false script >>=? fun (Ex_script parsed_script, ctxt) -> - Script_ir_translator.extract_big_map_diff ctxt Optimized parsed_script.storage_type parsed_script.storage - ~to_duplicate: Script_ir_translator.no_big_map_id - ~to_update: Script_ir_translator.no_big_map_id - ~temporary:false >>=? fun (storage, big_map_diff, ctxt) -> - Script_ir_translator.unparse_data ctxt Optimized parsed_script.storage_type storage >>=? fun (storage, ctxt) -> - let storage = Alpha_context.Script.lazy_expr (Micheline.strip_locations storage) in - return (({ script with storage }, big_map_diff), ctxt) + let typecheck (ctxt : Alpha_context.context) + (script : Alpha_context.Script.t) = + Script_ir_translator.parse_script ctxt ~legacy:false script + >>=? fun (Ex_script parsed_script, ctxt) -> + Script_ir_translator.extract_big_map_diff + ctxt + Optimized + parsed_script.storage_type + parsed_script.storage + ~to_duplicate:Script_ir_translator.no_big_map_id + ~to_update:Script_ir_translator.no_big_map_id + ~temporary:false + >>=? fun (storage, big_map_diff, ctxt) -> + Script_ir_translator.unparse_data + ctxt + Optimized + parsed_script.storage_type + storage + >>=? fun (storage, ctxt) -> + let storage = + Alpha_context.Script.lazy_expr (Micheline.strip_locations storage) + in + return (({script with storage}, big_map_diff), ctxt) in - Alpha_context.prepare_first_block - ~typecheck - ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> - return (Alpha_context.finalize ctxt) -(* Vanity nonce: 415767323 *) + Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt + >>=? fun ctxt -> return (Alpha_context.finalize ctxt) + +(* Vanity nonce: 0050006865723388 *) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/main.mli b/vendors/ligo-utils/tezos-protocol-alpha/main.mli index c0d9f66c3..5b41eb2bf 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/main.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/main.mli @@ -27,44 +27,43 @@ type validation_mode = | Application of { - block_header : Alpha_context.Block_header.t ; - baker : Alpha_context.public_key_hash ; - block_delay : Alpha_context.Period.t ; + block_header : Alpha_context.Block_header.t; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; } | Partial_application of { - block_header : Alpha_context.Block_header.t ; - baker : Alpha_context.public_key_hash ; - block_delay : Alpha_context.Period.t ; - } - | Partial_construction of { - predecessor : Block_hash.t ; + block_header : Alpha_context.Block_header.t; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; } + | Partial_construction of {predecessor : Block_hash.t} | Full_construction of { - predecessor : Block_hash.t ; - protocol_data : Alpha_context.Block_header.contents ; - baker : Alpha_context.public_key_hash ; - block_delay : Alpha_context.Period.t ; + predecessor : Block_hash.t; + protocol_data : Alpha_context.Block_header.contents; + baker : Alpha_context.public_key_hash; + block_delay : Alpha_context.Period.t; } -type validation_state = - { mode : validation_mode ; - chain_id : Chain_id.t ; - ctxt : Alpha_context.t ; - op_count : int ; - } +type validation_state = { + mode : validation_mode; + chain_id : Chain_id.t; + ctxt : Alpha_context.t; + op_count : int; +} type operation_data = Alpha_context.packed_protocol_data type operation = Alpha_context.packed_operation = { - shell: Operation.shell_header ; - protocol_data: operation_data ; + shell : Operation.shell_header; + protocol_data : operation_data; } -include Updater.PROTOCOL - with type block_header_data = Alpha_context.Block_header.protocol_data - and type block_header_metadata = Apply_results.block_metadata - and type block_header = Alpha_context.Block_header.t - and type operation_data := operation_data - and type operation_receipt = Apply_results.packed_operation_metadata - and type operation := operation - and type validation_state := validation_state +include + Updater.PROTOCOL + with type block_header_data = Alpha_context.Block_header.protocol_data + and type block_header_metadata = Apply_results.block_metadata + and type block_header = Alpha_context.Block_header.t + and type operation_data := operation_data + and type operation_receipt = Apply_results.packed_operation_metadata + and type operation := operation + and type validation_state := validation_state diff --git a/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.ml index 8b7561aeb..b96a51401 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/manager_repr.ml @@ -34,27 +34,19 @@ type t = manager_key open Data_encoding let hash_case tag = - case tag + case + tag ~title:"Public_key_hash" Signature.Public_key_hash.encoding - (function - | Hash hash -> Some hash - | _ -> None) + (function Hash hash -> Some hash | _ -> None) (fun hash -> Hash hash) let pubkey_case tag = - case tag + case + tag ~title:"Public_key" Signature.Public_key.encoding - (function - | Public_key hash -> Some hash - | _ -> None) + (function Public_key hash -> Some hash | _ -> None) (fun hash -> Public_key hash) - -let encoding = - union [ - hash_case (Tag 0) ; - pubkey_case (Tag 1) ; - ] - +let encoding = union [hash_case (Tag 0); pubkey_case (Tag 1)] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml index f61e519fe..4bee0a364 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.ml @@ -27,125 +27,147 @@ open Alpha_context open Gas module Cost_of = struct - let log2 = - let rec help acc = function - | 0 -> acc - | n -> help (acc + 1) (n / 2) - in help 1 + let rec help acc = function 0 -> acc | n -> help (acc + 1) (n / 2) in + help 1 let z_bytes (z : Z.t) = let bits = Z.numbits z in (7 + bits) / 8 - let int_bytes (z : 'a Script_int.num) = - z_bytes (Script_int.to_zint z) + let int_bytes (z : 'a Script_int.num) = z_bytes (Script_int.to_zint z) let timestamp_bytes (t : Script_timestamp.t) = let z = Script_timestamp.to_zint t in z_bytes z (* For now, returns size in bytes, but this could get more complicated... *) - let rec size_of_comparable : type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int = - fun wit v -> - match wit with - | Int_key _ -> int_bytes v - | Nat_key _ -> int_bytes v - | String_key _ -> String.length v - | Bytes_key _ -> MBytes.length v - | Bool_key _ -> 8 - | Key_hash_key _ -> Signature.Public_key_hash.size - | Timestamp_key _ -> timestamp_bytes v - | Address_key _ -> Signature.Public_key_hash.size - | Mutez_key _ -> 8 - | Pair_key ((l, _), (r, _), _) -> - let (lval, rval) = v in - size_of_comparable l lval + size_of_comparable r rval + let rec size_of_comparable : + type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int = + fun wit v -> + match wit with + | Int_key _ -> + int_bytes v + | Nat_key _ -> + int_bytes v + | String_key _ -> + String.length v + | Bytes_key _ -> + MBytes.length v + | Bool_key _ -> + 8 + | Key_hash_key _ -> + Signature.Public_key_hash.size + | Timestamp_key _ -> + timestamp_bytes v + | Address_key _ -> + Signature.Public_key_hash.size + | Mutez_key _ -> + 8 + | Pair_key ((l, _), (r, _), _) -> + let (lval, rval) = v in + size_of_comparable l lval + size_of_comparable r rval - let string length = - alloc_bytes_cost length + let string length = alloc_bytes_cost length - let bytes length = - alloc_mbytes_cost length + let bytes length = alloc_mbytes_cost length let manager_operation = step_cost 10_000 module Legacy = struct - let zint z = - alloc_bits_cost (Z.numbits z) + let zint z = alloc_bits_cost (Z.numbits z) - let set_to_list : type item. item Script_typed_ir.set -> cost - = fun (module Box) -> - alloc_cost @@ Pervasives.(Box.size * 2) + let set_to_list : type item. item Script_typed_ir.set -> cost = + fun (module Box) -> alloc_cost @@ Pervasives.(Box.size * 2) let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost - = fun (module Box) -> - let size = snd Box.boxed in - 3 *@ alloc_cost size + = + fun (module Box) -> + let size = snd Box.boxed in + 3 *@ alloc_cost size let z_to_int64 = step_cost 2 +@ alloc_cost 1 - let hash data len = 10 *@ step_cost (MBytes.length data) +@ bytes len + let hash data len = (10 *@ step_cost (MBytes.length data)) +@ bytes len - let set_access : type elt. elt -> elt Script_typed_ir.set -> int - = fun _key (module Box) -> - log2 @@ Box.size + let set_access : type elt. elt -> elt Script_typed_ir.set -> int = + fun _key (module Box) -> log2 @@ Box.size - let set_update key _presence set = - set_access key set *@ alloc_cost 3 + let set_update key _presence set = set_access key set *@ alloc_cost 3 end module Interpreter = struct let cycle = atomic_step_cost 10 + let nop = free + let stack_op = atomic_step_cost 10 + let push = atomic_step_cost 10 + let wrap = atomic_step_cost 10 + let variant_no_data = atomic_step_cost 10 + let branch = atomic_step_cost 10 + let pair = atomic_step_cost 10 + let pair_access = atomic_step_cost 10 + let cons = atomic_step_cost 10 + let loop_size = atomic_step_cost 5 + let loop_cycle = atomic_step_cost 10 + let loop_iter = atomic_step_cost 20 + let loop_map = atomic_step_cost 30 + let empty_set = atomic_step_cost 10 + let set_to_list : type elt. elt Script_typed_ir.set -> cost = - fun (module Box) -> - atomic_step_cost (Box.size * 20) + fun (module Box) -> atomic_step_cost (Box.size * 20) let set_mem : type elt. elt -> elt Script_typed_ir.set -> cost = - fun elt (module Box) -> - let elt_bytes = size_of_comparable Box.elt_ty elt in - atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size) + fun elt (module Box) -> + let elt_bytes = size_of_comparable Box.elt_ty elt in + atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size) let set_update : type elt. elt -> bool -> elt Script_typed_ir.set -> cost = - fun elt _ (module Box) -> - let elt_bytes = size_of_comparable Box.elt_ty elt in - atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size) + fun elt _ (module Box) -> + let elt_bytes = size_of_comparable Box.elt_ty elt in + atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size) let set_size = atomic_step_cost 10 - let empty_map = atomic_step_cost 10 - let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost = - fun (module Box) -> - let size = snd Box.boxed in - atomic_step_cost (size * 20) - let map_access : type key value. key -> (key, value) Script_typed_ir.map -> cost - = fun key (module Box) -> - let map_card = snd Box.boxed in - let key_bytes = size_of_comparable Box.key_ty key in - atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card) + let empty_map = atomic_step_cost 10 + + let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost + = + fun (module Box) -> + let size = snd Box.boxed in + atomic_step_cost (size * 20) + + let map_access : + type key value. key -> (key, value) Script_typed_ir.map -> cost = + fun key (module Box) -> + let map_card = snd Box.boxed in + let key_bytes = size_of_comparable Box.key_ty key in + atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card) let map_mem = map_access + let map_get = map_access - let map_update : type key value. key -> value option -> (key, value) Script_typed_ir.map -> cost - = fun key _value (module Box) -> - let map_card = snd Box.boxed in - let key_bytes = size_of_comparable Box.key_ty key in - atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card) + let map_update : + type key value. + key -> value option -> (key, value) Script_typed_ir.map -> cost = + fun key _value (module Box) -> + let map_card = snd Box.boxed in + let key_bytes = size_of_comparable Box.key_ty key in + atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card) let map_size = atomic_step_cost 10 @@ -153,16 +175,16 @@ module Cost_of = struct let bytes1 = timestamp_bytes t1 in let bytes2 = int_bytes t2 in atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62)) + let sub_timestamp = add_timestamp + let diff_timestamps (t1 : Script_timestamp.t) (t2 : Script_timestamp.t) = let bytes1 = timestamp_bytes t1 in let bytes2 = timestamp_bytes t2 in atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62)) let rec concat_loop l acc = - match l with - | [] -> 30 - | _ :: tl -> concat_loop tl (acc + 30) + match l with [] -> 30 | _ :: tl -> concat_loop tl (acc + 30) let concat_string string_list = atomic_step_cost (concat_loop string_list 0) @@ -170,19 +192,28 @@ module Cost_of = struct let slice_string string_length = atomic_step_cost (40 + (string_length / 70)) - let concat_bytes bytes_list = - atomic_step_cost (concat_loop bytes_list 0) + let concat_bytes bytes_list = atomic_step_cost (concat_loop bytes_list 0) let int64_op = atomic_step_cost 61 + let z_to_int64 = atomic_step_cost 20 + let int64_to_z = atomic_step_cost 20 + let bool_binop _ _ = atomic_step_cost 10 + let bool_unop _ = atomic_step_cost 10 - let abs int = atomic_step_cost (61 + ((int_bytes int) / 70)) + let abs int = atomic_step_cost (61 + (int_bytes int / 70)) + let int _int = free + let neg = abs - let add i1 i2 = atomic_step_cost (51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62)) + + let add i1 i2 = + atomic_step_cost + (51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62)) + let sub = add let mul i1 i2 = @@ -198,303 +229,537 @@ module Cost_of = struct atomic_step_cost (51 + (cost / 3151)) let shift_left _i _shift_bits = atomic_step_cost 30 + let shift_right _i _shift_bits = atomic_step_cost 30 + let logor i1 i2 = let bytes1 = int_bytes i1 in let bytes2 = int_bytes i2 in - atomic_step_cost (51 + ((Compare.Int.max bytes1 bytes2) / 70)) + atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 70)) + let logand i1 i2 = let bytes1 = int_bytes i1 in let bytes2 = int_bytes i2 in - atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 70)) + atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 70)) + let logxor = logor - let lognot i = atomic_step_cost (51 + ((int_bytes i) / 20)) + + let lognot i = atomic_step_cost (51 + (int_bytes i / 20)) + let exec = atomic_step_cost 10 + let compare_bool _ _ = atomic_step_cost 30 let compare_string s1 s2 = let bytes1 = String.length s1 in let bytes2 = String.length s2 in - atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123)) + atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123)) + let compare_bytes b1 b2 = let bytes1 = MBytes.length b1 in let bytes2 = MBytes.length b2 in - atomic_step_cost (30 + ((Compare.Int.min bytes1 bytes2) / 123)) + atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123)) + let compare_tez _ _ = atomic_step_cost 30 + let compare_zint i1 i2 = - atomic_step_cost (51 + ((Compare.Int.min (int_bytes i1) (int_bytes i2)) / 82)) + atomic_step_cost + (51 + (Compare.Int.min (int_bytes i1) (int_bytes i2) / 82)) + let compare_key_hash _ _ = atomic_step_cost 92 let compare_timestamp t1 t2 = let bytes1 = timestamp_bytes t1 in let bytes2 = timestamp_bytes t2 in - atomic_step_cost (51 + ((Compare.Int.min bytes1 bytes2) / 82)) + atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 82)) let compare_address _ _ = atomic_step_cost 92 + let compare_res = atomic_step_cost 30 + let unpack_failed bytes = (* We cannot instrument failed deserialization, so we take worst case fees: a set of size 1 bytes values. *) let len = MBytes.length bytes in - (len *@ alloc_mbytes_cost 1) +@ - (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1))) + (len *@ alloc_mbytes_cost 1) + +@ (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1))) + let address = atomic_step_cost 10 + let contract = step_cost 10000 + let transfer = step_cost 10 + let create_account = step_cost 10 + let create_contract = step_cost 10 + let implicit_account = step_cost 10 + let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32) + let balance = atomic_step_cost 10 + let now = atomic_step_cost 10 + let check_signature_secp256k1 bytes = atomic_step_cost (10342 + (bytes / 5)) + let check_signature_ed25519 bytes = atomic_step_cost (36864 + (bytes / 5)) + let check_signature_p256 bytes = atomic_step_cost (36864 + (bytes / 5)) + let check_signature (pkey : Signature.public_key) bytes = match pkey with - | Ed25519 _ -> check_signature_ed25519 (MBytes.length bytes) - | Secp256k1 _ -> check_signature_secp256k1 (MBytes.length bytes) - | P256 _ -> check_signature_p256 (MBytes.length bytes) + | Ed25519 _ -> + check_signature_ed25519 (MBytes.length bytes) + | Secp256k1 _ -> + check_signature_secp256k1 (MBytes.length bytes) + | P256 _ -> + check_signature_p256 (MBytes.length bytes) + let hash_key = atomic_step_cost 30 - let hash_blake2b b = atomic_step_cost (102 + ((MBytes.length b) / 5)) - let hash_sha256 b = atomic_step_cost (409 + (MBytes.length b)) + + let hash_blake2b b = atomic_step_cost (102 + (MBytes.length b / 5)) + + let hash_sha256 b = atomic_step_cost (409 + MBytes.length b) + let hash_sha512 b = - let bytes = MBytes.length b in atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4))) + let bytes = MBytes.length b in + atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4))) + let steps_to_quota = atomic_step_cost 10 + let source = atomic_step_cost 10 + let self = atomic_step_cost 10 + let amount = atomic_step_cost 10 + let chain_id = step_cost 1 - let stack_n_op n = atomic_step_cost (20 + (((n lsr 1) + (n lsr 2)) + (n lsr 4))) + + let stack_n_op n = + atomic_step_cost (20 + ((n lsr 1) + (n lsr 2) + (n lsr 4))) + let apply = alloc_cost 8 +@ step_cost 1 - let rec compare : type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost = fun ty x y -> + let rec compare : + type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost = + fun ty x y -> match ty with - | Bool_key _ -> compare_bool x y - | String_key _ -> compare_string x y - | Bytes_key _ -> compare_bytes x y - | Mutez_key _ -> compare_tez x y - | Int_key _ -> compare_zint x y - | Nat_key _ -> compare_zint x y - | Key_hash_key _ -> compare_key_hash x y - | Timestamp_key _ -> compare_timestamp x y - | Address_key _ -> compare_address x y + | Bool_key _ -> + compare_bool x y + | String_key _ -> + compare_string x y + | Bytes_key _ -> + compare_bytes x y + | Mutez_key _ -> + compare_tez x y + | Int_key _ -> + compare_zint x y + | Nat_key _ -> + compare_zint x y + | Key_hash_key _ -> + compare_key_hash x y + | Timestamp_key _ -> + compare_timestamp x y + | Address_key _ -> + compare_address x y | Pair_key ((tl, _), (tr, _), _) -> (* Reasonable over-approximation of the cost of lexicographic comparison. *) let (xl, xr) = x and (yl, yr) = y in compare tl xl yl +@ compare tr xr yr - end module Typechecking = struct let cycle = step_cost 1 + let bool = free + let unit = free + let string = string + let bytes = bytes + let z = Legacy.zint + let int_of_string str = - alloc_cost @@ (Pervasives.(/) (String.length str) 5) + alloc_cost @@ Pervasives.( / ) (String.length str) 5 + let tez = step_cost 1 +@ alloc_cost 1 + let string_timestamp = step_cost 3 +@ alloc_cost 3 + let key = step_cost 3 +@ alloc_cost 3 + let key_hash = step_cost 1 +@ alloc_cost 1 + let signature = step_cost 1 +@ alloc_cost 1 + let chain_id = step_cost 1 +@ alloc_cost 1 + let contract = step_cost 5 + let get_script = step_cost 20 +@ alloc_cost 5 + let contract_exists = step_cost 15 +@ alloc_cost 5 + let pair = alloc_cost 2 + let union = alloc_cost 1 + let lambda = alloc_cost 5 +@ step_cost 3 + let some = alloc_cost 1 + let none = alloc_cost 0 + let list_element = alloc_cost 2 +@ step_cost 1 + let set_element size = log2 size *@ (alloc_cost 3 +@ step_cost 2) + let map_element size = log2 size *@ (alloc_cost 4 +@ step_cost 2) + let primitive_type = alloc_cost 1 + let one_arg_type = alloc_cost 2 + let two_arg_type = alloc_cost 3 + let operation b = bytes b + let type_ nb_args = alloc_cost (nb_args + 1) (* Cost of parsing instruction, is cost of allocation of constructor + cost of contructor parameters + cost of allocation on the stack type *) - let instr - : type b a. (b, a) Script_typed_ir.instr -> cost - = fun i -> - let open Script_typed_ir in - alloc_cost 1 +@ (* cost of allocation of constructor *) - match i with - | Drop -> alloc_cost 0 - | Dup -> alloc_cost 1 - | Swap -> alloc_cost 0 - | Const _ -> alloc_cost 1 - | Cons_pair -> alloc_cost 2 - | Car -> alloc_cost 1 - | Cdr -> alloc_cost 1 - | Cons_some -> alloc_cost 2 - | Cons_none _ -> alloc_cost 3 - | If_none _ -> alloc_cost 2 - | Left -> alloc_cost 3 - | Right -> alloc_cost 3 - | If_left _ -> alloc_cost 2 - | Cons_list -> alloc_cost 1 - | Nil -> alloc_cost 1 - | If_cons _ -> alloc_cost 2 - | List_map _ -> alloc_cost 5 - | List_iter _ -> alloc_cost 4 - | List_size -> alloc_cost 1 - | Empty_set _ -> alloc_cost 1 - | Set_iter _ -> alloc_cost 4 - | Set_mem -> alloc_cost 1 - | Set_update -> alloc_cost 1 - | Set_size -> alloc_cost 1 - | Empty_map _ -> alloc_cost 2 - | Map_map _ -> alloc_cost 5 - | Map_iter _ -> alloc_cost 4 - | Map_mem -> alloc_cost 1 - | Map_get -> alloc_cost 1 - | Map_update -> alloc_cost 1 - | Map_size -> alloc_cost 1 - | Empty_big_map _ -> alloc_cost 2 - | Big_map_mem -> alloc_cost 1 - | Big_map_get -> alloc_cost 1 - | Big_map_update -> alloc_cost 1 - | Concat_string -> alloc_cost 1 - | Concat_string_pair -> alloc_cost 1 - | Concat_bytes -> alloc_cost 1 - | Concat_bytes_pair -> alloc_cost 1 - | Slice_string -> alloc_cost 1 - | Slice_bytes -> alloc_cost 1 - | String_size -> alloc_cost 1 - | Bytes_size -> alloc_cost 1 - | Add_seconds_to_timestamp -> alloc_cost 1 - | Add_timestamp_to_seconds -> alloc_cost 1 - | Sub_timestamp_seconds -> alloc_cost 1 - | Diff_timestamps -> alloc_cost 1 - | Add_tez -> alloc_cost 1 - | Sub_tez -> alloc_cost 1 - | Mul_teznat -> alloc_cost 1 - | Mul_nattez -> alloc_cost 1 - | Ediv_teznat -> alloc_cost 1 - | Ediv_tez -> alloc_cost 1 - | Or -> alloc_cost 1 - | And -> alloc_cost 1 - | Xor -> alloc_cost 1 - | Not -> alloc_cost 1 - | Is_nat -> alloc_cost 1 - | Neg_nat -> alloc_cost 1 - | Neg_int -> alloc_cost 1 - | Abs_int -> alloc_cost 1 - | Int_nat -> alloc_cost 1 - | Add_intint -> alloc_cost 1 - | Add_intnat -> alloc_cost 1 - | Add_natint -> alloc_cost 1 - | Add_natnat -> alloc_cost 1 - | Sub_int -> alloc_cost 1 - | Mul_intint -> alloc_cost 1 - | Mul_intnat -> alloc_cost 1 - | Mul_natint -> alloc_cost 1 - | Mul_natnat -> alloc_cost 1 - | Ediv_intint -> alloc_cost 1 - | Ediv_intnat -> alloc_cost 1 - | Ediv_natint -> alloc_cost 1 - | Ediv_natnat -> alloc_cost 1 - | Lsl_nat -> alloc_cost 1 - | Lsr_nat -> alloc_cost 1 - | Or_nat -> alloc_cost 1 - | And_nat -> alloc_cost 1 - | And_int_nat -> alloc_cost 1 - | Xor_nat -> alloc_cost 1 - | Not_nat -> alloc_cost 1 - | Not_int -> alloc_cost 1 - | Seq _ -> alloc_cost 8 - | If _ -> alloc_cost 8 - | Loop _ -> alloc_cost 4 - | Loop_left _ -> alloc_cost 5 - | Dip _ -> alloc_cost 4 - | Exec -> alloc_cost 1 - | Apply _ -> alloc_cost 1 - | Lambda _ -> alloc_cost 2 - | Failwith _ -> alloc_cost 1 - | Nop -> alloc_cost 0 - | Compare _ -> alloc_cost 1 - | Eq -> alloc_cost 1 - | Neq -> alloc_cost 1 - | Lt -> alloc_cost 1 - | Gt -> alloc_cost 1 - | Le -> alloc_cost 1 - | Ge -> alloc_cost 1 - | Address -> alloc_cost 1 - | Contract _ -> alloc_cost 2 - | Transfer_tokens -> alloc_cost 1 - | Create_account -> alloc_cost 2 - | Implicit_account -> alloc_cost 1 - | Create_contract _ -> alloc_cost 8 - (* Deducted the cost of removed arguments manager, spendable and delegatable: + let instr : type b a. (b, a) Script_typed_ir.instr -> cost = + fun i -> + let open Script_typed_ir in + alloc_cost 1 + +@ + (* cost of allocation of constructor *) + match i with + | Drop -> + alloc_cost 0 + | Dup -> + alloc_cost 1 + | Swap -> + alloc_cost 0 + | Const _ -> + alloc_cost 1 + | Cons_pair -> + alloc_cost 2 + | Car -> + alloc_cost 1 + | Cdr -> + alloc_cost 1 + | Cons_some -> + alloc_cost 2 + | Cons_none _ -> + alloc_cost 3 + | If_none _ -> + alloc_cost 2 + | Left -> + alloc_cost 3 + | Right -> + alloc_cost 3 + | If_left _ -> + alloc_cost 2 + | Cons_list -> + alloc_cost 1 + | Nil -> + alloc_cost 1 + | If_cons _ -> + alloc_cost 2 + | List_map _ -> + alloc_cost 5 + | List_iter _ -> + alloc_cost 4 + | List_size -> + alloc_cost 1 + | Empty_set _ -> + alloc_cost 1 + | Set_iter _ -> + alloc_cost 4 + | Set_mem -> + alloc_cost 1 + | Set_update -> + alloc_cost 1 + | Set_size -> + alloc_cost 1 + | Empty_map _ -> + alloc_cost 2 + | Map_map _ -> + alloc_cost 5 + | Map_iter _ -> + alloc_cost 4 + | Map_mem -> + alloc_cost 1 + | Map_get -> + alloc_cost 1 + | Map_update -> + alloc_cost 1 + | Map_size -> + alloc_cost 1 + | Empty_big_map _ -> + alloc_cost 2 + | Big_map_mem -> + alloc_cost 1 + | Big_map_get -> + alloc_cost 1 + | Big_map_update -> + alloc_cost 1 + | Concat_string -> + alloc_cost 1 + | Concat_string_pair -> + alloc_cost 1 + | Concat_bytes -> + alloc_cost 1 + | Concat_bytes_pair -> + alloc_cost 1 + | Slice_string -> + alloc_cost 1 + | Slice_bytes -> + alloc_cost 1 + | String_size -> + alloc_cost 1 + | Bytes_size -> + alloc_cost 1 + | Add_seconds_to_timestamp -> + alloc_cost 1 + | Add_timestamp_to_seconds -> + alloc_cost 1 + | Sub_timestamp_seconds -> + alloc_cost 1 + | Diff_timestamps -> + alloc_cost 1 + | Add_tez -> + alloc_cost 1 + | Sub_tez -> + alloc_cost 1 + | Mul_teznat -> + alloc_cost 1 + | Mul_nattez -> + alloc_cost 1 + | Ediv_teznat -> + alloc_cost 1 + | Ediv_tez -> + alloc_cost 1 + | Or -> + alloc_cost 1 + | And -> + alloc_cost 1 + | Xor -> + alloc_cost 1 + | Not -> + alloc_cost 1 + | Is_nat -> + alloc_cost 1 + | Neg_nat -> + alloc_cost 1 + | Neg_int -> + alloc_cost 1 + | Abs_int -> + alloc_cost 1 + | Int_nat -> + alloc_cost 1 + | Add_intint -> + alloc_cost 1 + | Add_intnat -> + alloc_cost 1 + | Add_natint -> + alloc_cost 1 + | Add_natnat -> + alloc_cost 1 + | Sub_int -> + alloc_cost 1 + | Mul_intint -> + alloc_cost 1 + | Mul_intnat -> + alloc_cost 1 + | Mul_natint -> + alloc_cost 1 + | Mul_natnat -> + alloc_cost 1 + | Ediv_intint -> + alloc_cost 1 + | Ediv_intnat -> + alloc_cost 1 + | Ediv_natint -> + alloc_cost 1 + | Ediv_natnat -> + alloc_cost 1 + | Lsl_nat -> + alloc_cost 1 + | Lsr_nat -> + alloc_cost 1 + | Or_nat -> + alloc_cost 1 + | And_nat -> + alloc_cost 1 + | And_int_nat -> + alloc_cost 1 + | Xor_nat -> + alloc_cost 1 + | Not_nat -> + alloc_cost 1 + | Not_int -> + alloc_cost 1 + | Seq _ -> + alloc_cost 8 + | If _ -> + alloc_cost 8 + | Loop _ -> + alloc_cost 4 + | Loop_left _ -> + alloc_cost 5 + | Dip _ -> + alloc_cost 4 + | Exec -> + alloc_cost 1 + | Apply _ -> + alloc_cost 1 + | Lambda _ -> + alloc_cost 2 + | Failwith _ -> + alloc_cost 1 + | Nop -> + alloc_cost 0 + | Compare _ -> + alloc_cost 1 + | Eq -> + alloc_cost 1 + | Neq -> + alloc_cost 1 + | Lt -> + alloc_cost 1 + | Gt -> + alloc_cost 1 + | Le -> + alloc_cost 1 + | Ge -> + alloc_cost 1 + | Address -> + alloc_cost 1 + | Contract _ -> + alloc_cost 2 + | Transfer_tokens -> + alloc_cost 1 + | Create_account -> + alloc_cost 2 + | Implicit_account -> + alloc_cost 1 + | Create_contract _ -> + alloc_cost 8 + (* Deducted the cost of removed arguments manager, spendable and delegatable: - manager: key_hash = 1 - spendable: bool = 0 - delegatable: bool = 0 *) - | Create_contract_2 _ -> alloc_cost 7 - | Set_delegate -> alloc_cost 1 - | Now -> alloc_cost 1 - | Balance -> alloc_cost 1 - | Check_signature -> alloc_cost 1 - | Hash_key -> alloc_cost 1 - | Pack _ -> alloc_cost 2 - | Unpack _ -> alloc_cost 2 - | Blake2b -> alloc_cost 1 - | Sha256 -> alloc_cost 1 - | Sha512 -> alloc_cost 1 - | Steps_to_quota -> alloc_cost 1 - | Source -> alloc_cost 1 - | Sender -> alloc_cost 1 - | Self _ -> alloc_cost 2 - | Amount -> alloc_cost 1 - | Dig (n,_) -> n *@ alloc_cost 1 (* _ is a unary development of n *) - | Dug (n,_) -> n *@ alloc_cost 1 - | Dipn (n,_,_) -> n *@ alloc_cost 1 - | Dropn (n,_) -> n *@ alloc_cost 1 - | ChainId -> alloc_cost 1 + | Create_contract_2 _ -> + alloc_cost 7 + | Set_delegate -> + alloc_cost 1 + | Now -> + alloc_cost 1 + | Balance -> + alloc_cost 1 + | Check_signature -> + alloc_cost 1 + | Hash_key -> + alloc_cost 1 + | Pack _ -> + alloc_cost 2 + | Unpack _ -> + alloc_cost 2 + | Blake2b -> + alloc_cost 1 + | Sha256 -> + alloc_cost 1 + | Sha512 -> + alloc_cost 1 + | Steps_to_quota -> + alloc_cost 1 + | Source -> + alloc_cost 1 + | Sender -> + alloc_cost 1 + | Self _ -> + alloc_cost 2 + | Amount -> + alloc_cost 1 + | Dig (n, _) -> + n *@ alloc_cost 1 (* _ is a unary development of n *) + | Dug (n, _) -> + n *@ alloc_cost 1 + | Dipn (n, _, _) -> + n *@ alloc_cost 1 + | Dropn (n, _) -> + n *@ alloc_cost 1 + | ChainId -> + alloc_cost 1 end module Unparse = struct let prim_cost l annot = Script.prim_node_cost_nonrec_of_length l annot + let seq_cost = Script.seq_node_cost_nonrec_of_length + let string_cost length = Script.string_node_cost_of_length length let cycle = step_cost 1 + let bool = prim_cost 0 [] + let unit = prim_cost 0 [] + (* We count the length of strings and bytes to prevent hidden miscalculations due to non detectable expansion of sharing. *) let string s = Script.string_node_cost s + let bytes s = Script.bytes_node_cost s + let z i = Script.int_node_cost i + let int i = Script.int_node_cost (Script_int.to_zint i) + let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *) + let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int + let operation bytes = Script.bytes_node_cost bytes + let chain_id bytes = Script.bytes_node_cost bytes + let key = string_cost 54 + let key_hash = string_cost 36 + let signature = string_cost 128 + let contract = string_cost 36 + let pair = prim_cost 2 [] + let union = prim_cost 1 [] + let some = prim_cost 1 [] + let none = prim_cost 0 [] + let list_element = alloc_cost 2 + let set_element = alloc_cost 2 + let map_element = alloc_cost 2 + let one_arg_type = prim_cost 1 + let two_arg_type = prim_cost 2 let set_to_list = Legacy.set_to_list + let map_to_list = Legacy.map_to_list end - end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli index c950a7496..98205ee57 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_gas.mli @@ -26,107 +26,194 @@ open Alpha_context module Cost_of : sig - val manager_operation : Gas.cost module Legacy : sig val z_to_int64 : Gas.cost + val hash : MBytes.t -> int -> Gas.cost - val map_to_list : - ('b, 'c) Script_typed_ir.map -> Gas.cost + + val map_to_list : ('b, 'c) Script_typed_ir.map -> Gas.cost + val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost end module Interpreter : sig val cycle : Gas.cost + val loop_cycle : Gas.cost + val loop_size : Gas.cost + val loop_iter : Gas.cost + val loop_map : Gas.cost + val nop : Gas.cost + val stack_op : Gas.cost + val stack_n_op : int -> Gas.cost + val bool_binop : 'a -> 'b -> Gas.cost + val bool_unop : 'a -> Gas.cost + val pair : Gas.cost + val pair_access : Gas.cost + val cons : Gas.cost + val variant_no_data : Gas.cost + val branch : Gas.cost + val concat_string : string list -> Gas.cost + val concat_bytes : MBytes.t list -> Gas.cost + val slice_string : int -> Gas.cost - val map_mem : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost + + val map_mem : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_get : 'a -> ('a, 'b) Script_typed_ir.map -> Gas.cost - val map_update : 'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> Gas.cost + + val map_update : + 'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> Gas.cost + val map_size : Gas.cost + val set_to_list : 'a Script_typed_ir.set -> Gas.cost + val set_update : 'a -> bool -> 'a Script_typed_ir.set -> Gas.cost + val set_mem : 'a -> 'a Script_typed_ir.set -> Gas.cost + val mul : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val div : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val add : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val sub : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val abs : 'a Script_int.num -> Gas.cost + val neg : 'a Script_int.num -> Gas.cost + val int : 'a -> Gas.cost + val add_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost + val sub_timestamp : Script_timestamp.t -> 'a Script_int.num -> Gas.cost + val diff_timestamps : Script_timestamp.t -> Script_timestamp.t -> Gas.cost + val empty_set : Gas.cost + val set_size : Gas.cost + val empty_map : Gas.cost + val int64_op : Gas.cost + val z_to_int64 : Gas.cost + val int64_to_z : Gas.cost + val logor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val logand : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val logxor : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val lognot : 'a Script_int.num -> Gas.cost + val shift_left : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val shift_right : 'a Script_int.num -> 'b Script_int.num -> Gas.cost + val exec : Gas.cost + val push : Gas.cost + val compare_res : Gas.cost + val unpack_failed : MBytes.t -> Gas.cost + val address : Gas.cost + val contract : Gas.cost + val transfer : Gas.cost + val create_account : Gas.cost + val create_contract : Gas.cost + val implicit_account : Gas.cost + val set_delegate : Gas.cost + val balance : Gas.cost + val now : Gas.cost + val check_signature : public_key -> MBytes.t -> Gas.cost + val hash_key : Gas.cost + val hash_blake2b : MBytes.t -> Gas.cost + val hash_sha256 : MBytes.t -> Gas.cost + val hash_sha512 : MBytes.t -> Gas.cost + val steps_to_quota : Gas.cost + val source : Gas.cost + val self : Gas.cost + val amount : Gas.cost + val chain_id : Gas.cost + val wrap : Gas.cost + val compare : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> Gas.cost + val apply : Gas.cost end module Typechecking : sig val cycle : Gas.cost + val unit : Gas.cost + val bool : Gas.cost + val tez : Gas.cost + val z : Z.t -> Gas.cost + val string : int -> Gas.cost + val bytes : int -> Gas.cost + val int_of_string : string -> Gas.cost + val string_timestamp : Gas.cost + val key : Gas.cost + val key_hash : Gas.cost + val signature : Gas.cost + val chain_id : Gas.cost val contract : Gas.cost @@ -144,14 +231,19 @@ module Cost_of : sig val lambda : Gas.cost val some : Gas.cost + val none : Gas.cost val list_element : Gas.cost + val set_element : int -> Gas.cost + val map_element : int -> Gas.cost val primitive_type : Gas.cost + val one_arg_type : Gas.cost + val two_arg_type : Gas.cost val operation : int -> Gas.cost @@ -165,20 +257,35 @@ module Cost_of : sig module Unparse : sig val prim_cost : int -> Script.annot -> Gas.cost + val seq_cost : int -> Gas.cost + val cycle : Gas.cost + val unit : Gas.cost + val bool : Gas.cost + val z : Z.t -> Gas.cost + val int : 'a Script_int.num -> Gas.cost + val tez : Gas.cost + val string : string -> Gas.cost + val bytes : MBytes.t -> Gas.cost + val timestamp : Script_timestamp.t -> Gas.cost + val key : Gas.cost + val key_hash : Gas.cost + val signature : Gas.cost + val operation : MBytes.t -> Gas.cost + val chain_id : MBytes.t -> Gas.cost val contract : Gas.cost @@ -189,15 +296,21 @@ module Cost_of : sig val union : Gas.cost val some : Gas.cost + val none : Gas.cost val list_element : Gas.cost + val set_element : Gas.cost + val map_element : Gas.cost val one_arg_type : Script.annot -> Gas.cost + val two_arg_type : Script.annot -> Gas.cost + val set_to_list : 'a Script_typed_ir.set -> Gas.cost + val map_to_list : ('a, 'b) Script_typed_ir.map -> Gas.cost end end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml index 6c6a1025b..a2f92870f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml @@ -26,8 +26,12 @@ open Micheline type error += Unknown_primitive_name of string + type error += Invalid_case of string -type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location + +type error += + | Invalid_primitive_name of + string Micheline.canonical * Micheline.canonical_location type prim = | K_parameter @@ -150,486 +154,711 @@ type prim = | T_chain_id let valid_case name = - let is_lower = function '_' | 'a'..'z' -> true | _ -> false in - let is_upper = function '_' | 'A'..'Z' -> true | _ -> false in + let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in + let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in let rec for_all a b f = - Compare.Int.(a > b) || f a && for_all (a + 1) b f in + Compare.Int.(a > b) || (f a && for_all (a + 1) b f) + in let len = String.length name in Compare.Int.(len <> 0) - && - Compare.Char.(String.get name 0 <> '_') - && - ((is_upper (String.get name 0) - && for_all 1 (len - 1) (fun i -> is_upper (String.get name i))) - || - (is_upper (String.get name 0) - && for_all 1 (len - 1) (fun i -> is_lower (String.get name i))) - || - (is_lower (String.get name 0) - && for_all 1 (len - 1) (fun i -> is_lower (String.get name i)))) + && Compare.Char.(name.[0] <> '_') + && ( (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_upper name.[i])) + || (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i])) + || (is_lower name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i])) + ) let string_of_prim = function - | K_parameter -> "parameter" - | K_storage -> "storage" - | K_code -> "code" - | D_False -> "False" - | D_Elt -> "Elt" - | D_Left -> "Left" - | D_None -> "None" - | D_Pair -> "Pair" - | D_Right -> "Right" - | D_Some -> "Some" - | D_True -> "True" - | D_Unit -> "Unit" - | I_PACK -> "PACK" - | I_UNPACK -> "UNPACK" - | I_BLAKE2B -> "BLAKE2B" - | I_SHA256 -> "SHA256" - | I_SHA512 -> "SHA512" - | I_ABS -> "ABS" - | I_ADD -> "ADD" - | I_AMOUNT -> "AMOUNT" - | I_AND -> "AND" - | I_BALANCE -> "BALANCE" - | I_CAR -> "CAR" - | I_CDR -> "CDR" - | I_CHAIN_ID -> "CHAIN_ID" - | I_CHECK_SIGNATURE -> "CHECK_SIGNATURE" - | I_COMPARE -> "COMPARE" - | I_CONCAT -> "CONCAT" - | I_CONS -> "CONS" - | I_CREATE_ACCOUNT -> "CREATE_ACCOUNT" - | I_CREATE_CONTRACT -> "CREATE_CONTRACT" - | I_IMPLICIT_ACCOUNT -> "IMPLICIT_ACCOUNT" - | I_DIP -> "DIP" - | I_DROP -> "DROP" - | I_DUP -> "DUP" - | I_EDIV -> "EDIV" - | I_EMPTY_BIG_MAP -> "EMPTY_BIG_MAP" - | I_EMPTY_MAP -> "EMPTY_MAP" - | I_EMPTY_SET -> "EMPTY_SET" - | I_EQ -> "EQ" - | I_EXEC -> "EXEC" - | I_APPLY -> "APPLY" - | I_FAILWITH -> "FAILWITH" - | I_GE -> "GE" - | I_GET -> "GET" - | I_GT -> "GT" - | I_HASH_KEY -> "HASH_KEY" - | I_IF -> "IF" - | I_IF_CONS -> "IF_CONS" - | I_IF_LEFT -> "IF_LEFT" - | I_IF_NONE -> "IF_NONE" - | I_INT -> "INT" - | I_LAMBDA -> "LAMBDA" - | I_LE -> "LE" - | I_LEFT -> "LEFT" - | I_LOOP -> "LOOP" - | I_LSL -> "LSL" - | I_LSR -> "LSR" - | I_LT -> "LT" - | I_MAP -> "MAP" - | I_MEM -> "MEM" - | I_MUL -> "MUL" - | I_NEG -> "NEG" - | I_NEQ -> "NEQ" - | I_NIL -> "NIL" - | I_NONE -> "NONE" - | I_NOT -> "NOT" - | I_NOW -> "NOW" - | I_OR -> "OR" - | I_PAIR -> "PAIR" - | I_PUSH -> "PUSH" - | I_RIGHT -> "RIGHT" - | I_SIZE -> "SIZE" - | I_SOME -> "SOME" - | I_SOURCE -> "SOURCE" - | I_SENDER -> "SENDER" - | I_SELF -> "SELF" - | I_SLICE -> "SLICE" - | I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA" - | I_SUB -> "SUB" - | I_SWAP -> "SWAP" - | I_TRANSFER_TOKENS -> "TRANSFER_TOKENS" - | I_SET_DELEGATE -> "SET_DELEGATE" - | I_UNIT -> "UNIT" - | I_UPDATE -> "UPDATE" - | I_XOR -> "XOR" - | I_ITER -> "ITER" - | I_LOOP_LEFT -> "LOOP_LEFT" - | I_ADDRESS -> "ADDRESS" - | I_CONTRACT -> "CONTRACT" - | I_ISNAT -> "ISNAT" - | I_CAST -> "CAST" - | I_RENAME -> "RENAME" - | I_DIG -> "DIG" - | I_DUG -> "DUG" - | T_bool -> "bool" - | T_contract -> "contract" - | T_int -> "int" - | T_key -> "key" - | T_key_hash -> "key_hash" - | T_lambda -> "lambda" - | T_list -> "list" - | T_map -> "map" - | T_big_map -> "big_map" - | T_nat -> "nat" - | T_option -> "option" - | T_or -> "or" - | T_pair -> "pair" - | T_set -> "set" - | T_signature -> "signature" - | T_string -> "string" - | T_bytes -> "bytes" - | T_mutez -> "mutez" - | T_timestamp -> "timestamp" - | T_unit -> "unit" - | T_operation -> "operation" - | T_address -> "address" - | T_chain_id -> "chain_id" + | K_parameter -> + "parameter" + | K_storage -> + "storage" + | K_code -> + "code" + | D_False -> + "False" + | D_Elt -> + "Elt" + | D_Left -> + "Left" + | D_None -> + "None" + | D_Pair -> + "Pair" + | D_Right -> + "Right" + | D_Some -> + "Some" + | D_True -> + "True" + | D_Unit -> + "Unit" + | I_PACK -> + "PACK" + | I_UNPACK -> + "UNPACK" + | I_BLAKE2B -> + "BLAKE2B" + | I_SHA256 -> + "SHA256" + | I_SHA512 -> + "SHA512" + | I_ABS -> + "ABS" + | I_ADD -> + "ADD" + | I_AMOUNT -> + "AMOUNT" + | I_AND -> + "AND" + | I_BALANCE -> + "BALANCE" + | I_CAR -> + "CAR" + | I_CDR -> + "CDR" + | I_CHAIN_ID -> + "CHAIN_ID" + | I_CHECK_SIGNATURE -> + "CHECK_SIGNATURE" + | I_COMPARE -> + "COMPARE" + | I_CONCAT -> + "CONCAT" + | I_CONS -> + "CONS" + | I_CREATE_ACCOUNT -> + "CREATE_ACCOUNT" + | I_CREATE_CONTRACT -> + "CREATE_CONTRACT" + | I_IMPLICIT_ACCOUNT -> + "IMPLICIT_ACCOUNT" + | I_DIP -> + "DIP" + | I_DROP -> + "DROP" + | I_DUP -> + "DUP" + | I_EDIV -> + "EDIV" + | I_EMPTY_BIG_MAP -> + "EMPTY_BIG_MAP" + | I_EMPTY_MAP -> + "EMPTY_MAP" + | I_EMPTY_SET -> + "EMPTY_SET" + | I_EQ -> + "EQ" + | I_EXEC -> + "EXEC" + | I_APPLY -> + "APPLY" + | I_FAILWITH -> + "FAILWITH" + | I_GE -> + "GE" + | I_GET -> + "GET" + | I_GT -> + "GT" + | I_HASH_KEY -> + "HASH_KEY" + | I_IF -> + "IF" + | I_IF_CONS -> + "IF_CONS" + | I_IF_LEFT -> + "IF_LEFT" + | I_IF_NONE -> + "IF_NONE" + | I_INT -> + "INT" + | I_LAMBDA -> + "LAMBDA" + | I_LE -> + "LE" + | I_LEFT -> + "LEFT" + | I_LOOP -> + "LOOP" + | I_LSL -> + "LSL" + | I_LSR -> + "LSR" + | I_LT -> + "LT" + | I_MAP -> + "MAP" + | I_MEM -> + "MEM" + | I_MUL -> + "MUL" + | I_NEG -> + "NEG" + | I_NEQ -> + "NEQ" + | I_NIL -> + "NIL" + | I_NONE -> + "NONE" + | I_NOT -> + "NOT" + | I_NOW -> + "NOW" + | I_OR -> + "OR" + | I_PAIR -> + "PAIR" + | I_PUSH -> + "PUSH" + | I_RIGHT -> + "RIGHT" + | I_SIZE -> + "SIZE" + | I_SOME -> + "SOME" + | I_SOURCE -> + "SOURCE" + | I_SENDER -> + "SENDER" + | I_SELF -> + "SELF" + | I_SLICE -> + "SLICE" + | I_STEPS_TO_QUOTA -> + "STEPS_TO_QUOTA" + | I_SUB -> + "SUB" + | I_SWAP -> + "SWAP" + | I_TRANSFER_TOKENS -> + "TRANSFER_TOKENS" + | I_SET_DELEGATE -> + "SET_DELEGATE" + | I_UNIT -> + "UNIT" + | I_UPDATE -> + "UPDATE" + | I_XOR -> + "XOR" + | I_ITER -> + "ITER" + | I_LOOP_LEFT -> + "LOOP_LEFT" + | I_ADDRESS -> + "ADDRESS" + | I_CONTRACT -> + "CONTRACT" + | I_ISNAT -> + "ISNAT" + | I_CAST -> + "CAST" + | I_RENAME -> + "RENAME" + | I_DIG -> + "DIG" + | I_DUG -> + "DUG" + | T_bool -> + "bool" + | T_contract -> + "contract" + | T_int -> + "int" + | T_key -> + "key" + | T_key_hash -> + "key_hash" + | T_lambda -> + "lambda" + | T_list -> + "list" + | T_map -> + "map" + | T_big_map -> + "big_map" + | T_nat -> + "nat" + | T_option -> + "option" + | T_or -> + "or" + | T_pair -> + "pair" + | T_set -> + "set" + | T_signature -> + "signature" + | T_string -> + "string" + | T_bytes -> + "bytes" + | T_mutez -> + "mutez" + | T_timestamp -> + "timestamp" + | T_unit -> + "unit" + | T_operation -> + "operation" + | T_address -> + "address" + | T_chain_id -> + "chain_id" let prim_of_string = function - | "parameter" -> ok K_parameter - | "storage" -> ok K_storage - | "code" -> ok K_code - | "False" -> ok D_False - | "Elt" -> ok D_Elt - | "Left" -> ok D_Left - | "None" -> ok D_None - | "Pair" -> ok D_Pair - | "Right" -> ok D_Right - | "Some" -> ok D_Some - | "True" -> ok D_True - | "Unit" -> ok D_Unit - | "PACK" -> ok I_PACK - | "UNPACK" -> ok I_UNPACK - | "BLAKE2B" -> ok I_BLAKE2B - | "SHA256" -> ok I_SHA256 - | "SHA512" -> ok I_SHA512 - | "ABS" -> ok I_ABS - | "ADD" -> ok I_ADD - | "AMOUNT" -> ok I_AMOUNT - | "AND" -> ok I_AND - | "BALANCE" -> ok I_BALANCE - | "CAR" -> ok I_CAR - | "CDR" -> ok I_CDR - | "CHAIN_ID" -> ok I_CHAIN_ID - | "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE - | "COMPARE" -> ok I_COMPARE - | "CONCAT" -> ok I_CONCAT - | "CONS" -> ok I_CONS - | "CREATE_ACCOUNT" -> ok I_CREATE_ACCOUNT - | "CREATE_CONTRACT" -> ok I_CREATE_CONTRACT - | "IMPLICIT_ACCOUNT" -> ok I_IMPLICIT_ACCOUNT - | "DIP" -> ok I_DIP - | "DROP" -> ok I_DROP - | "DUP" -> ok I_DUP - | "EDIV" -> ok I_EDIV - | "EMPTY_BIG_MAP" -> ok I_EMPTY_BIG_MAP - | "EMPTY_MAP" -> ok I_EMPTY_MAP - | "EMPTY_SET" -> ok I_EMPTY_SET - | "EQ" -> ok I_EQ - | "EXEC" -> ok I_EXEC - | "APPLY" -> ok I_APPLY - | "FAILWITH" -> ok I_FAILWITH - | "GE" -> ok I_GE - | "GET" -> ok I_GET - | "GT" -> ok I_GT - | "HASH_KEY" -> ok I_HASH_KEY - | "IF" -> ok I_IF - | "IF_CONS" -> ok I_IF_CONS - | "IF_LEFT" -> ok I_IF_LEFT - | "IF_NONE" -> ok I_IF_NONE - | "INT" -> ok I_INT - | "LAMBDA" -> ok I_LAMBDA - | "LE" -> ok I_LE - | "LEFT" -> ok I_LEFT - | "LOOP" -> ok I_LOOP - | "LSL" -> ok I_LSL - | "LSR" -> ok I_LSR - | "LT" -> ok I_LT - | "MAP" -> ok I_MAP - | "MEM" -> ok I_MEM - | "MUL" -> ok I_MUL - | "NEG" -> ok I_NEG - | "NEQ" -> ok I_NEQ - | "NIL" -> ok I_NIL - | "NONE" -> ok I_NONE - | "NOT" -> ok I_NOT - | "NOW" -> ok I_NOW - | "OR" -> ok I_OR - | "PAIR" -> ok I_PAIR - | "PUSH" -> ok I_PUSH - | "RIGHT" -> ok I_RIGHT - | "SIZE" -> ok I_SIZE - | "SOME" -> ok I_SOME - | "SOURCE" -> ok I_SOURCE - | "SENDER" -> ok I_SENDER - | "SELF" -> ok I_SELF - | "SLICE" -> ok I_SLICE - | "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA - | "SUB" -> ok I_SUB - | "SWAP" -> ok I_SWAP - | "TRANSFER_TOKENS" -> ok I_TRANSFER_TOKENS - | "SET_DELEGATE" -> ok I_SET_DELEGATE - | "UNIT" -> ok I_UNIT - | "UPDATE" -> ok I_UPDATE - | "XOR" -> ok I_XOR - | "ITER" -> ok I_ITER - | "LOOP_LEFT" -> ok I_LOOP_LEFT - | "ADDRESS" -> ok I_ADDRESS - | "CONTRACT" -> ok I_CONTRACT - | "ISNAT" -> ok I_ISNAT - | "CAST" -> ok I_CAST - | "RENAME" -> ok I_RENAME - | "DIG" -> ok I_DIG - | "DUG" -> ok I_DUG - | "bool" -> ok T_bool - | "contract" -> ok T_contract - | "int" -> ok T_int - | "key" -> ok T_key - | "key_hash" -> ok T_key_hash - | "lambda" -> ok T_lambda - | "list" -> ok T_list - | "map" -> ok T_map - | "big_map" -> ok T_big_map - | "nat" -> ok T_nat - | "option" -> ok T_option - | "or" -> ok T_or - | "pair" -> ok T_pair - | "set" -> ok T_set - | "signature" -> ok T_signature - | "string" -> ok T_string - | "bytes" -> ok T_bytes - | "mutez" -> ok T_mutez - | "timestamp" -> ok T_timestamp - | "unit" -> ok T_unit - | "operation" -> ok T_operation - | "address" -> ok T_address - | "chain_id" -> ok T_chain_id + | "parameter" -> + ok K_parameter + | "storage" -> + ok K_storage + | "code" -> + ok K_code + | "False" -> + ok D_False + | "Elt" -> + ok D_Elt + | "Left" -> + ok D_Left + | "None" -> + ok D_None + | "Pair" -> + ok D_Pair + | "Right" -> + ok D_Right + | "Some" -> + ok D_Some + | "True" -> + ok D_True + | "Unit" -> + ok D_Unit + | "PACK" -> + ok I_PACK + | "UNPACK" -> + ok I_UNPACK + | "BLAKE2B" -> + ok I_BLAKE2B + | "SHA256" -> + ok I_SHA256 + | "SHA512" -> + ok I_SHA512 + | "ABS" -> + ok I_ABS + | "ADD" -> + ok I_ADD + | "AMOUNT" -> + ok I_AMOUNT + | "AND" -> + ok I_AND + | "BALANCE" -> + ok I_BALANCE + | "CAR" -> + ok I_CAR + | "CDR" -> + ok I_CDR + | "CHAIN_ID" -> + ok I_CHAIN_ID + | "CHECK_SIGNATURE" -> + ok I_CHECK_SIGNATURE + | "COMPARE" -> + ok I_COMPARE + | "CONCAT" -> + ok I_CONCAT + | "CONS" -> + ok I_CONS + | "CREATE_ACCOUNT" -> + ok I_CREATE_ACCOUNT + | "CREATE_CONTRACT" -> + ok I_CREATE_CONTRACT + | "IMPLICIT_ACCOUNT" -> + ok I_IMPLICIT_ACCOUNT + | "DIP" -> + ok I_DIP + | "DROP" -> + ok I_DROP + | "DUP" -> + ok I_DUP + | "EDIV" -> + ok I_EDIV + | "EMPTY_BIG_MAP" -> + ok I_EMPTY_BIG_MAP + | "EMPTY_MAP" -> + ok I_EMPTY_MAP + | "EMPTY_SET" -> + ok I_EMPTY_SET + | "EQ" -> + ok I_EQ + | "EXEC" -> + ok I_EXEC + | "APPLY" -> + ok I_APPLY + | "FAILWITH" -> + ok I_FAILWITH + | "GE" -> + ok I_GE + | "GET" -> + ok I_GET + | "GT" -> + ok I_GT + | "HASH_KEY" -> + ok I_HASH_KEY + | "IF" -> + ok I_IF + | "IF_CONS" -> + ok I_IF_CONS + | "IF_LEFT" -> + ok I_IF_LEFT + | "IF_NONE" -> + ok I_IF_NONE + | "INT" -> + ok I_INT + | "LAMBDA" -> + ok I_LAMBDA + | "LE" -> + ok I_LE + | "LEFT" -> + ok I_LEFT + | "LOOP" -> + ok I_LOOP + | "LSL" -> + ok I_LSL + | "LSR" -> + ok I_LSR + | "LT" -> + ok I_LT + | "MAP" -> + ok I_MAP + | "MEM" -> + ok I_MEM + | "MUL" -> + ok I_MUL + | "NEG" -> + ok I_NEG + | "NEQ" -> + ok I_NEQ + | "NIL" -> + ok I_NIL + | "NONE" -> + ok I_NONE + | "NOT" -> + ok I_NOT + | "NOW" -> + ok I_NOW + | "OR" -> + ok I_OR + | "PAIR" -> + ok I_PAIR + | "PUSH" -> + ok I_PUSH + | "RIGHT" -> + ok I_RIGHT + | "SIZE" -> + ok I_SIZE + | "SOME" -> + ok I_SOME + | "SOURCE" -> + ok I_SOURCE + | "SENDER" -> + ok I_SENDER + | "SELF" -> + ok I_SELF + | "SLICE" -> + ok I_SLICE + | "STEPS_TO_QUOTA" -> + ok I_STEPS_TO_QUOTA + | "SUB" -> + ok I_SUB + | "SWAP" -> + ok I_SWAP + | "TRANSFER_TOKENS" -> + ok I_TRANSFER_TOKENS + | "SET_DELEGATE" -> + ok I_SET_DELEGATE + | "UNIT" -> + ok I_UNIT + | "UPDATE" -> + ok I_UPDATE + | "XOR" -> + ok I_XOR + | "ITER" -> + ok I_ITER + | "LOOP_LEFT" -> + ok I_LOOP_LEFT + | "ADDRESS" -> + ok I_ADDRESS + | "CONTRACT" -> + ok I_CONTRACT + | "ISNAT" -> + ok I_ISNAT + | "CAST" -> + ok I_CAST + | "RENAME" -> + ok I_RENAME + | "DIG" -> + ok I_DIG + | "DUG" -> + ok I_DUG + | "bool" -> + ok T_bool + | "contract" -> + ok T_contract + | "int" -> + ok T_int + | "key" -> + ok T_key + | "key_hash" -> + ok T_key_hash + | "lambda" -> + ok T_lambda + | "list" -> + ok T_list + | "map" -> + ok T_map + | "big_map" -> + ok T_big_map + | "nat" -> + ok T_nat + | "option" -> + ok T_option + | "or" -> + ok T_or + | "pair" -> + ok T_pair + | "set" -> + ok T_set + | "signature" -> + ok T_signature + | "string" -> + ok T_string + | "bytes" -> + ok T_bytes + | "mutez" -> + ok T_mutez + | "timestamp" -> + ok T_timestamp + | "unit" -> + ok T_unit + | "operation" -> + ok T_operation + | "address" -> + ok T_address + | "chain_id" -> + ok T_chain_id | n -> - if valid_case n then - error (Unknown_primitive_name n) - else - error (Invalid_case n) + if valid_case n then error (Unknown_primitive_name n) + else error (Invalid_case n) let prims_of_strings expr = let rec convert = function - | Int _ | String _ | Bytes _ as expr -> ok expr + | (Int _ | String _ | Bytes _) as expr -> + ok expr | Prim (loc, prim, args, annot) -> Error_monad.record_trace (Invalid_primitive_name (expr, loc)) - (prim_of_string prim) >>? fun prim -> + (prim_of_string prim) + >>? fun prim -> List.fold_left (fun acc arg -> - acc >>? fun args -> - convert arg >>? fun arg -> - ok (arg :: args)) - (ok []) args >>? fun args -> - ok (Prim (0, prim, List.rev args, annot)) + acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args)) + (ok []) + args + >>? fun args -> ok (Prim (0, prim, List.rev args, annot)) | Seq (_, args) -> List.fold_left (fun acc arg -> - acc >>? fun args -> - convert arg >>? fun arg -> - ok (arg :: args)) - (ok []) args >>? fun args -> - ok (Seq (0, List.rev args)) in - convert (root expr) >>? fun expr -> - ok (strip_locations expr) + acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args)) + (ok []) + args + >>? fun args -> ok (Seq (0, List.rev args)) + in + convert (root expr) >>? fun expr -> ok (strip_locations expr) let strings_of_prims expr = let rec convert = function - | Int _ | String _ | Bytes _ as expr -> expr + | (Int _ | String _ | Bytes _) as expr -> + expr | Prim (_, prim, args, annot) -> let prim = string_of_prim prim in let args = List.map convert args in Prim (0, prim, args, annot) | Seq (_, args) -> let args = List.map convert args in - Seq (0, args) in + Seq (0, args) + in strip_locations (convert (root expr)) let prim_encoding = let open Data_encoding in - def "michelson.v1.primitives" @@ - string_enum [ - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("parameter", K_parameter) ; - ("storage", K_storage) ; - ("code", K_code) ; - ("False", D_False) ; - ("Elt", D_Elt) ; - ("Left", D_Left) ; - ("None", D_None) ; - ("Pair", D_Pair) ; - ("Right", D_Right) ; - ("Some", D_Some) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("True", D_True) ; - ("Unit", D_Unit) ; - ("PACK", I_PACK) ; - ("UNPACK", I_UNPACK) ; - ("BLAKE2B", I_BLAKE2B) ; - ("SHA256", I_SHA256) ; - ("SHA512", I_SHA512) ; - ("ABS", I_ABS) ; - ("ADD", I_ADD) ; - ("AMOUNT", I_AMOUNT) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("AND", I_AND) ; - ("BALANCE", I_BALANCE) ; - ("CAR", I_CAR) ; - ("CDR", I_CDR) ; - ("CHECK_SIGNATURE", I_CHECK_SIGNATURE) ; - ("COMPARE", I_COMPARE) ; - ("CONCAT", I_CONCAT) ; - ("CONS", I_CONS) ; - ("CREATE_ACCOUNT", I_CREATE_ACCOUNT) ; - ("CREATE_CONTRACT", I_CREATE_CONTRACT) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) ; - ("DIP", I_DIP) ; - ("DROP", I_DROP) ; - ("DUP", I_DUP) ; - ("EDIV", I_EDIV) ; - ("EMPTY_MAP", I_EMPTY_MAP) ; - ("EMPTY_SET", I_EMPTY_SET) ; - ("EQ", I_EQ) ; - ("EXEC", I_EXEC) ; - ("FAILWITH", I_FAILWITH) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("GE", I_GE) ; - ("GET", I_GET) ; - ("GT", I_GT) ; - ("HASH_KEY", I_HASH_KEY) ; - ("IF", I_IF) ; - ("IF_CONS", I_IF_CONS) ; - ("IF_LEFT", I_IF_LEFT) ; - ("IF_NONE", I_IF_NONE) ; - ("INT", I_INT) ; - ("LAMBDA", I_LAMBDA) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("LE", I_LE) ; - ("LEFT", I_LEFT) ; - ("LOOP", I_LOOP) ; - ("LSL", I_LSL) ; - ("LSR", I_LSR) ; - ("LT", I_LT) ; - ("MAP", I_MAP) ; - ("MEM", I_MEM) ; - ("MUL", I_MUL) ; - ("NEG", I_NEG) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("NEQ", I_NEQ) ; - ("NIL", I_NIL) ; - ("NONE", I_NONE) ; - ("NOT", I_NOT) ; - ("NOW", I_NOW) ; - ("OR", I_OR) ; - ("PAIR", I_PAIR) ; - ("PUSH", I_PUSH) ; - ("RIGHT", I_RIGHT) ; - ("SIZE", I_SIZE) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("SOME", I_SOME) ; - ("SOURCE", I_SOURCE) ; - ("SENDER", I_SENDER) ; - ("SELF", I_SELF) ; - ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) ; - ("SUB", I_SUB) ; - ("SWAP", I_SWAP) ; - ("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ; - ("SET_DELEGATE", I_SET_DELEGATE) ; - ("UNIT", I_UNIT) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("UPDATE", I_UPDATE) ; - ("XOR", I_XOR) ; - ("ITER", I_ITER) ; - ("LOOP_LEFT", I_LOOP_LEFT) ; - ("ADDRESS", I_ADDRESS) ; - ("CONTRACT", I_CONTRACT) ; - ("ISNAT", I_ISNAT) ; - ("CAST", I_CAST) ; - ("RENAME", I_RENAME) ; - ("bool", T_bool) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("contract", T_contract) ; - ("int", T_int) ; - ("key", T_key) ; - ("key_hash", T_key_hash) ; - ("lambda", T_lambda) ; - ("list", T_list) ; - ("map", T_map) ; - ("big_map", T_big_map) ; - ("nat", T_nat) ; - ("option", T_option) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("or", T_or) ; - ("pair", T_pair) ; - ("set", T_set) ; - ("signature", T_signature) ; - ("string", T_string) ; - ("bytes", T_bytes) ; - ("mutez", T_mutez) ; - ("timestamp", T_timestamp) ; - ("unit", T_unit) ; - ("operation", T_operation) ; - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("address", T_address) ; - (* Alpha_002 addition *) - ("SLICE", I_SLICE) ; - (* Alpha_005 addition *) - ("DIG", I_DIG) ; - ("DUG", I_DUG) ; - ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP) ; - ("APPLY", I_APPLY) ; - ("chain_id", T_chain_id) ; - ("CHAIN_ID", I_CHAIN_ID) - (* New instructions must be added here, for backward compatibility of the encoding. *) - ] + def "michelson.v1.primitives" + @@ string_enum + [ (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("parameter", K_parameter); + ("storage", K_storage); + ("code", K_code); + ("False", D_False); + ("Elt", D_Elt); + ("Left", D_Left); + ("None", D_None); + ("Pair", D_Pair); + ("Right", D_Right); + ("Some", D_Some); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("True", D_True); + ("Unit", D_Unit); + ("PACK", I_PACK); + ("UNPACK", I_UNPACK); + ("BLAKE2B", I_BLAKE2B); + ("SHA256", I_SHA256); + ("SHA512", I_SHA512); + ("ABS", I_ABS); + ("ADD", I_ADD); + ("AMOUNT", I_AMOUNT); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("AND", I_AND); + ("BALANCE", I_BALANCE); + ("CAR", I_CAR); + ("CDR", I_CDR); + ("CHECK_SIGNATURE", I_CHECK_SIGNATURE); + ("COMPARE", I_COMPARE); + ("CONCAT", I_CONCAT); + ("CONS", I_CONS); + ("CREATE_ACCOUNT", I_CREATE_ACCOUNT); + ("CREATE_CONTRACT", I_CREATE_CONTRACT); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT); + ("DIP", I_DIP); + ("DROP", I_DROP); + ("DUP", I_DUP); + ("EDIV", I_EDIV); + ("EMPTY_MAP", I_EMPTY_MAP); + ("EMPTY_SET", I_EMPTY_SET); + ("EQ", I_EQ); + ("EXEC", I_EXEC); + ("FAILWITH", I_FAILWITH); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("GE", I_GE); + ("GET", I_GET); + ("GT", I_GT); + ("HASH_KEY", I_HASH_KEY); + ("IF", I_IF); + ("IF_CONS", I_IF_CONS); + ("IF_LEFT", I_IF_LEFT); + ("IF_NONE", I_IF_NONE); + ("INT", I_INT); + ("LAMBDA", I_LAMBDA); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("LE", I_LE); + ("LEFT", I_LEFT); + ("LOOP", I_LOOP); + ("LSL", I_LSL); + ("LSR", I_LSR); + ("LT", I_LT); + ("MAP", I_MAP); + ("MEM", I_MEM); + ("MUL", I_MUL); + ("NEG", I_NEG); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("NEQ", I_NEQ); + ("NIL", I_NIL); + ("NONE", I_NONE); + ("NOT", I_NOT); + ("NOW", I_NOW); + ("OR", I_OR); + ("PAIR", I_PAIR); + ("PUSH", I_PUSH); + ("RIGHT", I_RIGHT); + ("SIZE", I_SIZE); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("SOME", I_SOME); + ("SOURCE", I_SOURCE); + ("SENDER", I_SENDER); + ("SELF", I_SELF); + ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA); + ("SUB", I_SUB); + ("SWAP", I_SWAP); + ("TRANSFER_TOKENS", I_TRANSFER_TOKENS); + ("SET_DELEGATE", I_SET_DELEGATE); + ("UNIT", I_UNIT); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("UPDATE", I_UPDATE); + ("XOR", I_XOR); + ("ITER", I_ITER); + ("LOOP_LEFT", I_LOOP_LEFT); + ("ADDRESS", I_ADDRESS); + ("CONTRACT", I_CONTRACT); + ("ISNAT", I_ISNAT); + ("CAST", I_CAST); + ("RENAME", I_RENAME); + ("bool", T_bool); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("contract", T_contract); + ("int", T_int); + ("key", T_key); + ("key_hash", T_key_hash); + ("lambda", T_lambda); + ("list", T_list); + ("map", T_map); + ("big_map", T_big_map); + ("nat", T_nat); + ("option", T_option); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("or", T_or); + ("pair", T_pair); + ("set", T_set); + ("signature", T_signature); + ("string", T_string); + ("bytes", T_bytes); + ("mutez", T_mutez); + ("timestamp", T_timestamp); + ("unit", T_unit); + ("operation", T_operation); + (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("address", T_address); + (* Alpha_002 addition *) + ("SLICE", I_SLICE); + (* Alpha_005 addition *) + ("DIG", I_DIG); + ("DUG", I_DUG); + ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP); + ("APPLY", I_APPLY); + ("chain_id", T_chain_id); + ("CHAIN_ID", I_CHAIN_ID) + (* New instructions must be added here, for backward compatibility of the encoding. *) + ] let () = register_error_kind `Permanent ~id:"michelson_v1.unknown_primitive_name" - ~title: "Unknown primitive name" - ~description: - "In a script or data expression, a primitive was unknown." + ~title:"Unknown primitive name" + ~description:"In a script or data expression, a primitive was unknown." ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n) Data_encoding.(obj1 (req "wrong_primitive_name" string)) - (function - | Unknown_primitive_name got -> Some got - | _ -> None) - (fun got -> - Unknown_primitive_name got) ; + (function Unknown_primitive_name got -> Some got | _ -> None) + (fun got -> Unknown_primitive_name got) ; register_error_kind `Permanent ~id:"michelson_v1.invalid_primitive_name_case" - ~title: "Invalid primitive name case" + ~title:"Invalid primitive name case" ~description: - "In a script or data expression, a primitive name is \ - neither uppercase, lowercase or capitalized." + "In a script or data expression, a primitive name is neither uppercase, \ + lowercase or capitalized." ~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n) Data_encoding.(obj1 (req "wrong_primitive_name" string)) - (function - | Invalid_case name -> Some name - | _ -> None) - (fun name -> - Invalid_case name) ; + (function Invalid_case name -> Some name | _ -> None) + (fun name -> Invalid_case name) ; register_error_kind `Permanent ~id:"michelson_v1.invalid_primitive_name" - ~title: "Invalid primitive name" + ~title:"Invalid primitive name" ~description: - "In a script or data expression, a primitive name is \ - unknown or has a wrong case." + "In a script or data expression, a primitive name is unknown or has a \ + wrong case." ~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.") - Data_encoding.(obj2 - (req "expression" (Micheline.canonical_encoding ~variant:"generic" string)) - (req "location" Micheline.canonical_location_encoding)) + Data_encoding.( + obj2 + (req + "expression" + (Micheline.canonical_encoding ~variant:"generic" string)) + (req "location" Micheline.canonical_location_encoding)) (function - | Invalid_primitive_name (expr, loc) -> Some (expr, loc) - | _ -> None) - (fun (expr, loc) -> - Invalid_primitive_name (expr, loc)) + | Invalid_primitive_name (expr, loc) -> Some (expr, loc) | _ -> None) + (fun (expr, loc) -> Invalid_primitive_name (expr, loc)) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli index 6a0852bf4..4fd908bf5 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.mli @@ -24,8 +24,14 @@ (*****************************************************************************) type error += Unknown_primitive_name of string (* `Permanent *) + type error += Invalid_case of string (* `Permanent *) -type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location (* `Permanent *) + +type error += + | Invalid_primitive_name of + string Micheline.canonical * Micheline.canonical_location + +(* `Permanent *) type prim = | K_parameter @@ -153,6 +159,7 @@ val string_of_prim : prim -> string val prim_of_string : string -> prim tzresult -val prims_of_strings : string Micheline.canonical -> prim Micheline.canonical tzresult +val prims_of_strings : + string Micheline.canonical -> prim Micheline.canonical tzresult val strings_of_prims : prim Micheline.canonical -> string Micheline.canonical diff --git a/vendors/ligo-utils/tezos-protocol-alpha/misc.ml b/vendors/ligo-utils/tezos-protocol-alpha/misc.ml index 26be1e0eb..1d8aad77a 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/misc.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/misc.ml @@ -24,61 +24,56 @@ (*****************************************************************************) type 'a lazyt = unit -> 'a -type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt) + +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 rec (-->) i j = (* [i; i+1; ...; j] *) - if Compare.Int.(i > j) - then [] - else i :: (succ i --> j) +let rec ( --> ) i j = + (* [i; i+1; ...; j] *) + if Compare.Int.(i > j) then [] else i :: (succ i --> j) -let rec (--->) i j = (* [i; i+1; ...; j] *) - if Compare.Int32.(i > j) - then [] - else i :: (Int32.succ i ---> j) +let rec ( ---> ) i j = + (* [i; i+1; ...; j] *) + if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j) let split delim ?(limit = max_int) path = let l = String.length path in let rec do_slashes acc limit i = - if Compare.Int.(i >= l) then - List.rev acc - else if Compare.Char.(String.get path i = delim) then - do_slashes acc limit (i + 1) - else - do_split acc limit i + if Compare.Int.(i >= l) then List.rev acc + else if Compare.Char.(path.[i] = delim) then do_slashes acc limit (i + 1) + else do_split acc limit i and do_split acc limit i = if Compare.Int.(limit <= 0) then - if Compare.Int.(i = l) then - List.rev acc - else - List.rev (String.sub path i (l - i) :: acc) - else - do_component acc (pred limit) i i + if Compare.Int.(i = l) then List.rev acc + else List.rev (String.sub path i (l - i) :: acc) + else do_component acc (pred limit) i i and do_component acc limit i j = if Compare.Int.(j >= l) then - if Compare.Int.(i = j) then - List.rev acc - else - List.rev (String.sub path i (j - i) :: acc) - else if Compare.Char.(String.get path j = delim) then + if Compare.Int.(i = j) then List.rev acc + else List.rev (String.sub path i (j - i) :: acc) + else if Compare.Char.(path.[j] = delim) then do_slashes (String.sub path i (j - i) :: acc) limit j - else - do_component acc limit i (j + 1) in - if Compare.Int.(limit > 0) then - do_slashes [] limit 0 - else - [ path ] + else do_component acc limit i (j + 1) + in + if Compare.Int.(limit > 0) then do_slashes [] limit 0 else [path] let pp_print_paragraph ppf description = - Format.fprintf ppf "@[%a@]" + Format.fprintf + ppf + "@[%a@]" Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string) (split ' ' description) let take n l = let rec loop acc n = function - | xs when Compare.Int.(n <= 0) -> Some (List.rev acc, xs) - | [] -> None - | x :: xs -> loop (x :: acc) (n-1) xs in + | xs when Compare.Int.(n <= 0) -> + Some (List.rev acc, xs) + | [] -> + None + | x :: xs -> + loop (x :: acc) (n - 1) xs + in loop [] n l let remove_prefix ~prefix s = @@ -86,10 +81,12 @@ let remove_prefix ~prefix s = let n = String.length s in if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then Some (String.sub s x (n - x)) - else - None + else None let rec remove_elem_from_list nb = function - | [] -> [] - | l when Compare.Int.(nb <= 0) -> l - | _ :: tl -> remove_elem_from_list (nb - 1) tl + | [] -> + [] + | l when Compare.Int.(nb <= 0) -> + l + | _ :: tl -> + remove_elem_from_list (nb - 1) tl diff --git a/vendors/ligo-utils/tezos-protocol-alpha/misc.mli b/vendors/ligo-utils/tezos-protocol-alpha/misc.mli index 407d7480b..fb4e07dae 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/misc.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/misc.mli @@ -26,19 +26,22 @@ (** {2 Helper functions} *) type 'a lazyt = unit -> 'a -type 'a lazy_list_t = LCons of 'a * ('a lazy_list_t tzresult Lwt.t lazyt) + +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 (** Include bounds *) -val (-->) : int -> int -> int list -val (--->) : Int32.t -> Int32.t -> Int32.t list +val ( --> ) : int -> int -> int list + +val ( ---> ) : Int32.t -> Int32.t -> Int32.t list val pp_print_paragraph : Format.formatter -> string -> unit -val take: int -> 'a list -> ('a list * 'a list) option +val take : int -> 'a list -> ('a list * 'a list) option -(** Some (input with [prefix] removed), if string has [prefix], else [None] **) -val remove_prefix: prefix:string -> string -> string option +(** Some (input with [prefix] removed), if string has [prefix], else [None] *) +val remove_prefix : prefix:string -> string -> string option (** [remove nb list] remove the first [nb] elements from the list [list]. *) -val remove_elem_from_list: int -> 'a list -> 'a list +val remove_elem_from_list : int -> 'a list -> 'a list diff --git a/vendors/ligo-utils/tezos-protocol-alpha/nonce_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/nonce_hash.ml index 931011a92..a79656ea8 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/nonce_hash.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/nonce_hash.ml @@ -26,12 +26,16 @@ (* 32 *) let nonce_hash = "\069\220\169" (* nce(53) *) -include Blake2B.Make(Base58)(struct - let name = "cycle_nonce" - let title = "A nonce hash" - let b58check_prefix = nonce_hash - let size = None - end) +include Blake2B.Make + (Base58) + (struct + let name = "cycle_nonce" -let () = - Base58.check_encoded_prefix b58check_encoding "nce" 53 + let title = "A nonce hash" + + let b58check_prefix = nonce_hash + + let size = None + end) + +let () = Base58.check_encoded_prefix b58check_encoding "nce" 53 diff --git a/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.ml index 2a43e2d9c..14ce2e737 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.ml @@ -24,7 +24,9 @@ (*****************************************************************************) type t = Seed_repr.nonce + type nonce = t + let encoding = Seed_repr.nonce_encoding type error += @@ -39,8 +41,8 @@ let () = ~id:"nonce.too_late_revelation" ~title:"Too late nonce revelation" ~description:"Nonce revelation happens too late" - ~pp: (fun ppf () -> - Format.fprintf ppf "This nonce cannot be revealed anymore.") + ~pp:(fun ppf () -> + Format.fprintf ppf "This nonce cannot be revealed anymore.") Data_encoding.unit (function Too_late_revelation -> Some () | _ -> None) (fun () -> Too_late_revelation) ; @@ -49,8 +51,8 @@ let () = ~id:"nonce.too_early_revelation" ~title:"Too early nonce revelation" ~description:"Nonce revelation happens before cycle end" - ~pp: (fun ppf () -> - Format.fprintf ppf "This nonce should not yet be revealed") + ~pp:(fun ppf () -> + Format.fprintf ppf "This nonce should not yet be revealed") Data_encoding.unit (function Too_early_revelation -> Some () | _ -> None) (fun () -> Too_early_revelation) ; @@ -59,8 +61,7 @@ let () = ~id:"nonce.previously_revealed" ~title:"Previously revealed nonce" ~description:"Duplicated revelation for a nonce." - ~pp: (fun ppf () -> - Format.fprintf ppf "This nonce was previously revealed") + ~pp:(fun ppf () -> Format.fprintf ppf "This nonce was previously revealed") Data_encoding.unit (function Previously_revealed_nonce -> Some () | _ -> None) (fun () -> Previously_revealed_nonce) ; @@ -68,9 +69,13 @@ let () = `Branch ~id:"nonce.unexpected" ~title:"Unexpected nonce" - ~description:"The provided nonce is inconsistent with the committed nonce hash." - ~pp: (fun ppf () -> - Format.fprintf ppf "This nonce revelation is invalid (inconsistent with the committed hash)") + ~description: + "The provided nonce is inconsistent with the committed nonce hash." + ~pp:(fun ppf () -> + Format.fprintf + ppf + "This nonce revelation is invalid (inconsistent with the committed \ + hash)") Data_encoding.unit (function Unexpected_nonce -> Some () | _ -> None) (fun () -> Unexpected_nonce) @@ -80,34 +85,40 @@ let () = let get_unrevealed ctxt level = let cur_level = Level_storage.current ctxt in match Cycle_repr.pred cur_level.cycle with - | None -> fail Too_early_revelation (* no revelations during cycle 0 *) - | Some revealed_cycle -> + | None -> + fail Too_early_revelation (* no revelations during cycle 0 *) + | Some revealed_cycle -> ( if Cycle_repr.(revealed_cycle < level.Level_repr.cycle) then fail Too_early_revelation else if Cycle_repr.(level.Level_repr.cycle < revealed_cycle) then fail Too_late_revelation else - Storage.Seed.Nonce.get ctxt level >>=? function - | Revealed _ -> fail Previously_revealed_nonce - | Unrevealed status -> return status + Storage.Seed.Nonce.get ctxt level + >>=? function + | Revealed _ -> + fail Previously_revealed_nonce + | Unrevealed status -> + return status ) let record_hash ctxt unrevealed = let level = Level_storage.current ctxt in Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed) let reveal ctxt level nonce = - get_unrevealed ctxt level >>=? fun unrevealed -> + get_unrevealed ctxt level + >>=? fun unrevealed -> fail_unless (Seed_repr.check_hash nonce unrevealed.nonce_hash) - Unexpected_nonce >>=? fun () -> - Storage.Seed.Nonce.set ctxt level (Revealed nonce) >>=? fun ctxt -> - return ctxt + Unexpected_nonce + >>=? fun () -> + Storage.Seed.Nonce.set ctxt level (Revealed nonce) + >>=? fun ctxt -> return ctxt type unrevealed = Storage.Seed.unrevealed_nonce = { - nonce_hash: Nonce_hash.t ; - delegate: Signature.Public_key_hash.t ; - rewards: Tez_repr.t ; - fees: Tez_repr.t ; + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; } type status = Storage.Seed.nonce_status = @@ -117,5 +128,7 @@ type status = Storage.Seed.nonce_status = let get = Storage.Seed.Nonce.get let of_bytes = Seed_repr.make_nonce + let hash = Seed_repr.hash + let check_hash = Seed_repr.check_hash diff --git a/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.mli index 026f9a4e2..da64fd676 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/nonce_storage.mli @@ -30,28 +30,29 @@ type error += | Unexpected_nonce type t = Seed_repr.nonce + type nonce = t -val encoding: nonce Data_encoding.t + +val encoding : nonce Data_encoding.t type unrevealed = Storage.Seed.unrevealed_nonce = { - nonce_hash: Nonce_hash.t ; - delegate: Signature.Public_key_hash.t ; - rewards: Tez_repr.t ; - fees: Tez_repr.t ; + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; } -type status = - | Unrevealed of unrevealed - | Revealed of Seed_repr.nonce +type status = Unrevealed of unrevealed | Revealed of Seed_repr.nonce -val get: Raw_context.t -> Level_repr.t -> status tzresult Lwt.t +val get : Raw_context.t -> Level_repr.t -> status tzresult Lwt.t -val record_hash: - Raw_context.t -> unrevealed -> Raw_context.t tzresult Lwt.t +val record_hash : Raw_context.t -> unrevealed -> Raw_context.t tzresult Lwt.t -val reveal: +val reveal : Raw_context.t -> Level_repr.t -> nonce -> Raw_context.t tzresult Lwt.t -val of_bytes: MBytes.t -> nonce tzresult -val hash: nonce -> Nonce_hash.t -val check_hash: nonce -> Nonce_hash.t -> bool +val of_bytes : MBytes.t -> nonce tzresult + +val hash : nonce -> Nonce_hash.t + +val check_hash : nonce -> Nonce_hash.t -> bool diff --git a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml index f07ef5c55..b9ed9e4b1 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.ml @@ -27,16 +27,27 @@ module Kind = struct type seed_nonce_revelation = Seed_nonce_revelation_kind + type double_endorsement_evidence = Double_endorsement_evidence_kind + type double_baking_evidence = Double_baking_evidence_kind + type activate_account = Activate_account_kind + type endorsement = Endorsement_kind + type proposals = Proposals_kind + type ballot = Ballot_kind + type reveal = Reveal_kind + type transaction = Transaction_kind + type origination = Origination_kind + type delegation = Delegation_kind + type 'a manager = | Reveal_manager_kind : reveal manager | Transaction_manager_kind : transaction manager @@ -44,105 +55,114 @@ module Kind = struct | Delegation_manager_kind : delegation manager end -type raw = Operation.t = { - shell: Operation.shell_header ; - proto: MBytes.t ; -} +type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t} let raw_encoding = Operation.encoding type 'kind operation = { - shell: Operation.shell_header ; - protocol_data: 'kind protocol_data ; + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; } and 'kind protocol_data = { - contents: 'kind contents_list ; - signature: Signature.t option ; + contents : 'kind contents_list; + signature : Signature.t option; } 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 + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list and _ contents = - | Endorsement : { - level: Raw_level_repr.t ; - } -> Kind.endorsement contents + | Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents | Seed_nonce_revelation : { - level: Raw_level_repr.t ; - nonce: Seed_repr.nonce ; - } -> Kind.seed_nonce_revelation contents + level : Raw_level_repr.t; + nonce : Seed_repr.nonce; + } + -> Kind.seed_nonce_revelation contents | Double_endorsement_evidence : { - op1: Kind.endorsement operation ; - op2: Kind.endorsement operation ; - } -> Kind.double_endorsement_evidence contents + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents | Double_baking_evidence : { - bh1: Block_header_repr.t ; - bh2: Block_header_repr.t ; - } -> Kind.double_baking_evidence contents + bh1 : Block_header_repr.t; + bh2 : Block_header_repr.t; + } + -> Kind.double_baking_evidence contents | Activate_account : { - id: Ed25519.Public_key_hash.t ; - activation_code: Blinded_public_key_hash.activation_code ; - } -> Kind.activate_account contents + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents | Proposals : { - source: Signature.Public_key_hash.t ; - period: Voting_period_repr.t ; - proposals: Protocol_hash.t list ; - } -> Kind.proposals contents + source : Signature.Public_key_hash.t; + period : Voting_period_repr.t; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents | Ballot : { - source: Signature.Public_key_hash.t ; - period: Voting_period_repr.t ; - proposal: Protocol_hash.t ; - ballot: Vote_repr.ballot ; - } -> Kind.ballot contents + source : Signature.Public_key_hash.t; + period : Voting_period_repr.t; + proposal : Protocol_hash.t; + ballot : Vote_repr.ballot; + } + -> Kind.ballot contents | Manager_operation : { - source: Signature.public_key_hash ; - fee: Tez_repr.tez ; - counter: counter ; - operation: 'kind manager_operation ; - gas_limit: Z.t; - storage_limit: Z.t; - } -> 'kind Kind.manager contents + source : Signature.public_key_hash; + fee : Tez_repr.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Z.t; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : { - amount: Tez_repr.tez ; - parameters: Script_repr.lazy_expr ; - entrypoint: string ; - destination: Contract_repr.contract ; - } -> Kind.transaction manager_operation + amount : Tez_repr.tez; + parameters : Script_repr.lazy_expr; + entrypoint : string; + destination : Contract_repr.contract; + } + -> Kind.transaction manager_operation | Origination : { - delegate: Signature.Public_key_hash.t option ; - script: Script_repr.t ; - credit: Tez_repr.tez ; - preorigination: Contract_repr.t option ; - } -> Kind.origination manager_operation + delegate : Signature.Public_key_hash.t option; + script : Script_repr.t; + credit : Tez_repr.tez; + preorigination : Contract_repr.t option; + } + -> Kind.origination manager_operation | Delegation : - Signature.Public_key_hash.t option -> Kind.delegation manager_operation + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation and counter = Z.t let manager_kind : type kind. kind manager_operation -> kind Kind.manager = function - | Reveal _ -> Kind.Reveal_manager_kind - | Transaction _ -> Kind.Transaction_manager_kind - | Origination _ -> Kind.Origination_manager_kind - | Delegation _ -> Kind.Delegation_manager_kind + | Reveal _ -> + Kind.Reveal_manager_kind + | Transaction _ -> + Kind.Transaction_manager_kind + | Origination _ -> + Kind.Origination_manager_kind + | Delegation _ -> + Kind.Delegation_manager_kind type 'kind internal_operation = { - source: Contract_repr.contract ; - operation: 'kind manager_operation ; - nonce: int ; + source : Contract_repr.contract; + operation : 'kind manager_operation; + nonce : int; } type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation -type packed_contents = - | Contents : 'kind contents -> packed_contents +type packed_contents = Contents : 'kind contents -> packed_contents type packed_contents_list = | Contents_list : 'kind contents_list -> packed_contents_list @@ -151,424 +171,437 @@ type packed_protocol_data = | Operation_data : 'kind protocol_data -> packed_protocol_data type packed_operation = { - shell: Operation.shell_header ; - protocol_data: packed_protocol_data ; + shell : Operation.shell_header; + protocol_data : packed_protocol_data; } -let pack ({ shell ; protocol_data} : _ operation) : packed_operation = { - shell ; - protocol_data = Operation_data protocol_data ; -} +let pack ({shell; protocol_data} : _ operation) : packed_operation = + {shell; protocol_data = Operation_data protocol_data} type packed_internal_operation = | Internal_operation : 'kind internal_operation -> packed_internal_operation let rec to_list = function - | Contents_list (Single o) -> [Contents o] + | Contents_list (Single o) -> + [Contents o] | Contents_list (Cons (o, os)) -> Contents o :: to_list (Contents_list os) let rec of_list = function - | [] -> assert false - | [Contents o] -> Contents_list (Single o) - | (Contents o) :: os -> - let Contents_list os = of_list os in - match o, os with - | Manager_operation _, Single (Manager_operation _) -> + | [] -> + assert false + | [Contents o] -> + Contents_list (Single o) + | Contents o :: os -> ( + let (Contents_list os) = of_list os in + match (o, os) with + | (Manager_operation _, Single (Manager_operation _)) -> Contents_list (Cons (o, os)) - | Manager_operation _, Cons _ -> + | (Manager_operation _, Cons _) -> Contents_list (Cons (o, os)) | _ -> - Pervasives.failwith "Operation list of length > 1 \ - should only contains manager operations." + Pervasives.failwith + "Operation list of length > 1 should only contains manager \ + operations." ) module Encoding = struct - open Data_encoding let case tag name args proj inj = let open Data_encoding in - case tag + case + tag ~title:(String.capitalize_ascii name) - (merge_objs - (obj1 (req "kind" (constant name))) - args) + (merge_objs (obj1 (req "kind" (constant name))) args) (fun x -> match proj x with None -> None | Some x -> Some ((), x)) (fun ((), x) -> inj x) module Manager_operations = struct - type 'kind case = - MCase : { tag: int ; - name: string ; - encoding: 'a Data_encoding.t ; - select: packed_manager_operation -> 'kind manager_operation option ; - proj: 'kind manager_operation -> 'a ; - inj: 'a -> 'kind manager_operation } -> 'kind case + | MCase : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_manager_operation -> 'kind manager_operation option; + proj : 'kind manager_operation -> 'a; + inj : 'a -> 'kind manager_operation; + } + -> 'kind 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) ; - inj = - (fun pkh -> Reveal pkh) - } + 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); + inj = (fun pkh -> Reveal pkh); + } let entrypoint_encoding = def ~title:"entrypoint" ~description:"Named entrypoint to a Michelson smart contract" - "entrypoint" @@ + "entrypoint" + @@ let builtin_case tag name = - Data_encoding.case (Tag tag) ~title:name + Data_encoding.case + (Tag tag) + ~title:name (constant name) - (fun n -> if Compare.String.(n = name) then Some () else None) (fun () -> name) in - union [ builtin_case 0 "default" ; - builtin_case 1 "root" ; - builtin_case 2 "do" ; - builtin_case 3 "set_delegate" ; - builtin_case 4 "remove_delegate" ; - Data_encoding.case (Tag 255) ~title:"named" (Bounded.string 31) (fun s -> Some s) (fun s -> s) ] + (fun n -> if Compare.String.(n = name) then Some () else None) + (fun () -> name) + in + union + [ builtin_case 0 "default"; + builtin_case 1 "root"; + builtin_case 2 "do"; + builtin_case 3 "set_delegate"; + builtin_case 4 "remove_delegate"; + Data_encoding.case + (Tag 255) + ~title:"named" + (Bounded.string 31) + (fun s -> Some s) + (fun s -> s) ] let transaction_case = - MCase { - tag = 1 ; - name = "transaction" ; - encoding = - (obj3 - (req "amount" Tez_repr.encoding) - (req "destination" Contract_repr.encoding) - (opt "parameters" - (obj2 - (req "entrypoint" entrypoint_encoding) - (req "value" Script_repr.lazy_expr_encoding)))) ; - select = - (function - | Manager (Transaction _ as op) -> Some op - | _ -> None) ; - proj = - (function - | Transaction { amount ; destination ; parameters ; entrypoint } -> + MCase + { + tag = 1; + name = "transaction"; + encoding = + obj3 + (req "amount" Tez_repr.encoding) + (req "destination" Contract_repr.encoding) + (opt + "parameters" + (obj2 + (req "entrypoint" entrypoint_encoding) + (req "value" Script_repr.lazy_expr_encoding))); + select = + (function Manager (Transaction _ as op) -> Some op | _ -> None); + proj = + (function + | Transaction {amount; destination; parameters; entrypoint} -> let parameters = - if Script_repr.is_unit_parameter parameters && Compare.String.(entrypoint = "default") then - None - else - Some (entrypoint, parameters) in - (amount, destination, parameters)) ; - inj = - (fun (amount, destination, parameters) -> - let entrypoint, parameters = match parameters with - | None -> "default", Script_repr.unit_parameter - | Some (entrypoint, value) -> entrypoint, value in - Transaction { amount ; destination ; parameters ; entrypoint }) - } + if + Script_repr.is_unit_parameter parameters + && Compare.String.(entrypoint = "default") + then None + else Some (entrypoint, parameters) + in + (amount, destination, parameters)); + inj = + (fun (amount, destination, parameters) -> + let (entrypoint, parameters) = + match parameters with + | None -> + ("default", Script_repr.unit_parameter) + | Some (entrypoint, value) -> + (entrypoint, value) + in + Transaction {amount; destination; parameters; entrypoint}); + } let origination_case = - MCase { - tag = 2 ; - name = "origination" ; - encoding = - (obj3 - (req "balance" Tez_repr.encoding) - (opt "delegate" Signature.Public_key_hash.encoding) - (req "script" Script_repr.encoding)) ; - select = - (function - | Manager (Origination _ as op) -> Some op - | _ -> None) ; - proj = - (function - | Origination { credit ; delegate ; script ; - preorigination = _ - (* the hash is only used internally + MCase + { + tag = 2; + name = "origination"; + encoding = + obj3 + (req "balance" Tez_repr.encoding) + (opt "delegate" Signature.Public_key_hash.encoding) + (req "script" Script_repr.encoding); + select = + (function Manager (Origination _ as op) -> Some op | _ -> None); + proj = + (function + | Origination + { credit; + delegate; + script; + preorigination = + _ + (* the hash is only used internally when originating from smart - contracts, don't serialize it *) } -> - (credit, delegate, script)) ; - inj = - (fun (credit, delegate, script) -> - Origination - {credit ; delegate ; script ; preorigination = None }) - } + contracts, don't serialize it *) + } -> + (credit, delegate, script)); + inj = + (fun (credit, delegate, script) -> + Origination {credit; delegate; script; preorigination = None}); + } let delegation_case = - MCase { - tag = 3 ; - name = "delegation" ; - encoding = - (obj1 - (opt "delegate" Signature.Public_key_hash.encoding)) ; - select = - (function - | Manager (Delegation _ as op) -> Some op - | _ -> None) ; - proj = - (function Delegation key -> key) ; - inj = - (fun key -> Delegation key) - } + MCase + { + tag = 3; + name = "delegation"; + encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); + select = + (function Manager (Delegation _ as op) -> Some op | _ -> None); + proj = (function Delegation key -> key); + inj = (fun key -> Delegation key); + } let encoding = - let make (MCase { 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 -> Manager (inj x)) in - union ~tag_size:`Uint8 [ - make reveal_case ; - make transaction_case ; - make origination_case ; - make delegation_case ; - ] - + let make (MCase {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 -> Manager (inj x)) + in + union + ~tag_size:`Uint8 + [ make reveal_case; + make transaction_case; + make origination_case; + make delegation_case ] end type 'b case = - Case : { tag: int ; - name: string ; - encoding: 'a Data_encoding.t ; - select: packed_contents -> 'b contents option ; - proj: 'b contents -> 'a ; - inj: 'a -> 'b contents } -> 'b case + | Case : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_contents -> 'b contents option; + proj : 'b contents -> 'a; + inj : 'a -> 'b contents; + } + -> 'b case - let endorsement_encoding = - obj1 - (req "level" Raw_level_repr.encoding) + let endorsement_encoding = obj1 (req "level" Raw_level_repr.encoding) let endorsement_case = - Case { - tag = 0 ; - name = "endorsement" ; - encoding = endorsement_encoding ; - select = - (function - | Contents (Endorsement _ as op) -> Some op - | _ -> None) ; - proj = - (fun (Endorsement { level }) -> level) ; - inj = - (fun level -> Endorsement { level }) - } + Case + { + tag = 0; + name = "endorsement"; + encoding = endorsement_encoding; + select = + (function Contents (Endorsement _ as op) -> Some op | _ -> None); + proj = (fun (Endorsement {level}) -> level); + inj = (fun level -> Endorsement {level}); + } let endorsement_encoding = - let make (Case { tag ; name ; encoding ; select = _ ; proj ; inj }) = - case (Tag tag) name encoding - (fun o -> Some (proj o)) - (fun x -> inj x) in + let make (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 -> _ = function - | Single o -> o in - let of_list : Kind.endorsement contents -> _ = function - | o -> Single o in - def "inlined.endorsement" @@ - conv - (fun ({ shell ; protocol_data = { contents ; signature } } : _ operation)-> - (shell, (contents, signature))) - (fun (shell, (contents, signature)) -> - ({ shell ; protocol_data = { contents ; signature }} : _ operation)) - (merge_objs - Operation.shell_header_encoding - (obj2 - (req "operations" - (conv to_list of_list @@ - def "inlined.endorsement.contents" @@ - union [ - make endorsement_case ; - ])) - (varopt "signature" Signature.encoding))) + | Single o -> + o + in + let of_list : Kind.endorsement contents -> _ = function o -> Single o in + def "inlined.endorsement" + @@ conv + (fun ({shell; protocol_data = {contents; signature}} : _ operation) -> + (shell, (contents, signature))) + (fun (shell, (contents, signature)) -> + ({shell; protocol_data = {contents; signature}} : _ operation)) + (merge_objs + Operation.shell_header_encoding + (obj2 + (req + "operations" + ( conv to_list of_list + @@ def "inlined.endorsement.contents" + @@ union [make endorsement_case] )) + (varopt "signature" Signature.encoding))) let seed_nonce_revelation_case = - Case { - tag = 1; - name = "seed_nonce_revelation" ; - encoding = - (obj2 - (req "level" Raw_level_repr.encoding) - (req "nonce" Seed_repr.nonce_encoding)) ; - select = - (function - | Contents (Seed_nonce_revelation _ as op) -> Some op - | _ -> None) ; - proj = - (fun (Seed_nonce_revelation { level ; nonce }) -> (level, nonce)) ; - inj = - (fun (level, nonce) -> Seed_nonce_revelation { level ; nonce }) - } + Case + { + tag = 1; + name = "seed_nonce_revelation"; + encoding = + obj2 + (req "level" Raw_level_repr.encoding) + (req "nonce" Seed_repr.nonce_encoding); + select = + (function + | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None); + proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce)); + inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce}); + } - let double_endorsement_evidence_case : Kind.double_endorsement_evidence case = - Case { - tag = 2 ; - name = "double_endorsement_evidence" ; - encoding = - (obj2 - (req "op1" (dynamic_size endorsement_encoding)) - (req "op2" (dynamic_size endorsement_encoding))) ; - select = - (function - | Contents (Double_endorsement_evidence _ as op) -> Some op - | _ -> None) ; - proj = - (fun (Double_endorsement_evidence { op1 ; op2 }) -> (op1, op2)) ; - inj = - (fun (op1, op2) -> (Double_endorsement_evidence { op1 ; op2 })) - } + let double_endorsement_evidence_case : Kind.double_endorsement_evidence case + = + Case + { + tag = 2; + name = "double_endorsement_evidence"; + encoding = + obj2 + (req "op1" (dynamic_size endorsement_encoding)) + (req "op2" (dynamic_size endorsement_encoding)); + select = + (function + | Contents (Double_endorsement_evidence _ as op) -> + Some op + | _ -> + None); + proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2)); + inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2}); + } let double_baking_evidence_case = - Case { - tag = 3 ; - name = "double_baking_evidence" ; - encoding = - (obj2 - (req "bh1" (dynamic_size Block_header_repr.encoding)) - (req "bh2" (dynamic_size Block_header_repr.encoding))) ; - select = - (function - | Contents (Double_baking_evidence _ as op) -> Some op - | _ -> None) ; - proj = - (fun (Double_baking_evidence { bh1 ; bh2 }) -> (bh1, bh2)) ; - inj = - (fun (bh1, bh2) -> Double_baking_evidence { bh1 ; bh2 }) ; - } + Case + { + tag = 3; + name = "double_baking_evidence"; + encoding = + obj2 + (req "bh1" (dynamic_size Block_header_repr.encoding)) + (req "bh2" (dynamic_size Block_header_repr.encoding)); + select = + (function + | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None); + proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2)); + inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2}); + } let activate_account_case = - Case { - tag = 4 ; - name = "activate_account" ; - encoding = - (obj2 - (req "pkh" Ed25519.Public_key_hash.encoding) - (req "secret" Blinded_public_key_hash.activation_code_encoding)) ; - select = - (function - | Contents (Activate_account _ as op) -> Some op - | _ -> None) ; - proj = - (fun (Activate_account { id ; activation_code }) -> (id, activation_code)) ; - inj = - (fun (id, activation_code) -> Activate_account { id ; activation_code }) - } + Case + { + tag = 4; + name = "activate_account"; + encoding = + obj2 + (req "pkh" Ed25519.Public_key_hash.encoding) + (req "secret" Blinded_public_key_hash.activation_code_encoding); + select = + (function + | Contents (Activate_account _ as op) -> Some op | _ -> None); + proj = + (fun (Activate_account {id; activation_code}) -> + (id, activation_code)); + inj = + (fun (id, activation_code) -> Activate_account {id; activation_code}); + } let proposals_case = - Case { - tag = 5 ; - name = "proposals" ; - encoding = - (obj3 - (req "source" Signature.Public_key_hash.encoding) - (req "period" Voting_period_repr.encoding) - (req "proposals" (list Protocol_hash.encoding))) ; - select = - (function - | Contents (Proposals _ as op) -> Some op - | _ -> None) ; - proj = - (fun (Proposals { source ; period ; proposals }) -> - (source, period, proposals)) ; - inj = - (fun (source, period, proposals) -> - Proposals { source ; period ; proposals }) ; - } + Case + { + tag = 5; + name = "proposals"; + encoding = + obj3 + (req "source" Signature.Public_key_hash.encoding) + (req "period" Voting_period_repr.encoding) + (req "proposals" (list Protocol_hash.encoding)); + select = + (function Contents (Proposals _ as op) -> Some op | _ -> None); + proj = + (fun (Proposals {source; period; proposals}) -> + (source, period, proposals)); + inj = + (fun (source, period, proposals) -> + Proposals {source; period; proposals}); + } let ballot_case = - Case { - tag = 6 ; - name = "ballot" ; - encoding = - (obj4 - (req "source" Signature.Public_key_hash.encoding) - (req "period" Voting_period_repr.encoding) - (req "proposal" Protocol_hash.encoding) - (req "ballot" Vote_repr.ballot_encoding)) ; - select = - (function - | Contents (Ballot _ as op) -> Some op - | _ -> None) ; - proj = - (function - (Ballot { source ; period ; proposal ; ballot }) -> - (source, period, proposal, ballot)) ; - inj = - (fun (source, period, proposal, ballot) -> - Ballot { source ; period ; proposal ; ballot }) ; - } + Case + { + tag = 6; + name = "ballot"; + encoding = + obj4 + (req "source" Signature.Public_key_hash.encoding) + (req "period" Voting_period_repr.encoding) + (req "proposal" Protocol_hash.encoding) + (req "ballot" Vote_repr.ballot_encoding); + select = (function Contents (Ballot _ as op) -> Some op | _ -> None); + proj = + (function + | Ballot {source; period; proposal; ballot} -> + (source, period, proposal, ballot)); + inj = + (fun (source, period, proposal, ballot) -> + Ballot {source; period; proposal; ballot}); + } let manager_encoding = - (obj5 - (req "source" Signature.Public_key_hash.encoding) - (req "fee" Tez_repr.encoding) - (req "counter" (check_size 10 n)) - (req "gas_limit" (check_size 10 n)) - (req "storage_limit" (check_size 10 n))) + obj5 + (req "source" Signature.Public_key_hash.encoding) + (req "fee" Tez_repr.encoding) + (req "counter" (check_size 10 n)) + (req "gas_limit" (check_size 10 n)) + (req "storage_limit" (check_size 10 n)) - let extract - (type kind) - (Manager_operation { source ; fee ; counter ; - gas_limit ; storage_limit ; operation = _ } : kind Kind.manager contents) = + let extract (type kind) + (Manager_operation + {source; fee; counter; gas_limit; storage_limit; operation = _} : + kind Kind.manager contents) = (source, fee, counter, gas_limit, storage_limit) let rebuild (source, fee, counter, gas_limit, storage_limit) operation = - Manager_operation { source ; fee ; counter ; - gas_limit ; storage_limit ; operation } + Manager_operation + {source; fee; counter; gas_limit; storage_limit; operation} - let make_manager_case tag - (type kind) + let make_manager_case tag (type kind) (Manager_operations.MCase mcase : kind Manager_operations.case) = - Case { - tag ; - name = mcase.name ; - encoding = - merge_objs - manager_encoding - mcase.encoding ; - select = - (function - | Contents (Manager_operation ({ operation ; _ } as op)) -> begin - match mcase.select (Manager operation) with - | None -> None - | Some operation -> - Some (Manager_operation { op with operation }) - end - | _ -> None) ; - proj = - (function - | Manager_operation { operation ; _ } as op -> - (extract op, mcase.proj operation )) ; - inj = - (fun (op, contents) -> - (rebuild op (mcase.inj contents))) - } + Case + { + tag; + name = mcase.name; + encoding = merge_objs manager_encoding mcase.encoding; + select = + (function + | Contents (Manager_operation ({operation; _} as op)) -> ( + match mcase.select (Manager operation) with + | None -> + None + | Some operation -> + Some (Manager_operation {op with operation}) ) + | _ -> + None); + proj = + (function + | Manager_operation {operation; _} as op -> + (extract op, mcase.proj operation)); + inj = (fun (op, contents) -> rebuild op (mcase.inj contents)); + } let reveal_case = make_manager_case 107 Manager_operations.reveal_case - let transaction_case = make_manager_case 108 Manager_operations.transaction_case - let origination_case = make_manager_case 109 Manager_operations.origination_case - let delegation_case = make_manager_case 110 Manager_operations.delegation_case + + let transaction_case = + make_manager_case 108 Manager_operations.transaction_case + + let origination_case = + make_manager_case 109 Manager_operations.origination_case + + let delegation_case = + make_manager_case 110 Manager_operations.delegation_case let contents_encoding = - let make (Case { tag ; name ; encoding ; select ; proj ; inj }) = - case (Tag tag) name 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)) in - def "operation.alpha.contents" @@ - union [ - make endorsement_case ; - make seed_nonce_revelation_case ; - make double_endorsement_evidence_case ; - make double_baking_evidence_case ; - make activate_account_case ; - make proposals_case ; - make ballot_case ; - make reveal_case ; - make transaction_case ; - make origination_case ; - make delegation_case ; - ] + (fun x -> Contents (inj x)) + in + def "operation.alpha.contents" + @@ union + [ make endorsement_case; + make seed_nonce_revelation_case; + make double_endorsement_evidence_case; + make double_baking_evidence_case; + make activate_account_case; + make proposals_case; + make ballot_case; + make reveal_case; + make transaction_case; + make origination_case; + make delegation_case ] let contents_list_encoding = conv to_list of_list (Variable.list contents_encoding) @@ -580,79 +613,84 @@ module Encoding = struct Signature.encoding let protocol_data_encoding = - def "operation.alpha.contents_and_signature" @@ - conv - (fun (Operation_data { contents ; signature }) -> - (Contents_list contents, signature)) - (fun (Contents_list contents, signature) -> - Operation_data { contents ; signature }) - (obj2 - (req "contents" contents_list_encoding) - (req "signature" optional_signature_encoding)) + def "operation.alpha.contents_and_signature" + @@ conv + (fun (Operation_data {contents; signature}) -> + (Contents_list contents, signature)) + (fun (Contents_list contents, signature) -> + Operation_data {contents; signature}) + (obj2 + (req "contents" contents_list_encoding) + (req "signature" optional_signature_encoding)) let operation_encoding = conv - (fun ({ shell ; protocol_data }) -> - (shell, protocol_data)) - (fun (shell, protocol_data) -> - { shell ; protocol_data }) - (merge_objs - Operation.shell_header_encoding - protocol_data_encoding) + (fun {shell; protocol_data} -> (shell, protocol_data)) + (fun (shell, protocol_data) -> {shell; protocol_data}) + (merge_objs Operation.shell_header_encoding protocol_data_encoding) let unsigned_operation_encoding = - def "operation.alpha.unsigned_operation" @@ - merge_objs - Operation.shell_header_encoding - (obj1 (req "contents" contents_list_encoding)) + def "operation.alpha.unsigned_operation" + @@ merge_objs + Operation.shell_header_encoding + (obj1 (req "contents" contents_list_encoding)) let internal_operation_encoding = - def "operation.alpha.internal_operation" @@ - conv - (fun (Internal_operation { source ; operation ; nonce }) -> - ((source, nonce), Manager operation)) - (fun ((source, nonce), Manager operation) -> - Internal_operation { source ; operation ; nonce }) - (merge_objs - (obj2 - (req "source" Contract_repr.encoding) - (req "nonce" uint16)) - Manager_operations.encoding) - + def "operation.alpha.internal_operation" + @@ conv + (fun (Internal_operation {source; operation; nonce}) -> + ((source, nonce), Manager operation)) + (fun ((source, nonce), Manager operation) -> + Internal_operation {source; operation; nonce}) + (merge_objs + (obj2 (req "source" Contract_repr.encoding) (req "nonce" uint16)) + Manager_operations.encoding) end let encoding = Encoding.operation_encoding + let contents_encoding = Encoding.contents_encoding + let contents_list_encoding = Encoding.contents_list_encoding + let protocol_data_encoding = Encoding.protocol_data_encoding + let unsigned_operation_encoding = Encoding.unsigned_operation_encoding + let internal_operation_encoding = Encoding.internal_operation_encoding -let raw ({ shell ; protocol_data } : _ operation) = +let raw ({shell; protocol_data} : _ operation) = let proto = Data_encoding.Binary.to_bytes_exn protocol_data_encoding - (Operation_data protocol_data) in - { Operation.shell ; proto } + (Operation_data protocol_data) + in + {Operation.shell; proto} let acceptable_passes (op : packed_operation) = - let Operation_data protocol_data = op.protocol_data in + let (Operation_data protocol_data) = op.protocol_data in match protocol_data.contents with - - | Single (Endorsement _) -> [0] - - | Single (Proposals _ ) -> [1] - | Single (Ballot _ ) -> [1] - - | Single (Seed_nonce_revelation _) -> [2] - | Single (Double_endorsement_evidence _) -> [2] - | Single (Double_baking_evidence _) -> [2] - | Single (Activate_account _) -> [2] - - | Single (Manager_operation _) -> [3] - | Cons _ -> [3] + | Single (Endorsement _) -> + [0] + | Single (Proposals _) -> + [1] + | Single (Ballot _) -> + [1] + | Single (Seed_nonce_revelation _) -> + [2] + | Single (Double_endorsement_evidence _) -> + [2] + | Single (Double_baking_evidence _) -> + [2] + | Single (Activate_account _) -> + [2] + | Single (Manager_operation _) -> + [3] + | Cons _ -> + [3] type error += Invalid_signature (* `Permanent *) + type error += Missing_signature (* `Permanent *) let () = @@ -660,10 +698,10 @@ let () = `Permanent ~id:"operation.invalid_signature" ~title:"Invalid operation signature" - ~description:"The operation signature is ill-formed \ - or has been made with the wrong public key" - ~pp:(fun ppf () -> - Format.fprintf ppf "The operation signature is invalid") + ~description: + "The operation signature is ill-formed or has been made with the wrong \ + public key" + ~pp:(fun ppf () -> Format.fprintf ppf "The operation signature is invalid") Data_encoding.unit (function Invalid_signature -> Some () | _ -> None) (fun () -> Invalid_signature) ; @@ -671,114 +709,148 @@ let () = `Permanent ~id:"operation.missing_signature" ~title:"Missing operation signature" - ~description:"The operation is of a kind that must be signed, \ - but the signature is missing" - ~pp:(fun ppf () -> - Format.fprintf ppf "The operation requires a signature") + ~description: + "The operation is of a kind that must be signed, but the signature is \ + missing" + ~pp:(fun ppf () -> Format.fprintf ppf "The operation requires a signature") Data_encoding.unit (function Missing_signature -> Some () | _ -> None) (fun () -> Missing_signature) -let check_signature_sync (type kind) key chain_id ({ shell ; protocol_data } : kind operation) = +let check_signature_sync (type kind) key chain_id + ({shell; protocol_data} : kind operation) = let check ~watermark contents signature = let unsigned_operation = Data_encoding.Binary.to_bytes_exn - unsigned_operation_encoding (shell, contents) in - if Signature.check ~watermark key signature unsigned_operation then - Ok () - else - error Invalid_signature in - match protocol_data.contents, protocol_data.signature with - | Single _, None -> + unsigned_operation_encoding + (shell, contents) + in + if Signature.check ~watermark key signature unsigned_operation then Ok () + else error Invalid_signature + in + match (protocol_data.contents, protocol_data.signature) with + | (Single _, None) -> error Missing_signature - | Cons _, None -> + | (Cons _, None) -> error Missing_signature - | Single (Endorsement _) as contents, Some signature -> - check ~watermark:(Endorsement chain_id) (Contents_list contents) signature - | Single _ as contents, Some signature -> + | ((Single (Endorsement _) as contents), Some signature) -> + check + ~watermark:(Endorsement chain_id) + (Contents_list contents) + signature + | ((Single _ as contents), Some signature) -> check ~watermark:Generic_operation (Contents_list contents) signature - | Cons _ as contents, Some signature -> + | ((Cons _ as contents), Some signature) -> check ~watermark:Generic_operation (Contents_list contents) signature let check_signature pk chain_id op = Lwt.return (check_signature_sync pk chain_id op) let hash_raw = Operation.hash + let hash (o : _ operation) = let proto = Data_encoding.Binary.to_bytes_exn protocol_data_encoding - (Operation_data o.protocol_data) in - Operation.hash { shell = o.shell ; proto } + (Operation_data o.protocol_data) + in + Operation.hash {shell = o.shell; proto} + let hash_packed (o : packed_operation) = let proto = - Data_encoding.Binary.to_bytes_exn - protocol_data_encoding - o.protocol_data in - Operation.hash { shell = o.shell ; proto } + Data_encoding.Binary.to_bytes_exn protocol_data_encoding o.protocol_data + in + Operation.hash {shell = o.shell; proto} type ('a, 'b) eq = Eq : ('a, 'a) eq -let equal_manager_operation_kind - : type a b. a manager_operation -> b manager_operation -> (a, b) eq option - = fun op1 op2 -> - match op1, op2 with - | Reveal _, Reveal _ -> Some Eq - | Reveal _, _ -> None - | Transaction _, Transaction _ -> Some Eq - | Transaction _, _ -> None - | Origination _, Origination _ -> Some Eq - | Origination _, _ -> None - | Delegation _, Delegation _ -> Some Eq - | Delegation _, _ -> None - -let equal_contents_kind - : type a b. a contents -> b contents -> (a, b) eq option - = fun op1 op2 -> - match op1, op2 with - | Endorsement _, Endorsement _ -> Some Eq - | Endorsement _, _ -> None - | Seed_nonce_revelation _, Seed_nonce_revelation _ -> Some Eq - | Seed_nonce_revelation _, _ -> None - | Double_endorsement_evidence _, Double_endorsement_evidence _ -> Some Eq - | Double_endorsement_evidence _, _ -> None - | Double_baking_evidence _, Double_baking_evidence _ -> Some Eq - | Double_baking_evidence _, _ -> None - | Activate_account _, Activate_account _ -> Some Eq - | Activate_account _, _ -> None - | Proposals _, Proposals _ -> Some Eq - | Proposals _, _ -> None - | Ballot _, Ballot _ -> Some Eq - | Ballot _, _ -> None - | Manager_operation op1, Manager_operation op2 -> begin - match equal_manager_operation_kind op1.operation op2.operation with - | None -> None - | Some Eq -> Some Eq - end - | Manager_operation _, _ -> None - -let rec equal_contents_kind_list - : type a b. a contents_list -> b contents_list -> (a, b) eq option - = fun op1 op2 -> - match op1, op2 with - | Single op1, Single op2 -> - equal_contents_kind op1 op2 - | Single _, Cons _ -> None - | Cons _, Single _ -> None - | Cons (op1, ops1), Cons (op2, ops2) -> begin - match equal_contents_kind op1 op2 with - | None -> None - | Some Eq -> - match equal_contents_kind_list ops1 ops2 with - | None -> None - | Some Eq -> Some Eq - end - -let equal - : type a b. a operation -> b operation -> (a, b) eq option - = fun op1 op2 -> - if not (Operation_hash.equal (hash op1) (hash op2)) then +let equal_manager_operation_kind : + type a b. a manager_operation -> b manager_operation -> (a, b) eq option = + fun op1 op2 -> + match (op1, op2) with + | (Reveal _, Reveal _) -> + Some Eq + | (Reveal _, _) -> None - else - equal_contents_kind_list - op1.protocol_data.contents op2.protocol_data.contents + | (Transaction _, Transaction _) -> + Some Eq + | (Transaction _, _) -> + None + | (Origination _, Origination _) -> + Some Eq + | (Origination _, _) -> + None + | (Delegation _, Delegation _) -> + Some Eq + | (Delegation _, _) -> + None + +let equal_contents_kind : + type a b. a contents -> b contents -> (a, b) eq option = + fun op1 op2 -> + match (op1, op2) with + | (Endorsement _, Endorsement _) -> + Some Eq + | (Endorsement _, _) -> + None + | (Seed_nonce_revelation _, Seed_nonce_revelation _) -> + Some Eq + | (Seed_nonce_revelation _, _) -> + None + | (Double_endorsement_evidence _, Double_endorsement_evidence _) -> + Some Eq + | (Double_endorsement_evidence _, _) -> + None + | (Double_baking_evidence _, Double_baking_evidence _) -> + Some Eq + | (Double_baking_evidence _, _) -> + None + | (Activate_account _, Activate_account _) -> + Some Eq + | (Activate_account _, _) -> + None + | (Proposals _, Proposals _) -> + Some Eq + | (Proposals _, _) -> + None + | (Ballot _, Ballot _) -> + Some Eq + | (Ballot _, _) -> + None + | (Manager_operation op1, Manager_operation op2) -> ( + match equal_manager_operation_kind op1.operation op2.operation with + | None -> + None + | Some Eq -> + Some Eq ) + | (Manager_operation _, _) -> + None + +let rec equal_contents_kind_list : + type a b. a contents_list -> b contents_list -> (a, b) eq option = + fun op1 op2 -> + match (op1, op2) with + | (Single op1, Single op2) -> + equal_contents_kind op1 op2 + | (Single _, Cons _) -> + None + | (Cons _, Single _) -> + None + | (Cons (op1, ops1), Cons (op2, ops2)) -> ( + match equal_contents_kind op1 op2 with + | None -> + None + | Some Eq -> ( + match equal_contents_kind_list ops1 ops2 with + | None -> + None + | Some Eq -> + Some Eq ) ) + +let equal : type a b. a operation -> b operation -> (a, b) eq option = + fun op1 op2 -> + if not (Operation_hash.equal (hash op1) (hash op2)) then None + else + equal_contents_kind_list + op1.protocol_data.contents + op2.protocol_data.contents diff --git a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli index dd46b15c9..03509fa2d 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/operation_repr.mli @@ -27,204 +27,243 @@ module Kind : sig type seed_nonce_revelation = Seed_nonce_revelation_kind + type double_endorsement_evidence = Double_endorsement_evidence_kind + type double_baking_evidence = Double_baking_evidence_kind + type activate_account = Activate_account_kind + type endorsement = Endorsement_kind + type proposals = Proposals_kind + type ballot = Ballot_kind + type reveal = Reveal_kind + type transaction = Transaction_kind + type origination = Origination_kind + type delegation = Delegation_kind + type 'a manager = | Reveal_manager_kind : reveal manager | Transaction_manager_kind : transaction manager | Origination_manager_kind : origination manager | Delegation_manager_kind : delegation manager - end -type raw = Operation.t = { - shell: Operation.shell_header ; - proto: MBytes.t ; -} +type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t} -val raw_encoding: raw Data_encoding.t +val raw_encoding : raw Data_encoding.t type 'kind operation = { - shell: Operation.shell_header ; - protocol_data: 'kind protocol_data ; + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; } and 'kind protocol_data = { - contents: 'kind contents_list ; - signature: Signature.t option ; + contents : 'kind contents_list; + signature : Signature.t option; } 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 + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list and _ contents = - | Endorsement : { - level: Raw_level_repr.t ; - } -> Kind.endorsement contents + | Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents | Seed_nonce_revelation : { - level: Raw_level_repr.t ; - nonce: Seed_repr.nonce ; - } -> Kind.seed_nonce_revelation contents + level : Raw_level_repr.t; + nonce : Seed_repr.nonce; + } + -> Kind.seed_nonce_revelation contents | Double_endorsement_evidence : { - op1: Kind.endorsement operation ; - op2: Kind.endorsement operation ; - } -> Kind.double_endorsement_evidence contents + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents | Double_baking_evidence : { - bh1: Block_header_repr.t ; - bh2: Block_header_repr.t ; - } -> Kind.double_baking_evidence contents + bh1 : Block_header_repr.t; + bh2 : Block_header_repr.t; + } + -> Kind.double_baking_evidence contents | Activate_account : { - id: Ed25519.Public_key_hash.t ; - activation_code: Blinded_public_key_hash.activation_code ; - } -> Kind.activate_account contents + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents | Proposals : { - source: Signature.Public_key_hash.t ; - period: Voting_period_repr.t ; - proposals: Protocol_hash.t list ; - } -> Kind.proposals contents + source : Signature.Public_key_hash.t; + period : Voting_period_repr.t; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents | Ballot : { - source: Signature.Public_key_hash.t ; - period: Voting_period_repr.t ; - proposal: Protocol_hash.t ; - ballot: Vote_repr.ballot ; - } -> Kind.ballot contents + source : Signature.Public_key_hash.t; + period : Voting_period_repr.t; + proposal : Protocol_hash.t; + ballot : Vote_repr.ballot; + } + -> Kind.ballot contents | Manager_operation : { - source: Signature.Public_key_hash.t ; - fee: Tez_repr.tez ; - counter: counter ; - operation: 'kind manager_operation ; - gas_limit: Z.t; - storage_limit: Z.t; - } -> 'kind Kind.manager contents + source : Signature.Public_key_hash.t; + fee : Tez_repr.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Z.t; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : { - amount: Tez_repr.tez ; - parameters: Script_repr.lazy_expr ; - entrypoint: string ; - destination: Contract_repr.contract ; - } -> Kind.transaction manager_operation + amount : Tez_repr.tez; + parameters : Script_repr.lazy_expr; + entrypoint : string; + destination : Contract_repr.contract; + } + -> Kind.transaction manager_operation | Origination : { - delegate: Signature.Public_key_hash.t option ; - script: Script_repr.t ; - credit: Tez_repr.tez ; - preorigination: Contract_repr.t option ; - } -> Kind.origination manager_operation + delegate : Signature.Public_key_hash.t option; + script : Script_repr.t; + credit : Tez_repr.tez; + preorigination : Contract_repr.t option; + } + -> Kind.origination manager_operation | Delegation : - Signature.Public_key_hash.t option -> Kind.delegation manager_operation + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation and counter = Z.t type 'kind internal_operation = { - source: Contract_repr.contract ; - operation: 'kind manager_operation ; - nonce: int ; + source : Contract_repr.contract; + operation : 'kind manager_operation; + nonce : int; } type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation -type packed_contents = - | Contents : 'kind contents -> packed_contents +type packed_contents = Contents : 'kind contents -> packed_contents type packed_contents_list = | Contents_list : 'kind contents_list -> packed_contents_list -val of_list: packed_contents list -> packed_contents_list -val to_list: packed_contents_list -> packed_contents list +val of_list : packed_contents list -> packed_contents_list + +val to_list : packed_contents_list -> packed_contents list type packed_protocol_data = | Operation_data : 'kind protocol_data -> packed_protocol_data type packed_operation = { - shell: Operation.shell_header ; - protocol_data: packed_protocol_data ; + shell : Operation.shell_header; + protocol_data : packed_protocol_data; } -val pack: 'kind operation -> packed_operation +val pack : 'kind operation -> packed_operation type packed_internal_operation = | Internal_operation : 'kind internal_operation -> packed_internal_operation -val manager_kind: 'kind manager_operation -> 'kind Kind.manager +val manager_kind : 'kind manager_operation -> 'kind Kind.manager -val encoding: packed_operation Data_encoding.t -val contents_encoding: packed_contents Data_encoding.t -val contents_list_encoding: packed_contents_list Data_encoding.t -val protocol_data_encoding: packed_protocol_data Data_encoding.t -val unsigned_operation_encoding: (Operation.shell_header * packed_contents_list) Data_encoding.t +val encoding : packed_operation Data_encoding.t -val raw: _ operation -> raw +val contents_encoding : packed_contents Data_encoding.t -val hash_raw: raw -> Operation_hash.t -val hash: _ operation -> Operation_hash.t -val hash_packed: packed_operation -> Operation_hash.t +val contents_list_encoding : packed_contents_list Data_encoding.t -val acceptable_passes: packed_operation -> int list +val protocol_data_encoding : packed_protocol_data Data_encoding.t + +val unsigned_operation_encoding : + (Operation.shell_header * packed_contents_list) Data_encoding.t + +val raw : _ operation -> raw + +val hash_raw : raw -> Operation_hash.t + +val hash : _ operation -> Operation_hash.t + +val hash_packed : packed_operation -> Operation_hash.t + +val acceptable_passes : packed_operation -> int list type error += Missing_signature (* `Permanent *) + type error += Invalid_signature (* `Permanent *) -val check_signature: +val check_signature : Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult Lwt.t -val check_signature_sync: + +val check_signature_sync : Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult - -val internal_operation_encoding: - packed_internal_operation Data_encoding.t +val internal_operation_encoding : packed_internal_operation Data_encoding.t type ('a, 'b) eq = Eq : ('a, 'a) eq -val equal: 'a operation -> 'b operation -> ('a, 'b) eq option + +val equal : 'a operation -> 'b operation -> ('a, 'b) eq option module Encoding : sig - type 'b case = - Case : { tag: int ; - name: string ; - encoding: 'a Data_encoding.t ; - select: packed_contents -> 'b contents option ; - proj: 'b contents -> 'a ; - inj: 'a -> 'b contents } -> 'b case + | Case : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_contents -> 'b contents option; + proj : 'b contents -> 'a; + inj : 'a -> 'b contents; + } + -> 'b case - val endorsement_case: Kind.endorsement case - val seed_nonce_revelation_case: Kind.seed_nonce_revelation case - val double_endorsement_evidence_case: Kind.double_endorsement_evidence case - val double_baking_evidence_case: Kind.double_baking_evidence case - val activate_account_case: Kind.activate_account case - val proposals_case: Kind.proposals case - val ballot_case: Kind.ballot case - val reveal_case: Kind.reveal Kind.manager case - val transaction_case: Kind.transaction Kind.manager case - val origination_case: Kind.origination Kind.manager case - val delegation_case: Kind.delegation Kind.manager case + val endorsement_case : Kind.endorsement case + + val seed_nonce_revelation_case : Kind.seed_nonce_revelation case + + val double_endorsement_evidence_case : Kind.double_endorsement_evidence case + + val double_baking_evidence_case : Kind.double_baking_evidence case + + val activate_account_case : Kind.activate_account case + + val proposals_case : Kind.proposals case + + val ballot_case : Kind.ballot case + + val reveal_case : Kind.reveal Kind.manager case + + val transaction_case : Kind.transaction Kind.manager case + + val origination_case : Kind.origination Kind.manager case + + val delegation_case : Kind.delegation Kind.manager case module Manager_operations : sig - type 'b case = - MCase : { tag: int ; - name: string ; - encoding: 'a Data_encoding.t ; - select: packed_manager_operation -> 'kind manager_operation option ; - proj: 'kind manager_operation -> 'a ; - inj: 'a -> 'kind manager_operation } -> 'kind case + | MCase : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_manager_operation -> 'kind manager_operation option; + proj : 'kind manager_operation -> 'a; + inj : 'a -> 'kind manager_operation; + } + -> 'kind case - val reveal_case: Kind.reveal case - val transaction_case: Kind.transaction case - val origination_case: Kind.origination case - val delegation_case: Kind.delegation case + val reveal_case : Kind.reveal case + val transaction_case : Kind.transaction case + + val origination_case : Kind.origination case + + val delegation_case : Kind.delegation case end - end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml index bbf9c18fb..d5869c641 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.ml @@ -24,62 +24,65 @@ (*****************************************************************************) type bootstrap_account = { - public_key_hash : Signature.Public_key_hash.t ; - public_key : Signature.Public_key.t option ; - amount : Tez_repr.t ; + public_key_hash : Signature.Public_key_hash.t; + public_key : Signature.Public_key.t option; + amount : Tez_repr.t; } type bootstrap_contract = { - delegate : Signature.Public_key_hash.t ; - amount : Tez_repr.t ; - script : Script_repr.t ; + delegate : Signature.Public_key_hash.t; + amount : Tez_repr.t; + script : Script_repr.t; } type t = { - bootstrap_accounts : bootstrap_account list ; - bootstrap_contracts : bootstrap_contract list ; - commitments : Commitment_repr.t list ; - constants : Constants_repr.parametric ; - security_deposit_ramp_up_cycles : int option ; - no_reward_cycles : int option ; + bootstrap_accounts : bootstrap_account list; + bootstrap_contracts : bootstrap_contract list; + commitments : Commitment_repr.t list; + constants : Constants_repr.parametric; + security_deposit_ramp_up_cycles : int option; + no_reward_cycles : int option; } let bootstrap_account_encoding = let open Data_encoding in union - [ case (Tag 0) ~title:"Public_key_known" - (tup2 - Signature.Public_key.encoding - Tez_repr.encoding) + [ case + (Tag 0) + ~title:"Public_key_known" + (tup2 Signature.Public_key.encoding Tez_repr.encoding) (function - | { public_key_hash ; public_key = Some public_key ; amount } -> - assert (Signature.Public_key_hash.equal - (Signature.Public_key.hash public_key) - public_key_hash) ; + | {public_key_hash; public_key = Some public_key; amount} -> + assert ( + Signature.Public_key_hash.equal + (Signature.Public_key.hash public_key) + public_key_hash ) ; Some (public_key, amount) - | { public_key = None } -> None) + | {public_key = None} -> + None) (fun (public_key, amount) -> - { public_key = Some public_key ; - public_key_hash = Signature.Public_key.hash public_key ; - amount }) ; - case (Tag 1) ~title:"Public_key_unknown" - (tup2 - Signature.Public_key_hash.encoding - Tez_repr.encoding) + { + public_key = Some public_key; + public_key_hash = Signature.Public_key.hash public_key; + amount; + }); + case + (Tag 1) + ~title:"Public_key_unknown" + (tup2 Signature.Public_key_hash.encoding Tez_repr.encoding) (function - | { public_key_hash ; public_key = None ; amount } -> + | {public_key_hash; public_key = None; amount} -> Some (public_key_hash, amount) - | { public_key = Some _ } -> None) + | {public_key = Some _} -> + None) (fun (public_key_hash, amount) -> - { public_key = None ; - public_key_hash ; - amount }) ] + {public_key = None; public_key_hash; amount}) ] let bootstrap_contract_encoding = let open Data_encoding in conv - (fun { delegate ; amount ; script } -> (delegate, amount, script)) - (fun (delegate, amount, script) -> { delegate ; amount ; script }) + (fun {delegate; amount; script} -> (delegate, amount, script)) + (fun (delegate, amount, script) -> {delegate; amount; script}) (obj3 (req "delegate" Signature.Public_key_hash.encoding) (req "amount" Tez_repr.encoding) @@ -88,16 +91,32 @@ let bootstrap_contract_encoding = let encoding = let open Data_encoding in conv - (fun { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ; - security_deposit_ramp_up_cycles ; no_reward_cycles } -> - ((bootstrap_accounts, bootstrap_contracts, commitments, - security_deposit_ramp_up_cycles, no_reward_cycles), - constants)) - (fun ( (bootstrap_accounts, bootstrap_contracts, commitments, - security_deposit_ramp_up_cycles, no_reward_cycles), - constants) -> - { bootstrap_accounts ; bootstrap_contracts ; commitments ; constants ; - security_deposit_ramp_up_cycles ; no_reward_cycles }) + (fun { bootstrap_accounts; + bootstrap_contracts; + commitments; + constants; + security_deposit_ramp_up_cycles; + no_reward_cycles } -> + ( ( bootstrap_accounts, + bootstrap_contracts, + commitments, + security_deposit_ramp_up_cycles, + no_reward_cycles ), + constants )) + (fun ( ( bootstrap_accounts, + bootstrap_contracts, + commitments, + security_deposit_ramp_up_cycles, + no_reward_cycles ), + constants ) -> + { + bootstrap_accounts; + bootstrap_contracts; + commitments; + constants; + security_deposit_ramp_up_cycles; + no_reward_cycles; + }) (merge_objs (obj5 (req "bootstrap_accounts" (list bootstrap_account_encoding)) @@ -106,253 +125,3 @@ let encoding = (opt "security_deposit_ramp_up_cycles" int31) (opt "no_reward_cycles" int31)) Constants_repr.parametric_encoding) - - -(* Only for migration from 004 to 005 *) - -module Proto_004 = struct - - type parametric = { - preserved_cycles: int ; - blocks_per_cycle: int32 ; - blocks_per_commitment: int32 ; - blocks_per_roll_snapshot: int32 ; - blocks_per_voting_period: int32 ; - time_between_blocks: Period_repr.t list ; - endorsers_per_block: int ; - hard_gas_limit_per_operation: Z.t ; - hard_gas_limit_per_block: Z.t ; - proof_of_work_threshold: int64 ; - tokens_per_roll: Tez_repr.t ; - michelson_maximum_type_size: int; - seed_nonce_revelation_tip: Tez_repr.t ; - origination_size: int ; - block_security_deposit: Tez_repr.t ; - endorsement_security_deposit: Tez_repr.t ; - block_reward: Tez_repr.t ; - endorsement_reward: Tez_repr.t ; - cost_per_byte: Tez_repr.t ; - hard_storage_limit_per_operation: Z.t ; - test_chain_duration: int64 ; (* in seconds *) - } - - let default = { - preserved_cycles = 5 ; - blocks_per_cycle = 4096l ; - blocks_per_commitment = 32l ; - blocks_per_roll_snapshot = 256l ; - blocks_per_voting_period = 32768l ; - time_between_blocks = - List.map Period_repr.of_seconds_exn [ 60L ; 75L ] ; - endorsers_per_block = 32 ; - hard_gas_limit_per_operation = Z.of_int 800_000 ; - hard_gas_limit_per_block = Z.of_int 8_000_000 ; - proof_of_work_threshold = - Int64.(sub (shift_left 1L 46) 1L) ; - tokens_per_roll = - Tez_repr.(mul_exn one 8_000) ; - michelson_maximum_type_size = 1000 ; - seed_nonce_revelation_tip = begin - match Tez_repr.(one /? 8L) with - | Ok c -> c - | Error _ -> assert false - end ; - origination_size = 257 ; - block_security_deposit = Tez_repr.(mul_exn one 512) ; - endorsement_security_deposit = Tez_repr.(mul_exn one 64) ; - block_reward = Tez_repr.(mul_exn one 16) ; - endorsement_reward = Tez_repr.(mul_exn one 2) ; - hard_storage_limit_per_operation = Z.of_int 60_000 ; - cost_per_byte = Tez_repr.of_mutez_exn 1_000L ; - test_chain_duration = Int64.mul 32768L 60L; - } - - (* This encoding is used to read configuration files (e.g. sandbox.json) - where some fields can be missing, in that case they are replaced by - the default. *) - let constants_encoding = - let open Data_encoding in - conv - (fun (c : parametric) -> - let module Compare_time_between_blocks = Compare.List (Period_repr) in - let module Compare_keys = Compare.List (Ed25519.Public_key) in - let opt (=) def v = if def = v then None else Some v in - let preserved_cycles = - opt Compare.Int.(=) - default.preserved_cycles c.preserved_cycles - and blocks_per_cycle = - opt Compare.Int32.(=) - default.blocks_per_cycle c.blocks_per_cycle - and blocks_per_commitment = - opt Compare.Int32.(=) - default.blocks_per_commitment c.blocks_per_commitment - and blocks_per_roll_snapshot = - opt Compare.Int32.(=) - default.blocks_per_roll_snapshot c.blocks_per_roll_snapshot - and blocks_per_voting_period = - opt Compare.Int32.(=) - default.blocks_per_voting_period c.blocks_per_voting_period - and time_between_blocks = - opt Compare_time_between_blocks.(=) - default.time_between_blocks c.time_between_blocks - and endorsers_per_block = - opt Compare.Int.(=) - default.endorsers_per_block c.endorsers_per_block - and hard_gas_limit_per_operation = - opt Compare.Z.(=) - default.hard_gas_limit_per_operation c.hard_gas_limit_per_operation - and hard_gas_limit_per_block = - opt Compare.Z.(=) - default.hard_gas_limit_per_block c.hard_gas_limit_per_block - and proof_of_work_threshold = - opt Compare.Int64.(=) - default.proof_of_work_threshold c.proof_of_work_threshold - and tokens_per_roll = - opt Tez_repr.(=) - default.tokens_per_roll c.tokens_per_roll - and michelson_maximum_type_size = - opt Compare.Int.(=) - default.michelson_maximum_type_size c.michelson_maximum_type_size - and seed_nonce_revelation_tip = - opt Tez_repr.(=) - default.seed_nonce_revelation_tip c.seed_nonce_revelation_tip - and origination_size = - opt Compare.Int.(=) - default.origination_size c.origination_size - and block_security_deposit = - opt Tez_repr.(=) - default.block_security_deposit c.block_security_deposit - and endorsement_security_deposit = - opt Tez_repr.(=) - default.endorsement_security_deposit c.endorsement_security_deposit - and block_reward = - opt Tez_repr.(=) - default.block_reward c.block_reward - and endorsement_reward = - opt Tez_repr.(=) - default.endorsement_reward c.endorsement_reward - and cost_per_byte = - opt Tez_repr.(=) - default.cost_per_byte c.cost_per_byte - and hard_storage_limit_per_operation = - opt Compare.Z.(=) - default.hard_storage_limit_per_operation c.hard_storage_limit_per_operation - and test_chain_duration = - opt Compare.Int64.(=) - default.test_chain_duration c.test_chain_duration - in - (( preserved_cycles, - blocks_per_cycle, - blocks_per_commitment, - blocks_per_roll_snapshot, - blocks_per_voting_period, - time_between_blocks, - endorsers_per_block, - hard_gas_limit_per_operation, - hard_gas_limit_per_block), - ((proof_of_work_threshold, - tokens_per_roll, - michelson_maximum_type_size, - seed_nonce_revelation_tip, - origination_size, - block_security_deposit, - endorsement_security_deposit, - block_reward), - (endorsement_reward, - cost_per_byte, - hard_storage_limit_per_operation, - test_chain_duration)))) - (fun (( preserved_cycles, - blocks_per_cycle, - blocks_per_commitment, - blocks_per_roll_snapshot, - blocks_per_voting_period, - time_between_blocks, - endorsers_per_block, - hard_gas_limit_per_operation, - hard_gas_limit_per_block), - ((proof_of_work_threshold, - tokens_per_roll, - michelson_maximum_type_size, - seed_nonce_revelation_tip, - origination_size, - block_security_deposit, - endorsement_security_deposit, - block_reward), - (endorsement_reward, - cost_per_byte, - hard_storage_limit_per_operation, - test_chain_duration))) -> - let unopt def = function None -> def | Some v -> v in - { preserved_cycles = - unopt default.preserved_cycles preserved_cycles ; - blocks_per_cycle = - unopt default.blocks_per_cycle blocks_per_cycle ; - blocks_per_commitment = - unopt default.blocks_per_commitment blocks_per_commitment ; - blocks_per_roll_snapshot = - unopt default.blocks_per_roll_snapshot blocks_per_roll_snapshot ; - blocks_per_voting_period = - unopt default.blocks_per_voting_period blocks_per_voting_period ; - time_between_blocks = - unopt default.time_between_blocks @@ - time_between_blocks ; - endorsers_per_block = - unopt default.endorsers_per_block endorsers_per_block ; - hard_gas_limit_per_operation = - unopt default.hard_gas_limit_per_operation hard_gas_limit_per_operation ; - hard_gas_limit_per_block = - unopt default.hard_gas_limit_per_block hard_gas_limit_per_block ; - proof_of_work_threshold = - unopt default.proof_of_work_threshold proof_of_work_threshold ; - tokens_per_roll = - unopt default.tokens_per_roll tokens_per_roll ; - michelson_maximum_type_size = - unopt default.michelson_maximum_type_size michelson_maximum_type_size ; - seed_nonce_revelation_tip = - unopt default.seed_nonce_revelation_tip seed_nonce_revelation_tip ; - origination_size = - unopt default.origination_size origination_size ; - block_security_deposit = - unopt default.block_security_deposit block_security_deposit ; - endorsement_security_deposit = - unopt default.endorsement_security_deposit endorsement_security_deposit ; - block_reward = - unopt default.block_reward block_reward ; - endorsement_reward = - unopt default.endorsement_reward endorsement_reward ; - cost_per_byte = - unopt default.cost_per_byte cost_per_byte ; - hard_storage_limit_per_operation = - unopt default.hard_storage_limit_per_operation hard_storage_limit_per_operation ; - test_chain_duration = - unopt default.test_chain_duration test_chain_duration ; - } ) - (merge_objs - (obj9 - (opt "preserved_cycles" uint8) - (opt "blocks_per_cycle" int32) - (opt "blocks_per_commitment" int32) - (opt "blocks_per_roll_snapshot" int32) - (opt "blocks_per_voting_period" int32) - (opt "time_between_blocks" (list Period_repr.encoding)) - (opt "endorsers_per_block" uint16) - (opt "hard_gas_limit_per_operation" z) - (opt "hard_gas_limit_per_block" z)) - (merge_objs - (obj8 - (opt "proof_of_work_threshold" int64) - (opt "tokens_per_roll" Tez_repr.encoding) - (opt "michelson_maximum_type_size" uint16) - (opt "seed_nonce_revelation_tip" Tez_repr.encoding) - (opt "origination_size" int31) - (opt "block_security_deposit" Tez_repr.encoding) - (opt "endorsement_security_deposit" Tez_repr.encoding) - (opt "block_reward" Tez_repr.encoding)) - (obj4 - (opt "endorsement_reward" Tez_repr.encoding) - (opt "cost_per_byte" Tez_repr.encoding) - (opt "hard_storage_limit_per_operation" z) - (opt "test_chain_duration" int64)))) - -end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli index c679c58f1..6f8436e71 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/parameters_repr.mli @@ -24,55 +24,24 @@ (*****************************************************************************) type bootstrap_account = { - public_key_hash : Signature.Public_key_hash.t ; - public_key : Signature.Public_key.t option ; - amount : Tez_repr.t ; + public_key_hash : Signature.Public_key_hash.t; + public_key : Signature.Public_key.t option; + amount : Tez_repr.t; } type bootstrap_contract = { - delegate : Signature.Public_key_hash.t ; - amount : Tez_repr.t ; - script : Script_repr.t ; + delegate : Signature.Public_key_hash.t; + amount : Tez_repr.t; + script : Script_repr.t; } type t = { - bootstrap_accounts : bootstrap_account list ; - bootstrap_contracts : bootstrap_contract list ; - commitments : Commitment_repr.t list ; - constants : Constants_repr.parametric ; - security_deposit_ramp_up_cycles : int option ; - no_reward_cycles : int option ; + bootstrap_accounts : bootstrap_account list; + bootstrap_contracts : bootstrap_contract list; + commitments : Commitment_repr.t list; + constants : Constants_repr.parametric; + security_deposit_ramp_up_cycles : int option; + no_reward_cycles : int option; } -val encoding: t Data_encoding.t - - -(* Only for migration from 004 to 005 *) - -module Proto_004 : sig - type parametric = { - preserved_cycles: int ; - blocks_per_cycle: int32 ; - blocks_per_commitment: int32 ; - blocks_per_roll_snapshot: int32 ; - blocks_per_voting_period: int32 ; - time_between_blocks: Period_repr.t list ; - endorsers_per_block: int ; - hard_gas_limit_per_operation: Z.t ; - hard_gas_limit_per_block: Z.t ; - proof_of_work_threshold: int64 ; - tokens_per_roll: Tez_repr.t ; - michelson_maximum_type_size: int; - seed_nonce_revelation_tip: Tez_repr.t ; - origination_size: int ; - block_security_deposit: Tez_repr.t ; - endorsement_security_deposit: Tez_repr.t ; - block_reward: Tez_repr.t ; - endorsement_reward: Tez_repr.t ; - cost_per_byte: Tez_repr.t ; - hard_storage_limit_per_operation: Z.t ; - test_chain_duration: int64 ; - } - - val constants_encoding: parametric Data_encoding.t -end +val encoding : t Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml index 3719221f4..2bd3e643b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.ml @@ -24,8 +24,11 @@ (*****************************************************************************) type t = Int64.t + type period = t + include (Compare.Int64 : Compare.S with type t := t) + let encoding = Data_encoding.int64 let rpc_arg = RPC_arg.int64 @@ -33,8 +36,7 @@ let rpc_arg = RPC_arg.int64 let pp ppf v = Format.fprintf ppf "%Ld" v type error += (* `Permanent *) - | Malformed_period - | Invalid_arg + Malformed_period | Invalid_arg let () = let open Data_encoding in @@ -60,22 +62,26 @@ let () = (fun () -> Invalid_arg) let of_seconds t = - if Compare.Int64.(t >= 0L) - then ok t - else error Malformed_period + if Compare.Int64.(t >= 0L) then ok t else error Malformed_period + let to_seconds t = t + let of_seconds_exn t = match of_seconds t with - | Ok t -> t - | _ -> invalid_arg "Period.of_seconds_exn" + | Ok t -> + t + | _ -> + invalid_arg "Period.of_seconds_exn" let mult i p = (* TODO check overflow *) - if Compare.Int32.(i < 0l) - then error Invalid_arg + if Compare.Int32.(i < 0l) then error Invalid_arg else ok (Int64.mul (Int64.of_int32 i) p) let zero = of_seconds_exn 0L + let one_second = of_seconds_exn 1L + let one_minute = of_seconds_exn 60L + let one_hour = of_seconds_exn 3600L diff --git a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli index a84fba7d2..4fbd52db4 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/period_repr.mli @@ -24,12 +24,16 @@ (*****************************************************************************) type t -type period = t -include Compare.S with type t := t -val encoding : period Data_encoding.t -val rpc_arg : period RPC_arg.t -val pp: Format.formatter -> period -> unit +type period = t + +include Compare.S with type t := t + +val encoding : period Data_encoding.t + +val rpc_arg : period RPC_arg.t + +val pp : Format.formatter -> period -> unit val to_seconds : period -> int64 @@ -43,6 +47,9 @@ val of_seconds_exn : int64 -> period val mult : int32 -> period -> period tzresult val zero : period + val one_second : period + val one_minute : period + val one_hour : period diff --git a/vendors/ligo-utils/tezos-protocol-alpha/qty_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/qty_repr.ml index 02fc79723..a397a8f74 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/qty_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/qty_repr.ml @@ -35,18 +35,28 @@ module type S = sig | Subtraction_underflow of qty * qty (* `Temporary *) | Multiplication_overflow of qty * int64 (* `Temporary *) | Negative_multiplicator of qty * int64 (* `Temporary *) - | Invalid_divisor of qty * int64 (* `Temporary *) + | Invalid_divisor of qty * int64 + + (* `Temporary *) val id : string + val zero : qty + val one_mutez : qty + val one_cent : qty + val fifty_cents : qty + val one : qty val ( -? ) : qty -> qty -> qty tzresult + val ( +? ) : qty -> qty -> qty tzresult + val ( *? ) : qty -> int64 -> qty tzresult + val ( /? ) : qty -> int64 -> qty tzresult val to_mutez : qty -> int64 @@ -70,15 +80,14 @@ module type S = sig include Compare.S with type t := qty - val pp: Format.formatter -> qty -> unit + val pp : Format.formatter -> qty -> unit - val of_string: string -> qty option - val to_string: qty -> string + val of_string : string -> qty option + val to_string : qty -> string end -module Make (T: QTY) : S = struct - +module Make (T : QTY) : S = struct type qty = int64 (* invariant: positive *) type error += @@ -86,16 +95,24 @@ module Make (T: QTY) : S = struct | Subtraction_underflow of qty * qty (* `Temporary *) | Multiplication_overflow of qty * int64 (* `Temporary *) | Negative_multiplicator of qty * int64 (* `Temporary *) - | Invalid_divisor of qty * int64 (* `Temporary *) + | Invalid_divisor of qty * int64 + + (* `Temporary *) include Compare.Int64 + let zero = 0L + (* all other constant are defined from the value of one micro tez *) let one_mutez = 1L + let one_cent = Int64.mul one_mutez 10_000L + let fifty_cents = Int64.mul one_cent 50L + (* 1 tez = 100 cents = 1_000_000 mutez *) let one = Int64.mul one_cent 100L + let id = T.id let of_string s = @@ -103,143 +120,130 @@ module Make (T: QTY) : S = struct | hd :: tl -> let len = String.length hd in Compare.Int.( - len <= 3 && len > 0 && - List.for_all (fun s -> String.length s = 3) tl - ) - | [] -> false in + len <= 3 && len > 0 + && List.for_all (fun s -> String.length s = 3) tl) + | [] -> + false + in let integers s = triplets (String.split_on_char ',' s) in let decimals s = let l = String.split_on_char ',' s in - if Compare.Int.(List.length l > 2) then - false - else - triplets (List.rev l) in + if Compare.Int.(List.length l > 2) then false else triplets (List.rev l) + in let parse left right = let remove_commas s = String.concat "" (String.split_on_char ',' s) in let pad_to_six s = let len = String.length s in - String.init 6 (fun i -> if Compare.Int.(i < len) then String.get s i else '0') in + String.init 6 (fun i -> if Compare.Int.(i < len) then s.[i] else '0') + in try - Some (Int64.of_string (remove_commas left ^ pad_to_six (remove_commas right))) - with _ -> None in + Some + (Int64.of_string + (remove_commas left ^ pad_to_six (remove_commas right))) + with _ -> None + in match String.split_on_char '.' s with - | [ left ; right ] -> + | [left; right] -> if String.contains s ',' then - if integers left && decimals right then - parse left right - else - None - else if Compare.Int.(String.length right > 0) - && Compare.Int.(String.length right <= 6) then - parse left right + if integers left && decimals right then parse left right else None + else if + Compare.Int.(String.length right > 0) + && Compare.Int.(String.length right <= 6) + then parse left right else None - | [ left ] -> - if not (String.contains s ',') || integers left then - parse left "" + | [left] -> + if (not (String.contains s ',')) || integers left then parse left "" else None - | _ -> None + | _ -> + None let pp ppf amount = let mult_int = 1_000_000L in let rec left ppf amount = - let d, r = Int64.(div amount 1000L), Int64.(rem amount 1000L) in - if d > 0L then - Format.fprintf ppf "%a%03Ld" left d r - else - Format.fprintf ppf "%Ld" r in + let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in + if d > 0L then Format.fprintf ppf "%a%03Ld" left d r + else Format.fprintf ppf "%Ld" r + in let right ppf amount = let triplet ppf v = - if Compare.Int.(v mod 10 > 0) then - Format.fprintf ppf "%03d" v + if Compare.Int.(v mod 10 > 0) then Format.fprintf ppf "%03d" v else if Compare.Int.(v mod 100 > 0) then Format.fprintf ppf "%02d" (v / 10) - else - Format.fprintf ppf "%d" (v / 100) in - let hi, lo = amount / 1000, amount mod 1000 in - if Compare.Int.(lo = 0) then - Format.fprintf ppf "%a" triplet hi - else - Format.fprintf ppf "%03d%a" hi triplet lo in - let ints, decs = - Int64.(div amount mult_int), - Int64.(to_int (rem amount mult_int)) in + else Format.fprintf ppf "%d" (v / 100) + in + let (hi, lo) = (amount / 1000, amount mod 1000) in + if Compare.Int.(lo = 0) then Format.fprintf ppf "%a" triplet hi + else Format.fprintf ppf "%03d%a" hi triplet lo + in + let (ints, decs) = + (Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int))) + in Format.fprintf ppf "%a" left ints ; - if Compare.Int.(decs > 0) then - Format.fprintf ppf ".%a" right decs + if Compare.Int.(decs > 0) then Format.fprintf ppf ".%a" right decs - let to_string t = - Format.asprintf "%a" pp t + let to_string t = Format.asprintf "%a" pp t - let (-) t1 t2 = - if t2 <= t1 - then Some (Int64.sub t1 t2) - else None + let ( - ) t1 t2 = if t2 <= t1 then Some (Int64.sub t1 t2) else None let ( -? ) t1 t2 = match t1 - t2 with - | None -> error (Subtraction_underflow (t1, t2)) - | Some v -> ok v + | None -> + error (Subtraction_underflow (t1, t2)) + | Some v -> + ok v let ( +? ) t1 t2 = let t = Int64.add t1 t2 in - if t < t1 - then error (Addition_overflow (t1, t2)) - else ok t + if t < t1 then error (Addition_overflow (t1, t2)) else ok t let ( *? ) t m = let open Compare.Int64 in let open Int64 in let rec step cur pow acc = - if cur = 0L then - ok acc + if cur = 0L then ok acc else - pow +? pow >>? fun npow -> + pow +? pow + >>? fun npow -> if logand cur 1L = 1L then - acc +? pow >>? fun nacc -> - step (shift_right_logical cur 1) npow nacc - else - step (shift_right_logical cur 1) npow acc in - if m < 0L then - error (Negative_multiplicator (t, m)) + acc +? pow >>? fun nacc -> step (shift_right_logical cur 1) npow nacc + else step (shift_right_logical cur 1) npow acc + in + if m < 0L then error (Negative_multiplicator (t, m)) else match step m t 0L with - | Ok res -> Ok res - | Error ([ Addition_overflow _ ] as errs) -> + | Ok res -> + Ok res + | Error ([Addition_overflow _] as errs) -> Error (Multiplication_overflow (t, m) :: errs) - | Error errs -> Error errs + | Error errs -> + Error errs let ( /? ) t d = - if d <= 0L then - error (Invalid_divisor (t, d)) - else - ok (Int64.div t d) + if d <= 0L then error (Invalid_divisor (t, d)) else ok (Int64.div t d) let add_exn t1 t2 = let t = Int64.add t1 t2 in - if t <= 0L - then invalid_arg "add_exn" - else t + if t <= 0L then invalid_arg "add_exn" else t let mul_exn t m = match t *? Int64.(of_int m) with - | Ok v -> v - | Error _ -> invalid_arg "mul_exn" + | Ok v -> + v + | Error _ -> + invalid_arg "mul_exn" - let of_mutez t = - if t < 0L then None - else Some t + let of_mutez t = if t < 0L then None else Some t let of_mutez_exn x = - match of_mutez x with - | None -> invalid_arg "Qty.of_mutez" - | Some v -> v + match of_mutez x with None -> invalid_arg "Qty.of_mutez" | Some v -> v let to_int64 t = t + let to_mutez t = t let encoding = let open Data_encoding in - (check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n)) + check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n) let () = let open Data_encoding in @@ -247,11 +251,17 @@ module Make (T: QTY) : S = struct `Temporary ~id:(T.id ^ ".addition_overflow") ~title:("Overflowing " ^ T.id ^ " addition") - ~pp: (fun ppf (opa, opb) -> - Format.fprintf ppf "Overflowing addition of %a %s and %a %s" - pp opa T.id pp opb T.id) - ~description: - ("An addition of two " ^ T.id ^ " amounts overflowed") + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Overflowing addition of %a %s and %a %s" + pp + opa + T.id + pp + opb + T.id) + ~description:("An addition of two " ^ T.id ^ " amounts overflowed") (obj1 (req "amounts" (tup2 encoding encoding))) (function Addition_overflow (a, b) -> Some (a, b) | _ -> None) (fun (a, b) -> Addition_overflow (a, b)) ; @@ -259,11 +269,17 @@ module Make (T: QTY) : S = struct `Temporary ~id:(T.id ^ ".subtraction_underflow") ~title:("Underflowing " ^ T.id ^ " subtraction") - ~pp: (fun ppf (opa, opb) -> - Format.fprintf ppf "Underflowing subtraction of %a %s and %a %s" - pp opa T.id pp opb T.id) - ~description: - ("An subtraction of two " ^ T.id ^ " amounts underflowed") + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Underflowing subtraction of %a %s and %a %s" + pp + opa + T.id + pp + opb + T.id) + ~description:("An subtraction of two " ^ T.id ^ " amounts underflowed") (obj1 (req "amounts" (tup2 encoding encoding))) (function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None) (fun (a, b) -> Subtraction_underflow (a, b)) ; @@ -271,43 +287,51 @@ module Make (T: QTY) : S = struct `Temporary ~id:(T.id ^ ".multiplication_overflow") ~title:("Overflowing " ^ T.id ^ " multiplication") - ~pp: (fun ppf (opa, opb) -> - Format.fprintf ppf "Overflowing multiplication of %a %s and %Ld" - pp opa T.id opb) + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Overflowing multiplication of %a %s and %Ld" + pp + opa + T.id + opb) ~description: ("A multiplication of a " ^ T.id ^ " amount by an integer overflowed") - (obj2 - (req "amount" encoding) - (req "multiplicator" int64)) + (obj2 (req "amount" encoding) (req "multiplicator" int64)) (function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None) (fun (a, b) -> Multiplication_overflow (a, b)) ; register_error_kind `Temporary ~id:(T.id ^ ".negative_multiplicator") ~title:("Negative " ^ T.id ^ " multiplicator") - ~pp: (fun ppf (opa, opb) -> - Format.fprintf ppf "Multiplication of %a %s by negative integer %Ld" - pp opa T.id opb) + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Multiplication of %a %s by negative integer %Ld" + pp + opa + T.id + opb) ~description: ("Multiplication of a " ^ T.id ^ " amount by a negative integer") - (obj2 - (req "amount" encoding) - (req "multiplicator" int64)) + (obj2 (req "amount" encoding) (req "multiplicator" int64)) (function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None) (fun (a, b) -> Negative_multiplicator (a, b)) ; register_error_kind `Temporary ~id:(T.id ^ ".invalid_divisor") ~title:("Invalid " ^ T.id ^ " divisor") - ~pp: (fun ppf (opa, opb) -> - Format.fprintf ppf "Division of %a %s by non positive integer %Ld" - pp opa T.id opb) + ~pp:(fun ppf (opa, opb) -> + Format.fprintf + ppf + "Division of %a %s by non positive integer %Ld" + pp + opa + T.id + opb) ~description: ("Multiplication of a " ^ T.id ^ " amount by a non positive integer") - (obj2 - (req "amount" encoding) - (req "divisor" int64)) + (obj2 (req "amount" encoding) (req "divisor" int64)) (function Invalid_divisor (a, b) -> Some (a, b) | _ -> None) (fun (a, b) -> Invalid_divisor (a, b)) - end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml index 87b3615d0..799f7ca98 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.ml @@ -26,62 +26,75 @@ module Int_set = Set.Make (Compare.Int) type t = { - context: Context.t ; - constants: Constants_repr.parametric ; - first_level: Raw_level_repr.t ; - level: Level_repr.t ; - predecessor_timestamp: Time.t ; - timestamp: Time.t ; - fitness: Int64.t ; - deposits: Tez_repr.t Signature.Public_key_hash.Map.t ; - included_endorsements: int ; - allowed_endorsements: - (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ; - fees: Tez_repr.t ; - rewards: Tez_repr.t ; - block_gas: Z.t ; - operation_gas: Gas_limit_repr.t ; - internal_gas: Gas_limit_repr.internal_gas ; - storage_space_to_pay: Z.t option ; - allocated_contracts: int option ; - origination_nonce: Contract_repr.origination_nonce option ; - temporary_big_map: Z.t ; - internal_nonce: int ; - internal_nonces_used: Int_set.t ; + context : Context.t; + constants : Constants_repr.parametric; + first_level : Raw_level_repr.t; + level : Level_repr.t; + predecessor_timestamp : Time.t; + timestamp : Time.t; + fitness : Int64.t; + deposits : Tez_repr.t Signature.Public_key_hash.Map.t; + included_endorsements : int; + allowed_endorsements : + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t; + fees : Tez_repr.t; + rewards : Tez_repr.t; + block_gas : Z.t; + operation_gas : Gas_limit_repr.t; + internal_gas : Gas_limit_repr.internal_gas; + storage_space_to_pay : Z.t option; + allocated_contracts : int option; + origination_nonce : Contract_repr.origination_nonce option; + temporary_big_map : Z.t; + internal_nonce : int; + internal_nonces_used : Int_set.t; } type context = t + type root_context = t let current_level ctxt = ctxt.level + let predecessor_timestamp ctxt = ctxt.predecessor_timestamp + let current_timestamp ctxt = ctxt.timestamp + let current_fitness ctxt = ctxt.fitness + let first_level ctxt = ctxt.first_level + let constants ctxt = ctxt.constants + let recover ctxt = ctxt.context let record_endorsement ctxt k = match Signature.Public_key_hash.Map.find_opt k ctxt.allowed_endorsements with - | None -> assert false - | Some (_, _, true) -> assert false (* right already used *) + | None -> + assert false + | Some (_, _, true) -> + assert false (* right already used *) | Some (d, s, false) -> - { ctxt with - included_endorsements = ctxt.included_endorsements + (List.length s); + { + ctxt with + included_endorsements = ctxt.included_endorsements + List.length s; allowed_endorsements = - Signature.Public_key_hash.Map.add k (d,s,true) ctxt.allowed_endorsements } + Signature.Public_key_hash.Map.add + k + (d, s, true) + ctxt.allowed_endorsements; + } let init_endorsements ctxt allowed_endorsements = - if Signature.Public_key_hash.Map.is_empty allowed_endorsements - then assert false (* can't initialize to empty *) - else begin - if Signature.Public_key_hash.Map.is_empty ctxt.allowed_endorsements - then { ctxt with allowed_endorsements } - else assert false (* can't initialize twice *) - end + if Signature.Public_key_hash.Map.is_empty allowed_endorsements then + assert false (* can't initialize to empty *) + else if Signature.Public_key_hash.Map.is_empty ctxt.allowed_endorsements then + {ctxt with allowed_endorsements} + else assert false -let allowed_endorsements ctxt = - ctxt.allowed_endorsements +(* can't initialize twice *) + +let allowed_endorsements ctxt = ctxt.allowed_endorsements let included_endorsements ctxt = ctxt.included_endorsements @@ -92,10 +105,9 @@ let () = register_error_kind `Permanent ~id:"too_many_internal_operations" - ~title: "Too many internal operations" + ~title:"Too many internal operations" ~description: - "A transaction exceeded the hard limit \ - of internal operations it can emit" + "A transaction exceeded the hard limit of internal operations it can emit" empty (function Too_many_internal_operations -> Some () | _ -> None) (fun () -> Too_many_internal_operations) @@ -104,36 +116,48 @@ let fresh_internal_nonce ctxt = if Compare.Int.(ctxt.internal_nonce >= 65_535) then error Too_many_internal_operations else - ok ({ ctxt with internal_nonce = ctxt.internal_nonce + 1 }, ctxt.internal_nonce) + ok + ( {ctxt with internal_nonce = ctxt.internal_nonce + 1}, + ctxt.internal_nonce ) + let reset_internal_nonce ctxt = - { ctxt with internal_nonces_used = Int_set.empty ; internal_nonce = 0 } + {ctxt with internal_nonces_used = Int_set.empty; internal_nonce = 0} + let record_internal_nonce ctxt k = - { ctxt with internal_nonces_used = Int_set.add k ctxt.internal_nonces_used } + {ctxt with internal_nonces_used = Int_set.add k ctxt.internal_nonces_used} + let internal_nonce_already_recorded ctxt k = Int_set.mem k ctxt.internal_nonces_used -let set_current_fitness ctxt fitness = { ctxt with fitness } +let set_current_fitness ctxt fitness = {ctxt with fitness} let add_fees ctxt fees = - Lwt.return Tez_repr.(ctxt.fees +? fees) >>=? fun fees -> - return { ctxt with fees} + Lwt.return Tez_repr.(ctxt.fees +? fees) + >>=? fun fees -> return {ctxt with fees} let add_rewards ctxt rewards = - Lwt.return Tez_repr.(ctxt.rewards +? rewards) >>=? fun rewards -> - return { ctxt with rewards} + Lwt.return Tez_repr.(ctxt.rewards +? rewards) + >>=? fun rewards -> return {ctxt with rewards} let add_deposit ctxt delegate deposit = let previous = match Signature.Public_key_hash.Map.find_opt delegate ctxt.deposits with - | Some tz -> tz - | None -> Tez_repr.zero in - Lwt.return Tez_repr.(previous +? deposit) >>=? fun deposit -> + | Some tz -> + tz + | None -> + Tez_repr.zero + in + Lwt.return Tez_repr.(previous +? deposit) + >>=? fun deposit -> let deposits = - Signature.Public_key_hash.Map.add delegate deposit ctxt.deposits in - return { ctxt with deposits } + Signature.Public_key_hash.Map.add delegate deposit ctxt.deposits + in + return {ctxt with deposits} let get_deposits ctxt = ctxt.deposits + let get_rewards ctxt = ctxt.rewards + let get_fees ctxt = ctxt.fees type error += Undefined_operation_nonce (* `Permanent *) @@ -143,7 +167,7 @@ let () = register_error_kind `Permanent ~id:"undefined_operation_nonce" - ~title: "Ill timed access to the origination nonce" + ~title:"Ill timed access to the origination nonce" ~description: "An origination was attemped out of the scope of a manager operation" empty @@ -152,24 +176,28 @@ let () = let init_origination_nonce ctxt operation_hash = let origination_nonce = - Some (Contract_repr.initial_origination_nonce operation_hash) in - { ctxt with origination_nonce } + Some (Contract_repr.initial_origination_nonce operation_hash) + in + {ctxt with origination_nonce} let origination_nonce ctxt = match ctxt.origination_nonce with - | None -> error Undefined_operation_nonce - | Some origination_nonce -> ok origination_nonce + | None -> + error Undefined_operation_nonce + | Some origination_nonce -> + ok origination_nonce let increment_origination_nonce ctxt = match ctxt.origination_nonce with - | None -> error Undefined_operation_nonce + | None -> + error Undefined_operation_nonce | Some cur_origination_nonce -> let origination_nonce = - Some (Contract_repr.incr_origination_nonce cur_origination_nonce) in - ok ({ ctxt with origination_nonce }, cur_origination_nonce) + Some (Contract_repr.incr_origination_nonce cur_origination_nonce) + in + ok ({ctxt with origination_nonce}, cur_origination_nonce) -let unset_origination_nonce ctxt = - { ctxt with origination_nonce = None } +let unset_origination_nonce ctxt = {ctxt with origination_nonce = None} type error += Gas_limit_too_high (* `Permanent *) @@ -178,71 +206,88 @@ let () = register_error_kind `Permanent ~id:"gas_limit_too_high" - ~title: "Gas limit out of protocol hard bounds" - ~description: - "A transaction tried to exceed the hard limit on gas" + ~title:"Gas limit out of protocol hard bounds" + ~description:"A transaction tried to exceed the hard limit on gas" empty (function Gas_limit_too_high -> Some () | _ -> None) (fun () -> Gas_limit_too_high) let check_gas_limit ctxt remaining = - if Compare.Z.(remaining > ctxt.constants.hard_gas_limit_per_operation) - || Compare.Z.(remaining < Z.zero) then - error Gas_limit_too_high - else - ok () + if + Compare.Z.(remaining > ctxt.constants.hard_gas_limit_per_operation) + || Compare.Z.(remaining < Z.zero) + then error Gas_limit_too_high + else ok () + let set_gas_limit ctxt remaining = - { ctxt with operation_gas = Limited { remaining } ; - internal_gas = Gas_limit_repr.internal_gas_zero } -let set_gas_unlimited ctxt = - { ctxt with operation_gas = Unaccounted } + { + ctxt with + operation_gas = Limited {remaining}; + internal_gas = Gas_limit_repr.internal_gas_zero; + } + +let set_gas_unlimited ctxt = {ctxt with operation_gas = Unaccounted} + let consume_gas ctxt cost = Gas_limit_repr.consume ctxt.block_gas ctxt.operation_gas ctxt.internal_gas - cost >>? fun (block_gas, operation_gas, internal_gas) -> - ok { ctxt with block_gas ; operation_gas ; internal_gas } + cost + >>? fun (block_gas, operation_gas, internal_gas) -> + ok {ctxt with block_gas; operation_gas; internal_gas} + let check_enough_gas ctxt cost = - Gas_limit_repr.check_enough ctxt.block_gas ctxt.operation_gas ctxt.internal_gas cost + Gas_limit_repr.check_enough + ctxt.block_gas + ctxt.operation_gas + ctxt.internal_gas + cost + let gas_level ctxt = ctxt.operation_gas + let block_gas_level ctxt = ctxt.block_gas let gas_consumed ~since ~until = - match gas_level since, gas_level until with - | Limited { remaining = before }, Limited { remaining = after } -> Z.sub before after - | _, _ -> Z.zero + match (gas_level since, gas_level until) with + | (Limited {remaining = before}, Limited {remaining = after}) -> + Z.sub before after + | (_, _) -> + Z.zero let init_storage_space_to_pay ctxt = match ctxt.storage_space_to_pay with | Some _ -> assert false | None -> - { ctxt with storage_space_to_pay = Some Z.zero ; allocated_contracts = Some 0 } + { + ctxt with + storage_space_to_pay = Some Z.zero; + allocated_contracts = Some 0; + } let update_storage_space_to_pay ctxt n = match ctxt.storage_space_to_pay with | None -> assert false | Some storage_space_to_pay -> - { ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay) } + {ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay)} let update_allocated_contracts_count ctxt = match ctxt.allocated_contracts with | None -> assert false | Some allocated_contracts -> - { ctxt with allocated_contracts = Some (succ allocated_contracts) } + {ctxt with allocated_contracts = Some (succ allocated_contracts)} let clear_storage_space_to_pay ctxt = - match ctxt.storage_space_to_pay, ctxt.allocated_contracts with - | None, _ | _, None -> + match (ctxt.storage_space_to_pay, ctxt.allocated_contracts) with + | (None, _) | (_, None) -> assert false - | Some storage_space_to_pay, Some allocated_contracts -> - { ctxt with storage_space_to_pay = None ; - allocated_contracts = None}, - storage_space_to_pay, - allocated_contracts + | (Some storage_space_to_pay, Some allocated_contracts) -> + ( {ctxt with storage_space_to_pay = None; allocated_contracts = None}, + storage_space_to_pay, + allocated_contracts ) type storage_error = | Incompatible_protocol_version of string @@ -252,58 +297,68 @@ type storage_error = let storage_error_encoding = let open Data_encoding in - union [ - case (Tag 0) - ~title:"Incompatible_protocol_version" - (obj1 (req "incompatible_protocol_version" string)) - (function Incompatible_protocol_version arg -> Some arg | _ -> None) - (fun arg -> Incompatible_protocol_version arg) ; - case (Tag 1) - ~title:"Missing_key" - (obj2 - (req "missing_key" (list string)) - (req "function" (string_enum ["get", `Get ; "set", `Set ; "del", `Del ; "copy", `Copy ]))) - (function Missing_key (key, f) -> Some (key, f) | _ -> None) - (fun (key, f) -> Missing_key (key, f)) ; - case (Tag 2) - ~title:"Existing_key" - (obj1 (req "existing_key" (list string))) - (function Existing_key key -> Some key | _ -> None) - (fun key -> Existing_key key) ; - case (Tag 3) - ~title:"Corrupted_data" - (obj1 (req "corrupted_data" (list string))) - (function Corrupted_data key -> Some key | _ -> None) - (fun key -> Corrupted_data key) ; - ] + union + [ case + (Tag 0) + ~title:"Incompatible_protocol_version" + (obj1 (req "incompatible_protocol_version" string)) + (function Incompatible_protocol_version arg -> Some arg | _ -> None) + (fun arg -> Incompatible_protocol_version arg); + case + (Tag 1) + ~title:"Missing_key" + (obj2 + (req "missing_key" (list string)) + (req + "function" + (string_enum + [("get", `Get); ("set", `Set); ("del", `Del); ("copy", `Copy)]))) + (function Missing_key (key, f) -> Some (key, f) | _ -> None) + (fun (key, f) -> Missing_key (key, f)); + case + (Tag 2) + ~title:"Existing_key" + (obj1 (req "existing_key" (list string))) + (function Existing_key key -> Some key | _ -> None) + (fun key -> Existing_key key); + case + (Tag 3) + ~title:"Corrupted_data" + (obj1 (req "corrupted_data" (list string))) + (function Corrupted_data key -> Some key | _ -> None) + (fun key -> Corrupted_data key) ] let pp_storage_error ppf = function | Incompatible_protocol_version version -> - Format.fprintf ppf + Format.fprintf + ppf "Found a context with an unexpected version '%s'." version | Missing_key (key, `Get) -> - Format.fprintf ppf - "Missing key '%s'." - (String.concat "/" key) + Format.fprintf ppf "Missing key '%s'." (String.concat "/" key) | Missing_key (key, `Set) -> - Format.fprintf ppf + Format.fprintf + ppf "Cannot set undefined key '%s'." (String.concat "/" key) | Missing_key (key, `Del) -> - Format.fprintf ppf + Format.fprintf + ppf "Cannot delete undefined key '%s'." (String.concat "/" key) | Missing_key (key, `Copy) -> - Format.fprintf ppf + Format.fprintf + ppf "Cannot copy undefined key '%s'." (String.concat "/" key) | Existing_key key -> - Format.fprintf ppf + Format.fprintf + ppf "Cannot initialize defined key '%s'." (String.concat "/" key) | Corrupted_data key -> - Format.fprintf ppf + Format.fprintf + ppf "Failed to parse the data at '%s'." (String.concat "/" key) @@ -313,14 +368,12 @@ let () = register_error_kind `Permanent ~id:"context.storage_error" - ~title: "Storage error (fatal internal error)" + ~title:"Storage error (fatal internal error)" ~description: - "An error that should never happen unless something \ - has been deleted or corrupted in the database." + "An error that should never happen unless something has been deleted or \ + corrupted in the database." ~pp:(fun ppf err -> - Format.fprintf ppf - "@[Storage error:@ %a@]" - pp_storage_error err) + Format.fprintf ppf "@[Storage error:@ %a@]" pp_storage_error err) storage_error_encoding (function Storage_error err -> Some err | _ -> None) (fun err -> Storage_error err) @@ -330,244 +383,275 @@ let storage_error err = fail (Storage_error err) (* Initialization *********************************************************) (* This key should always be populated for every version of the - protocol. Its absence meaning that the context is empty. *) + protocol. It's absence meaning that the context is empty. *) let version_key = ["version"] -let version_value = "babylon_005" + +let version_value = "carthage_006" let version = "v1" -let first_level_key = [ version ; "first_level" ] -let constants_key = [ version ; "constants" ] -let protocol_param_key = [ "protocol_parameters" ] + +let first_level_key = [version; "first_level"] + +let constants_key = [version; "constants"] + +let protocol_param_key = ["protocol_parameters"] let get_first_level ctxt = - Context.get ctxt first_level_key >>= function - | None -> storage_error (Missing_key (first_level_key, `Get)) - | Some bytes -> - match - Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes - with - | None -> storage_error (Corrupted_data first_level_key) - | Some level -> return level + Context.get ctxt first_level_key + >>= function + | None -> + storage_error (Missing_key (first_level_key, `Get)) + | Some bytes -> ( + match Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes with + | None -> + storage_error (Corrupted_data first_level_key) + | Some level -> + return level ) let set_first_level ctxt level = let bytes = - Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level in - Context.set ctxt first_level_key bytes >>= fun ctxt -> - return ctxt + Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level + in + Context.set ctxt first_level_key bytes >>= fun ctxt -> return ctxt type error += Failed_to_parse_parameter of MBytes.t + type error += Failed_to_decode_parameter of Data_encoding.json * string let () = register_error_kind `Temporary ~id:"context.failed_to_parse_parameter" - ~title: "Failed to parse parameter" - ~description: - "The protocol parameters are not valid JSON." - ~pp:begin fun ppf bytes -> - Format.fprintf ppf + ~title:"Failed to parse parameter" + ~description:"The protocol parameters are not valid JSON." + ~pp:(fun ppf bytes -> + Format.fprintf + ppf "@[Cannot parse the protocol parameter:@ %s@]" - (MBytes.to_string bytes) - end + (MBytes.to_string bytes)) Data_encoding.(obj1 (req "contents" bytes)) (function Failed_to_parse_parameter data -> Some data | _ -> None) (fun data -> Failed_to_parse_parameter data) ; register_error_kind `Temporary ~id:"context.failed_to_decode_parameter" - ~title: "Failed to decode parameter" - ~description: - "Unexpected JSON object." - ~pp:begin fun ppf (json, msg) -> - Format.fprintf ppf + ~title:"Failed to decode parameter" + ~description:"Unexpected JSON object." + ~pp:(fun ppf (json, msg) -> + Format.fprintf + ppf "@[Cannot decode the protocol parameter:@ %s@ %a@]" msg - Data_encoding.Json.pp json - end - Data_encoding.(obj2 - (req "contents" json) - (req "error" string)) + Data_encoding.Json.pp + json) + Data_encoding.(obj2 (req "contents" json) (req "error" string)) (function - | Failed_to_decode_parameter (json, msg) -> Some (json, msg) - | _ -> None) + | Failed_to_decode_parameter (json, msg) -> Some (json, msg) | _ -> None) (fun (json, msg) -> Failed_to_decode_parameter (json, msg)) let get_proto_param ctxt = - Context.get ctxt protocol_param_key >>= function + Context.get ctxt protocol_param_key + >>= function | None -> failwith "Missing protocol parameters." - | Some bytes -> - match Data_encoding.Binary.of_bytes Data_encoding.json bytes with - | None -> fail (Failed_to_parse_parameter bytes) - | Some json -> begin - Context.del ctxt protocol_param_key >>= fun ctxt -> - match Data_encoding.Json.destruct Parameters_repr.encoding json with - | exception (Data_encoding.Json.Cannot_destruct _ as exn) -> - Format.kasprintf - failwith "Invalid protocol_parameters: %a %a" - (fun ppf -> Data_encoding.Json.print_error ppf) exn - Data_encoding.Json.pp json - | param -> return (param, ctxt) - end + | Some bytes -> ( + match Data_encoding.Binary.of_bytes Data_encoding.json bytes with + | None -> + fail (Failed_to_parse_parameter bytes) + | Some json -> ( + Context.del ctxt protocol_param_key + >>= fun ctxt -> + match Data_encoding.Json.destruct Parameters_repr.encoding json with + | exception (Data_encoding.Json.Cannot_destruct _ as exn) -> + Format.kasprintf + failwith + "Invalid protocol_parameters: %a %a" + (fun ppf -> Data_encoding.Json.print_error ppf) + exn + Data_encoding.Json.pp + json + | param -> + return (param, ctxt) ) ) let set_constants ctxt constants = let bytes = Data_encoding.Binary.to_bytes_exn - Constants_repr.parametric_encoding constants in + Constants_repr.parametric_encoding + constants + in Context.set ctxt constants_key bytes let get_constants ctxt = - Context.get ctxt constants_key >>= function + Context.get ctxt constants_key + >>= function | None -> failwith "Internal error: cannot read constants in context." - | Some bytes -> - match - Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes - with - | None -> - failwith "Internal error: cannot parse constants in context." - | Some constants -> return constants + | Some bytes -> ( + match + Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes + with + | None -> + failwith "Internal error: cannot parse constants in context." + | Some constants -> + return constants ) -(* only for migration from 004 to 005 *) -let get_004_constants ctxt = - Context.get ctxt constants_key >>= function +(* only for migration from 005 to 006 *) +let get_005_constants ctxt = + Context.get ctxt constants_key + >>= function | None -> - failwith "Internal error: cannot read constants in context." - | Some bytes -> - match - Data_encoding.Binary.of_bytes Parameters_repr.Proto_004.constants_encoding bytes - with - | None -> - failwith "Internal error: cannot parse constants in context." - | Some constants -> return constants + failwith "Internal error: cannot read 005 constants in context." + | Some bytes -> ( + match + Data_encoding.Binary.of_bytes + Constants_repr.Proto_005.parametric_encoding + bytes + with + | None -> + failwith "Internal error: cannot parse 005 constants in context." + | Some constants -> + return constants ) let patch_constants ctxt f = let constants = f ctxt.constants in - set_constants ctxt.context constants >>= fun context -> - Lwt.return { ctxt with context ; constants } + set_constants ctxt.context constants + >>= fun context -> Lwt.return {ctxt with context; constants} let check_inited ctxt = - Context.get ctxt version_key >>= function + Context.get ctxt version_key + >>= function | None -> failwith "Internal error: un-initialized context." | Some bytes -> let s = MBytes.to_string bytes in - if Compare.String.(s = version_value) then - return_unit - else - storage_error (Incompatible_protocol_version s) + if Compare.String.(s = version_value) then return_unit + else storage_error (Incompatible_protocol_version s) let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt = - Lwt.return (Raw_level_repr.of_int32 level) >>=? fun level -> - Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness -> - check_inited ctxt >>=? fun () -> - get_constants ctxt >>=? fun constants -> - get_first_level ctxt >>=? fun first_level -> + Lwt.return (Raw_level_repr.of_int32 level) + >>=? fun level -> + Lwt.return (Fitness_repr.to_int64 fitness) + >>=? fun fitness -> + check_inited ctxt + >>=? fun () -> + get_constants ctxt + >>=? fun constants -> + get_first_level ctxt + >>=? fun first_level -> let level = Level_repr.from_raw ~first_level ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle - ~blocks_per_voting_period:constants.Constants_repr.blocks_per_voting_period + ~blocks_per_voting_period: + constants.Constants_repr.blocks_per_voting_period ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment - level in - return { - context = ctxt ; constants ; level ; - predecessor_timestamp ; - timestamp ; fitness ; first_level ; - allowed_endorsements = Signature.Public_key_hash.Map.empty ; - included_endorsements = 0 ; - fees = Tez_repr.zero ; - rewards = Tez_repr.zero ; - deposits = Signature.Public_key_hash.Map.empty ; - operation_gas = Unaccounted ; - internal_gas = Gas_limit_repr.internal_gas_zero ; - storage_space_to_pay = None ; - allocated_contracts = None ; - block_gas = constants.Constants_repr.hard_gas_limit_per_block ; - origination_nonce = None ; - temporary_big_map = Z.sub Z.zero Z.one ; - internal_nonce = 0 ; - internal_nonces_used = Int_set.empty ; - } + level + in + return + { + context = ctxt; + constants; + level; + predecessor_timestamp; + timestamp; + fitness; + first_level; + allowed_endorsements = Signature.Public_key_hash.Map.empty; + included_endorsements = 0; + fees = Tez_repr.zero; + rewards = Tez_repr.zero; + deposits = Signature.Public_key_hash.Map.empty; + operation_gas = Unaccounted; + internal_gas = Gas_limit_repr.internal_gas_zero; + storage_space_to_pay = None; + allocated_contracts = None; + block_gas = constants.Constants_repr.hard_gas_limit_per_block; + origination_nonce = None; + temporary_big_map = Z.sub Z.zero Z.one; + internal_nonce = 0; + internal_nonces_used = Int_set.empty; + } -type previous_protocol = - | Genesis of Parameters_repr.t - | Athens_004 +type previous_protocol = Genesis of Parameters_repr.t | Babylon_005 let check_and_update_protocol_version ctxt = - begin - Context.get ctxt version_key >>= function - | None -> - failwith "Internal error: un-initialized context in check_first_block." - | Some bytes -> - let s = MBytes.to_string bytes in - if Compare.String.(s = version_value) then - failwith "Internal error: previously initialized context." - else if Compare.String.(s = "genesis") then - get_proto_param ctxt >>=? fun (param, ctxt) -> - return (Genesis param, ctxt) - else if Compare.String.(s = "athens_004") then - return (Athens_004, ctxt) - else - storage_error (Incompatible_protocol_version s) - end >>=? fun (previous_proto, ctxt) -> - Context.set ctxt version_key - (MBytes.of_string version_value) >>= fun ctxt -> - return (previous_proto, ctxt) + Context.get ctxt version_key + >>= (function + | None -> + failwith + "Internal error: un-initialized context in check_first_block." + | Some bytes -> + let s = MBytes.to_string bytes in + if Compare.String.(s = version_value) then + failwith "Internal error: previously initialized context." + else if Compare.String.(s = "genesis") then + get_proto_param ctxt + >>=? fun (param, ctxt) -> return (Genesis param, ctxt) + else if Compare.String.(s = "babylon_005") then + return (Babylon_005, ctxt) + else storage_error (Incompatible_protocol_version s)) + >>=? fun (previous_proto, ctxt) -> + Context.set ctxt version_key (MBytes.of_string version_value) + >>= fun ctxt -> return (previous_proto, ctxt) let prepare_first_block ~level ~timestamp ~fitness ctxt = - check_and_update_protocol_version ctxt >>=? fun (previous_proto, ctxt) -> - begin - match previous_proto with - | Genesis param -> - Lwt.return (Raw_level_repr.of_int32 level) >>=? fun first_level -> - set_first_level ctxt first_level >>=? fun ctxt -> - set_constants ctxt param.constants >>= fun ctxt -> - return ctxt - | Athens_004 -> - get_004_constants ctxt >>=? fun c -> - let constants = Constants_repr.{ - preserved_cycles = c.preserved_cycles ; - blocks_per_cycle = c.blocks_per_cycle ; - blocks_per_commitment = c.blocks_per_commitment ; - blocks_per_roll_snapshot = c.blocks_per_roll_snapshot ; - blocks_per_voting_period = c.blocks_per_voting_period ; - time_between_blocks = - List.map Period_repr.of_seconds_exn [ 60L ; 40L ] ; - endorsers_per_block = c.endorsers_per_block ; - hard_gas_limit_per_operation = c.hard_gas_limit_per_operation ; - hard_gas_limit_per_block = c.hard_gas_limit_per_block ; - proof_of_work_threshold = c.proof_of_work_threshold ; - tokens_per_roll = c.tokens_per_roll ; + check_and_update_protocol_version ctxt + >>=? fun (previous_proto, ctxt) -> + ( match previous_proto with + | Genesis param -> + Lwt.return (Raw_level_repr.of_int32 level) + >>=? fun first_level -> + set_first_level ctxt first_level + >>=? fun ctxt -> + set_constants ctxt param.constants >>= fun ctxt -> return ctxt + | Babylon_005 -> + get_005_constants ctxt + >>=? fun c -> + let constants = + Constants_repr. + { + preserved_cycles = c.preserved_cycles; + blocks_per_cycle = c.blocks_per_cycle; + blocks_per_commitment = c.blocks_per_commitment; + blocks_per_roll_snapshot = c.blocks_per_roll_snapshot; + blocks_per_voting_period = c.blocks_per_voting_period; + time_between_blocks = c.time_between_blocks; + endorsers_per_block = c.endorsers_per_block; + hard_gas_limit_per_operation = Z.of_int 1_040_000; + hard_gas_limit_per_block = Z.of_int 10_400_000; + proof_of_work_threshold = c.proof_of_work_threshold; + tokens_per_roll = c.tokens_per_roll; michelson_maximum_type_size = c.michelson_maximum_type_size; - seed_nonce_revelation_tip = c.seed_nonce_revelation_tip ; - origination_size = c.origination_size ; - block_security_deposit = c.block_security_deposit ; - endorsement_security_deposit = c.endorsement_security_deposit ; - block_reward = c.block_reward ; - endorsement_reward = c.endorsement_reward ; - cost_per_byte = c.cost_per_byte ; - hard_storage_limit_per_operation = c.hard_storage_limit_per_operation ; - test_chain_duration = c.test_chain_duration ; - quorum_min = 20_00l ; (* quorum is in centile of a percentage *) - quorum_max = 70_00l ; - min_proposal_quorum = 5_00l ; - initial_endorsers = 24 ; - delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L ; - } in - set_constants ctxt constants >>= fun ctxt -> - return ctxt - end >>=? fun ctxt -> - prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness >>=? fun ctxt -> - return (previous_proto, ctxt) + seed_nonce_revelation_tip = c.seed_nonce_revelation_tip; + origination_size = c.origination_size; + block_security_deposit = c.block_security_deposit; + endorsement_security_deposit = c.endorsement_security_deposit; + baking_reward_per_endorsement = + Tez_repr.[of_mutez_exn 1_250_000L; of_mutez_exn 187_500L]; + endorsement_reward = + Tez_repr.[of_mutez_exn 1_250_000L; of_mutez_exn 833_333L]; + cost_per_byte = c.cost_per_byte; + hard_storage_limit_per_operation = + c.hard_storage_limit_per_operation; + test_chain_duration = c.test_chain_duration; + quorum_min = c.quorum_min; + quorum_max = c.quorum_max; + min_proposal_quorum = c.min_proposal_quorum; + initial_endorsers = c.initial_endorsers; + delay_per_missing_endorsement = c.delay_per_missing_endorsement; + } + in + set_constants ctxt constants >>= fun ctxt -> return ctxt ) + >>=? fun ctxt -> + prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness + >>=? fun ctxt -> return (previous_proto, ctxt) -let activate ({ context = c ; _ } as s) h = - Updater.activate c h >>= fun c -> Lwt.return { s with context = c } +let activate ({context = c; _} as s) h = + Updater.activate c h >>= fun c -> Lwt.return {s with context = c} -let fork_test_chain ({ context = c ; _ } as s) protocol expiration = - Updater.fork_test_chain c ~protocol ~expiration >>= fun c -> - Lwt.return { s with context = c } +let fork_test_chain ({context = c; _} as s) protocol expiration = + Updater.fork_test_chain c ~protocol ~expiration + >>= fun c -> Lwt.return {s with context = c} (* Generic context ********************************************************) @@ -576,112 +660,129 @@ type key = string list type value = MBytes.t module type T = sig - type t + type context = t - val mem: context -> key -> bool Lwt.t - val dir_mem: context -> key -> bool Lwt.t - val get: context -> key -> value tzresult Lwt.t - val get_option: context -> key -> value option Lwt.t - val init: context -> key -> value -> context tzresult Lwt.t - val set: context -> key -> value -> context tzresult Lwt.t - val init_set: context -> key -> value -> context Lwt.t - val set_option: context -> key -> value option -> context Lwt.t - val delete: context -> key -> context tzresult Lwt.t - val remove: context -> key -> context Lwt.t - val remove_rec: context -> key -> context Lwt.t - val copy: context -> from:key -> to_:key -> context tzresult Lwt.t + val mem : context -> key -> bool Lwt.t - val fold: - context -> key -> init:'a -> - f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + val dir_mem : context -> key -> bool Lwt.t + + val get : context -> key -> value tzresult Lwt.t + + val get_option : context -> key -> value option Lwt.t + + val init : context -> key -> value -> context tzresult Lwt.t + + val set : context -> key -> value -> context tzresult Lwt.t + + val init_set : context -> key -> value -> context Lwt.t + + val set_option : context -> key -> value option -> context Lwt.t + + val delete : context -> key -> context tzresult Lwt.t + + val remove : context -> key -> context Lwt.t + + val remove_rec : context -> key -> context Lwt.t + + val copy : context -> from:key -> to_:key -> context tzresult Lwt.t + + val fold : + context -> + key -> + init:'a -> + f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) -> 'a Lwt.t - val keys: context -> key -> key list Lwt.t + val keys : context -> key -> key list Lwt.t - val fold_keys: + val fold_keys : context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t - val project: context -> root_context + val project : context -> root_context - val absolute_key: context -> key -> key + val absolute_key : context -> key -> key - val consume_gas: context -> Gas_limit_repr.cost -> context tzresult + val consume_gas : context -> Gas_limit_repr.cost -> context tzresult - val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult - - val description: context Storage_description.t + val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult + val description : context Storage_description.t end let mem ctxt k = Context.mem ctxt.context k + let dir_mem ctxt k = Context.dir_mem ctxt.context k let get ctxt k = - Context.get ctxt.context k >>= function - | None -> storage_error (Missing_key (k, `Get)) - | Some v -> return v - -let get_option ctxt k = Context.get ctxt.context k + >>= function + | None -> storage_error (Missing_key (k, `Get)) | Some v -> return v + +let get_option ctxt k = Context.get ctxt.context k (* Verify that the k is present before modifying *) let set ctxt k v = - Context.mem ctxt.context k >>= function - | false -> storage_error (Missing_key (k, `Set)) + Context.mem ctxt.context k + >>= function + | false -> + storage_error (Missing_key (k, `Set)) | true -> - Context.set ctxt.context k v >>= fun context -> - return { ctxt with context } + Context.set ctxt.context k v + >>= fun context -> return {ctxt with context} (* Verify that the k is not present before inserting *) let init ctxt k v = - Context.mem ctxt.context k >>= function - | true -> storage_error (Existing_key k) + Context.mem ctxt.context k + >>= function + | true -> + storage_error (Existing_key k) | false -> - Context.set ctxt.context k v >>= fun context -> - return { ctxt with context } + Context.set ctxt.context k v + >>= fun context -> return {ctxt with context} (* Does not verify that the key is present or not *) let init_set ctxt k v = - Context.set ctxt.context k v >>= fun context -> - Lwt.return { ctxt with context } + Context.set ctxt.context k v + >>= fun context -> Lwt.return {ctxt with context} (* Verify that the key is present before deleting *) let delete ctxt k = - Context.mem ctxt.context k >>= function - | false -> storage_error (Missing_key (k, `Del)) + Context.mem ctxt.context k + >>= function + | false -> + storage_error (Missing_key (k, `Del)) | true -> - Context.del ctxt.context k >>= fun context -> - return { ctxt with context } + Context.del ctxt.context k >>= fun context -> return {ctxt with context} (* Do not verify before deleting *) let remove ctxt k = - Context.del ctxt.context k >>= fun context -> - Lwt.return { ctxt with context } + Context.del ctxt.context k >>= fun context -> Lwt.return {ctxt with context} let set_option ctxt k = function - | None -> remove ctxt k - | Some v -> init_set ctxt k v + | None -> + remove ctxt k + | Some v -> + init_set ctxt k v let remove_rec ctxt k = - Context.remove_rec ctxt.context k >>= fun context -> - Lwt.return { ctxt with context } + Context.remove_rec ctxt.context k + >>= fun context -> Lwt.return {ctxt with context} let copy ctxt ~from ~to_ = - Context.copy ctxt.context ~from ~to_ >>= function - | None -> storage_error (Missing_key (from, `Copy)) + Context.copy ctxt.context ~from ~to_ + >>= function + | None -> + storage_error (Missing_key (from, `Copy)) | Some context -> - return { ctxt with context } + return {ctxt with context} -let fold ctxt k ~init ~f = - Context.fold ctxt.context k ~init ~f +let fold ctxt k ~init ~f = Context.fold ctxt.context k ~init ~f -let keys ctxt k = - Context.keys ctxt.context k +let keys ctxt k = Context.keys ctxt.context k -let fold_keys ctxt k ~init ~f = - Context.fold_keys ctxt.context k ~init ~f +let fold_keys ctxt k ~init ~f = Context.fold_keys ctxt.context k ~init ~f let project x = x @@ -690,17 +791,15 @@ let absolute_key _ k = k let description = Storage_description.create () let fresh_temporary_big_map ctxt = - { ctxt with temporary_big_map = Z.sub ctxt.temporary_big_map Z.one }, - ctxt.temporary_big_map + ( {ctxt with temporary_big_map = Z.sub ctxt.temporary_big_map Z.one}, + ctxt.temporary_big_map ) let reset_temporary_big_map ctxt = - { ctxt with temporary_big_map = Z.sub Z.zero Z.one } + {ctxt with temporary_big_map = Z.sub Z.zero Z.one} let temporary_big_maps ctxt f acc = let rec iter acc id = - if Z.equal id ctxt.temporary_big_map then - Lwt.return acc - else - f acc id >>= fun acc -> - iter acc (Z.sub id Z.one) in + if Z.equal id ctxt.temporary_big_map then Lwt.return acc + else f acc id >>= fun acc -> iter acc (Z.sub id Z.one) + in iter acc (Z.sub Z.zero Z.one) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli index 749878b6c..b004d6a06 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli @@ -35,125 +35,152 @@ type storage_error = | Corrupted_data of string list type error += Storage_error of storage_error + type error += Failed_to_parse_parameter of MBytes.t + type error += Failed_to_decode_parameter of Data_encoding.json * string -val storage_error: storage_error -> 'a tzresult Lwt.t +val storage_error : storage_error -> 'a tzresult Lwt.t (** {1 Abstract Context} *) (** Abstract view of the context. Includes a handle to the functional key-value database ({!Context.t}) along with some in-memory values (gas, etc.). *) + module Int_set : sig type t end type t = { - context: Context.t ; - constants: Constants_repr.parametric ; - first_level: Raw_level_repr.t ; - level: Level_repr.t ; - predecessor_timestamp: Time.t ; - timestamp: Time.t ; - fitness: Int64.t ; - deposits: Tez_repr.t Signature.Public_key_hash.Map.t ; - included_endorsements: int ; - allowed_endorsements: - (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ; - fees: Tez_repr.t ; - rewards: Tez_repr.t ; - block_gas: Z.t ; - operation_gas: Gas_limit_repr.t ; - internal_gas: Gas_limit_repr.internal_gas ; - storage_space_to_pay: Z.t option ; - allocated_contracts: int option ; - origination_nonce: Contract_repr.origination_nonce option ; - temporary_big_map: Z.t ; - internal_nonce: int ; - internal_nonces_used: Int_set.t ; + context : Context.t; + constants : Constants_repr.parametric; + first_level : Raw_level_repr.t; + level : Level_repr.t; + predecessor_timestamp : Time.t; + timestamp : Time.t; + fitness : Int64.t; + deposits : Tez_repr.t Signature.Public_key_hash.Map.t; + included_endorsements : int; + allowed_endorsements : + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t; + fees : Tez_repr.t; + rewards : Tez_repr.t; + block_gas : Z.t; + operation_gas : Gas_limit_repr.t; + internal_gas : Gas_limit_repr.internal_gas; + storage_space_to_pay : Z.t option; + allocated_contracts : int option; + origination_nonce : Contract_repr.origination_nonce option; + temporary_big_map : Z.t; + internal_nonce : int; + internal_nonces_used : Int_set.t; } type context = t + type root_context = t (** Retrieves the state of the database and gives its abstract view. It also returns wether this is the first block validated with this version of the protocol. *) -val prepare: - level: Int32.t -> - predecessor_timestamp: Time.t -> - timestamp: Time.t -> - fitness: Fitness.t -> - Context.t -> context tzresult Lwt.t +val prepare : + level:Int32.t -> + predecessor_timestamp:Time.t -> + timestamp:Time.t -> + fitness:Fitness.t -> + Context.t -> + context tzresult Lwt.t -type previous_protocol = - | Genesis of Parameters_repr.t - | Athens_004 +type previous_protocol = Genesis of Parameters_repr.t | Babylon_005 -val prepare_first_block: +val prepare_first_block : level:int32 -> timestamp:Time.t -> fitness:Fitness.t -> - Context.t -> (previous_protocol * context) tzresult Lwt.t + Context.t -> + (previous_protocol * context) tzresult Lwt.t -val activate: context -> Protocol_hash.t -> t Lwt.t -val fork_test_chain: context -> Protocol_hash.t -> Time.t -> t Lwt.t +val activate : context -> Protocol_hash.t -> t Lwt.t + +val fork_test_chain : context -> Protocol_hash.t -> Time.t -> t Lwt.t (** Returns the state of the database resulting of operations on its abstract view *) -val recover: context -> Context.t +val recover : context -> Context.t -val current_level: context -> Level_repr.t -val predecessor_timestamp: context -> Time.t -val current_timestamp: context -> Time.t +val current_level : context -> Level_repr.t -val current_fitness: context -> Int64.t -val set_current_fitness: context -> Int64.t -> t +val predecessor_timestamp : context -> Time.t -val constants: context -> Constants_repr.parametric -val patch_constants: +val current_timestamp : context -> Time.t + +val current_fitness : context -> Int64.t + +val set_current_fitness : context -> Int64.t -> t + +val constants : context -> Constants_repr.parametric + +val patch_constants : context -> (Constants_repr.parametric -> Constants_repr.parametric) -> context Lwt.t -val first_level: context -> Raw_level_repr.t + +val first_level : context -> Raw_level_repr.t (** Increment the current block fee stash that will be credited to baker's frozen_fees account at finalize_application *) -val add_fees: context -> Tez_repr.t -> context tzresult Lwt.t +val add_fees : context -> Tez_repr.t -> context tzresult Lwt.t (** Increment the current block reward stash that will be credited to baker's frozen_fees account at finalize_application *) -val add_rewards: context -> Tez_repr.t -> context tzresult Lwt.t +val add_rewards : context -> Tez_repr.t -> context tzresult Lwt.t (** Increment the current block deposit stash for a specific delegate. All the delegates' frozen_deposit accounts are credited at finalize_application *) -val add_deposit: - context -> Signature.Public_key_hash.t -> Tez_repr.t -> context tzresult Lwt.t +val add_deposit : + context -> + Signature.Public_key_hash.t -> + Tez_repr.t -> + context tzresult Lwt.t -val get_fees: context -> Tez_repr.t -val get_rewards: context -> Tez_repr.t -val get_deposits: context -> Tez_repr.t Signature.Public_key_hash.Map.t +val get_fees : context -> Tez_repr.t + +val get_rewards : context -> Tez_repr.t + +val get_deposits : context -> Tez_repr.t Signature.Public_key_hash.Map.t type error += Gas_limit_too_high (* `Permanent *) -val check_gas_limit: t -> Z.t -> unit tzresult -val set_gas_limit: t -> Z.t -> t -val set_gas_unlimited: t -> t -val gas_level: t -> Gas_limit_repr.t -val gas_consumed: since: t -> until: t -> Z.t -val block_gas_level: t -> Z.t +val check_gas_limit : t -> Z.t -> unit tzresult -val init_storage_space_to_pay: t -> t -val update_storage_space_to_pay: t -> Z.t -> t -val update_allocated_contracts_count: t -> t -val clear_storage_space_to_pay: t -> t * Z.t * int +val set_gas_limit : t -> Z.t -> t + +val set_gas_unlimited : t -> t + +val gas_level : t -> Gas_limit_repr.t + +val gas_consumed : since:t -> until:t -> Z.t + +val block_gas_level : t -> Z.t + +val init_storage_space_to_pay : t -> t + +val update_storage_space_to_pay : t -> Z.t -> t + +val update_allocated_contracts_count : t -> t + +val clear_storage_space_to_pay : t -> t * Z.t * int type error += Undefined_operation_nonce (* `Permanent *) -val init_origination_nonce: t -> Operation_hash.t -> t -val origination_nonce: t -> Contract_repr.origination_nonce tzresult -val increment_origination_nonce: t -> (t * Contract_repr.origination_nonce) tzresult -val unset_origination_nonce: t -> t +val init_origination_nonce : t -> Operation_hash.t -> t + +val origination_nonce : t -> Contract_repr.origination_nonce tzresult + +val increment_origination_nonce : + t -> (t * Contract_repr.origination_nonce) tzresult + +val unset_origination_nonce : t -> t (** {1 Generic accessors} *) @@ -165,127 +192,127 @@ type value = MBytes.t as-is for direct context accesses, and used in {!Storage_functors} to provide restricted views to the context. *) module type T = sig - type t + type context = t (** Tells if the key is already defined as a value. *) - val mem: context -> key -> bool Lwt.t + val mem : context -> key -> bool Lwt.t (** Tells if the key is already defined as a directory. *) - val dir_mem: context -> key -> bool Lwt.t + val dir_mem : context -> key -> bool Lwt.t (** Retrieve the value from the storage bucket ; returns a {!Storage_error Missing_key} if the key is not set. *) - val get: context -> key -> value tzresult Lwt.t + val get : context -> key -> value tzresult Lwt.t (** Retrieves the value from the storage bucket ; returns [None] if the data is not initialized. *) - val get_option: context -> key -> value option Lwt.t + val get_option : context -> key -> value option Lwt.t (** Allocates the storage bucket and initializes it ; returns a {!Storage_error Existing_key} if the bucket exists. *) - val init: context -> key -> value -> context tzresult Lwt.t + val init : context -> key -> value -> context tzresult Lwt.t (** Updates the content of the bucket ; returns a {!Storage_error Missing_key} if the value does not exists. *) - val set: context -> key -> value -> context tzresult Lwt.t + val set : context -> key -> value -> context tzresult Lwt.t (** Allocates the data and initializes it with a value ; just updates it if the bucket exists. *) - val init_set: context -> key -> value -> context Lwt.t + val init_set : context -> key -> value -> context Lwt.t (** When the value is [Some v], allocates the data and initializes it with [v] ; just updates it if the bucket exists. When the valus is [None], delete the storage bucket when the value ; does nothing if the bucket does not exists. *) - val set_option: context -> key -> value option -> context Lwt.t + val set_option : context -> key -> value option -> context Lwt.t (** Delete the storage bucket ; returns a {!Storage_error Missing_key} if the bucket does not exists. *) - val delete: context -> key -> context tzresult Lwt.t + val delete : context -> key -> context tzresult Lwt.t (** Removes the storage bucket and its contents ; does nothing if the bucket does not exists. *) - val remove: context -> key -> context Lwt.t + val remove : context -> key -> context Lwt.t (** Recursively removes all the storage buckets and contents ; does nothing if no bucket exists. *) - val remove_rec: context -> key -> context Lwt.t + val remove_rec : context -> key -> context Lwt.t - val copy: context -> from:key -> to_:key -> context tzresult Lwt.t + val copy : context -> from:key -> to_:key -> context tzresult Lwt.t (** Iterator on all the items of a given directory. *) - val fold: - context -> key -> init:'a -> - f:([ `Key of key | `Dir of key ] -> 'a -> 'a Lwt.t) -> + val fold : + context -> + key -> + init:'a -> + f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) -> 'a Lwt.t (** Recursively list all subkeys of a given key. *) - val keys: context -> key -> key list Lwt.t + val keys : context -> key -> key list Lwt.t (** Recursive iterator on all the subkeys of a given key. *) - val fold_keys: + val fold_keys : context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t (** Internally used in {!Storage_functors} to escape from a view. *) - val project: context -> root_context + val project : context -> root_context (** Internally used in {!Storage_functors} to retrieve a full key from partial key relative a view. *) - val absolute_key: context -> key -> key + val absolute_key : context -> key -> key (** Internally used in {!Storage_functors} to consume gas from within a view. *) - val consume_gas: context -> Gas_limit_repr.cost -> context tzresult + val consume_gas : context -> Gas_limit_repr.cost -> context tzresult (** Check if consume_gas will fail *) - val check_enough_gas: context -> Gas_limit_repr.cost -> unit tzresult - - val description: context Storage_description.t + val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult + val description : context Storage_description.t end include T with type t := t and type context := context (** Initialize the local nonce used for preventing a script to duplicate an internal operation to replay it. *) -val reset_internal_nonce: context -> context +val reset_internal_nonce : context -> context (** Increments the internal operation nonce. *) -val fresh_internal_nonce: context -> (context * int) tzresult +val fresh_internal_nonce : context -> (context * int) tzresult (** Mark an internal operation nonce as taken. *) -val record_internal_nonce: context -> int -> context +val record_internal_nonce : context -> int -> context (** Check is the internal operation nonce has been taken. *) -val internal_nonce_already_recorded: context -> int -> bool +val internal_nonce_already_recorded : context -> int -> bool (** Returns a map where to each endorser's pkh is associated the list of its endorsing slots (in decreasing order) for a given level. *) -val allowed_endorsements: +val allowed_endorsements : context -> (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t (** Keep track of the number of endorsements that are included in a block *) -val included_endorsements: context -> int +val included_endorsements : context -> int (** Initializes the map of allowed endorsements, this function must only be called once. *) -val init_endorsements: +val init_endorsements : context -> (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t -> context (** Marks an endorsment in the map as used. *) -val record_endorsement: - context -> Signature.Public_key_hash.t -> context +val record_endorsement : context -> Signature.Public_key_hash.t -> context (** Provide a fresh identifier for a temporary big map (negative index). *) -val fresh_temporary_big_map: context -> context * Z.t +val fresh_temporary_big_map : context -> context * Z.t (** Reset the temporary big_map identifier generator to [-1]. *) -val reset_temporary_big_map: context -> context +val reset_temporary_big_map : context -> context (** Iterate over all created temporary big maps since the last {!reset_temporary_big_map}. *) -val temporary_big_maps: context -> ('a -> Z.t -> 'a Lwt.t) -> 'a -> 'a Lwt.t +val temporary_big_maps : context -> ('a -> Z.t -> 'a Lwt.t) -> 'a -> 'a Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml index 16b4f2d62..b5953a94e 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.ml @@ -24,37 +24,43 @@ (*****************************************************************************) type t = int32 + type raw_level = t + include (Compare.Int32 : Compare.S with type t := t) + let encoding = Data_encoding.int32 + let pp ppf level = Format.fprintf ppf "%ld" level + let rpc_arg = let construct raw_level = Int32.to_string raw_level in let destruct str = match Int32.of_string str with - | exception _ -> Error "Cannot parse level" - | raw_level -> Ok raw_level in + | exception _ -> + Error "Cannot parse level" + | raw_level -> + Ok raw_level + in RPC_arg.make ~descr:"A level integer" - ~name: "block_level" + ~name:"block_level" ~construct ~destruct () let root = 0l + let succ = Int32.succ -let pred l = - if l = 0l - then None - else Some (Int32.pred l) + +let pred l = if l = 0l then None else Some (Int32.pred l) let diff = Int32.sub let to_int32 l = l + let of_int32_exn l = - if Compare.Int32.(l >= 0l) - then l - else invalid_arg "Level_repr.of_int32" + if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.of_int32" type error += Unexpected_level of Int32.t (* `Permanent *) @@ -65,26 +71,32 @@ let () = ~title:"Unexpected level" ~description:"Level must be non-negative." ~pp:(fun ppf l -> - Format.fprintf ppf "The level is %s but should be non-negative." (Int32.to_string l)) + Format.fprintf + ppf + "The level is %s but should be non-negative." + (Int32.to_string l)) Data_encoding.(obj1 (req "level" int32)) (function Unexpected_level l -> Some l | _ -> None) (fun l -> Unexpected_level l) -let of_int32 l = - try Ok (of_int32_exn l) - with _ -> error (Unexpected_level l) +let of_int32 l = try Ok (of_int32_exn l) with _ -> error (Unexpected_level l) module Index = struct type t = raw_level + let path_length = 1 + let to_path level l = Int32.to_string level :: l + let of_path = function - | [s] -> begin - try Some (Int32.of_string s) - with _ -> None - end - | _ -> None + | [s] -> ( + try Some (Int32.of_string s) with _ -> None ) + | _ -> + None + let rpc_arg = rpc_arg + let encoding = encoding + let compare = compare end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.mli index d7171dcf3..0f7dad593 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_level_repr.mli @@ -27,21 +27,29 @@ since genesis: genesis is 0, all other blocks have increasing levels from there. *) type t + type raw_level = t -val encoding: raw_level Data_encoding.t -val rpc_arg: raw_level RPC_arg.arg -val pp: Format.formatter -> raw_level -> unit + +val encoding : raw_level Data_encoding.t + +val rpc_arg : raw_level RPC_arg.arg + +val pp : Format.formatter -> raw_level -> unit + include Compare.S with type t := raw_level -val to_int32: raw_level -> int32 -val of_int32_exn: int32 -> raw_level -val of_int32: int32 -> raw_level tzresult +val to_int32 : raw_level -> int32 -val diff: raw_level -> raw_level -> int32 +val of_int32_exn : int32 -> raw_level -val root: raw_level +val of_int32 : int32 -> raw_level tzresult -val succ: raw_level -> raw_level -val pred: raw_level -> raw_level option +val diff : raw_level -> raw_level -> int32 + +val root : raw_level + +val succ : raw_level -> raw_level + +val pred : raw_level -> raw_level option module Index : Storage_description.INDEX with type t = raw_level diff --git a/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.ml index 65e3d8e73..105ce476b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.ml @@ -24,38 +24,42 @@ (*****************************************************************************) include Compare.Int32 + type roll = t let encoding = Data_encoding.int32 let first = 0l + let succ i = Int32.succ i -let random sequence ~bound = - Seed_repr.take_int32 sequence bound +let random sequence ~bound = Seed_repr.take_int32 sequence bound -let rpc_arg = - RPC_arg.like - RPC_arg.int32 - "roll" +let rpc_arg = RPC_arg.like RPC_arg.int32 "roll" let to_int32 v = v - module Index = struct type t = roll + let path_length = 3 + let to_path roll l = - (Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff)) :: - (Int32.to_string @@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff)) :: - Int32.to_string roll :: l + (Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff)) + :: ( Int32.to_string + @@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff) + ) + :: Int32.to_string roll :: l + let of_path = function - | _ :: _ :: s :: _ -> begin - try Some (Int32.of_string s) - with _ -> None - end - | _ -> None + | _ :: _ :: s :: _ -> ( + try Some (Int32.of_string s) with _ -> None ) + | _ -> + None + let rpc_arg = rpc_arg + let encoding = encoding + let compare = compare end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.mli index 000e1c7c4..cb792b012 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/roll_repr.mli @@ -24,19 +24,21 @@ (*****************************************************************************) type t = private int32 + type roll = t -val encoding: roll Data_encoding.t -val rpc_arg: roll RPC_arg.t +val encoding : roll Data_encoding.t -val random: - Seed_repr.sequence -> bound:roll -> roll * Seed_repr.sequence +val rpc_arg : roll RPC_arg.t -val first: roll -val succ: roll -> roll +val random : Seed_repr.sequence -> bound:roll -> roll * Seed_repr.sequence -val to_int32: roll -> Int32.t +val first : roll -val (=): roll -> roll -> bool +val succ : roll -> roll + +val to_int32 : roll -> Int32.t + +val ( = ) : roll -> roll -> bool module Index : Storage_description.INDEX with type t = roll diff --git a/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.ml index 5c23075b0..2d9601c29 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.ml @@ -29,7 +29,9 @@ type error += | Consume_roll_change (* `Permanent *) | No_roll_for_delegate (* `Permanent *) | No_roll_snapshot_for_cycle of Cycle_repr.t (* `Permanent *) - | Unregistered_delegate of Signature.Public_key_hash.t (* `Permanent *) + | Unregistered_delegate of Signature.Public_key_hash.t + +(* `Permanent *) let () = let open Data_encoding in @@ -40,7 +42,7 @@ let () = ~title:"Consume roll change" ~description:"Change is not enough to consume a roll." ~pp:(fun ppf () -> - Format.fprintf ppf "Not enough change to consume a roll.") + Format.fprintf ppf "Not enough change to consume a roll.") empty (function Consume_roll_change -> Some () | _ -> None) (fun () -> Consume_roll_change) ; @@ -59,12 +61,16 @@ let () = `Permanent ~id:"contract.manager.no_roll_snapshot_for_cycle" ~title:"No roll snapshot for cycle" - ~description:"A snapshot of the rolls distribution does not exist for this cycle." + ~description: + "A snapshot of the rolls distribution does not exist for this cycle." ~pp:(fun ppf c -> - Format.fprintf ppf - "A snapshot of the rolls distribution does not exist for cycle %a" Cycle_repr.pp c) + Format.fprintf + ppf + "A snapshot of the rolls distribution does not exist for cycle %a" + Cycle_repr.pp + c) (obj1 (req "cycle" Cycle_repr.encoding)) - (function No_roll_snapshot_for_cycle c-> Some c | _ -> None) + (function No_roll_snapshot_for_cycle c -> Some c | _ -> None) (fun c -> No_roll_snapshot_for_cycle c) ; (* Unregistered delegate *) register_error_kind @@ -72,10 +78,13 @@ let () = ~id:"contract.manager.unregistered_delegate" ~title:"Unregistered delegate" ~description:"A contract cannot be delegated to an unregistered delegate" - ~pp:(fun ppf k-> - Format.fprintf ppf "The provided public key (with hash %a) is \ - \ not registered as valid delegate key." - Signature.Public_key_hash.pp k) + ~pp:(fun ppf k -> + Format.fprintf + ppf + "The provided public key (with hash %a) is not registered as valid \ + delegate key." + Signature.Public_key_hash.pp + k) (obj1 (req "hash" Signature.Public_key_hash.encoding)) (function Unregistered_delegate k -> Some k | _ -> None) (fun k -> Unregistered_delegate k) @@ -84,96 +93,109 @@ let get_contract_delegate c contract = Storage.Contract.Delegate.get_option c contract let delegate_pubkey ctxt delegate = - Storage.Contract.Manager.get_option ctxt - (Contract_repr.implicit_contract delegate) >>=? function + Storage.Contract.Manager.get_option + ctxt + (Contract_repr.implicit_contract delegate) + >>=? function | None | Some (Manager_repr.Hash _) -> fail (Unregistered_delegate delegate) | Some (Manager_repr.Public_key pk) -> return pk let clear_cycle c cycle = - Storage.Roll.Snapshot_for_cycle.get c cycle >>=? fun index -> - Storage.Roll.Snapshot_for_cycle.delete c cycle >>=? fun c -> - Storage.Roll.Last_for_snapshot.delete (c, cycle) index >>=? fun c -> - Storage.Roll.Owner.delete_snapshot c (cycle, index) >>= fun c -> - return c + Storage.Roll.Snapshot_for_cycle.get c cycle + >>=? fun index -> + Storage.Roll.Snapshot_for_cycle.delete c cycle + >>=? fun c -> + Storage.Roll.Last_for_snapshot.delete (c, cycle) index + >>=? fun c -> + Storage.Roll.Owner.delete_snapshot c (cycle, index) >>= fun c -> return c let fold ctxt ~f init = - Storage.Roll.Next.get ctxt >>=? fun last -> + Storage.Roll.Next.get ctxt + >>=? fun last -> let rec loop ctxt roll acc = - acc >>=? fun acc -> - if Roll_repr.(roll = last) then - return acc + acc + >>=? fun acc -> + if Roll_repr.(roll = last) then return acc else - Storage.Roll.Owner.get_option ctxt roll >>=? function + Storage.Roll.Owner.get_option ctxt roll + >>=? function | None -> loop ctxt (Roll_repr.succ roll) (return acc) | Some delegate -> - loop ctxt (Roll_repr.succ roll) (f roll delegate acc) in + loop ctxt (Roll_repr.succ roll) (f roll delegate acc) + in loop ctxt Roll_repr.first (return init) let snapshot_rolls_for_cycle ctxt cycle = - Storage.Roll.Snapshot_for_cycle.get ctxt cycle >>=? fun index -> - Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1) >>=? fun ctxt -> - Storage.Roll.Owner.snapshot ctxt (cycle, index) >>=? fun ctxt -> - Storage.Roll.Next.get ctxt >>=? fun last -> - Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last >>=? fun ctxt -> - return ctxt + Storage.Roll.Snapshot_for_cycle.get ctxt cycle + >>=? fun index -> + Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1) + >>=? fun ctxt -> + Storage.Roll.Owner.snapshot ctxt (cycle, index) + >>=? fun ctxt -> + Storage.Roll.Next.get ctxt + >>=? fun last -> + Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last + >>=? fun ctxt -> return ctxt let freeze_rolls_for_cycle ctxt cycle = - Storage.Roll.Snapshot_for_cycle.get ctxt cycle >>=? fun max_index -> - Storage.Seed.For_cycle.get ctxt cycle >>=? fun seed -> + Storage.Roll.Snapshot_for_cycle.get ctxt cycle + >>=? fun max_index -> + Storage.Seed.For_cycle.get ctxt cycle + >>=? fun seed -> let rd = Seed_repr.initialize_new seed [MBytes.of_string "roll_snapshot"] in let seq = Seed_repr.sequence rd 0l in let selected_index = - Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int in - Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index >>=? fun ctxt -> + Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int + in + Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index + >>=? fun ctxt -> fold_left_s (fun ctxt index -> - if Compare.Int.(index = selected_index) then - return ctxt - else - Storage.Roll.Owner.delete_snapshot ctxt (cycle, index) >>= fun ctxt -> - Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index >>=? fun ctxt -> - return ctxt - ) + if Compare.Int.(index = selected_index) then return ctxt + else + Storage.Roll.Owner.delete_snapshot ctxt (cycle, index) + >>= fun ctxt -> + Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index + >>=? fun ctxt -> return ctxt) ctxt - Misc.(0 --> (max_index - 1)) >>=? fun ctxt -> - return ctxt + Misc.(0 --> (max_index - 1)) + >>=? fun ctxt -> return ctxt (* Roll selection *) module Random = struct - let int32_to_bytes i = let b = MBytes.create 4 in - MBytes.set_int32 b 0 i; - b + MBytes.set_int32 b 0 i ; b let level_random seed use level = let position = level.Level_repr.cycle_position in - Seed_repr.initialize_new seed - [MBytes.of_string ("level "^use^":"); - int32_to_bytes position] + Seed_repr.initialize_new + seed + [MBytes.of_string ("level " ^ use ^ ":"); int32_to_bytes position] let owner c kind level offset = let cycle = level.Level_repr.cycle in - Seed_storage.for_cycle c cycle >>=? fun random_seed -> + Seed_storage.for_cycle c cycle + >>=? fun random_seed -> let rd = level_random random_seed kind level in let sequence = Seed_repr.sequence rd (Int32.of_int offset) in - Storage.Roll.Snapshot_for_cycle.get c cycle >>=? fun index -> - Storage.Roll.Last_for_snapshot.get (c, cycle) index >>=? fun bound -> + Storage.Roll.Snapshot_for_cycle.get c cycle + >>=? fun index -> + Storage.Roll.Last_for_snapshot.get (c, cycle) index + >>=? fun bound -> let rec loop sequence = - let roll, sequence = Roll_repr.random sequence ~bound in - Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll) >>=? function - | None -> - loop sequence - | Some delegate -> - return delegate in - Storage.Roll.Owner.snapshot_exists c (cycle, index) >>= fun snapshot_exists -> - fail_unless snapshot_exists (No_roll_snapshot_for_cycle cycle) >>=? fun () -> - loop sequence - + let (roll, sequence) = Roll_repr.random sequence ~bound in + Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll) + >>=? function None -> loop sequence | Some delegate -> return delegate + in + Storage.Roll.Owner.snapshot_exists c (cycle, index) + >>= fun snapshot_exists -> + fail_unless snapshot_exists (No_roll_snapshot_for_cycle cycle) + >>=? fun () -> loop sequence end let baking_rights_owner c level ~priority = @@ -184,125 +206,153 @@ let endorsement_rights_owner c level ~slot = let traverse_rolls ctxt head = let rec loop acc roll = - Storage.Roll.Successor.get_option ctxt roll >>=? function - | None -> return (List.rev acc) - | Some next -> loop (next :: acc) next in + Storage.Roll.Successor.get_option ctxt roll + >>=? function + | None -> return (List.rev acc) | Some next -> loop (next :: acc) next + in loop [head] head let get_rolls ctxt delegate = - Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? function - | None -> return_nil - | Some head_roll -> traverse_rolls ctxt head_roll + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? function + | None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll let count_rolls ctxt delegate = - Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? function - | None -> return 0 + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? function + | None -> + return 0 | Some head_roll -> let rec loop acc roll = - Storage.Roll.Successor.get_option ctxt roll >>=? function - | None -> return acc - | Some next -> loop (succ acc) next in + Storage.Roll.Successor.get_option ctxt roll + >>=? function None -> return acc | Some next -> loop (succ acc) next + in loop 1 head_roll let get_change c delegate = - Storage.Roll.Delegate_change.get_option c delegate >>=? function - | None -> return Tez_repr.zero - | Some change -> return change + Storage.Roll.Delegate_change.get_option c delegate + >>=? function None -> return Tez_repr.zero | Some change -> return change module Delegate = struct - let fresh_roll c = - Storage.Roll.Next.get c >>=? fun roll -> - Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c -> - return (roll, c) + Storage.Roll.Next.get c + >>=? fun roll -> + Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c -> return (roll, c) let get_limbo_roll c = - Storage.Roll.Limbo.get_option c >>=? function + Storage.Roll.Limbo.get_option c + >>=? function | None -> - fresh_roll c >>=? fun (roll, c) -> - Storage.Roll.Limbo.init c roll >>=? fun c -> - return (roll, c) + fresh_roll c + >>=? fun (roll, c) -> + Storage.Roll.Limbo.init c roll >>=? fun c -> return (roll, c) | Some roll -> return (roll, c) let consume_roll_change c delegate = let tokens_per_roll = Constants_storage.tokens_per_roll c in - Storage.Roll.Delegate_change.get c delegate >>=? fun change -> - trace Consume_roll_change - (Lwt.return Tez_repr.(change -? tokens_per_roll)) >>=? fun new_change -> + Storage.Roll.Delegate_change.get c delegate + >>=? fun change -> + trace Consume_roll_change (Lwt.return Tez_repr.(change -? tokens_per_roll)) + >>=? fun new_change -> Storage.Roll.Delegate_change.set c delegate new_change let recover_roll_change c delegate = let tokens_per_roll = Constants_storage.tokens_per_roll c in - Storage.Roll.Delegate_change.get c delegate >>=? fun change -> - Lwt.return Tez_repr.(change +? tokens_per_roll) >>=? fun new_change -> + Storage.Roll.Delegate_change.get c delegate + >>=? fun change -> + Lwt.return Tez_repr.(change +? tokens_per_roll) + >>=? fun new_change -> Storage.Roll.Delegate_change.set c delegate new_change let pop_roll_from_delegate c delegate = - recover_roll_change c delegate >>=? fun c -> + recover_roll_change c delegate + >>=? fun c -> (* beginning: delegate : roll -> successor_roll -> ... limbo : limbo_head -> ... *) - Storage.Roll.Limbo.get_option c >>=? fun limbo_head -> - Storage.Roll.Delegate_roll_list.get_option c delegate >>=? function - | None -> fail No_roll_for_delegate + Storage.Roll.Limbo.get_option c + >>=? fun limbo_head -> + Storage.Roll.Delegate_roll_list.get_option c delegate + >>=? function + | None -> + fail No_roll_for_delegate | Some roll -> - Storage.Roll.Owner.delete c roll >>=? fun c -> - Storage.Roll.Successor.get_option c roll >>=? fun successor_roll -> - Storage.Roll.Delegate_roll_list.set_option c delegate successor_roll >>= fun c -> + Storage.Roll.Owner.delete c roll + >>=? fun c -> + Storage.Roll.Successor.get_option c roll + >>=? fun successor_roll -> + Storage.Roll.Delegate_roll_list.set_option c delegate successor_roll + >>= fun c -> (* delegate : successor_roll -> ... roll ------^ limbo : limbo_head -> ... *) - Storage.Roll.Successor.set_option c roll limbo_head >>= fun c -> + Storage.Roll.Successor.set_option c roll limbo_head + >>= fun c -> (* delegate : successor_roll -> ... roll ------v limbo : limbo_head -> ... *) - Storage.Roll.Limbo.init_set c roll >>= fun c -> + Storage.Roll.Limbo.init_set c roll + >>= fun c -> (* delegate : successor_roll -> ... limbo : roll -> limbo_head -> ... *) return (roll, c) let create_roll_in_delegate c delegate delegate_pk = - consume_roll_change c delegate >>=? fun c -> - + consume_roll_change c delegate + >>=? fun c -> (* beginning: delegate : delegate_head -> ... limbo : roll -> limbo_successor -> ... *) - Storage.Roll.Delegate_roll_list.get_option c delegate >>=? fun delegate_head -> - get_limbo_roll c >>=? fun (roll, c) -> - Storage.Roll.Owner.init c roll delegate_pk >>=? fun c -> - Storage.Roll.Successor.get_option c roll >>=? fun limbo_successor -> - Storage.Roll.Limbo.set_option c limbo_successor >>= fun c -> + Storage.Roll.Delegate_roll_list.get_option c delegate + >>=? fun delegate_head -> + get_limbo_roll c + >>=? fun (roll, c) -> + Storage.Roll.Owner.init c roll delegate_pk + >>=? fun c -> + Storage.Roll.Successor.get_option c roll + >>=? fun limbo_successor -> + Storage.Roll.Limbo.set_option c limbo_successor + >>= fun c -> (* delegate : delegate_head -> ... roll ------v limbo : limbo_successor -> ... *) - Storage.Roll.Successor.set_option c roll delegate_head >>= fun c -> + Storage.Roll.Successor.set_option c roll delegate_head + >>= fun c -> (* delegate : delegate_head -> ... roll ------^ limbo : limbo_successor -> ... *) - Storage.Roll.Delegate_roll_list.init_set c delegate roll >>= fun c -> + Storage.Roll.Delegate_roll_list.init_set c delegate roll + >>= fun c -> (* delegate : roll -> delegate_head -> ... limbo : limbo_successor -> ... *) return c let ensure_inited c delegate = - Storage.Roll.Delegate_change.mem c delegate >>= function - | true -> return c + Storage.Roll.Delegate_change.mem c delegate + >>= function + | true -> + return c | false -> Storage.Roll.Delegate_change.init c delegate Tez_repr.zero let is_inactive c delegate = - Storage.Contract.Inactive_delegate.mem c - (Contract_repr.implicit_contract delegate) >>= fun inactive -> - if inactive then - return inactive + Storage.Contract.Inactive_delegate.mem + c + (Contract_repr.implicit_contract delegate) + >>= fun inactive -> + if inactive then return inactive else - Storage.Contract.Delegate_desactivation.get_option c - (Contract_repr.implicit_contract delegate) >>=? function + Storage.Contract.Delegate_desactivation.get_option + c + (Contract_repr.implicit_contract delegate) + >>=? function | Some last_active_cycle -> - let { Level_repr.cycle = current_cycle } = Raw_context.current_level c in + let {Level_repr.cycle = current_cycle} = + Raw_context.current_level c + in return Cycle_repr.(last_active_cycle < current_cycle) | None -> (* This case is only when called from `set_active`, when creating @@ -310,79 +360,101 @@ module Delegate = struct return_false let add_amount c delegate amount = - ensure_inited c delegate >>=? fun c -> + ensure_inited c delegate + >>=? fun c -> let tokens_per_roll = Constants_storage.tokens_per_roll c in - Storage.Roll.Delegate_change.get c delegate >>=? fun change -> - Lwt.return Tez_repr.(amount +? change) >>=? fun change -> - Storage.Roll.Delegate_change.set c delegate change >>=? fun c -> - delegate_pubkey c delegate >>=? fun delegate_pk -> + Storage.Roll.Delegate_change.get c delegate + >>=? fun change -> + Lwt.return Tez_repr.(amount +? change) + >>=? fun change -> + Storage.Roll.Delegate_change.set c delegate change + >>=? fun c -> + delegate_pubkey c delegate + >>=? fun delegate_pk -> let rec loop c change = - if Tez_repr.(change < tokens_per_roll) then - return c + if Tez_repr.(change < tokens_per_roll) then return c else - Lwt.return Tez_repr.(change -? tokens_per_roll) >>=? fun change -> - create_roll_in_delegate c delegate delegate_pk >>=? fun c -> - loop c change in - is_inactive c delegate >>=? fun inactive -> - if inactive then - return c + Lwt.return Tez_repr.(change -? tokens_per_roll) + >>=? fun change -> + create_roll_in_delegate c delegate delegate_pk + >>=? fun c -> loop c change + in + is_inactive c delegate + >>=? fun inactive -> + if inactive then return c else - loop c change >>=? fun c -> - Storage.Roll.Delegate_roll_list.get_option c delegate >>=? fun rolls -> + loop c change + >>=? fun c -> + Storage.Roll.Delegate_roll_list.get_option c delegate + >>=? fun rolls -> match rolls with | None -> return c | Some _ -> - Storage.Active_delegates_with_rolls.add c delegate >>= fun c -> - return c + Storage.Active_delegates_with_rolls.add c delegate + >>= fun c -> return c let remove_amount c delegate amount = let tokens_per_roll = Constants_storage.tokens_per_roll c in let rec loop c change = - if Tez_repr.(amount <= change) - then return (c, change) + if Tez_repr.(amount <= change) then return (c, change) else - pop_roll_from_delegate c delegate >>=? fun (_, c) -> - Lwt.return Tez_repr.(change +? tokens_per_roll) >>=? fun change -> - loop c change in - Storage.Roll.Delegate_change.get c delegate >>=? fun change -> - is_inactive c delegate >>=? fun inactive -> - begin - if inactive then - return (c, change) - else - loop c change >>=? fun (c, change) -> - Storage.Roll.Delegate_roll_list.get_option c delegate >>=? fun rolls -> - match rolls with - | None -> - Storage.Active_delegates_with_rolls.del c delegate >>= fun c -> - return (c, change) - | Some _ -> - return (c, change) - end >>=? fun (c, change) -> - Lwt.return Tez_repr.(change -? amount) >>=? fun change -> - Storage.Roll.Delegate_change.set c delegate change + pop_roll_from_delegate c delegate + >>=? fun (_, c) -> + Lwt.return Tez_repr.(change +? tokens_per_roll) + >>=? fun change -> loop c change + in + Storage.Roll.Delegate_change.get c delegate + >>=? fun change -> + is_inactive c delegate + >>=? fun inactive -> + ( if inactive then return (c, change) + else + loop c change + >>=? fun (c, change) -> + Storage.Roll.Delegate_roll_list.get_option c delegate + >>=? fun rolls -> + match rolls with + | None -> + Storage.Active_delegates_with_rolls.del c delegate + >>= fun c -> return (c, change) + | Some _ -> + return (c, change) ) + >>=? fun (c, change) -> + Lwt.return Tez_repr.(change -? amount) + >>=? fun change -> Storage.Roll.Delegate_change.set c delegate change let set_inactive ctxt delegate = - ensure_inited ctxt delegate >>=? fun ctxt -> + ensure_inited ctxt delegate + >>=? fun ctxt -> let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in - Storage.Roll.Delegate_change.get ctxt delegate >>=? fun change -> - Storage.Contract.Inactive_delegate.add ctxt - (Contract_repr.implicit_contract delegate) >>= fun ctxt -> - Storage.Active_delegates_with_rolls.del ctxt delegate >>= fun ctxt -> + Storage.Roll.Delegate_change.get ctxt delegate + >>=? fun change -> + Storage.Contract.Inactive_delegate.add + ctxt + (Contract_repr.implicit_contract delegate) + >>= fun ctxt -> + Storage.Active_delegates_with_rolls.del ctxt delegate + >>= fun ctxt -> let rec loop ctxt change = - Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? function - | None -> return (ctxt, change) + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? function + | None -> + return (ctxt, change) | Some _roll -> - pop_roll_from_delegate ctxt delegate >>=? fun (_, ctxt) -> - Lwt.return Tez_repr.(change +? tokens_per_roll) >>=? fun change -> - loop ctxt change in - loop ctxt change >>=? fun (ctxt, change) -> - Storage.Roll.Delegate_change.set ctxt delegate change >>=? fun ctxt -> - return ctxt + pop_roll_from_delegate ctxt delegate + >>=? fun (_, ctxt) -> + Lwt.return Tez_repr.(change +? tokens_per_roll) + >>=? fun change -> loop ctxt change + in + loop ctxt change + >>=? fun (ctxt, change) -> + Storage.Roll.Delegate_change.set ctxt delegate change + >>=? fun ctxt -> return ctxt let set_active ctxt delegate = - is_inactive ctxt delegate >>=? fun inactive -> + is_inactive ctxt delegate + >>=? fun inactive -> let current_cycle = (Raw_context.current_level ctxt).cycle in let preserved_cycles = Constants_storage.preserved_cycles ctxt in (* When the delegate is new or inactive, she will become active in @@ -390,126 +462,143 @@ module Delegate = struct delegate to start baking. When the delegate is active, we only give her at least `preserved_cycles` after the current cycle before to be deactivated. *) - Storage.Contract.Delegate_desactivation.get_option ctxt - (Contract_repr.implicit_contract delegate) >>=? fun current_expiration -> - let expiration = match current_expiration with + Storage.Contract.Delegate_desactivation.get_option + ctxt + (Contract_repr.implicit_contract delegate) + >>=? fun current_expiration -> + let expiration = + match current_expiration with | None -> - Cycle_repr.add current_cycle (1+2*preserved_cycles) + Cycle_repr.add current_cycle (1 + (2 * preserved_cycles)) | Some current_expiration -> let delay = - if inactive then (1+2*preserved_cycles) else 1+preserved_cycles in - let updated = - Cycle_repr.add current_cycle delay in - Cycle_repr.max current_expiration updated in - Storage.Contract.Delegate_desactivation.init_set ctxt + if inactive then 1 + (2 * preserved_cycles) + else 1 + preserved_cycles + in + let updated = Cycle_repr.add current_cycle delay in + Cycle_repr.max current_expiration updated + in + Storage.Contract.Delegate_desactivation.init_set + ctxt (Contract_repr.implicit_contract delegate) - expiration >>= fun ctxt -> - if not inactive then - return ctxt - else begin - ensure_inited ctxt delegate >>=? fun ctxt -> + expiration + >>= fun ctxt -> + if not inactive then return ctxt + else + ensure_inited ctxt delegate + >>=? fun ctxt -> let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in - Storage.Roll.Delegate_change.get ctxt delegate >>=? fun change -> - Storage.Contract.Inactive_delegate.del ctxt - (Contract_repr.implicit_contract delegate) >>= fun ctxt -> - delegate_pubkey ctxt delegate >>=? fun delegate_pk -> + Storage.Roll.Delegate_change.get ctxt delegate + >>=? fun change -> + Storage.Contract.Inactive_delegate.del + ctxt + (Contract_repr.implicit_contract delegate) + >>= fun ctxt -> + delegate_pubkey ctxt delegate + >>=? fun delegate_pk -> let rec loop ctxt change = - if Tez_repr.(change < tokens_per_roll) then - return ctxt + if Tez_repr.(change < tokens_per_roll) then return ctxt else - Lwt.return Tez_repr.(change -? tokens_per_roll) >>=? fun change -> - create_roll_in_delegate ctxt delegate delegate_pk >>=? fun ctxt -> - loop ctxt change in - loop ctxt change >>=? fun ctxt -> - Storage.Roll.Delegate_roll_list.get_option ctxt delegate >>=? fun rolls -> + Lwt.return Tez_repr.(change -? tokens_per_roll) + >>=? fun change -> + create_roll_in_delegate ctxt delegate delegate_pk + >>=? fun ctxt -> loop ctxt change + in + loop ctxt change + >>=? fun ctxt -> + Storage.Roll.Delegate_roll_list.get_option ctxt delegate + >>=? fun rolls -> match rolls with | None -> return ctxt | Some _ -> - Storage.Active_delegates_with_rolls.add ctxt delegate >>= fun ctxt -> - return ctxt - end - + Storage.Active_delegates_with_rolls.add ctxt delegate + >>= fun ctxt -> return ctxt end module Contract = struct - let add_amount c contract amount = - get_contract_delegate c contract >>=? function - | None -> return c - | Some delegate -> - Delegate.add_amount c delegate amount + get_contract_delegate c contract + >>=? function + | None -> return c | Some delegate -> Delegate.add_amount c delegate amount let remove_amount c contract amount = - get_contract_delegate c contract >>=? function - | None -> return c + get_contract_delegate c contract + >>=? function + | None -> + return c | Some delegate -> Delegate.remove_amount c delegate amount - end -let init ctxt = - Storage.Roll.Next.init ctxt Roll_repr.first +let init ctxt = Storage.Roll.Next.init ctxt Roll_repr.first let init_first_cycles ctxt = let preserved = Constants_storage.preserved_cycles ctxt in (* Precompute rolls for cycle (0 --> preserved_cycles) *) List.fold_left (fun ctxt c -> - ctxt >>=? fun ctxt -> - let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in - Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt -> - snapshot_rolls_for_cycle ctxt cycle >>=? fun ctxt -> - freeze_rolls_for_cycle ctxt cycle) - (return ctxt) (0 --> preserved) >>=? fun ctxt -> + ctxt + >>=? fun ctxt -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in + Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 + >>=? fun ctxt -> + snapshot_rolls_for_cycle ctxt cycle + >>=? fun ctxt -> freeze_rolls_for_cycle ctxt cycle) + (return ctxt) + (0 --> preserved) + >>=? fun ctxt -> let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 1)) in (* Precomputed a snapshot for cycle (preserved_cycles + 1) *) - Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt -> - snapshot_rolls_for_cycle ctxt cycle >>=? fun ctxt -> + Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 + >>=? fun ctxt -> + snapshot_rolls_for_cycle ctxt cycle + >>=? fun ctxt -> (* Prepare storage for storing snapshots for cycle (preserved_cycles+2) *) let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 2)) in - Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt -> - return ctxt + Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 + >>=? fun ctxt -> return ctxt let snapshot_rolls ctxt = let current_level = Raw_context.current_level ctxt in let preserved = Constants_storage.preserved_cycles ctxt in - let cycle = Cycle_repr.add current_level.cycle (preserved+2) in + let cycle = Cycle_repr.add current_level.cycle (preserved + 2) in snapshot_rolls_for_cycle ctxt cycle let cycle_end ctxt last_cycle = let preserved = Constants_storage.preserved_cycles ctxt in - begin - match Cycle_repr.sub last_cycle preserved with - | None -> return ctxt - | Some cleared_cycle -> - clear_cycle ctxt cleared_cycle - end >>=? fun ctxt -> - let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved+1) in - freeze_rolls_for_cycle ctxt frozen_roll_cycle >>=? fun ctxt -> + ( match Cycle_repr.sub last_cycle preserved with + | None -> + return ctxt + | Some cleared_cycle -> + clear_cycle ctxt cleared_cycle ) + >>=? fun ctxt -> + let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved + 1) in + freeze_rolls_for_cycle ctxt frozen_roll_cycle + >>=? fun ctxt -> Storage.Roll.Snapshot_for_cycle.init - ctxt (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle)) 0 >>=? fun ctxt -> - return ctxt + ctxt + (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle)) + 0 + >>=? fun ctxt -> return ctxt let update_tokens_per_roll ctxt new_tokens_per_roll = let constants = Raw_context.constants ctxt in let old_tokens_per_roll = constants.tokens_per_roll in - Raw_context.patch_constants ctxt begin fun constants -> - { constants with Constants_repr.tokens_per_roll = new_tokens_per_roll } - end >>= fun ctxt -> + Raw_context.patch_constants ctxt (fun constants -> + {constants with Constants_repr.tokens_per_roll = new_tokens_per_roll}) + >>= fun ctxt -> let decrease = Tez_repr.(new_tokens_per_roll < old_tokens_per_roll) in - begin - if decrease then - Lwt.return Tez_repr.(old_tokens_per_roll -? new_tokens_per_roll) - else - Lwt.return Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll) - end >>=? fun abs_diff -> - Storage.Delegates.fold ctxt (Ok ctxt) begin fun pkh ctxt -> - Lwt.return ctxt >>=? fun ctxt -> - count_rolls ctxt pkh >>=? fun rolls -> - Lwt.return Tez_repr.(abs_diff *? Int64.of_int rolls) >>=? fun amount -> - if decrease then - Delegate.add_amount ctxt pkh amount - else - Delegate.remove_amount ctxt pkh amount - end + ( if decrease then + Lwt.return Tez_repr.(old_tokens_per_roll -? new_tokens_per_roll) + else Lwt.return Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll) ) + >>=? fun abs_diff -> + Storage.Delegates.fold ctxt (Ok ctxt) (fun pkh ctxt -> + Lwt.return ctxt + >>=? fun ctxt -> + count_rolls ctxt pkh + >>=? fun rolls -> + Lwt.return Tez_repr.(abs_diff *? Int64.of_int rolls) + >>=? fun amount -> + if decrease then Delegate.add_amount ctxt pkh amount + else Delegate.remove_amount ctxt pkh amount) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.mli index 5e901e72c..8d028b746 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/roll_storage.mli @@ -37,68 +37,96 @@ type error += | Consume_roll_change | No_roll_for_delegate | No_roll_snapshot_for_cycle of Cycle_repr.t - | Unregistered_delegate of Signature.Public_key_hash.t (* `Permanent *) + | Unregistered_delegate of Signature.Public_key_hash.t + +(* `Permanent *) val init : Raw_context.t -> Raw_context.t tzresult Lwt.t + val init_first_cycles : Raw_context.t -> Raw_context.t tzresult Lwt.t val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t -val snapshot_rolls : Raw_context.t -> Raw_context.t tzresult Lwt.t +val snapshot_rolls : Raw_context.t -> Raw_context.t tzresult Lwt.t val fold : Raw_context.t -> f:(Roll_repr.roll -> Signature.Public_key.t -> 'a -> 'a tzresult Lwt.t) -> - 'a -> 'a tzresult Lwt.t + 'a -> + 'a tzresult Lwt.t val baking_rights_owner : - Raw_context.t -> Level_repr.t -> priority:int -> + Raw_context.t -> + Level_repr.t -> + priority:int -> Signature.Public_key.t tzresult Lwt.t val endorsement_rights_owner : - Raw_context.t -> Level_repr.t -> slot:int -> + Raw_context.t -> + Level_repr.t -> + slot:int -> Signature.Public_key.t tzresult Lwt.t module Delegate : sig - val is_inactive : Raw_context.t -> Signature.Public_key_hash.t -> bool tzresult Lwt.t val add_amount : - Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t val remove_amount : - Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t + Raw_context.t -> + Signature.Public_key_hash.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t - val set_inactive : Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t - - val set_active : Raw_context.t -> Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t + val set_inactive : + Raw_context.t -> + Signature.Public_key_hash.t -> + Raw_context.t tzresult Lwt.t + val set_active : + Raw_context.t -> + Signature.Public_key_hash.t -> + Raw_context.t tzresult Lwt.t end module Contract : sig - val add_amount : - Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t + Raw_context.t -> + Contract_repr.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t val remove_amount : - Raw_context.t -> Contract_repr.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t - + Raw_context.t -> + Contract_repr.t -> + Tez_repr.t -> + Raw_context.t tzresult Lwt.t end -val delegate_pubkey: - Raw_context.t -> Signature.Public_key_hash.t -> +val delegate_pubkey : + Raw_context.t -> + Signature.Public_key_hash.t -> Signature.Public_key.t tzresult Lwt.t -val get_rolls: - Raw_context.t -> Signature.Public_key_hash.t -> Roll_repr.t list tzresult Lwt.t -val get_change: +val get_rolls : + Raw_context.t -> + Signature.Public_key_hash.t -> + Roll_repr.t list tzresult Lwt.t + +val get_change : Raw_context.t -> Signature.Public_key_hash.t -> Tez_repr.t tzresult Lwt.t -val update_tokens_per_roll: +val update_tokens_per_roll : Raw_context.t -> Tez_repr.t -> Raw_context.t tzresult Lwt.t (**/**) -val get_contract_delegate: - Raw_context.t -> Contract_repr.t -> Signature.Public_key_hash.t option tzresult Lwt.t +val get_contract_delegate : + Raw_context.t -> + Contract_repr.t -> + Signature.Public_key_hash.t option tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_expr_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_expr_hash.ml index a21e77fc8..2c7f93a04 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_expr_hash.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_expr_hash.ml @@ -25,12 +25,16 @@ let script_expr_hash = "\013\044\064\027" (* expr(54) *) -include Blake2B.Make(Base58)(struct - let name = "script_expr" - let title = "A script expression ID" - let b58check_prefix = script_expr_hash - let size = None - end) +include Blake2B.Make + (Base58) + (struct + let name = "script_expr" -let () = - Base58.check_encoded_prefix b58check_encoding "expr" 54 + let title = "A script expression ID" + + let b58check_prefix = script_expr_hash + + let size = None + end) + +let () = Base58.check_encoded_prefix b58check_encoding "expr" 54 diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.ml index 7e96549e4..a29c10189 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.ml @@ -24,28 +24,37 @@ (*****************************************************************************) type n = Natural_tag + type z = Integer_tag + type 't num = Z.t let compare x y = Z.compare x y let zero = Z.zero + let zero_n = Z.zero let to_string x = Z.to_string x + let of_string s = try Some (Z.of_string s) with _ -> None let to_int64 x = try Some (Z.to_int64 x) with _ -> None + let of_int64 n = Z.of_int64 n let to_int x = try Some (Z.to_int x) with _ -> None + let of_int n = Z.of_int n let of_zint x = x + let to_zint x = x let add x y = Z.add x y + let sub x y = Z.sub x y + let mul x y = Z.mul x y let ediv x y = @@ -55,33 +64,39 @@ let ediv x y = with _ -> None let add_n = add + let mul_n = mul + let ediv_n = ediv let abs x = Z.abs x -let is_nat x = - if Compare.Z.(x < Z.zero) then None else Some x + +let is_nat x = if Compare.Z.(x < Z.zero) then None else Some x + let neg x = Z.neg x + let int x = x let shift_left x y = - if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then - None + if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None else let y = Z.to_int y in Some (Z.shift_left x y) let shift_right x y = - if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then - None + if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None else let y = Z.to_int y in Some (Z.shift_right x y) let shift_left_n = shift_left + let shift_right_n = shift_right let logor x y = Z.logor x y + let logxor x y = Z.logxor x y + let logand x y = Z.logand x y + let lognot x = Z.lognot x diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.mli index 592e3a410..604878f4e 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_int_repr.mli @@ -81,7 +81,7 @@ val mul_n : n num -> n num -> n num (** Euclidean division between naturals. [ediv_n n d] returns [None] if divisor is zero, or [Some (q, r)] where [n = d * q + r] and [[0 <= r < d]] otherwise. *) -val ediv_n: n num -> n num -> (n num * n num) option +val ediv_n : n num -> n num -> (n num * n num) option (** Sign agnostic addition. Use {!add_n} when working with naturals to preserve the sign. *) @@ -99,7 +99,7 @@ val mul : _ num -> _ num -> z num [ediv n d] returns [None] if divisor is zero, or [Some (q, r)] where [n = d * q + r] and [[0 <= r < |d|]] otherwise. Use {!ediv_n} when working with naturals to preserve the sign. *) -val ediv: _ num -> _ num -> (z num * n num) option +val ediv : _ num -> _ num -> (z num * n num) option (** Compute the absolute value of a relative, turning it into a natural. *) val abs : z num -> n num diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml index 3e4917b1a..37c036c2b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.ml @@ -33,72 +33,80 @@ open Script_ir_translator type execution_trace = (Script.location * Gas.t * (Script.expr * string option) list) list -type error += Reject of Script.location * Script.expr * execution_trace option +type error += + | Reject of Script.location * Script.expr * execution_trace option + type error += Overflow of Script.location * execution_trace option + type error += Runtime_contract_error : Contract.t * Script.expr -> error + type error += Bad_contract_parameter of Contract.t (* `Permanent *) + type error += Cannot_serialize_log + type error += Cannot_serialize_failure + type error += Cannot_serialize_storage let () = let open Data_encoding in let trace_encoding = - (list @@ obj3 - (req "location" Script.location_encoding) - (req "gas" Gas.encoding) - (req "stack" - (list - (obj2 - (req "item" (Script.expr_encoding)) - (opt "annot" string))))) in + list + @@ obj3 + (req "location" Script.location_encoding) + (req "gas" Gas.encoding) + (req + "stack" + (list (obj2 (req "item" Script.expr_encoding) (opt "annot" string)))) + in (* Reject *) register_error_kind `Temporary ~id:"michelson_v1.script_rejected" - ~title: "Script failed" - ~description: "A FAILWITH instruction was reached" + ~title:"Script failed" + ~description:"A FAILWITH instruction was reached" (obj3 (req "location" Script.location_encoding) (req "with" Script.expr_encoding) (opt "trace" trace_encoding)) (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None) - (fun (loc, v, trace) -> Reject (loc, v, trace)); + (fun (loc, v, trace) -> Reject (loc, v, trace)) ; (* Overflow *) register_error_kind `Temporary ~id:"michelson_v1.script_overflow" - ~title: "Script failed (overflow error)" - ~description: "A FAIL instruction was reached due to the detection of an overflow" + ~title:"Script failed (overflow error)" + ~description: + "A FAIL instruction was reached due to the detection of an overflow" (obj2 (req "location" Script.location_encoding) (opt "trace" trace_encoding)) (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None) - (fun (loc, trace) -> Overflow (loc, trace)); + (fun (loc, trace) -> Overflow (loc, trace)) ; (* Runtime contract error *) register_error_kind `Temporary ~id:"michelson_v1.runtime_error" - ~title: "Script runtime error" - ~description: "Toplevel error for all runtime script errors" + ~title:"Script runtime error" + ~description:"Toplevel error for all runtime script errors" (obj2 (req "contract_handle" Contract.encoding) (req "contract_code" Script.expr_encoding)) (function | Runtime_contract_error (contract, expr) -> Some (contract, expr) - | _ -> None) - (fun (contract, expr) -> - Runtime_contract_error (contract, expr)) ; + | _ -> + None) + (fun (contract, expr) -> Runtime_contract_error (contract, expr)) ; (* Bad contract parameter *) register_error_kind `Permanent ~id:"michelson_v1.bad_contract_parameter" ~title:"Contract supplied an invalid parameter" - ~description:"Either no parameter was supplied to a contract with \ - a non-unit parameter type, a non-unit parameter was \ - passed to an account, or a parameter was supplied of \ - the wrong type" + ~description: + "Either no parameter was supplied to a contract with a non-unit \ + parameter type, a non-unit parameter was passed to an account, or a \ + parameter was supplied of the wrong type" Data_encoding.(obj1 (req "contract" Contract.encoding)) (function Bad_contract_parameter c -> Some c | _ -> None) (fun c -> Bad_contract_parameter c) ; @@ -107,8 +115,9 @@ let () = `Temporary ~id:"michelson_v1.cannot_serialize_log" ~title:"Not enough gas to serialize execution trace" - ~description:"Execution trace with stacks was to big to be serialized with \ - the provided gas" + ~description: + "Execution trace with stacks was to big to be serialized with the \ + provided gas" Data_encoding.empty (function Cannot_serialize_log -> Some () | _ -> None) (fun () -> Cannot_serialize_log) ; @@ -117,8 +126,8 @@ let () = `Temporary ~id:"michelson_v1.cannot_serialize_failure" ~title:"Not enough gas to serialize argument of FAILWITH" - ~description:"Argument of FAILWITH was too big to be serialized with \ - the provided gas" + ~description: + "Argument of FAILWITH was too big to be serialized with the provided gas" Data_encoding.empty (function Cannot_serialize_failure -> Some () | _ -> None) (fun () -> Cannot_serialize_failure) ; @@ -127,8 +136,8 @@ let () = `Temporary ~id:"michelson_v1.cannot_serialize_storage" ~title:"Not enough gas to serialize execution storage" - ~description:"The returned storage was too big to be serialized with \ - the provided gas" + ~description: + "The returned storage was too big to be serialized with the provided gas" Data_encoding.empty (function Cannot_serialize_storage -> Some () | _ -> None) (fun () -> Cannot_serialize_storage) @@ -142,891 +151,1358 @@ type 'tys stack = let unparse_stack ctxt (stack, stack_ty) = (* We drop the gas limit as this function is only used for debugging/errors. *) let ctxt = Gas.set_unlimited ctxt in - let rec unparse_stack - : type a. a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t - = function - | Empty, Empty_t -> return_nil - | Item (v, rest), Item_t (ty, rest_ty, annot) -> - unparse_data ctxt Readable ty v >>=? fun (data, _ctxt) -> - unparse_stack (rest, rest_ty) >>=? fun rest -> - let annot = match Script_ir_annot.unparse_var_annot annot with - | [] -> None - | [ a ] -> Some a - | _ -> assert false in - let data = Micheline.strip_locations data in - return ((data, annot) :: rest) in + let rec unparse_stack : + type a. + a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t + = function + | (Empty, Empty_t) -> + return_nil + | (Item (v, rest), Item_t (ty, rest_ty, annot)) -> + unparse_data ctxt Readable ty v + >>=? fun (data, _ctxt) -> + unparse_stack (rest, rest_ty) + >>=? fun rest -> + let annot = + match Script_ir_annot.unparse_var_annot annot with + | [] -> + None + | [a] -> + Some a + | _ -> + assert false + in + let data = Micheline.strip_locations data in + return ((data, annot) :: rest) + in unparse_stack (stack, stack_ty) module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter -let rec interp_stack_prefix_preserving_operation : type fbef bef faft aft result . - (fbef stack -> (faft stack * result) tzresult Lwt.t) - -> (fbef, faft, bef, aft) stack_prefix_preservation_witness - -> bef stack - -> (aft stack * result) tzresult Lwt.t = - fun f n stk -> - match n,stk with - | Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))), - Item (v0, Item (v1, Item (v2, Item (v3, Item (v4, Item (v5, Item (v6, Item (v7, Item (v8, Item (v9, Item (va, Item (vb, Item (vc, Item (vd, Item (ve, Item (vf, rest)))))))))))))))) -> - interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) -> - return (Item (v0, Item (v1, Item (v2, Item (v3, Item (v4, Item (v5, Item (v6, Item (v7, Item (v8, Item (v9, Item (va, Item (vb, Item (vc, Item (vd, Item (ve, Item (vf, rest')))))))))))))))), result) - | Prefix (Prefix (Prefix (Prefix n))), - Item (v0, Item (v1, Item (v2, Item (v3, rest)))) -> - interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) -> - return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result) - | Prefix n, Item (v, rest) -> - interp_stack_prefix_preserving_operation f n rest >>=? fun (rest', result) -> - return (Item (v, rest'), result) - | Rest, v -> f v +let rec interp_stack_prefix_preserving_operation : + type fbef bef faft aft result. + (fbef stack -> (faft stack * result) tzresult Lwt.t) -> + (fbef, faft, bef, aft) stack_prefix_preservation_witness -> + bef stack -> + (aft stack * result) tzresult Lwt.t = + fun f n stk -> + match (n, stk) with + | ( Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix + (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))), + Item + ( v0, + Item + ( v1, + Item + ( v2, + Item + ( v3, + Item + ( v4, + Item + ( v5, + Item + ( v6, + Item + ( v7, + Item + ( v8, + Item + ( v9, + Item + ( va, + Item + ( vb, + Item + ( vc, + Item + ( vd, + Item + ( ve, + Item + (vf, rest) + ) ) ) ) ) ) ) + ) ) ) ) ) ) ) ) ) -> + interp_stack_prefix_preserving_operation f n rest + >>=? fun (rest', result) -> + return + ( Item + ( v0, + Item + ( v1, + Item + ( v2, + Item + ( v3, + Item + ( v4, + Item + ( v5, + Item + ( v6, + Item + ( v7, + Item + ( v8, + Item + ( v9, + Item + ( va, + Item + ( vb, + Item + ( vc, + Item + ( vd, + Item + ( ve, + Item + ( vf, + rest' + ) ) ) + ) ) ) ) ) ) ) ) ) + ) ) ) ), + result ) + | ( Prefix (Prefix (Prefix (Prefix n))), + Item (v0, Item (v1, Item (v2, Item (v3, rest)))) ) -> + interp_stack_prefix_preserving_operation f n rest + >>=? fun (rest', result) -> + return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result) + | (Prefix n, Item (v, rest)) -> + interp_stack_prefix_preserving_operation f n rest + >>=? fun (rest', result) -> return (Item (v, rest'), result) + | (Rest, v) -> + f v -type step_constants = - { source : Contract.t ; - payer : Contract.t ; - self : Contract.t ; - amount : Tez.t ; - chain_id : Chain_id.t } +type step_constants = { + source : Contract.t; + payer : Contract.t; + self : Contract.t; + amount : Tez.t; + chain_id : Chain_id.t; +} -let rec step - : type b a. - (?log: execution_trace ref -> - context -> step_constants -> (b, a) descr -> b stack -> - (a stack * context) tzresult Lwt.t) = - fun ?log ctxt step_constants ({ instr ; loc ; _ } as descr) stack -> - Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> - let logged_return : type a b. - (b, a) descr -> - a stack * context -> - (a stack * context) tzresult Lwt.t = - fun descr (ret, ctxt) -> - match log with - | None -> return (ret, ctxt) - | Some log -> - trace - Cannot_serialize_log - (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> - log := (descr.loc, Gas.level ctxt, stack) :: !log ; - return (ret, ctxt) in - let get_log (log : execution_trace ref option) = - Option.map ~f:(fun l -> List.rev !l) log in - let consume_gas_terop : type ret arg1 arg2 arg3 rest. +let rec step : + type b a. + ?log:execution_trace ref -> + context -> + step_constants -> + (b, a) descr -> + b stack -> + (a stack * context) tzresult Lwt.t = + fun ?log ctxt step_constants ({instr; loc; _} as descr) stack -> + Lwt.return (Gas.consume ctxt Interp_costs.cycle) + >>=? fun ctxt -> + let logged_return : + type a b. + (b, a) descr -> a stack * context -> (a stack * context) tzresult Lwt.t = + fun descr (ret, ctxt) -> + match log with + | None -> + return (ret, ctxt) + | Some log -> + trace Cannot_serialize_log (unparse_stack ctxt (ret, descr.aft)) + >>=? fun stack -> + log := (descr.loc, Gas.level ctxt, stack) :: !log ; + return (ret, ctxt) + in + let get_log (log : execution_trace ref option) = + Option.map ~f:(fun l -> List.rev !l) log + in + let consume_gas_terop : + type ret arg1 arg2 arg3 rest. (_ * (_ * (_ * rest)), ret * rest) descr -> - ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> + (arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3 -> (arg1 -> arg2 -> arg3 -> Gas.cost) -> rest stack -> ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2, x3) cost_func rest -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2 x3, rest), ctxt) in - let consume_gas_binop : type ret arg1 arg2 rest. + fun descr (op, x1, x2, x3) cost_func rest -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) + >>=? fun ctxt -> logged_return descr (Item (op x1 x2 x3, rest), ctxt) + in + let consume_gas_binop : + type ret arg1 arg2 rest. (_ * (_ * rest), ret * rest) descr -> - ((arg1 -> arg2 -> ret) * arg1 * arg2) -> + (arg1 -> arg2 -> ret) * arg1 * arg2 -> (arg1 -> arg2 -> Gas.cost) -> rest stack -> context -> ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2, rest), ctxt) in - let consume_gas_unop : type ret arg rest. + fun descr (op, x1, x2) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2)) + >>=? fun ctxt -> logged_return descr (Item (op x1 x2, rest), ctxt) + in + let consume_gas_unop : + type ret arg rest. (_ * rest, ret * rest) descr -> - ((arg -> ret) * arg) -> + (arg -> ret) * arg -> (arg -> Gas.cost) -> rest stack -> context -> ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, arg) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> - logged_return descr (Item (op arg, rest), ctxt) in - let logged_return : - a stack * context -> - (a stack * context) tzresult Lwt.t = - logged_return descr in - match instr, stack with - (* stack ops *) - | Drop, Item (_, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (rest, ctxt) - | Dup, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (v, Item (v, rest)), ctxt) - | Swap, Item (vi, Item (vo, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (vo, Item (vi, rest)), ctxt) - | Const v, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - (* options *) - | Cons_some, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (Some v, rest), ctxt) - | Cons_none _, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | If_none (bt, _), Item (None, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ?log ctxt step_constants bt rest - | If_none (_, bf), Item (Some v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ?log ctxt step_constants bf (Item (v, rest)) - (* pairs *) - | Cons_pair, Item (a, Item (b, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> - logged_return (Item ((a, b), rest), ctxt) - (* Peephole optimization for UNPAIR *) - | Seq ({instr=Dup;_}, - {instr=Seq ({instr=Car;_}, - {instr=Seq ({instr=Dip {instr=Cdr}}, - {instr=Nop;_});_});_}), - Item ((a, b), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (a, Item (b, rest)), ctxt) - | Car, Item ((a, _), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (a, rest), ctxt) - | Cdr, Item ((_, b), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (b, rest), ctxt) - (* unions *) - | Left, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (L v, rest), ctxt) - | Right, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (R v, rest), ctxt) - | If_left (bt, _), Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ?log ctxt step_constants bt (Item (v, rest)) - | If_left (_, bf), Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ?log ctxt step_constants bf (Item (v, rest)) - (* lists *) - | Cons_list, Item (hd, Item (tl, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> - logged_return (Item (hd :: tl, rest), ctxt) - | Nil, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item ([], rest), ctxt) - | If_cons (_, bf), Item ([], rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ?log ctxt step_constants bf rest - | If_cons (bt, _), Item (hd :: tl, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ?log ctxt step_constants bt (Item (hd, Item (tl, rest))) - | List_map body, Item (l, rest) -> - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_map) >>=? fun ctxt -> - match l with - | [] -> return (Item (List.rev acc, rest), ctxt) - | hd :: tl -> - step ?log ctxt step_constants body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (hd :: acc) - in loop rest ctxt l [] >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | List_size, Item (list, rest) -> + fun descr (op, arg) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func arg)) + >>=? fun ctxt -> logged_return descr (Item (op arg, rest), ctxt) + in + let logged_return : a stack * context -> (a stack * context) tzresult Lwt.t = + logged_return descr + in + match (instr, stack) with + (* stack ops *) + | (Drop, Item (_, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) + >>=? fun ctxt -> logged_return (rest, ctxt) + | (Dup, Item (v, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) + >>=? fun ctxt -> logged_return (Item (v, Item (v, rest)), ctxt) + | (Swap, Item (vi, Item (vo, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) + >>=? fun ctxt -> logged_return (Item (vo, Item (vi, rest)), ctxt) + | (Const v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) + >>=? fun ctxt -> logged_return (Item (v, rest), ctxt) + (* options *) + | (Cons_some, Item (v, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) + >>=? fun ctxt -> logged_return (Item (Some v, rest), ctxt) + | (Cons_none _, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) + >>=? fun ctxt -> logged_return (Item (None, rest), ctxt) + | (If_none (bt, _), Item (None, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) + >>=? fun ctxt -> step ?log ctxt step_constants bt rest + | (If_none (_, bf), Item (Some v, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) + >>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest)) + (* pairs *) + | (Cons_pair, Item (a, Item (b, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair) + >>=? fun ctxt -> logged_return (Item ((a, b), rest), ctxt) + | (Car, Item ((a, _), rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) + >>=? fun ctxt -> logged_return (Item (a, rest), ctxt) + | (Cdr, Item ((_, b), rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) + >>=? fun ctxt -> logged_return (Item (b, rest), ctxt) + (* unions *) + | (Left, Item (v, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) + >>=? fun ctxt -> logged_return (Item (L v, rest), ctxt) + | (Right, Item (v, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) + >>=? fun ctxt -> logged_return (Item (R v, rest), ctxt) + | (If_left (bt, _), Item (L v, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) + >>=? fun ctxt -> step ?log ctxt step_constants bt (Item (v, rest)) + | (If_left (_, bf), Item (R v, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) + >>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest)) + (* lists *) + | (Cons_list, Item (hd, Item (tl, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.cons) + >>=? fun ctxt -> logged_return (Item (hd :: tl, rest), ctxt) + | (Nil, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) + >>=? fun ctxt -> logged_return (Item ([], rest), ctxt) + | (If_cons (_, bf), Item ([], rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) + >>=? fun ctxt -> step ?log ctxt step_constants bf rest + | (If_cons (bt, _), Item (hd :: tl, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) + >>=? fun ctxt -> + step ?log ctxt step_constants bt (Item (hd, Item (tl, rest))) + | (List_map body, Item (l, rest)) -> + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_map) + >>=? fun ctxt -> + match l with + | [] -> + return (Item (List.rev acc, rest), ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> loop rest ctxt tl (hd :: acc) + in + loop rest ctxt l [] >>=? fun (res, ctxt) -> logged_return (res, ctxt) + | (List_size, Item (list, rest)) -> + Lwt.return + (List.fold_left + (fun acc _ -> + acc + >>? fun (size, ctxt) -> + Gas.consume ctxt Interp_costs.loop_size + >>? fun ctxt -> ok (size + 1 (* FIXME: overflow *), ctxt)) + (ok (0, ctxt)) + list) + >>=? fun (len, ctxt) -> + logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) + | (List_iter body, Item (l, init)) -> + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) + >>=? fun ctxt -> + match l with + | [] -> + return (stack, ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> loop ctxt tl stack + in + loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt) + (* sets *) + | (Empty_set t, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_set) + >>=? fun ctxt -> logged_return (Item (empty_set t, rest), ctxt) + | (Set_iter body, Item (set, init)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) + >>=? fun ctxt -> + let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) + >>=? fun ctxt -> + match l with + | [] -> + return (stack, ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> loop ctxt tl stack + in + loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt) + | (Set_mem, Item (v, Item (set, rest))) -> + consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt + | (Set_update, Item (v, Item (presence, Item (set, rest)))) -> + consume_gas_terop + descr + (set_update, v, presence, set) + Interp_costs.set_update + rest + | (Set_size, Item (set, rest)) -> + consume_gas_unop + descr + (set_size, set) + (fun _ -> Interp_costs.set_size) + rest + ctxt + (* maps *) + | (Empty_map (t, _), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) + >>=? fun ctxt -> logged_return (Item (empty_map t, rest), ctxt) + | (Map_map body, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) + >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_map) + >>=? fun ctxt -> + match l with + | [] -> + return (Item (acc, rest), ctxt) + | ((k, _) as hd) :: tl -> + step ?log ctxt step_constants body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (map_update k (Some hd) acc) + in + loop rest ctxt l (empty_map (map_key_ty map)) + >>=? fun (res, ctxt) -> logged_return (res, ctxt) + | (Map_iter body, Item (map, init)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) + >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) + >>=? fun ctxt -> + match l with + | [] -> + return (stack, ctxt) + | hd :: tl -> + step ?log ctxt step_constants body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> loop ctxt tl stack + in + loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt) + | (Map_mem, Item (v, Item (map, rest))) -> + consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt + | (Map_get, Item (v, Item (map, rest))) -> + consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt + | (Map_update, Item (k, Item (v, Item (map, rest)))) -> + consume_gas_terop + descr + (map_update, k, v, map) + Interp_costs.map_update + rest + | (Map_size, Item (map, rest)) -> + consume_gas_unop + descr + (map_size, map) + (fun _ -> Interp_costs.map_size) + rest + ctxt + (* Big map operations *) + | (Empty_big_map (tk, tv), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) + >>=? fun ctxt -> + logged_return + (Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt) + | (Big_map_mem, Item (key, Item (map, rest))) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff)) + >>=? fun ctxt -> + Script_ir_translator.big_map_mem ctxt key map + >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt) + | (Big_map_get, Item (key, Item (map, rest))) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_get key map.diff)) + >>=? fun ctxt -> + Script_ir_translator.big_map_get ctxt key map + >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt) + | (Big_map_update, Item (key, Item (maybe_value, Item (map, rest)))) -> + consume_gas_terop + descr + (Script_ir_translator.big_map_update, key, maybe_value, map) + (fun k v m -> Interp_costs.map_update k (Some v) m.diff) + rest + (* timestamp operations *) + | (Add_seconds_to_timestamp, Item (n, Item (t, rest))) -> + consume_gas_binop + descr + (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp + rest + ctxt + | (Add_timestamp_to_seconds, Item (t, Item (n, rest))) -> + consume_gas_binop + descr + (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp + rest + ctxt + | (Sub_timestamp_seconds, Item (t, Item (s, rest))) -> + consume_gas_binop + descr + (Script_timestamp.sub_delta, t, s) + Interp_costs.sub_timestamp + rest + ctxt + | (Diff_timestamps, Item (t1, Item (t2, rest))) -> + consume_gas_binop + descr + (Script_timestamp.diff, t1, t2) + Interp_costs.diff_timestamps + rest + ctxt + (* string operations *) + | (Concat_string_pair, Item (x, Item (y, rest))) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) + >>=? fun ctxt -> + let s = String.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | (Concat_string, Item (ss, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) + >>=? fun ctxt -> + let s = String.concat "" ss in + logged_return (Item (s, rest), ctxt) + | (Slice_string, Item (offset, Item (length, Item (s, rest)))) -> + let s_length = Z.of_int (String.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then Lwt.return - (List.fold_left - (fun acc _ -> - acc >>? fun (size, ctxt) -> - Gas.consume ctxt Interp_costs.loop_size >>? fun ctxt -> - ok (size + 1 (* FIXME: overflow *), ctxt)) - (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> - logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) - | List_iter body, Item (l, init) -> - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ?log ctxt step_constants body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - (* sets *) - | Empty_set t, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> - logged_return (Item (empty_set t, rest), ctxt) - | Set_iter body, Item (set, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> - let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ?log ctxt step_constants body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Set_mem, Item (v, Item (set, rest)) -> - consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt - | Set_update, Item (v, Item (presence, Item (set, rest))) -> - consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest - | Set_size, Item (set, rest) -> - consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt - (* maps *) - | Empty_map (t, _), rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> - logged_return (Item (empty_map t, rest), ctxt) - | Map_map body, Item (map, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_map) >>=? fun ctxt -> - match l with - | [] -> return (acc, ctxt) - | (k, _) as hd :: tl -> - step ?log ctxt step_constants body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (map_update k (Some hd) acc) - in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Map_iter body, Item (map, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_iter) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ?log ctxt step_constants body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Map_mem, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt - | Map_get, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt - | Map_update, Item (k, Item (v, Item (map, rest))) -> - consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest - | Map_size, Item (map, rest) -> - consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt - (* Big map operations *) - | Empty_big_map (tk, tv), rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> - logged_return (Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt) - | Big_map_mem, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff)) >>=? fun ctxt -> - Script_ir_translator.big_map_mem ctxt key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_get, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_get key map.diff)) >>=? fun ctxt -> - Script_ir_translator.big_map_get ctxt key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> - consume_gas_terop descr - (Script_ir_translator.big_map_update, key, maybe_value, map) - (fun k v m -> Interp_costs.map_update k (Some v) m.diff) rest - (* timestamp operations *) - | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> - consume_gas_binop descr - (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> - consume_gas_binop descr (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> - consume_gas_binop descr (Script_timestamp.sub_delta, t, s) - Interp_costs.sub_timestamp rest ctxt - | Diff_timestamps, Item (t1, Item (t2, rest)) -> - consume_gas_binop descr (Script_timestamp.diff, t1, t2) - Interp_costs.diff_timestamps rest ctxt - (* string operations *) - | Concat_string_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> - let s = String.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_string, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> - let s = String.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_string, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (String.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | String_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) - (* bytes operations *) - | Concat_bytes_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> - let s = MBytes.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_bytes, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> - let s = MBytes.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (MBytes.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | Bytes_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) - (* currency operations *) - | Add_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x +? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Sub_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x -? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Mul_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - | Mul_nattez, Item (y, Item (x, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - (* boolean operations *) - | Or, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt - | And, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt - | Xor, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt - | Not, Item (x, rest) -> - consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt - (* integer operations *) - | Is_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt - | Abs_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt - | Int_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt - | Neg_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Neg_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Add_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt - | Sub_int, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt - | Mul_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt - | Ediv_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - let x = Script_int.of_int64 (Tez.to_mutez x) in - consume_gas_binop descr - ((fun x y -> - match Script_int.ediv x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 q, - Script_int.to_int64 r with - | Some q, Some r -> - begin - match Tez.of_mutez q, Tez.of_mutez r with - | Some q, Some r -> Some (q,r) - (* Cannot overflow *) - | _ -> assert false - end - (* Cannot overflow *) - | _ -> assert false), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - 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 - consume_gas_binop descr - ((fun x y -> match Script_int.ediv_n x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 r with - | None -> assert false (* Cannot overflow *) - | Some r -> - match Tez.of_mutez r with - | None -> assert false (* Cannot overflow *) - | Some r -> Some (q, r)), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt - | Lsl_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> - begin - match Script_int.shift_left_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some x -> logged_return (Item (x, rest), ctxt) - end - | Lsr_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> - begin - match Script_int.shift_right_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some r -> logged_return (Item (r, rest), ctxt) - end - | Or_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt - | And_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | And_int_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | Xor_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt - | Not_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - | Not_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - (* control *) - | Seq (hd, tl), stack -> - step ?log ctxt step_constants hd stack >>=? fun (trans, ctxt) -> - step ?log ctxt step_constants tl trans - | If (bt, _), Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ?log ctxt step_constants bt rest - | If (_, bf), Item (false, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ?log ctxt step_constants bf rest - | Loop body, Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step ?log ctxt step_constants body rest >>=? fun (trans, ctxt) -> - step ?log ctxt step_constants descr trans - | Loop _, Item (false, rest) -> - logged_return (rest, ctxt) - | Loop_left body, Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step ?log ctxt step_constants body (Item (v, rest)) >>=? fun (trans, ctxt) -> - step ?log ctxt step_constants descr trans - | Loop_left _, Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - | Dip b, Item (ign, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - step ?log ctxt step_constants b rest >>=? fun (res, ctxt) -> - logged_return (Item (ign, res), ctxt) - | Exec, Item (arg, Item (lam, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> - interp ?log ctxt step_constants lam arg >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Apply capture_ty, Item (capture, Item (lam, rest)) -> ( - Lwt.return (Gas.consume ctxt Interp_costs.apply) >>=? fun ctxt -> - let (Lam (descr, expr)) = lam in - let (Item_t (full_arg_ty , _ , _)) = descr.bef in - unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> - unparse_ty 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, Empty_t, None) in - let const_descr = ({ - loc = descr.loc ; - bef = arg_stack_ty ; - aft = Item_t (capture_ty, arg_stack_ty, None) ; - instr = Const capture ; - } : (_, _) descr) in - let pair_descr = ({ - loc = descr.loc ; - bef = Item_t (capture_ty, arg_stack_ty, None) ; - aft = Item_t (full_arg_ty, Empty_t, None) ; - instr = Cons_pair ; - } : (_, _) descr) in - let seq_descr = ({ - loc = descr.loc ; - bef = arg_stack_ty ; - aft = Item_t (full_arg_ty, Empty_t, None) ; - instr = Seq (const_descr, pair_descr) ; - } : (_, _) descr) in - let full_descr = ({ - loc = descr.loc ; - bef = arg_stack_ty ; - aft = descr.aft ; - instr = Seq (seq_descr, descr) ; - } : (_, _) descr) in - let full_expr = Micheline.Seq (0, [ - Prim (0, I_PUSH, [ ty_expr ; const_expr ], []) ; - Prim (0, I_PAIR, [], []) ; - expr ]) in - let lam' = Lam (full_descr, full_expr) in - logged_return (Item (lam', rest), ctxt) - ) - | _ -> assert false - ) - | Lambda lam, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (lam, rest), ctxt) - | Failwith tv, Item (v, _) -> - trace Cannot_serialize_failure - (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - fail (Reject (loc, v, get_log log)) - | Nop, stack -> - logged_return (stack, ctxt) - (* comparison *) - | Compare ty, Item (a, Item (b, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b)) >>=? fun ctxt -> - logged_return (Item (Script_int.of_int @@ Script_ir_translator.compare_comparable ty a b, rest), ctxt) - (* comparators *) - | Eq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres = 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Neq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <> 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Lt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres < 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Le, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Gt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres > 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Ge, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres >= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - (* packing *) - | Pack t, Item (value, rest) -> - Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> - logged_return (Item (bytes, rest), ctxt) - | Unpack t, Item (bytes, rest) -> - Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> - if Compare.Int.(MBytes.length bytes >= 1) && - Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then - let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in - match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with - | None -> - Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | Some expr -> - Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> - parse_data ctxt ~legacy:false t (Micheline.root expr) >>= function - | Ok (value, ctxt) -> - logged_return (Item (Some value, rest), ctxt) - | Error _ignored -> - Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - else - logged_return (Item (None, rest), ctxt) - (* protocol *) - | Address, Item ((_, address), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> - logged_return (Item (address, rest), ctxt) - | Contract (t, entrypoint), Item (contract, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> - begin match contract, entrypoint with - | (contract, "default"), entrypoint | (contract, entrypoint), "default" -> - Script_ir_translator.parse_contract_for_script - ~legacy:false ctxt loc t contract ~entrypoint >>=? fun (ctxt, maybe_contract) -> - logged_return (Item (maybe_contract, rest), ctxt) - | _ -> logged_return (Item (None, rest), ctxt) - end - | Transfer_tokens, - Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> - collect_big_maps ctxt tp p >>=? fun (to_duplicate, ctxt) -> - let to_update = no_big_map_id in - extract_big_map_diff ctxt Optimized tp p - ~to_duplicate ~to_update ~temporary:true >>=? fun (p, big_map_diff, ctxt) -> - unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> - let operation = - Transaction - { amount ; destination ; entrypoint ; - parameters = Script.lazy_expr (Micheline.strip_locations p) } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), rest), ctxt) - | Create_account, - Item (manager, Item (delegate, Item (_delegatable, Item (credit, rest)))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - (* store in optimized binary representation - as unparsed with [Optimized]. *) - let manager_bytes = - Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding manager in - let storage = - Script_repr.lazy_expr @@ Micheline.strip_locations @@ - Micheline.Bytes (0, manager_bytes) in - let script = - { code = Legacy_support.manager_script_code ; - storage ; - } in - let operation = - Origination - { credit ; delegate ; preorigination = Some contract ; script } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, None), - Item ((contract, "default"), rest)), ctxt) - | Implicit_account, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> - let contract = Contract.implicit_contract key in - logged_return (Item ((Unit_t None, (contract, "default")), rest), ctxt) - | Create_contract (storage_type, param_type, Lam (_, code), root_name), - Item (manager, Item - (delegate, Item - (spendable, Item - (delegatable, Item - (credit, Item - (init, rest)))))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> - unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> - let unparsed_param_type = - Script_ir_translator.add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None unparsed_param_type in - unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> - let code = - Script.lazy_expr @@ - Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; - Prim (0, K_storage, [ unparsed_storage_type ], []) ; - Prim (0, K_code, [ code ], []) ])) in - collect_big_maps ctxt storage_type init >>=? fun (to_duplicate, ctxt) -> - let to_update = no_big_map_id in - extract_big_map_diff ctxt Optimized storage_type init - ~to_duplicate ~to_update ~temporary:true >>=? fun (init, big_map_diff, ctxt) -> - unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> - let storage = Script.lazy_expr @@ Micheline.strip_locations storage in - begin - if spendable then - Legacy_support.add_do ~manager_pkh:manager - ~script_code:code ~script_storage:storage - else if delegatable then - Legacy_support.add_set_delegate ~manager_pkh:manager - ~script_code:code ~script_storage:storage - else if Legacy_support.has_default_entrypoint code then - Legacy_support.add_root_entrypoint code >>=? fun code -> - return (code, storage) - else return (code, storage) - end >>=? fun (code, storage) -> - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; delegate ; preorigination = Some contract ; - script = { code ; storage } } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) + >>=? fun ctxt -> logged_return - (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), - Item ((contract, "default"), rest)), ctxt) - | Create_contract_2 (storage_type, param_type, Lam (_, code), root_name), + ( Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), + ctxt ) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) + >>=? fun ctxt -> logged_return (Item (None, rest), ctxt) + | (String_size, Item (s, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) + >>=? fun ctxt -> + logged_return + (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) + (* bytes operations *) + | (Concat_bytes_pair, Item (x, Item (y, rest))) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) + >>=? fun ctxt -> + let s = MBytes.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | (Concat_bytes, Item (ss, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) + >>=? fun ctxt -> + let s = MBytes.concat "" ss in + logged_return (Item (s, rest), ctxt) + | (Slice_bytes, Item (offset, Item (length, Item (s, rest)))) -> + let s_length = Z.of_int (MBytes.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return + (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) + >>=? fun ctxt -> + logged_return + ( Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), + ctxt ) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) + >>=? fun ctxt -> logged_return (Item (None, rest), ctxt) + | (Bytes_size, Item (s, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) + >>=? fun ctxt -> + logged_return + (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) + (* currency operations *) + | (Add_tez, Item (x, Item (y, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) + >>=? fun ctxt -> + Lwt.return Tez.(x +? y) + >>=? fun res -> logged_return (Item (res, rest), ctxt) + | (Sub_tez, Item (x, Item (y, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) + >>=? fun ctxt -> + Lwt.return Tez.(x -? y) + >>=? fun res -> logged_return (Item (res, rest), ctxt) + | (Mul_teznat, Item (x, Item (y, rest))) -> ( + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) + >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) + >>=? fun ctxt -> + match Script_int.to_int64 y with + | None -> + fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) + >>=? fun res -> logged_return (Item (res, rest), ctxt) ) + | (Mul_nattez, Item (y, Item (x, rest))) -> ( + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) + >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) + >>=? fun ctxt -> + match Script_int.to_int64 y with + | None -> + fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) + >>=? fun res -> logged_return (Item (res, rest), ctxt) ) + (* boolean operations *) + | (Or, Item (x, Item (y, rest))) -> + consume_gas_binop descr (( || ), x, y) Interp_costs.bool_binop rest ctxt + | (And, Item (x, Item (y, rest))) -> + consume_gas_binop descr (( && ), x, y) Interp_costs.bool_binop rest ctxt + | (Xor, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Compare.Bool.( <> ), x, y) + Interp_costs.bool_binop + rest + ctxt + | (Not, Item (x, rest)) -> + consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt + (* integer operations *) + | (Is_nat, Item (x, rest)) -> + consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt + | (Abs_int, Item (x, rest)) -> + consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt + | (Int_nat, Item (x, rest)) -> + consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt + | (Neg_int, Item (x, rest)) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | (Neg_nat, Item (x, rest)) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | (Add_intint, Item (x, Item (y, rest))) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | (Add_intnat, Item (x, Item (y, rest))) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | (Add_natint, Item (x, Item (y, rest))) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | (Add_natnat, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.add_n, x, y) + Interp_costs.add + rest + ctxt + | (Sub_int, Item (x, Item (y, rest))) -> + consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt + | (Mul_intint, Item (x, Item (y, rest))) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | (Mul_intnat, Item (x, Item (y, rest))) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | (Mul_natint, Item (x, Item (y, rest))) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | (Mul_natnat, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.mul_n, x, y) + Interp_costs.mul + rest + ctxt + | (Ediv_teznat, Item (x, Item (y, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) + >>=? fun ctxt -> + let x = Script_int.of_int64 (Tez.to_mutez x) in + consume_gas_binop + descr + ( (fun x y -> + match Script_int.ediv x y with + | None -> + None + | Some (q, r) -> ( + match (Script_int.to_int64 q, Script_int.to_int64 r) with + | (Some q, Some r) -> ( + match (Tez.of_mutez q, Tez.of_mutez r) with + | (Some q, Some r) -> + Some (q, r) + (* Cannot overflow *) + | _ -> + assert false ) + (* Cannot overflow *) + | _ -> + assert false )), + x, + y ) + Interp_costs.div + rest + ctxt + | (Ediv_tez, Item (x, Item (y, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) + >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) + >>=? fun ctxt -> + 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 + consume_gas_binop + descr + ( (fun x y -> + match Script_int.ediv_n x y with + | None -> + None + | Some (q, r) -> ( + match Script_int.to_int64 r with + | None -> + assert false (* Cannot overflow *) + | Some r -> ( + match Tez.of_mutez r with + | None -> + assert false (* Cannot overflow *) + | Some r -> + Some (q, r) ) )), + x, + y ) + Interp_costs.div + rest + ctxt + | (Ediv_intint, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.ediv, x, y) + Interp_costs.div + rest + ctxt + | (Ediv_intnat, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.ediv, x, y) + Interp_costs.div + rest + ctxt + | (Ediv_natint, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.ediv, x, y) + Interp_costs.div + rest + ctxt + | (Ediv_natnat, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.ediv_n, x, y) + Interp_costs.div + rest + ctxt + | (Lsl_nat, Item (x, Item (y, rest))) -> ( + Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) + >>=? fun ctxt -> + match Script_int.shift_left_n x y with + | None -> + fail (Overflow (loc, get_log log)) + | Some x -> + logged_return (Item (x, rest), ctxt) ) + | (Lsr_nat, Item (x, Item (y, rest))) -> ( + Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) + >>=? fun ctxt -> + match Script_int.shift_right_n x y with + | None -> + fail (Overflow (loc, get_log log)) + | Some r -> + logged_return (Item (r, rest), ctxt) ) + | (Or_nat, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.logor, x, y) + Interp_costs.logor + rest + ctxt + | (And_nat, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.logand, x, y) + Interp_costs.logand + rest + ctxt + | (And_int_nat, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.logand, x, y) + Interp_costs.logand + rest + ctxt + | (Xor_nat, Item (x, Item (y, rest))) -> + consume_gas_binop + descr + (Script_int.logxor, x, y) + Interp_costs.logxor + rest + ctxt + | (Not_int, Item (x, rest)) -> + consume_gas_unop + descr + (Script_int.lognot, x) + Interp_costs.lognot + rest + ctxt + | (Not_nat, Item (x, rest)) -> + consume_gas_unop + descr + (Script_int.lognot, x) + Interp_costs.lognot + rest + ctxt + (* control *) + | (Seq (hd, tl), stack) -> + step ?log ctxt step_constants hd stack + >>=? fun (trans, ctxt) -> step ?log ctxt step_constants tl trans + | (If (bt, _), Item (true, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) + >>=? fun ctxt -> step ?log ctxt step_constants bt rest + | (If (_, bf), Item (false, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) + >>=? fun ctxt -> step ?log ctxt step_constants bf rest + | (Loop body, Item (true, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) + >>=? fun ctxt -> + step ?log ctxt step_constants body rest + >>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans + | (Loop _, Item (false, rest)) -> + logged_return (rest, ctxt) + | (Loop_left body, Item (L v, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) + >>=? fun ctxt -> + step ?log ctxt step_constants body (Item (v, rest)) + >>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans + | (Loop_left _, Item (R v, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) + >>=? fun ctxt -> logged_return (Item (v, rest), ctxt) + | (Dip b, Item (ign, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) + >>=? fun ctxt -> + step ?log ctxt step_constants b rest + >>=? fun (res, ctxt) -> logged_return (Item (ign, res), ctxt) + | (Exec, Item (arg, Item (lam, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.exec) + >>=? fun ctxt -> + interp ?log ctxt step_constants lam arg + >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt) + | (Apply capture_ty, Item (capture, Item (lam, rest))) -> ( + Lwt.return (Gas.consume ctxt Interp_costs.apply) + >>=? fun ctxt -> + let (Lam (descr, expr)) = lam in + let (Item_t (full_arg_ty, _, _)) = descr.bef in + unparse_data ctxt Optimized capture_ty capture + >>=? fun (const_expr, ctxt) -> + unparse_ty 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, Empty_t, None) in + let const_descr = + ( { + loc = descr.loc; + bef = arg_stack_ty; + aft = Item_t (capture_ty, arg_stack_ty, None); + instr = Const capture; + } + : (_, _) descr ) + in + let pair_descr = + ( { + loc = descr.loc; + bef = Item_t (capture_ty, arg_stack_ty, None); + aft = Item_t (full_arg_ty, Empty_t, None); + instr = Cons_pair; + } + : (_, _) descr ) + in + let seq_descr = + ( { + loc = descr.loc; + bef = arg_stack_ty; + aft = Item_t (full_arg_ty, Empty_t, None); + instr = Seq (const_descr, pair_descr); + } + : (_, _) descr ) + in + let full_descr = + ( { + loc = descr.loc; + bef = arg_stack_ty; + aft = descr.aft; + instr = Seq (seq_descr, descr); + } + : (_, _) descr ) + in + let full_expr = + Micheline.Seq + ( 0, + [ Prim (0, I_PUSH, [ty_expr; const_expr], []); + Prim (0, I_PAIR, [], []); + expr ] ) + in + let lam' = Lam (full_descr, full_expr) in + logged_return (Item (lam', rest), ctxt) + | _ -> + assert false ) + | (Lambda lam, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) + >>=? fun ctxt -> logged_return (Item (lam, rest), ctxt) + | (Failwith tv, Item (v, _)) -> + trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) + >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + fail (Reject (loc, v, get_log log)) + | (Nop, stack) -> + logged_return (stack, ctxt) + (* comparison *) + | (Compare ty, Item (a, Item (b, rest))) -> + Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b)) + >>=? fun ctxt -> + logged_return + ( Item + ( Script_int.of_int + @@ Script_ir_translator.compare_comparable ty a b, + rest ), + ctxt ) + (* comparators *) + | (Eq, Item (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres = 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) + >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt) + | (Neq, Item (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <> 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) + >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt) + | (Lt, Item (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres < 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) + >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt) + | (Le, Item (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) + >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt) + | (Gt, Item (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres > 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) + >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt) + | (Ge, Item (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres >= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) + >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt) + (* packing *) + | (Pack t, Item (value, rest)) -> + Script_ir_translator.pack_data ctxt t value + >>=? fun (bytes, ctxt) -> logged_return (Item (bytes, rest), ctxt) + | (Unpack t, Item (bytes, rest)) -> + Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) + >>=? fun () -> + if + Compare.Int.(MBytes.length bytes >= 1) + && Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) + then + let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in + match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) + >>=? fun ctxt -> logged_return (Item (None, rest), ctxt) + | Some expr -> ( + Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) + >>=? fun ctxt -> + parse_data ctxt ~legacy:false t (Micheline.root expr) + >>= function + | Ok (value, ctxt) -> + logged_return (Item (Some value, rest), ctxt) + | Error _ignored -> + Lwt.return + (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) + >>=? fun ctxt -> logged_return (Item (None, rest), ctxt) ) + else logged_return (Item (None, rest), ctxt) + (* protocol *) + | (Address, Item ((_, address), rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.address) + >>=? fun ctxt -> logged_return (Item (address, rest), ctxt) + | (Contract (t, entrypoint), Item (contract, rest)) -> ( + Lwt.return (Gas.consume ctxt Interp_costs.contract) + >>=? fun ctxt -> + match (contract, entrypoint) with + | ((contract, "default"), entrypoint) + | ((contract, entrypoint), "default") -> + Script_ir_translator.parse_contract_for_script + ~legacy:false + ctxt + loc + t + contract + ~entrypoint + >>=? fun (ctxt, maybe_contract) -> + logged_return (Item (maybe_contract, rest), ctxt) + | _ -> + logged_return (Item (None, rest), ctxt) ) + | ( Transfer_tokens, + Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) ) + -> + Lwt.return (Gas.consume ctxt Interp_costs.transfer) + >>=? fun ctxt -> + collect_big_maps ctxt tp p + >>=? fun (to_duplicate, ctxt) -> + let to_update = no_big_map_id in + extract_big_map_diff + ctxt + Optimized + tp + p + ~to_duplicate + ~to_update + ~temporary:true + >>=? fun (p, big_map_diff, ctxt) -> + unparse_data ctxt Optimized tp p + >>=? fun (p, ctxt) -> + let operation = + Transaction + { + amount; + destination; + entrypoint; + parameters = Script.lazy_expr (Micheline.strip_locations p); + } + in + Lwt.return (fresh_internal_nonce ctxt) + >>=? fun (ctxt, nonce) -> + logged_return + ( Item + ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + big_map_diff ), + rest ), + ctxt ) + | ( Create_account, + Item (manager, Item (delegate, Item (_delegatable, Item (credit, rest)))) + ) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) + >>=? fun ctxt -> + Contract.fresh_contract_from_current_nonce ctxt + >>=? fun (ctxt, contract) -> + (* store in optimized binary representation - as unparsed with [Optimized]. *) + let manager_bytes = + Data_encoding.Binary.to_bytes_exn + Signature.Public_key_hash.encoding + manager + in + let storage = + Script_repr.lazy_expr @@ Micheline.strip_locations + @@ Micheline.Bytes (0, manager_bytes) + in + let script = {code = Legacy_support.manager_script_code; storage} in + let operation = + Origination {credit; delegate; preorigination = Some contract; script} + in + Lwt.return (fresh_internal_nonce ctxt) + >>=? fun (ctxt, nonce) -> + logged_return + ( Item + ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + None ), + Item ((contract, "default"), rest) ), + ctxt ) + | (Implicit_account, Item (key, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) + >>=? fun ctxt -> + let contract = Contract.implicit_contract key in + logged_return (Item ((Unit_t None, (contract, "default")), rest), ctxt) + | ( Create_contract (storage_type, param_type, Lam (_, code), root_name), + Item + ( manager, + Item + ( delegate, + Item + ( spendable, + Item (delegatable, Item (credit, Item (init, rest))) ) ) ) ) + -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) + >>=? fun ctxt -> + unparse_ty ctxt param_type + >>=? fun (unparsed_param_type, ctxt) -> + let unparsed_param_type = + Script_ir_translator.add_field_annot + (Option.map ~f:(fun n -> `Field_annot n) root_name) + None + unparsed_param_type + in + unparse_ty ctxt storage_type + >>=? fun (unparsed_storage_type, ctxt) -> + let code = + Script.lazy_expr + @@ Micheline.strip_locations + (Seq + ( 0, + [ Prim (0, K_parameter, [unparsed_param_type], []); + Prim (0, K_storage, [unparsed_storage_type], []); + Prim (0, K_code, [code], []) ] )) + in + collect_big_maps ctxt storage_type init + >>=? fun (to_duplicate, ctxt) -> + let to_update = no_big_map_id in + extract_big_map_diff + ctxt + Optimized + storage_type + init + ~to_duplicate + ~to_update + ~temporary:true + >>=? fun (init, big_map_diff, ctxt) -> + unparse_data ctxt Optimized storage_type init + >>=? fun (storage, ctxt) -> + let storage = Script.lazy_expr @@ Micheline.strip_locations storage in + ( if spendable then + Legacy_support.add_do + ~manager_pkh:manager + ~script_code:code + ~script_storage:storage + else if delegatable then + Legacy_support.add_set_delegate + ~manager_pkh:manager + ~script_code:code + ~script_storage:storage + else if Legacy_support.has_default_entrypoint code then + Legacy_support.add_root_entrypoint code + >>=? fun code -> return (code, storage) + else return (code, storage) ) + >>=? fun (code, storage) -> + Contract.fresh_contract_from_current_nonce ctxt + >>=? fun (ctxt, contract) -> + let operation = + Origination + { + credit; + delegate; + preorigination = Some contract; + script = {code; storage}; + } + in + Lwt.return (fresh_internal_nonce ctxt) + >>=? fun (ctxt, nonce) -> + logged_return + ( Item + ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + big_map_diff ), + Item ((contract, "default"), rest) ), + ctxt ) + | ( Create_contract_2 (storage_type, param_type, Lam (_, code), root_name), (* Removed the instruction's arguments manager, spendable and delegatable *) - Item (delegate, Item - (credit, Item - (init, rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> - unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> - let unparsed_param_type = - Script_ir_translator.add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None unparsed_param_type in - unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> - let code = - Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; - Prim (0, K_storage, [ unparsed_storage_type ], []) ; - Prim (0, K_code, [ code ], []) ])) in - collect_big_maps ctxt storage_type init >>=? fun (to_duplicate, ctxt) -> - let to_update = no_big_map_id in - extract_big_map_diff ctxt Optimized storage_type init - ~to_duplicate ~to_update ~temporary:true >>=? fun (init, big_map_diff, ctxt) -> - unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> - let storage = Micheline.strip_locations storage in - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; delegate ; preorigination = Some contract ; - script = { code = Script.lazy_expr code ; - storage = Script.lazy_expr storage } } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return - (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, big_map_diff), - Item ((contract, "default"), rest)), ctxt) - | Set_delegate, - Item (delegate, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - let operation = Delegation delegate in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item ((Internal_operation { source = step_constants.self ; operation ; nonce }, None), rest), ctxt) - | Balance, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> - Contract.get_balance ctxt step_constants.self >>=? fun balance -> - logged_return (Item (balance, rest), ctxt) - | Now, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> - let now = Script_timestamp.now ctxt in - logged_return (Item (now, rest), ctxt) - | Check_signature, Item (key, Item (signature, Item (message, rest))) -> - Lwt.return (Gas.consume ctxt (Interp_costs.check_signature key message)) >>=? fun ctxt -> - let res = Signature.check key signature message in - logged_return (Item (res, rest), ctxt) - | Hash_key, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> - logged_return (Item (Signature.Public_key.hash key, rest), ctxt) - | Blake2b, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash_blake2b bytes)) >>=? fun ctxt -> - let hash = Raw_hashes.blake2b bytes in - logged_return (Item (hash, rest), ctxt) - | Sha256, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha256 bytes)) >>=? fun ctxt -> - let hash = Raw_hashes.sha256 bytes in - logged_return (Item (hash, rest), ctxt) - | Sha512, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha512 bytes)) >>=? fun ctxt -> - let hash = Raw_hashes.sha512 bytes in - logged_return (Item (hash, rest), ctxt) - | Steps_to_quota, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> - let steps = match Gas.level ctxt with - | Limited { remaining } -> remaining - | Unaccounted -> Z.of_string "99999999" in - logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) - | Source, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item ((step_constants.payer, "default"), rest), ctxt) - | Sender, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item ((step_constants.source, "default"), rest), ctxt) - | Self (t, entrypoint), rest -> - Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> - logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt) - | Amount, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> - logged_return (Item (step_constants.amount, rest), ctxt) - | Dig (n, n'), stack -> - Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> - interp_stack_prefix_preserving_operation (fun (Item (v, rest)) -> return (rest, v)) n' stack - >>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt) - | Dug (n, n'), Item (v, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> - interp_stack_prefix_preserving_operation (fun stk -> return (Item (v, stk), ())) n' rest - >>=? fun (aft, ()) -> logged_return (aft, ctxt) - | Dipn (n, n', b), stack -> - Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> - interp_stack_prefix_preserving_operation (fun stk -> - step ?log ctxt step_constants b stk >>=? fun (res, ctxt') -> - return (res, ctxt')) n' stack - >>=? fun (aft, ctxt') -> logged_return (aft, ctxt') - | Dropn (n, n'), stack -> - Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) >>=? fun ctxt -> - interp_stack_prefix_preserving_operation (fun stk -> return (stk, stk)) n' stack - >>=? fun (_, rest) -> logged_return (rest, ctxt) - | ChainId, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.chain_id) >>=? fun ctxt -> - logged_return (Item (step_constants.chain_id, rest), ctxt) + Item (delegate, Item (credit, Item (init, rest))) ) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) + >>=? fun ctxt -> + unparse_ty ctxt param_type + >>=? fun (unparsed_param_type, ctxt) -> + let unparsed_param_type = + Script_ir_translator.add_field_annot + (Option.map ~f:(fun n -> `Field_annot n) root_name) + None + unparsed_param_type + in + unparse_ty ctxt storage_type + >>=? fun (unparsed_storage_type, ctxt) -> + let code = + Micheline.strip_locations + (Seq + ( 0, + [ Prim (0, K_parameter, [unparsed_param_type], []); + Prim (0, K_storage, [unparsed_storage_type], []); + Prim (0, K_code, [code], []) ] )) + in + collect_big_maps ctxt storage_type init + >>=? fun (to_duplicate, ctxt) -> + let to_update = no_big_map_id in + extract_big_map_diff + ctxt + Optimized + storage_type + init + ~to_duplicate + ~to_update + ~temporary:true + >>=? fun (init, big_map_diff, ctxt) -> + unparse_data ctxt Optimized storage_type init + >>=? fun (storage, ctxt) -> + let storage = Micheline.strip_locations storage in + Contract.fresh_contract_from_current_nonce ctxt + >>=? fun (ctxt, contract) -> + let operation = + Origination + { + credit; + delegate; + preorigination = Some contract; + script = + { + code = Script.lazy_expr code; + storage = Script.lazy_expr storage; + }; + } + in + Lwt.return (fresh_internal_nonce ctxt) + >>=? fun (ctxt, nonce) -> + logged_return + ( Item + ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + big_map_diff ), + Item ((contract, "default"), rest) ), + ctxt ) + | (Set_delegate, Item (delegate, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) + >>=? fun ctxt -> + let operation = Delegation delegate in + Lwt.return (fresh_internal_nonce ctxt) + >>=? fun (ctxt, nonce) -> + logged_return + ( Item + ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + None ), + rest ), + ctxt ) + | (Balance, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.balance) + >>=? fun ctxt -> + Contract.get_balance ctxt step_constants.self + >>=? fun balance -> logged_return (Item (balance, rest), ctxt) + | (Now, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.now) + >>=? fun ctxt -> + let now = Script_timestamp.now ctxt in + logged_return (Item (now, rest), ctxt) + | (Check_signature, Item (key, Item (signature, Item (message, rest)))) -> + Lwt.return (Gas.consume ctxt (Interp_costs.check_signature key message)) + >>=? fun ctxt -> + let res = Signature.check key signature message in + logged_return (Item (res, rest), ctxt) + | (Hash_key, Item (key, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.hash_key) + >>=? fun ctxt -> + logged_return (Item (Signature.Public_key.hash key, rest), ctxt) + | (Blake2b, Item (bytes, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash_blake2b bytes)) + >>=? fun ctxt -> + let hash = Raw_hashes.blake2b bytes in + logged_return (Item (hash, rest), ctxt) + | (Sha256, Item (bytes, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha256 bytes)) + >>=? fun ctxt -> + let hash = Raw_hashes.sha256 bytes in + logged_return (Item (hash, rest), ctxt) + | (Sha512, Item (bytes, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha512 bytes)) + >>=? fun ctxt -> + let hash = Raw_hashes.sha512 bytes in + logged_return (Item (hash, rest), ctxt) + | (Steps_to_quota, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) + >>=? fun ctxt -> + let steps = + match Gas.level ctxt with + | Limited {remaining} -> + remaining + | Unaccounted -> + Z.of_string "99999999" + in + logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) + | (Source, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.source) + >>=? fun ctxt -> + logged_return (Item ((step_constants.payer, "default"), rest), ctxt) + | (Sender, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.source) + >>=? fun ctxt -> + logged_return (Item ((step_constants.source, "default"), rest), ctxt) + | (Self (t, entrypoint), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.self) + >>=? fun ctxt -> + logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt) + | (Amount, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.amount) + >>=? fun ctxt -> logged_return (Item (step_constants.amount, rest), ctxt) + | (Dig (n, n'), stack) -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) + >>=? fun ctxt -> + interp_stack_prefix_preserving_operation + (fun (Item (v, rest)) -> return (rest, v)) + n' + stack + >>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt) + | (Dug (n, n'), Item (v, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) + >>=? fun ctxt -> + interp_stack_prefix_preserving_operation + (fun stk -> return (Item (v, stk), ())) + n' + rest + >>=? fun (aft, ()) -> logged_return (aft, ctxt) + | (Dipn (n, n', b), stack) -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) + >>=? fun ctxt -> + interp_stack_prefix_preserving_operation + (fun stk -> + step ?log ctxt step_constants b stk + >>=? fun (res, ctxt') -> return (res, ctxt')) + n' + stack + >>=? fun (aft, ctxt') -> logged_return (aft, ctxt') + | (Dropn (n, n'), stack) -> + Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n)) + >>=? fun ctxt -> + interp_stack_prefix_preserving_operation + (fun stk -> return (stk, stk)) + n' + stack + >>=? fun (_, rest) -> logged_return (rest, ctxt) + | (ChainId, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.chain_id) + >>=? fun ctxt -> + logged_return (Item (step_constants.chain_id, rest), ctxt) -and interp - : type p r. - (?log: execution_trace ref -> - context -> - step_constants -> (p, r) lambda -> p -> - (r * context) tzresult Lwt.t) - = fun ?log ctxt step_constants (Lam (code, _)) arg -> - let stack = (Item (arg, Empty)) in - begin match log with - | None -> return_unit - | Some log -> - trace Cannot_serialize_log - (unparse_stack ctxt (stack, code.bef)) >>=? fun stack -> - log := (code.loc, Gas.level ctxt, stack) :: !log ; - return_unit - end >>=? fun () -> - step ?log ctxt step_constants code stack >>=? fun (Item (ret, Empty), ctxt) -> - return (ret, ctxt) +and interp : + type p r. + ?log:execution_trace ref -> + context -> + step_constants -> + (p, r) lambda -> + p -> + (r * context) tzresult Lwt.t = + fun ?log ctxt step_constants (Lam (code, _)) arg -> + let stack = Item (arg, Empty) in + ( match log with + | None -> + return_unit + | Some log -> + trace Cannot_serialize_log (unparse_stack ctxt (stack, code.bef)) + >>=? fun stack -> + log := (code.loc, Gas.level ctxt, stack) :: !log ; + return_unit ) + >>=? fun () -> + step ?log ctxt step_constants code stack + >>=? fun (Item (ret, Empty), ctxt) -> return (ret, ctxt) (* ---- contract handling ---------------------------------------------------*) - and execute ?log ctxt mode step_constants ~entrypoint unparsed_script arg : - (Script.expr * packed_internal_operation list * context * Contract.big_map_diff option) tzresult Lwt.t = + ( Script.expr + * packed_internal_operation list + * context + * Contract.big_map_diff option ) + tzresult + Lwt.t = parse_script ctxt unparsed_script ~legacy:true - >>=? fun (Ex_script { code ; arg_type ; storage ; storage_type ; root_name }, ctxt) -> + >>=? fun (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt) -> trace (Bad_contract_parameter step_constants.self) - (Lwt.return (find_entrypoint arg_type ~root_name entrypoint)) >>=? fun (box, _) -> + (Lwt.return (find_entrypoint arg_type ~root_name entrypoint)) + >>=? fun (box, _) -> trace (Bad_contract_parameter step_constants.self) - (parse_data ctxt ~legacy:false arg_type (box arg)) >>=? fun (arg, ctxt) -> - Script.force_decode ctxt unparsed_script.code >>=? fun (script_code, ctxt) -> - Script_ir_translator.collect_big_maps ctxt arg_type arg >>=? fun (to_duplicate, ctxt) -> - Script_ir_translator.collect_big_maps ctxt storage_type storage >>=? fun (to_update, ctxt) -> + (parse_data ctxt ~legacy:false arg_type (box arg)) + >>=? fun (arg, ctxt) -> + Script.force_decode ctxt unparsed_script.code + >>=? fun (script_code, ctxt) -> + Script_ir_translator.collect_big_maps ctxt arg_type arg + >>=? fun (to_duplicate, ctxt) -> + Script_ir_translator.collect_big_maps ctxt storage_type storage + >>=? fun (to_update, ctxt) -> trace (Runtime_contract_error (step_constants.self, script_code)) (interp ?log ctxt step_constants code (arg, storage)) >>=? fun ((ops, storage), ctxt) -> - Script_ir_translator.extract_big_map_diff ctxt mode - ~temporary:false ~to_duplicate ~to_update storage_type storage + Script_ir_translator.extract_big_map_diff + ctxt + mode + ~temporary:false + ~to_duplicate + ~to_update + storage_type + storage >>=? fun (storage, big_map_diff, ctxt) -> - trace Cannot_serialize_storage - (unparse_data ctxt mode storage_type storage) >>=? fun (storage, ctxt) -> - let ops, op_diffs = List.split ops in - let big_map_diff = match - List.flatten (List.map (Option.unopt ~default:[]) (op_diffs @ [ big_map_diff ])) + trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage) + >>=? fun (storage, ctxt) -> + let (ops, op_diffs) = List.split ops in + let big_map_diff = + match + List.flatten + (List.map (Option.unopt ~default:[]) (op_diffs @ [big_map_diff])) with - | [] -> None - | diff -> Some diff in + | [] -> + None + | diff -> + Some diff + in return (Micheline.strip_locations storage, ops, ctxt, big_map_diff) -type execution_result = - { ctxt : context ; - storage : Script.expr ; - big_map_diff : Contract.big_map_diff option ; - operations : packed_internal_operation list } +type execution_result = { + ctxt : context; + storage : Script.expr; + big_map_diff : Contract.big_map_diff option; + operations : packed_internal_operation list; +} let trace ctxt mode step_constants ~script ~entrypoint ~parameter = let log = ref [] in - execute ~log ctxt mode step_constants ~entrypoint script (Micheline.root parameter) + execute + ~log + ctxt + mode + step_constants + ~entrypoint + script + (Micheline.root parameter) >>=? fun (storage, operations, ctxt, big_map_diff) -> let trace = List.rev !log in - return ({ ctxt ; storage ; big_map_diff ; operations }, trace) + return ({ctxt; storage; big_map_diff; operations}, trace) let execute ctxt mode step_constants ~script ~entrypoint ~parameter = - execute ctxt mode step_constants ~entrypoint script (Micheline.root parameter) + execute + ctxt + mode + step_constants + ~entrypoint + script + (Micheline.root parameter) >>=? fun (storage, operations, ctxt, big_map_diff) -> - return { ctxt ; storage ; big_map_diff ; operations } + return {ctxt; storage; big_map_diff; operations} diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli index 7d583d37a..f327451fe 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_interpreter.mli @@ -28,52 +28,62 @@ open Alpha_context type execution_trace = (Script.location * Gas.t * (Script.expr * string option) list) list -type error += Reject of Script.location * Script.expr * execution_trace option +type error += + | Reject of Script.location * Script.expr * execution_trace option + type error += Overflow of Script.location * execution_trace option + type error += Runtime_contract_error : Contract.t * Script.expr -> error + type error += Bad_contract_parameter of Contract.t (* `Permanent *) + type error += Cannot_serialize_log + type error += Cannot_serialize_failure + type error += Cannot_serialize_storage -type execution_result = - { ctxt : context ; - storage : Script.expr ; - big_map_diff : Contract.big_map_diff option ; - operations : packed_internal_operation list } +type execution_result = { + ctxt : context; + storage : Script.expr; + big_map_diff : Contract.big_map_diff option; + operations : packed_internal_operation list; +} -type step_constants = - { source : Contract.t ; - payer : Contract.t ; - self : Contract.t ; - amount : Tez.t ; - chain_id : Chain_id.t } +type step_constants = { + source : Contract.t; + payer : Contract.t; + self : Contract.t; + amount : Tez.t; + chain_id : Chain_id.t; +} type 'tys stack = | Item : 'ty * 'rest stack -> ('ty * 'rest) stack | Empty : Script_typed_ir.end_of_stack stack -val step: - ?log: execution_trace ref -> - context -> step_constants -> +val step : + ?log:execution_trace ref -> + context -> + step_constants -> ('bef, 'aft) Script_typed_ir.descr -> 'bef stack -> ('aft stack * context) tzresult Lwt.t -val execute: +val execute : Alpha_context.t -> Script_ir_translator.unparsing_mode -> step_constants -> - script: Script.t -> - entrypoint: string -> - parameter: Script.expr -> + script:Script.t -> + entrypoint:string -> + parameter:Script.expr -> execution_result tzresult Lwt.t -val trace: +val trace : Alpha_context.t -> Script_ir_translator.unparsing_mode -> step_constants -> - script: Script.t -> - entrypoint: string -> - parameter: Script.expr -> + script:Script.t -> + entrypoint:string -> + parameter:Script.expr -> (execution_result * execution_trace) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml index 33660d98e..be405eef6 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.ml @@ -29,384 +29,517 @@ open Script_tc_errors open Script_typed_ir let default_now_annot = Some (`Var_annot "now") + let default_amount_annot = Some (`Var_annot "amount") + let default_balance_annot = Some (`Var_annot "balance") + let default_steps_annot = Some (`Var_annot "steps") + let default_source_annot = Some (`Var_annot "source") + let default_sender_annot = Some (`Var_annot "sender") + let default_self_annot = Some (`Var_annot "self") + let default_arg_annot = Some (`Var_annot "arg") + let default_param_annot = Some (`Var_annot "parameter") + let default_storage_annot = Some (`Var_annot "storage") let default_car_annot = Some (`Field_annot "car") + let default_cdr_annot = Some (`Field_annot "cdr") + let default_contract_annot = Some (`Field_annot "contract") + let default_addr_annot = Some (`Field_annot "address") + let default_manager_annot = Some (`Field_annot "manager") + let default_pack_annot = Some (`Field_annot "packed") + let default_unpack_annot = Some (`Field_annot "unpacked") + let default_slice_annot = Some (`Field_annot "slice") let default_elt_annot = Some (`Field_annot "elt") + let default_key_annot = Some (`Field_annot "key") + let default_hd_annot = Some (`Field_annot "hd") + let default_tl_annot = Some (`Field_annot "tl") + let default_some_annot = Some (`Field_annot "some") + let default_left_annot = Some (`Field_annot "left") + let default_right_annot = Some (`Field_annot "right") + let default_binding_annot = Some (`Field_annot "bnd") let unparse_type_annot : type_annot option -> string list = function - | None -> [] - | Some `Type_annot a -> [ ":" ^ a ] + | None -> + [] + | Some (`Type_annot a) -> + [":" ^ a] let unparse_var_annot : var_annot option -> string list = function - | None -> [] - | Some `Var_annot a -> [ "@" ^ a ] + | None -> + [] + | Some (`Var_annot a) -> + ["@" ^ a] let unparse_field_annot : field_annot option -> string list = function - | None -> [] - | Some `Field_annot a -> [ "%" ^ a ] + | None -> + [] + | Some (`Field_annot a) -> + ["%" ^ a] -let field_to_var_annot : field_annot option -> var_annot option = - function - | None -> None - | Some (`Field_annot s) -> Some (`Var_annot s) +let field_to_var_annot : field_annot option -> var_annot option = function + | None -> + None + | Some (`Field_annot s) -> + Some (`Var_annot s) -let type_to_var_annot : type_annot option -> var_annot option = - function - | None -> None - | Some (`Type_annot s) -> Some (`Var_annot s) +let type_to_var_annot : type_annot option -> var_annot option = function + | None -> + None + | Some (`Type_annot s) -> + Some (`Var_annot s) -let var_to_field_annot : var_annot option -> field_annot option = - function - | None -> None - | Some (`Var_annot s) -> Some (`Field_annot s) +let var_to_field_annot : var_annot option -> field_annot option = function + | None -> + None + | Some (`Var_annot s) -> + Some (`Field_annot s) -let default_annot ~default = function - | None -> default - | annot -> annot +let default_annot ~default = function None -> default | annot -> annot -let gen_access_annot - : var_annot option -> ?default:field_annot option -> field_annot option -> var_annot option - = fun value_annot ?(default=None) field_annot -> - match value_annot, field_annot, default with - | None, None, _ | Some _, None, None | None, Some `Field_annot "", _ -> None - | None, Some `Field_annot f, _ -> - Some (`Var_annot f) - | Some `Var_annot v, (None | Some `Field_annot ""), Some `Field_annot f -> - Some (`Var_annot (String.concat "." [v; f])) - | Some `Var_annot v, Some `Field_annot f, _ -> - Some (`Var_annot (String.concat "." [v; f])) +let gen_access_annot : + var_annot option -> + ?default:field_annot option -> + field_annot option -> + var_annot option = + fun value_annot ?(default = None) field_annot -> + match (value_annot, field_annot, default) with + | (None, None, _) | (Some _, None, None) | (None, Some (`Field_annot ""), _) + -> + None + | (None, Some (`Field_annot f), _) -> + Some (`Var_annot f) + | ( Some (`Var_annot v), + (None | Some (`Field_annot "")), + Some (`Field_annot f) ) -> + Some (`Var_annot (String.concat "." [v; f])) + | (Some (`Var_annot v), Some (`Field_annot f), _) -> + Some (`Var_annot (String.concat "." [v; f])) -let merge_type_annot - : legacy: bool -> type_annot option -> type_annot option -> type_annot option tzresult - = fun ~legacy annot1 annot2 -> - match annot1, annot2 with - | None, None - | Some _, None - | None, Some _ -> ok None - | Some `Type_annot a1, Some `Type_annot a2 -> - if legacy || String.equal a1 a2 - then ok annot1 - else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2)) +let merge_type_annot : + legacy:bool -> + type_annot option -> + type_annot option -> + type_annot option tzresult = + fun ~legacy annot1 annot2 -> + match (annot1, annot2) with + | (None, None) | (Some _, None) | (None, Some _) -> + ok None + | (Some (`Type_annot a1), Some (`Type_annot a2)) -> + if legacy || String.equal a1 a2 then ok annot1 + else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2)) -let merge_field_annot - : legacy: bool -> field_annot option -> field_annot option -> field_annot option tzresult - = fun ~legacy annot1 annot2 -> - match annot1, annot2 with - | None, None - | Some _, None - | None, Some _ -> ok None - | Some `Field_annot a1, Some `Field_annot a2 -> - if legacy || String.equal a1 a2 - then ok annot1 - else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2)) +let merge_field_annot : + legacy:bool -> + field_annot option -> + field_annot option -> + field_annot option tzresult = + fun ~legacy annot1 annot2 -> + match (annot1, annot2) with + | (None, None) | (Some _, None) | (None, Some _) -> + ok None + | (Some (`Field_annot a1), Some (`Field_annot a2)) -> + if legacy || String.equal a1 a2 then ok annot1 + else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2)) -let merge_var_annot - : var_annot option -> var_annot option -> var_annot option - = fun annot1 annot2 -> - match annot1, annot2 with - | None, None - | Some _, None - | None, Some _ -> None - | Some `Var_annot a1, Some `Var_annot a2 -> - if String.equal a1 a2 then annot1 else None +let merge_var_annot : var_annot option -> var_annot option -> var_annot option + = + fun annot1 annot2 -> + match (annot1, annot2) with + | (None, None) | (Some _, None) | (None, Some _) -> + None + | (Some (`Var_annot a1), Some (`Var_annot a2)) -> + if String.equal a1 a2 then annot1 else None let error_unexpected_annot loc annot = - match annot with - | [] -> ok () - | _ :: _ -> error (Unexpected_annotation loc) + match annot with [] -> ok () | _ :: _ -> error (Unexpected_annotation loc) let fail_unexpected_annot loc annot = Lwt.return (error_unexpected_annot loc annot) -let parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false) l = +(* 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 = + if Compare.Int.(i >= len) then ok () else p s.[i] >>? fun () -> aux (i + 1) + in + aux i + +(* Valid annotation characters as defined by the allowed_annot_char function from lib_micheline/micheline_parser *) +let check_char loc = function + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' | '%' | '@' | '0' .. '9' -> + ok () + | _ -> + error (Unexpected_annotation loc) + +(* This constant is defined in lib_micheline/micheline_parser which is not available in the environment. *) +let max_annot_length = 255 + +let parse_annots loc ?(allow_special_var = false) + ?(allow_special_field = false) l = (* allow emtpty annotations as wildcards but otherwise only accept annotations that start with [a-zA-Z_] *) let sub_or_wildcard ~specials wrap s acc = let len = String.length s in - if Compare.Int.(len = 1) then ok @@ wrap None :: acc - else match s.[1] with + ( if Compare.Int.(len > max_annot_length) then + error (Unexpected_annotation loc) + else ok () ) + >>? fun () -> + if Compare.Int.(len = 1) then ok @@ (wrap None :: acc) + else + match s.[1] with | 'a' .. 'z' | 'A' .. 'Z' | '_' -> - ok @@ wrap (Some (String.sub s 1 (len - 1))) :: acc + (* check that all characters are valid*) + string_iter (check_char loc) s 2 + >>? fun () -> ok @@ (wrap (Some (String.sub s 1 (len - 1))) :: acc) | '@' when Compare.Int.(len = 2) && List.mem '@' specials -> - ok @@ wrap (Some "@") :: acc + ok @@ (wrap (Some "@") :: acc) | '%' when List.mem '%' specials -> - if Compare.Int.(len = 2) - then ok @@ wrap (Some "%") :: acc - else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') - then ok @@ wrap (Some "%%") :: acc + if Compare.Int.(len = 2) then ok @@ (wrap (Some "%") :: acc) + else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then + ok @@ (wrap (Some "%%") :: acc) else error (Unexpected_annotation loc) - | _ -> error (Unexpected_annotation loc) in - List.fold_left (fun acc s -> - acc >>? fun acc -> + | _ -> + error (Unexpected_annotation loc) + in + List.fold_left + (fun acc s -> + acc + >>? fun acc -> if Compare.Int.(String.length s = 0) then error (Unexpected_annotation loc) - else match s.[0] with - | ':' -> sub_or_wildcard ~specials:[] (fun a -> `Type_annot a) s acc + else + match s.[0] with + | ':' -> + sub_or_wildcard ~specials:[] (fun a -> `Type_annot a) s acc | '@' -> sub_or_wildcard ~specials:(if allow_special_var then ['%'] else []) - (fun a -> `Var_annot a) s acc - | '%' -> sub_or_wildcard - ~specials:(if allow_special_field then ['@'] else []) - (fun a -> `Field_annot a) s acc - | _ -> error (Unexpected_annotation loc) - ) (ok []) l + (fun a -> `Var_annot a) + s + acc + | '%' -> + sub_or_wildcard + ~specials:(if allow_special_field then ['@'] else []) + (fun a -> `Field_annot a) + s + acc + | _ -> + error (Unexpected_annotation loc)) + (ok []) + l >|? List.rev let opt_var_of_var_opt = function - | `Var_annot None -> None - | `Var_annot Some a -> Some (`Var_annot a) + | `Var_annot None -> + None + | `Var_annot (Some a) -> + Some (`Var_annot a) let opt_field_of_field_opt = function - | `Field_annot None -> None - | `Field_annot Some a -> Some (`Field_annot a) + | `Field_annot None -> + None + | `Field_annot (Some a) -> + Some (`Field_annot a) let opt_type_of_type_opt = function - | `Type_annot None -> None - | `Type_annot Some a -> Some (`Type_annot a) + | `Type_annot None -> + None + | `Type_annot (Some a) -> + Some (`Type_annot a) -let classify_annot loc l - : (var_annot option list * type_annot option list * field_annot option list) tzresult - = +let classify_annot loc l : + (var_annot option list * type_annot option list * field_annot option list) + tzresult = try - let _, rv, _, rt, _, rf = + let (_, rv, _, rt, _, rf) = List.fold_left (fun (in_v, rv, in_t, rt, in_f, rf) a -> - match a, in_v, rv, in_t, rt, in_f, rf with - | (`Var_annot _ as a), true, _, _, _, _, _ - | (`Var_annot _ as a), false, [], _, _, _, _ -> - true, opt_var_of_var_opt a :: rv, - false, rt, - false, rf - | (`Type_annot _ as a), _, _, true, _, _, _ - | (`Type_annot _ as a), _, _, false, [], _, _ -> - false, rv, - true, opt_type_of_type_opt a :: rt, - false, rf - | (`Field_annot _ as a), _, _, _, _, true, _ - | (`Field_annot _ as a), _, _, _, _, false, [] -> - false, rv, - false, rt, - true, opt_field_of_field_opt a :: rf - | _ -> raise Exit - ) (false, [], false, [], false, []) l in + match (a, in_v, rv, in_t, rt, in_f, rf) with + | ((`Var_annot _ as a), true, _, _, _, _, _) + | ((`Var_annot _ as a), false, [], _, _, _, _) -> + (true, opt_var_of_var_opt a :: rv, false, rt, false, rf) + | ((`Type_annot _ as a), _, _, true, _, _, _) + | ((`Type_annot _ as a), _, _, false, [], _, _) -> + (false, rv, true, opt_type_of_type_opt a :: rt, false, rf) + | ((`Field_annot _ as a), _, _, _, _, true, _) + | ((`Field_annot _ as a), _, _, _, _, false, []) -> + (false, rv, false, rt, true, opt_field_of_field_opt a :: rf) + | _ -> + raise Exit) + (false, [], false, [], false, []) + l + in ok (List.rev rv, List.rev rt, List.rev rf) with Exit -> error (Ungrouped_annotations loc) let get_one_annot loc = function - | [] -> ok None - | [ a ] -> ok a - | _ -> error (Unexpected_annotation loc) + | [] -> + ok None + | [a] -> + ok a + | _ -> + error (Unexpected_annotation loc) let get_two_annot loc = function - | [] -> ok (None, None) - | [ a ] -> ok (a, None) - | [ a; b ] -> ok (a, b) - | _ -> error (Unexpected_annotation loc) + | [] -> + ok (None, None) + | [a] -> + ok (a, None) + | [a; b] -> + ok (a, b) + | _ -> + error (Unexpected_annotation loc) -let parse_type_annot - : int -> string list -> type_annot option tzresult - = fun loc annot -> - parse_annots loc annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - error_unexpected_annot loc vars >>? fun () -> - error_unexpected_annot loc fields >>? fun () -> - get_one_annot loc types +let parse_type_annot : int -> string list -> type_annot option tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars + >>? fun () -> + error_unexpected_annot loc fields >>? fun () -> get_one_annot loc types -let parse_type_field_annot - : int -> string list -> (type_annot option * field_annot option) tzresult - = fun loc annot -> - parse_annots loc annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - error_unexpected_annot loc vars >>? fun () -> - get_one_annot loc types >>? fun t -> - get_one_annot loc fields >|? fun f -> - (t, f) +let parse_type_field_annot : + int -> string list -> (type_annot option * field_annot option) tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars + >>? fun () -> + get_one_annot loc types + >>? fun t -> get_one_annot loc fields >|? fun f -> (t, f) -let parse_composed_type_annot - : int -> string list -> (type_annot option * field_annot option * field_annot option) tzresult - = fun loc annot -> - parse_annots loc annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - error_unexpected_annot loc vars >>? fun () -> - get_one_annot loc types >>? fun t -> - get_two_annot loc fields >|? fun (f1, f2) -> - (t, f1, f2) +let parse_composed_type_annot : + int -> + string list -> + (type_annot option * field_annot option * field_annot option) tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars + >>? fun () -> + get_one_annot loc types + >>? fun t -> get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2) -let parse_field_annot - : int -> string list -> field_annot option tzresult - = fun loc annot -> - parse_annots loc annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - error_unexpected_annot loc vars >>? fun () -> - error_unexpected_annot loc types >>? fun () -> - get_one_annot loc fields +let parse_field_annot : int -> string list -> field_annot option tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc vars + >>? fun () -> + error_unexpected_annot loc types >>? fun () -> get_one_annot loc fields -let extract_field_annot - : Script.node -> (Script.node * field_annot option) tzresult - = function - | Prim (loc, prim, args, annot) -> - let rec extract_first acc = function - | [] -> None, annot - | s :: rest -> - if Compare.Int.(String.length s > 0) && - Compare.Char.(s.[0] = '%') then - Some s, List.rev_append acc rest - else extract_first (s :: acc) rest in - let field_annot, annot = extract_first [] annot in - let field_annot = match field_annot with - | None -> None - | Some field_annot -> Some (`Field_annot (String.sub field_annot 1 (String.length field_annot - 1))) in - ok (Prim (loc, prim, args, annot), field_annot) - | expr -> ok (expr, None) +let extract_field_annot : + Script.node -> (Script.node * field_annot option) tzresult = function + | Prim (loc, prim, args, annot) -> + let rec extract_first acc = function + | [] -> + (None, annot) + | s :: rest -> + if Compare.Int.(String.length s > 0) && Compare.Char.(s.[0] = '%') + then (Some s, List.rev_append acc rest) + else extract_first (s :: acc) rest + in + let (field_annot, annot) = extract_first [] annot in + let field_annot = + match field_annot with + | None -> + None + | Some field_annot -> + Some + (`Field_annot + (String.sub field_annot 1 (String.length field_annot - 1))) + in + ok (Prim (loc, prim, args, annot), field_annot) + | expr -> + ok (expr, None) -let check_correct_field - : field_annot option -> field_annot option -> unit tzresult - = fun f1 f2 -> - match f1, f2 with - | None, _ | _, None -> ok () - | Some `Field_annot s1, Some `Field_annot s2 -> - if String.equal s1 s2 then ok () - else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2)) +let check_correct_field : + field_annot option -> field_annot option -> unit tzresult = + fun f1 f2 -> + match (f1, f2) with + | (None, _) | (_, None) -> + ok () + | (Some (`Field_annot s1), Some (`Field_annot s2)) -> + if String.equal s1 s2 then ok () + else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2)) - -let parse_var_annot - : int -> ?default:var_annot option -> string list -> - var_annot option tzresult - = fun loc ?default annot -> - parse_annots loc annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - error_unexpected_annot loc types >>? fun () -> - error_unexpected_annot loc fields >>? fun () -> - get_one_annot loc vars >|? function - | Some _ as a -> a - | None -> match default with - | Some a -> a - | None -> None +let parse_var_annot : + int -> + ?default:var_annot option -> + string list -> + var_annot option tzresult = + fun loc ?default annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc types + >>? fun () -> + error_unexpected_annot loc fields + >>? fun () -> + get_one_annot loc vars + >|? function + | Some _ as a -> + a + | None -> ( + match default with Some a -> a | None -> None ) let split_last_dot = function - | None -> None, None - | Some `Field_annot s -> - match String.rindex_opt s '.' with - | None -> None, Some (`Field_annot s) - | Some i -> - let s1 = String.sub s 0 i in - let s2 = String.sub s (i + 1) (String.length s - i - 1) in - let f = - if Compare.String.equal s2 "car" - || Compare.String.equal s2 "cdr" then - None - else - Some (`Field_annot s2) in - Some (`Var_annot s1), f + | None -> + (None, None) + | Some (`Field_annot s) -> ( + match String.rindex_opt s '.' with + | None -> + (None, Some (`Field_annot s)) + | Some i -> + let s1 = String.sub s 0 i in + let s2 = String.sub s (i + 1) (String.length s - i - 1) in + let f = + if Compare.String.equal s2 "car" || Compare.String.equal s2 "cdr" + then None + else Some (`Field_annot s2) + in + (Some (`Var_annot s1), f) ) let common_prefix v1 v2 = - match v1, v2 with - | Some (`Var_annot s1), Some (`Var_annot s2) when Compare.String.equal s1 s2 -> v1 - | Some _, None -> v1 - | None, Some _ -> v2 - | _, _ -> None + match (v1, v2) with + | (Some (`Var_annot s1), Some (`Var_annot s2)) + when Compare.String.equal s1 s2 -> + v1 + | (Some _, None) -> + v1 + | (None, Some _) -> + v2 + | (_, _) -> + None -let parse_constr_annot - : int -> +let parse_constr_annot : + int -> ?if_special_first:field_annot option -> ?if_special_second:field_annot option -> string list -> - (var_annot option * type_annot option * field_annot option * field_annot option) tzresult - = fun loc ?if_special_first ?if_special_second annot -> - parse_annots ~allow_special_field:true loc annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - get_one_annot loc vars >>? fun v -> - get_one_annot loc types >>? fun t -> - get_two_annot loc fields >>? fun (f1, f2) -> - begin match if_special_first, f1 with - | Some special_var, Some `Field_annot "@" -> - ok (split_last_dot special_var) - | None, Some `Field_annot "@" -> error (Unexpected_annotation loc) - | _, _ -> ok (v, f1) - end >>? fun (v1, f1) -> - begin match if_special_second, f2 with - | Some special_var, Some `Field_annot "@" -> - ok (split_last_dot special_var) - | None, Some `Field_annot "@" -> error (Unexpected_annotation loc) - | _, _ -> ok (v, f2) - end >|? fun (v2, f2) -> - let v = match v with - | None -> common_prefix v1 v2 - | Some _ -> v in - (v, t, f1, f2) + ( var_annot option + * type_annot option + * field_annot option + * field_annot option ) + tzresult = + fun loc ?if_special_first ?if_special_second annot -> + parse_annots ~allow_special_field:true loc annot + >>? classify_annot loc + >>? fun (vars, types, fields) -> + get_one_annot loc vars + >>? fun v -> + get_one_annot loc types + >>? fun t -> + get_two_annot loc fields + >>? fun (f1, f2) -> + ( match (if_special_first, f1) with + | (Some special_var, Some (`Field_annot "@")) -> + ok (split_last_dot special_var) + | (None, Some (`Field_annot "@")) -> + error (Unexpected_annotation loc) + | (_, _) -> + ok (v, f1) ) + >>? fun (v1, f1) -> + ( match (if_special_second, f2) with + | (Some special_var, Some (`Field_annot "@")) -> + ok (split_last_dot special_var) + | (None, Some (`Field_annot "@")) -> + error (Unexpected_annotation loc) + | (_, _) -> + ok (v, f2) ) + >|? fun (v2, f2) -> + let v = match v with None -> common_prefix v1 v2 | Some _ -> v in + (v, t, f1, f2) -let parse_two_var_annot - : int -> string list -> (var_annot option * var_annot option) tzresult - = fun loc annot -> - parse_annots loc annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - error_unexpected_annot loc types >>? fun () -> - error_unexpected_annot loc fields >>? fun () -> - get_two_annot loc vars +let parse_two_var_annot : + int -> string list -> (var_annot option * var_annot option) tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc types + >>? fun () -> + error_unexpected_annot loc fields >>? fun () -> get_two_annot loc vars -let parse_destr_annot - : int -> string list -> default_accessor:field_annot option -> - field_name:field_annot option -> - pair_annot:var_annot option -> value_annot:var_annot option -> - (var_annot option * field_annot option) tzresult - = fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot -> - parse_annots loc ~allow_special_var:true annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - error_unexpected_annot loc types >>? fun () -> - get_one_annot loc vars >>? fun v -> - get_one_annot loc fields >|? fun f -> - let default = gen_access_annot pair_annot field_name ~default:default_accessor in - let v = match v with - | Some `Var_annot "%" -> field_to_var_annot field_name - | Some `Var_annot "%%" -> default - | Some _ -> v - | None -> value_annot in - (v, f) +let parse_destr_annot : + int -> + string list -> + default_accessor:field_annot option -> + field_name:field_annot option -> + pair_annot:var_annot option -> + value_annot:var_annot option -> + (var_annot option * field_annot option) tzresult = + fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot -> + parse_annots loc ~allow_special_var:true annot + >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc types + >>? fun () -> + get_one_annot loc vars + >>? fun v -> + get_one_annot loc fields + >|? fun f -> + let default = + gen_access_annot pair_annot field_name ~default:default_accessor + in + let v = + match v with + | Some (`Var_annot "%") -> + field_to_var_annot field_name + | Some (`Var_annot "%%") -> + default + | Some _ -> + v + | None -> + value_annot + in + (v, f) -let parse_entrypoint_annot - : int -> ?default:var_annot option -> string list -> (var_annot option * field_annot option) tzresult - = fun loc ?default annot -> - parse_annots loc annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - error_unexpected_annot loc types >>? fun () -> - get_one_annot loc fields >>? fun f -> - get_one_annot loc vars >|? function - | Some _ as a -> (a, f) - | None -> match default with - | Some a -> (a, f) - | None -> (None, f) +let parse_entrypoint_annot : + int -> + ?default:var_annot option -> + string list -> + (var_annot option * field_annot option) tzresult = + fun loc ?default annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc types + >>? fun () -> + get_one_annot loc fields + >>? fun f -> + get_one_annot loc vars + >|? function + | Some _ as a -> + (a, f) + | None -> ( + match default with Some a -> (a, f) | None -> (None, f) ) -let parse_var_type_annot - : int -> string list -> (var_annot option * type_annot option) tzresult - = fun loc annot -> - parse_annots loc annot >>? - classify_annot loc >>? fun (vars, types, fields) -> - error_unexpected_annot loc fields >>? fun () -> - get_one_annot loc vars >>? fun v -> - get_one_annot loc types >|? fun t -> - (v, t) +let parse_var_type_annot : + int -> string list -> (var_annot option * type_annot option) tzresult = + fun loc annot -> + parse_annots loc annot >>? classify_annot loc + >>? fun (vars, types, fields) -> + error_unexpected_annot loc fields + >>? fun () -> + get_one_annot loc vars + >>? fun v -> get_one_annot loc types >|? fun t -> (v, t) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli index 7ac470139..0128a391e 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_annot.mli @@ -29,44 +29,71 @@ open Script_typed_ir (** Default annotations *) val default_now_annot : var_annot option + val default_amount_annot : var_annot option + val default_balance_annot : var_annot option + val default_steps_annot : var_annot option + val default_source_annot : var_annot option + val default_sender_annot : var_annot option + val default_self_annot : var_annot option + val default_arg_annot : var_annot option + val default_param_annot : var_annot option + val default_storage_annot : var_annot option val default_car_annot : field_annot option + val default_cdr_annot : field_annot option + val default_contract_annot : field_annot option + val default_addr_annot : field_annot option + val default_manager_annot : field_annot option + val default_pack_annot : field_annot option + val default_unpack_annot : field_annot option + val default_slice_annot : field_annot option val default_elt_annot : field_annot option + val default_key_annot : field_annot option + val default_hd_annot : field_annot option + val default_tl_annot : field_annot option + val default_some_annot : field_annot option + val default_left_annot : field_annot option + val default_right_annot : field_annot option + val default_binding_annot : field_annot option (** Unparse annotations to their string representation *) val unparse_type_annot : type_annot option -> string list + val unparse_var_annot : var_annot option -> string list + val unparse_field_annot : field_annot option -> string list (** Convertions functions between different annotation kinds *) val field_to_var_annot : field_annot option -> var_annot option + val type_to_var_annot : type_annot option -> var_annot option + val var_to_field_annot : var_annot option -> field_annot option (** Replace an annotation by its default value if it is [None] *) @@ -75,23 +102,30 @@ val default_annot : default:'a option -> 'a option -> 'a option (** Generate annotation for field accesses, of the form [var.field1.field2] *) val gen_access_annot : var_annot option -> - ?default:field_annot option -> field_annot option -> var_annot option + ?default:field_annot option -> + field_annot option -> + var_annot option (** Merge type annotations. @return an error {!Inconsistent_type_annotations} if they are both present and different, unless [legacy] *) val merge_type_annot : - legacy: bool -> type_annot option -> type_annot option -> type_annot option tzresult + legacy:bool -> + type_annot option -> + type_annot option -> + type_annot option tzresult (** Merge field annotations. @return an error {!Inconsistent_type_annotations} if they are both present and different, unless [legacy] *) val merge_field_annot : - legacy: bool -> field_annot option -> field_annot option -> field_annot option tzresult + legacy:bool -> + field_annot option -> + field_annot option -> + field_annot option tzresult (** Merge variable annotations, does not fail ([None] if different). *) -val merge_var_annot : - var_annot option -> var_annot option -> var_annot option +val merge_var_annot : var_annot option -> var_annot option -> var_annot option (** @return an error {!Unexpected_annotation} in the monad the list is not empty. *) val error_unexpected_annot : int -> 'a list -> unit tzresult @@ -103,8 +137,7 @@ val fail_unexpected_annot : int -> 'a list -> unit tzresult Lwt.t val parse_type_annot : int -> string list -> type_annot option tzresult (** Parse a field annotation only. *) -val parse_field_annot : - int -> string list -> field_annot option tzresult +val parse_field_annot : int -> string list -> field_annot option tzresult (** Parse an annotation for composed types, of the form [:ty_name %field] in any order. *) @@ -114,7 +147,8 @@ val parse_type_field_annot : (** Parse an annotation for composed types, of the form [:ty_name %field1 %field2] in any order. *) val parse_composed_type_annot : - int -> string list -> + int -> + string list -> (type_annot option * field_annot option * field_annot option) tzresult (** Extract and remove a field annotation from a node *) @@ -129,23 +163,25 @@ val check_correct_field : (** Parse a variable annotation, replaced by a default value if [None]. *) val parse_var_annot : - int -> - ?default:var_annot option -> - string list -> var_annot option tzresult + int -> ?default:var_annot option -> string list -> var_annot option tzresult val parse_constr_annot : int -> ?if_special_first:field_annot option -> ?if_special_second:field_annot option -> string list -> - (var_annot option * type_annot option * - field_annot option * field_annot option) tzresult + ( var_annot option + * type_annot option + * field_annot option + * field_annot option ) + tzresult val parse_two_var_annot : int -> string list -> (var_annot option * var_annot option) tzresult val parse_destr_annot : - int -> string list -> + int -> + string list -> default_accessor:field_annot option -> field_name:field_annot option -> pair_annot:var_annot option -> diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml index b73d610ba..df884eb02 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.ml @@ -29,226 +29,392 @@ open Script open Script_typed_ir open Script_tc_errors open Script_ir_annot - module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse -type ex_comparable_ty = Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty +type ex_comparable_ty = + | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty + type ex_ty = Ex_ty : 'a ty -> ex_ty + type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty type tc_context = | Lambda : tc_context | Dip : 'a stack_ty * tc_context -> tc_context - | Toplevel : { storage_type : 'sto ty ; param_type : 'param ty ; root_name : string option ; - legacy_create_contract_literal : bool } -> tc_context + | Toplevel : { + storage_type : 'sto ty; + param_type : 'param ty; + root_name : string option; + legacy_create_contract_literal : bool; + } + -> tc_context type unparsing_mode = Optimized | Readable type type_logger = - int -> (Script.expr * Script.annot) list -> (Script.expr * Script.annot) list -> unit + int -> + (Script.expr * Script.annot) list -> + (Script.expr * Script.annot) list -> + unit let add_dip ty annot prev = match prev with - | Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev) - | Dip (stack, _) -> Dip (Item_t (ty, stack, annot), prev) + | Lambda | Toplevel _ -> + Dip (Item_t (ty, Empty_t, annot), prev) + | Dip (stack, _) -> + Dip (Item_t (ty, stack, annot), prev) (* ---- Type size accounting ------------------------------------------------*) -let rec comparable_type_size : type t a. (t, a) comparable_struct -> int = fun ty -> +let rec comparable_type_size : type t a. (t, a) comparable_struct -> int = + fun ty -> (* No wildcard to force the update when comparable_ty chages. *) match ty with - | Int_key _ -> 1 - | Nat_key _ -> 1 - | String_key _ -> 1 - | Bytes_key _ -> 1 - | Mutez_key _ -> 1 - | Bool_key _ -> 1 - | Key_hash_key _ -> 1 - | Timestamp_key _ -> 1 - | Address_key _ -> 1 - | Pair_key (_, (t, _), _) -> 1 + comparable_type_size t + | Int_key _ -> + 1 + | Nat_key _ -> + 1 + | String_key _ -> + 1 + | Bytes_key _ -> + 1 + | Mutez_key _ -> + 1 + | Bool_key _ -> + 1 + | Key_hash_key _ -> + 1 + | Timestamp_key _ -> + 1 + | Address_key _ -> + 1 + | Pair_key (_, (t, _), _) -> + 1 + comparable_type_size t let rec type_size : type t. t ty -> int = - fun ty -> match ty with - | Unit_t _ -> 1 - | Int_t _ -> 1 - | Nat_t _ -> 1 - | Signature_t _ -> 1 - | Bytes_t _ -> 1 - | String_t _ -> 1 - | Mutez_t _ -> 1 - | Key_hash_t _ -> 1 - | Key_t _ -> 1 - | Timestamp_t _ -> 1 - | Address_t _ -> 1 - | Bool_t _ -> 1 - | Operation_t _ -> 1 - | Pair_t ((l, _, _), (r, _, _), _, _) -> - 1 + type_size l + type_size r - | Union_t ((l, _), (r, _), _, _) -> - 1 + type_size l + type_size r - | Lambda_t (arg, ret, _) -> - 1 + type_size arg + type_size ret - | Option_t (t, _, _) -> - 1 + type_size t - | List_t (t, _, _) -> - 1 + type_size t - | Set_t (k, _) -> - 1 + comparable_type_size k - | Map_t (k, v, _, _) -> - 1 + comparable_type_size k + type_size v - | Big_map_t (k, v, _) -> - 1 + comparable_type_size k + type_size v - | Contract_t (arg, _) -> - 1 + type_size arg - | Chain_id_t _ -> 1 + fun ty -> + match ty with + | Unit_t _ -> + 1 + | Int_t _ -> + 1 + | Nat_t _ -> + 1 + | Signature_t _ -> + 1 + | Bytes_t _ -> + 1 + | String_t _ -> + 1 + | Mutez_t _ -> + 1 + | Key_hash_t _ -> + 1 + | Key_t _ -> + 1 + | Timestamp_t _ -> + 1 + | Address_t _ -> + 1 + | Bool_t _ -> + 1 + | Operation_t _ -> + 1 + | Pair_t ((l, _, _), (r, _, _), _, _) -> + 1 + type_size l + type_size r + | Union_t ((l, _), (r, _), _, _) -> + 1 + type_size l + type_size r + | Lambda_t (arg, ret, _) -> + 1 + type_size arg + type_size ret + | Option_t (t, _, _) -> + 1 + type_size t + | List_t (t, _, _) -> + 1 + type_size t + | Set_t (k, _) -> + 1 + comparable_type_size k + | Map_t (k, v, _, _) -> + 1 + comparable_type_size k + type_size v + | Big_map_t (k, v, _) -> + 1 + comparable_type_size k + type_size v + | Contract_t (arg, _) -> + 1 + type_size arg + | Chain_id_t _ -> + 1 -let rec type_size_of_stack_head - : type st. st stack_ty -> up_to:int -> int - = fun stack ~up_to -> - match stack with - | Empty_t -> 0 - | Item_t (head, tail, _annot) -> - if Compare.Int.(up_to > 0) then - Compare.Int.max (type_size head) - (type_size_of_stack_head tail ~up_to:(up_to - 1)) - else - 0 +let rec type_size_of_stack_head : type st. st stack_ty -> up_to:int -> int = + fun stack ~up_to -> + match stack with + | Empty_t -> + 0 + | Item_t (head, tail, _annot) -> + if Compare.Int.(up_to > 0) then + Compare.Int.max + (type_size head) + (type_size_of_stack_head tail ~up_to:(up_to - 1)) + else 0 (* This is the depth of the stack to inspect for sizes overflow. We only need to check the produced types that can be larger than the arguments. That's why Swap is 0 for instance as no type grows. Constant sized types are not checked: it is assumed they are lower than the bound (otherwise every program would be rejected). *) -let number_of_generated_growing_types : type b a. (b, a) instr -> int = function - | Drop -> 0 - | Dup -> 0 - | Swap -> 0 - | Const _ -> 1 - | Cons_pair -> 1 - | Car -> 0 - | Cdr -> 0 - | Cons_some -> 1 - | Cons_none _ -> 1 - | If_none _ -> 0 - | Left -> 0 - | Right -> 0 - | If_left _ -> 0 - | Cons_list -> 1 - | Nil -> 1 - | If_cons _ -> 0 - | List_map _ -> 1 - | List_size -> 0 - | List_iter _ -> 1 - | Empty_set _ -> 1 - | Set_iter _ -> 0 - | Set_mem -> 0 - | Set_update -> 0 - | Set_size -> 0 - | Empty_map _ -> 1 - | Map_map _ -> 1 - | Map_iter _ -> 1 - | Map_mem -> 0 - | Map_get -> 0 - | Map_update -> 0 - | Map_size -> 0 - | Empty_big_map _ -> 1 - | Big_map_get -> 0 - | Big_map_update -> 0 - | Big_map_mem -> 0 - | Concat_string -> 0 - | Concat_string_pair -> 0 - | Slice_string -> 0 - | String_size -> 0 - | Concat_bytes -> 0 - | Concat_bytes_pair -> 0 - | Slice_bytes -> 0 - | Bytes_size -> 0 - | Add_seconds_to_timestamp -> 0 - | Add_timestamp_to_seconds -> 0 - | Sub_timestamp_seconds -> 0 - | Diff_timestamps -> 0 - | Add_tez -> 0 - | Sub_tez -> 0 - | Mul_teznat -> 0 - | Mul_nattez -> 0 - | Ediv_teznat -> 0 - | Ediv_tez -> 0 - | Or -> 0 - | And -> 0 - | Xor -> 0 - | Not -> 0 - | Is_nat -> 0 - | Neg_nat -> 0 - | Neg_int -> 0 - | Abs_int -> 0 - | Int_nat -> 0 - | Add_intint -> 0 - | Add_intnat -> 0 - | Add_natint -> 0 - | Add_natnat -> 0 - | Sub_int -> 0 - | Mul_intint -> 0 - | Mul_intnat -> 0 - | Mul_natint -> 0 - | Mul_natnat -> 0 - | Ediv_intint -> 0 - | Ediv_intnat -> 0 - | Ediv_natint -> 0 - | Ediv_natnat -> 0 - | Lsl_nat -> 0 - | Lsr_nat -> 0 - | Or_nat -> 0 - | And_nat -> 0 - | And_int_nat -> 0 - | Xor_nat -> 0 - | Not_nat -> 0 - | Not_int -> 0 - | Seq _ -> 0 - | If _ -> 0 - | Loop _ -> 0 - | Loop_left _ -> 0 - | Dip _ -> 0 - | Exec -> 0 - | Apply _ -> 0 - | Lambda _ -> 1 - | Failwith _ -> 1 - | Nop -> 0 - | Compare _ -> 1 - | Eq -> 0 - | Neq -> 0 - | Lt -> 0 - | Gt -> 0 - | Le -> 0 - | Ge -> 0 - | Address -> 0 - | Contract _ -> 1 - | Transfer_tokens -> 1 - | Create_account -> 0 - | Implicit_account -> 0 - | Create_contract _ -> 1 - | Create_contract_2 _ -> 1 - | Now -> 0 - | Balance -> 0 - | Check_signature -> 0 - | Hash_key -> 0 - | Blake2b -> 0 - | Sha256 -> 0 - | Sha512 -> 0 - | Steps_to_quota -> 0 - | Source -> 0 - | Sender -> 0 - | Self _ -> 1 - | Amount -> 0 - | Set_delegate -> 0 - | Pack _ -> 0 - | Unpack _ -> 1 - | Dig _ -> 0 - | Dug _ -> 0 - | Dipn _ -> 0 - | Dropn _ -> 0 - | ChainId -> 0 +let number_of_generated_growing_types : type b a. (b, a) instr -> int = + function + | Drop -> + 0 + | Dup -> + 0 + | Swap -> + 0 + | Const _ -> + 1 + | Cons_pair -> + 1 + | Car -> + 0 + | Cdr -> + 0 + | Cons_some -> + 1 + | Cons_none _ -> + 1 + | If_none _ -> + 0 + | Left -> + 0 + | Right -> + 0 + | If_left _ -> + 0 + | Cons_list -> + 1 + | Nil -> + 1 + | If_cons _ -> + 0 + | List_map _ -> + 1 + | List_size -> + 0 + | List_iter _ -> + 1 + | Empty_set _ -> + 1 + | Set_iter _ -> + 0 + | Set_mem -> + 0 + | Set_update -> + 0 + | Set_size -> + 0 + | Empty_map _ -> + 1 + | Map_map _ -> + 1 + | Map_iter _ -> + 1 + | Map_mem -> + 0 + | Map_get -> + 0 + | Map_update -> + 0 + | Map_size -> + 0 + | Empty_big_map _ -> + 1 + | Big_map_get -> + 0 + | Big_map_update -> + 0 + | Big_map_mem -> + 0 + | Concat_string -> + 0 + | Concat_string_pair -> + 0 + | Slice_string -> + 0 + | String_size -> + 0 + | Concat_bytes -> + 0 + | Concat_bytes_pair -> + 0 + | Slice_bytes -> + 0 + | Bytes_size -> + 0 + | Add_seconds_to_timestamp -> + 0 + | Add_timestamp_to_seconds -> + 0 + | Sub_timestamp_seconds -> + 0 + | Diff_timestamps -> + 0 + | Add_tez -> + 0 + | Sub_tez -> + 0 + | Mul_teznat -> + 0 + | Mul_nattez -> + 0 + | Ediv_teznat -> + 0 + | Ediv_tez -> + 0 + | Or -> + 0 + | And -> + 0 + | Xor -> + 0 + | Not -> + 0 + | Is_nat -> + 0 + | Neg_nat -> + 0 + | Neg_int -> + 0 + | Abs_int -> + 0 + | Int_nat -> + 0 + | Add_intint -> + 0 + | Add_intnat -> + 0 + | Add_natint -> + 0 + | Add_natnat -> + 0 + | Sub_int -> + 0 + | Mul_intint -> + 0 + | Mul_intnat -> + 0 + | Mul_natint -> + 0 + | Mul_natnat -> + 0 + | Ediv_intint -> + 0 + | Ediv_intnat -> + 0 + | Ediv_natint -> + 0 + | Ediv_natnat -> + 0 + | Lsl_nat -> + 0 + | Lsr_nat -> + 0 + | Or_nat -> + 0 + | And_nat -> + 0 + | And_int_nat -> + 0 + | Xor_nat -> + 0 + | Not_nat -> + 0 + | Not_int -> + 0 + | Seq _ -> + 0 + | If _ -> + 0 + | Loop _ -> + 0 + | Loop_left _ -> + 0 + | Dip _ -> + 0 + | Exec -> + 0 + | Apply _ -> + 0 + | Lambda _ -> + 1 + | Failwith _ -> + 1 + | Nop -> + 0 + | Compare _ -> + 1 + | Eq -> + 0 + | Neq -> + 0 + | Lt -> + 0 + | Gt -> + 0 + | Le -> + 0 + | Ge -> + 0 + | Address -> + 0 + | Contract _ -> + 1 + | Transfer_tokens -> + 1 + | Create_account -> + 0 + | Implicit_account -> + 0 + | Create_contract _ -> + 1 + | Create_contract_2 _ -> + 1 + | Now -> + 0 + | Balance -> + 0 + | Check_signature -> + 0 + | Hash_key -> + 0 + | Blake2b -> + 0 + | Sha256 -> + 0 + | Sha512 -> + 0 + | Steps_to_quota -> + 0 + | Source -> + 0 + | Sender -> + 0 + | Self _ -> + 1 + | Amount -> + 0 + | Set_delegate -> + 0 + | Pack _ -> + 0 + | Unpack _ -> + 1 + | Dig _ -> + 0 + | Dug _ -> + 0 + | Dipn _ -> + 0 + | Dropn _ -> + 0 + | ChainId -> + 0 (* ---- Error helpers -------------------------------------------------------*) @@ -257,19 +423,24 @@ let location = function | Int (loc, _) | String (loc, _) | Bytes (loc, _) - | Seq (loc, _) -> loc + | Seq (loc, _) -> + loc let kind = function - | Int _ -> Int_kind - | String _ -> String_kind - | Bytes _ -> Bytes_kind - | Prim _ -> Prim_kind - | Seq _ -> Seq_kind + | Int _ -> + Int_kind + | String _ -> + String_kind + | Bytes _ -> + Bytes_kind + | Prim _ -> + Prim_kind + | Seq _ -> + Seq_kind let namespace = function - | K_parameter - | K_storage - | K_code -> Keyword_namespace + | K_parameter | K_storage | K_code -> + Keyword_namespace | D_False | D_Elt | D_Left @@ -278,7 +449,8 @@ let namespace = function | D_Right | D_Some | D_True - | D_Unit -> Constant_namespace + | D_Unit -> + Constant_namespace | I_PACK | I_UNPACK | I_BLAKE2B @@ -361,7 +533,8 @@ let namespace = function | I_CAST | I_RENAME | I_DIG - | I_DUG -> Instr_namespace + | I_DUG -> + Instr_namespace | T_bool | T_contract | T_int @@ -384,28 +557,31 @@ let namespace = function | T_unit | T_operation | T_address - | T_chain_id -> Type_namespace - + | T_chain_id -> + Type_namespace let unexpected expr exp_kinds exp_ns exp_prims = match expr with - | Int (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind) - | String (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind) - | Bytes (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind) - | Seq (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) - | Prim (loc, name, _, _) -> - match namespace name, exp_ns with - | Type_namespace, Type_namespace - | Instr_namespace, Instr_namespace - | Constant_namespace, Constant_namespace -> - Invalid_primitive (loc, exp_prims, name) - | ns, _ -> - Invalid_namespace (loc, name, exp_ns, ns) + | Int (loc, _) -> + Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind) + | String (loc, _) -> + Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind) + | Bytes (loc, _) -> + Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind) + | Seq (loc, _) -> + Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) + | Prim (loc, name, _, _) -> ( + match (namespace name, exp_ns) with + | (Type_namespace, Type_namespace) + | (Instr_namespace, Instr_namespace) + | (Constant_namespace, Constant_namespace) -> + Invalid_primitive (loc, exp_prims, name) + | (ns, _) -> + Invalid_namespace (loc, name, exp_ns, ns) ) let check_kind kinds expr = let kind = kind expr in - if List.mem kind kinds then - return_unit + if List.mem kind kinds then return_unit else let loc = location expr in fail (Invalid_kind (loc, kinds, kind)) @@ -414,3458 +590,5211 @@ let check_kind kinds expr = let wrap_compare compare a b = let res = compare a b in - if Compare.Int.(res = 0) then 0 - else if Compare.Int.(res > 0) then 1 - else -1 + if Compare.Int.(res = 0) then 0 else if Compare.Int.(res > 0) then 1 else -1 -let rec compare_comparable - : type a s. (a, s) comparable_struct -> a -> a -> int - = fun kind -> match kind with - | String_key _ -> wrap_compare Compare.String.compare - | Bool_key _ -> wrap_compare Compare.Bool.compare - | Mutez_key _ -> wrap_compare Tez.compare - | Key_hash_key _ -> wrap_compare Signature.Public_key_hash.compare - | Int_key _ -> wrap_compare Script_int.compare - | Nat_key _ -> wrap_compare Script_int.compare - | Timestamp_key _ -> wrap_compare Script_timestamp.compare - | Address_key _ -> - wrap_compare @@ fun (x, ex) (y, ey) -> - let lres = Contract.compare x y in - if Compare.Int.(lres = 0) then - Compare.String.compare ex ey - else lres - | Bytes_key _ -> wrap_compare MBytes.compare - | Pair_key ((tl, _), (tr, _), _) -> - fun (lx, rx) (ly, ry) -> - let lres = compare_comparable tl lx ly in - if Compare.Int.(lres = 0) then - compare_comparable tr rx ry - else lres +let rec compare_comparable : + type a s. (a, s) comparable_struct -> a -> a -> int = + fun kind -> + match kind with + | String_key _ -> + wrap_compare Compare.String.compare + | Bool_key _ -> + wrap_compare Compare.Bool.compare + | Mutez_key _ -> + wrap_compare Tez.compare + | Key_hash_key _ -> + wrap_compare Signature.Public_key_hash.compare + | Int_key _ -> + wrap_compare Script_int.compare + | Nat_key _ -> + wrap_compare Script_int.compare + | Timestamp_key _ -> + wrap_compare Script_timestamp.compare + | Address_key _ -> + wrap_compare + @@ fun (x, ex) (y, ey) -> + let lres = Contract.compare x y in + if Compare.Int.(lres = 0) then Compare.String.compare ex ey else lres + | Bytes_key _ -> + wrap_compare MBytes.compare + | Pair_key ((tl, _), (tr, _), _) -> + fun (lx, rx) (ly, ry) -> + let lres = compare_comparable tl lx ly in + if Compare.Int.(lres = 0) then compare_comparable tr rx ry else lres -let empty_set - : type a. a comparable_ty -> a set - = fun ty -> - let module OPS = Set.Make (struct - type t = a - let compare = compare_comparable ty - end) in - (module struct - type elt = a - let elt_ty = ty - module OPS = OPS - let boxed = OPS.empty - let size = 0 - end) +let empty_set : type a. a comparable_ty -> a set = + fun ty -> + let module OPS = Set.Make (struct + type t = a -let set_update - : type a. a -> bool -> a set -> a set - = fun v b (module Box) -> - (module struct - type elt = a - let elt_ty = Box.elt_ty - module OPS = Box.OPS - let boxed = - if b - then Box.OPS.add v Box.boxed - else Box.OPS.remove v Box.boxed - let size = - let mem = Box.OPS.mem v Box.boxed in - if mem - then if b then Box.size else Box.size - 1 - else if b then Box.size + 1 else Box.size - end) + let compare = compare_comparable ty + end) in + ( module struct + type elt = a -let set_mem - : type elt. elt -> elt set -> bool - = fun v (module Box) -> - Box.OPS.mem v Box.boxed + let elt_ty = ty -let set_fold - : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc - = fun f (module Box) -> - Box.OPS.fold f Box.boxed + module OPS = OPS -let set_size - : type elt. elt set -> Script_int.n Script_int.num = - fun (module Box) -> - Script_int.(abs (of_int Box.size)) + let boxed = OPS.empty -let map_key_ty - : type a b. (a, b) map -> a comparable_ty - = fun (module Box) -> Box.key_ty + let size = 0 + end ) -let empty_map - : type a b. a comparable_ty -> (a, b) map - = fun ty -> - let module OPS = Map.Make (struct - type t = a - let compare = compare_comparable ty - end) in - (module struct - type key = a - type value = b - let key_ty = ty - module OPS = OPS - let boxed = (OPS.empty, 0) - end) +let set_update : type a. a -> bool -> a set -> a set = + fun v b (module Box) -> + ( module struct + type elt = a -let map_get - : type key value. key -> (key, value) map -> value option - = fun k (module Box) -> - Box.OPS.find_opt k (fst Box.boxed) + let elt_ty = Box.elt_ty -let map_update - : type a b. a -> b option -> (a, b) map -> (a, b) map - = fun k v (module Box) -> - (module struct - type key = a - type value = b - let key_ty = Box.key_ty - module OPS = Box.OPS - let boxed = - let (map, size) = Box.boxed in - let contains = Box.OPS.mem k map in - match v with - | Some v -> (Box.OPS.add k v map, size + if contains then 0 else 1) - | None -> (Box.OPS.remove k map, size - if contains then 1 else 0) - end) + module OPS = Box.OPS -let map_set - : type a b. a -> b -> (a, b) map -> (a, b) map - = fun k v (module Box) -> - (module struct - type key = a - type value = b - let key_ty = Box.key_ty - module OPS = Box.OPS - let boxed = - let (map, size) = Box.boxed in - (Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1) - end) + let boxed = + if b then Box.OPS.add v Box.boxed else Box.OPS.remove v Box.boxed -let map_mem - : type key value. key -> (key, value) map -> bool - = fun k (module Box) -> - Box.OPS.mem k (fst Box.boxed) + let size = + let mem = Box.OPS.mem v Box.boxed in + if mem then if b then Box.size else Box.size - 1 + else if b then Box.size + 1 + else Box.size + end ) -let map_fold - : type key value acc. (key -> value -> acc -> acc) -> (key, value) map -> acc -> acc - = fun f (module Box) -> - Box.OPS.fold f (fst Box.boxed) +let set_mem : type elt. elt -> elt set -> bool = + fun v (module Box) -> Box.OPS.mem v Box.boxed -let map_size - : type key value. (key, value) map -> Script_int.n Script_int.num = - fun (module Box) -> - Script_int.(abs (of_int (snd Box.boxed))) +let set_fold : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc = + fun f (module Box) -> Box.OPS.fold f Box.boxed + +let set_size : type elt. elt set -> Script_int.n Script_int.num = + fun (module Box) -> Script_int.(abs (of_int Box.size)) + +let map_key_ty : type a b. (a, b) map -> a comparable_ty = + fun (module Box) -> Box.key_ty + +let empty_map : type a b. a comparable_ty -> (a, b) map = + fun ty -> + let module OPS = Map.Make (struct + type t = a + + let compare = compare_comparable ty + end) in + ( module struct + type key = a + + type value = b + + let key_ty = ty + + module OPS = OPS + + let boxed = (OPS.empty, 0) + end ) + +let map_get : type key value. key -> (key, value) map -> value option = + fun k (module Box) -> Box.OPS.find_opt k (fst Box.boxed) + +let map_update : type a b. a -> b option -> (a, b) map -> (a, b) map = + fun k v (module Box) -> + ( module struct + type key = a + + type value = b + + let key_ty = Box.key_ty + + module OPS = Box.OPS + + let boxed = + let (map, size) = Box.boxed in + let contains = Box.OPS.mem k map in + match v with + | Some v -> + (Box.OPS.add k v map, size + if contains then 0 else 1) + | None -> + (Box.OPS.remove k map, size - if contains then 1 else 0) + end ) + +let map_set : type a b. a -> b -> (a, b) map -> (a, b) map = + fun k v (module Box) -> + ( module struct + type key = a + + type value = b + + let key_ty = Box.key_ty + + module OPS = Box.OPS + + let boxed = + let (map, size) = Box.boxed in + (Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1) + end ) + +let map_mem : type key value. key -> (key, value) map -> bool = + fun k (module Box) -> Box.OPS.mem k (fst Box.boxed) + +let map_fold : + type key value acc. + (key -> value -> acc -> acc) -> (key, value) map -> acc -> acc = + fun f (module Box) -> Box.OPS.fold f (fst Box.boxed) + +let map_size : type key value. (key, value) map -> Script_int.n Script_int.num + = + fun (module Box) -> Script_int.(abs (of_int (snd Box.boxed))) (* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*) -let rec ty_of_comparable_ty - : type a s. (a, s) comparable_struct -> a ty - = function - | Int_key tname -> Int_t tname - | Nat_key tname -> Nat_t tname - | String_key tname -> String_t tname - | Bytes_key tname -> Bytes_t tname - | Mutez_key tname -> Mutez_t tname - | Bool_key tname -> Bool_t tname - | Key_hash_key tname -> Key_hash_t tname - | Timestamp_key tname -> Timestamp_t tname - | Address_key tname -> Address_t tname - | Pair_key ((l, al), (r, ar), tname) -> - Pair_t ((ty_of_comparable_ty l, al, None), (ty_of_comparable_ty r, ar, None), tname, false) +let rec ty_of_comparable_ty : type a s. (a, s) comparable_struct -> a ty = + function + | Int_key tname -> + Int_t tname + | Nat_key tname -> + Nat_t tname + | String_key tname -> + String_t tname + | Bytes_key tname -> + Bytes_t tname + | Mutez_key tname -> + Mutez_t tname + | Bool_key tname -> + Bool_t tname + | Key_hash_key tname -> + Key_hash_t tname + | Timestamp_key tname -> + Timestamp_t tname + | Address_key tname -> + Address_t tname + | Pair_key ((l, al), (r, ar), tname) -> + Pair_t + ( (ty_of_comparable_ty l, al, None), + (ty_of_comparable_ty r, ar, None), + tname, + false ) -let rec comparable_ty_of_ty - : type a. a ty -> a comparable_ty option - = function - | Int_t tname -> Some (Int_key tname) - | Nat_t tname -> Some (Nat_key tname) - | String_t tname -> Some (String_key tname) - | Bytes_t tname -> Some (Bytes_key tname) - | Mutez_t tname -> Some (Mutez_key tname) - | Bool_t tname -> Some (Bool_key tname) - | Key_hash_t tname -> Some (Key_hash_key tname) - | Timestamp_t tname -> Some (Timestamp_key tname) - | Address_t tname -> Some (Address_key tname) - | Pair_t ((l, al, _), (r, ar, _), pname, _) -> - begin match comparable_ty_of_ty r with - | None -> None - | Some rty -> - match comparable_ty_of_ty l with - | None -> None - | Some (Pair_key _) -> None (* not a comb *) - | Some (Int_key tname) -> Some (Pair_key ((Int_key tname, al), (rty, ar), pname)) - | Some (Nat_key tname) -> Some (Pair_key ((Nat_key tname, al), (rty, ar), pname)) - | Some (String_key tname) -> Some (Pair_key ((String_key tname, al), (rty, ar), pname)) - | Some (Bytes_key tname) -> Some (Pair_key ((Bytes_key tname, al), (rty, ar), pname)) - | Some (Mutez_key tname) -> Some (Pair_key ((Mutez_key tname, al), (rty, ar), pname)) - | Some (Bool_key tname) -> Some (Pair_key ((Bool_key tname, al), (rty, ar), pname)) - | Some (Key_hash_key tname) -> Some (Pair_key ((Key_hash_key tname, al), (rty, ar), pname)) - | Some (Timestamp_key tname) -> Some (Pair_key ((Timestamp_key tname, al), (rty, ar), pname)) - | Some (Address_key tname) -> Some (Pair_key ((Address_key tname, al), (rty, ar), pname)) - end - | _ -> None +let rec comparable_ty_of_ty : type a. a ty -> a comparable_ty option = function + | Int_t tname -> + Some (Int_key tname) + | Nat_t tname -> + Some (Nat_key tname) + | String_t tname -> + Some (String_key tname) + | Bytes_t tname -> + Some (Bytes_key tname) + | Mutez_t tname -> + Some (Mutez_key tname) + | Bool_t tname -> + Some (Bool_key tname) + | Key_hash_t tname -> + Some (Key_hash_key tname) + | Timestamp_t tname -> + Some (Timestamp_key tname) + | Address_t tname -> + Some (Address_key tname) + | Pair_t ((l, al, _), (r, ar, _), pname, _) -> ( + match comparable_ty_of_ty r with + | None -> + None + | Some rty -> ( + match comparable_ty_of_ty l with + | None -> + None + | Some (Pair_key _) -> + None (* not a comb *) + | Some (Int_key tname) -> + Some (Pair_key ((Int_key tname, al), (rty, ar), pname)) + | Some (Nat_key tname) -> + Some (Pair_key ((Nat_key tname, al), (rty, ar), pname)) + | Some (String_key tname) -> + Some (Pair_key ((String_key tname, al), (rty, ar), pname)) + | Some (Bytes_key tname) -> + Some (Pair_key ((Bytes_key tname, al), (rty, ar), pname)) + | Some (Mutez_key tname) -> + Some (Pair_key ((Mutez_key tname, al), (rty, ar), pname)) + | Some (Bool_key tname) -> + Some (Pair_key ((Bool_key tname, al), (rty, ar), pname)) + | Some (Key_hash_key tname) -> + Some (Pair_key ((Key_hash_key tname, al), (rty, ar), pname)) + | Some (Timestamp_key tname) -> + Some (Pair_key ((Timestamp_key tname, al), (rty, ar), pname)) + | Some (Address_key tname) -> + Some (Pair_key ((Address_key tname, al), (rty, ar), pname)) ) ) + | _ -> + None let add_field_annot a var = function | Prim (loc, prim, args, annots) -> - Prim (loc, prim, args, annots @ unparse_field_annot a @ unparse_var_annot var ) - | expr -> expr + Prim + ( loc, + prim, + args, + annots @ unparse_field_annot a @ unparse_var_annot var ) + | expr -> + expr -let rec unparse_comparable_ty - : type a s. (a, s) comparable_struct -> Script.node - = function - | Int_key tname -> Prim (-1, T_int, [], unparse_type_annot tname) - | Nat_key tname -> Prim (-1, T_nat, [], unparse_type_annot tname) - | String_key tname -> Prim (-1, T_string, [], unparse_type_annot tname) - | Bytes_key tname -> Prim (-1, T_bytes, [], unparse_type_annot tname) - | Mutez_key tname -> Prim (-1, T_mutez, [], unparse_type_annot tname) - | Bool_key tname -> Prim (-1, T_bool, [], unparse_type_annot tname) - | Key_hash_key tname -> Prim (-1, T_key_hash, [], unparse_type_annot tname) - | Timestamp_key tname -> Prim (-1, T_timestamp, [], unparse_type_annot tname) - | Address_key tname -> Prim (-1, T_address, [], unparse_type_annot tname) - | Pair_key ((l, al), (r, ar), pname) -> - let tl = add_field_annot al None (unparse_comparable_ty l) in - let tr = add_field_annot ar None (unparse_comparable_ty r) in - Prim (-1, T_pair, [ tl ; tr ], unparse_type_annot pname) +let rec unparse_comparable_ty : + type a s. (a, s) comparable_struct -> Script.node = function + | Int_key tname -> + Prim (-1, T_int, [], unparse_type_annot tname) + | Nat_key tname -> + Prim (-1, T_nat, [], unparse_type_annot tname) + | String_key tname -> + Prim (-1, T_string, [], unparse_type_annot tname) + | Bytes_key tname -> + Prim (-1, T_bytes, [], unparse_type_annot tname) + | Mutez_key tname -> + Prim (-1, T_mutez, [], unparse_type_annot tname) + | Bool_key tname -> + Prim (-1, T_bool, [], unparse_type_annot tname) + | Key_hash_key tname -> + Prim (-1, T_key_hash, [], unparse_type_annot tname) + | Timestamp_key tname -> + Prim (-1, T_timestamp, [], unparse_type_annot tname) + | Address_key tname -> + Prim (-1, T_address, [], unparse_type_annot tname) + | Pair_key ((l, al), (r, ar), pname) -> + let tl = add_field_annot al None (unparse_comparable_ty l) in + let tr = add_field_annot ar None (unparse_comparable_ty r) in + Prim (-1, T_pair, [tl; tr], unparse_type_annot pname) -let rec unparse_ty_no_lwt - : type a. context -> a ty -> (Script.node * context) tzresult - = fun ctxt ty -> - Gas.consume ctxt Unparse_costs.cycle >>? fun ctxt -> - let return ctxt (name, args, annot) = - let result = Prim (-1, name, args, annot) in - Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot) >>? fun ctxt -> - ok (result, ctxt) in - match ty with - | Unit_t tname -> return ctxt (T_unit, [], unparse_type_annot tname) - | Int_t tname -> return ctxt (T_int, [], unparse_type_annot tname) - | Nat_t tname -> return ctxt (T_nat, [], unparse_type_annot tname) - | String_t tname -> return ctxt (T_string, [], unparse_type_annot tname) - | Bytes_t tname -> return ctxt (T_bytes, [], unparse_type_annot tname) - | Mutez_t tname -> return ctxt (T_mutez, [], unparse_type_annot tname) - | Bool_t tname -> return ctxt (T_bool, [], unparse_type_annot tname) - | Key_hash_t tname -> return ctxt (T_key_hash, [], unparse_type_annot tname) - | Key_t tname -> return ctxt (T_key, [], unparse_type_annot tname) - | Timestamp_t tname -> return ctxt (T_timestamp, [], unparse_type_annot tname) - | Address_t tname -> return ctxt (T_address, [], unparse_type_annot tname) - | Signature_t tname -> return ctxt (T_signature, [], unparse_type_annot tname) - | Operation_t tname -> return ctxt (T_operation, [], unparse_type_annot tname) - | Chain_id_t tname -> return ctxt (T_chain_id, [], unparse_type_annot tname) - | Contract_t (ut, tname) -> - unparse_ty_no_lwt ctxt ut >>? fun (t, ctxt) -> - return ctxt (T_contract, [ t ], unparse_type_annot tname) - | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname, _) -> - let annot = unparse_type_annot tname in - unparse_ty_no_lwt ctxt utl >>? fun (utl, ctxt) -> - let tl = add_field_annot l_field l_var utl in - unparse_ty_no_lwt ctxt utr >>? fun (utr, ctxt) -> - let tr = add_field_annot r_field r_var utr in - return ctxt (T_pair, [ tl; tr ], annot) - | Union_t ((utl, l_field), (utr, r_field), tname, _) -> - let annot = unparse_type_annot tname in - unparse_ty_no_lwt ctxt utl >>? fun (utl, ctxt) -> - let tl = add_field_annot l_field None utl in - unparse_ty_no_lwt ctxt utr >>? fun (utr, ctxt) -> - let tr = add_field_annot r_field None utr in - return ctxt (T_or, [ tl; tr ], annot) - | Lambda_t (uta, utr, tname) -> - unparse_ty_no_lwt ctxt uta >>? fun (ta, ctxt) -> - unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> - return ctxt (T_lambda, [ ta; tr ], unparse_type_annot tname) - | Option_t (ut, tname, _) -> - let annot = unparse_type_annot tname in - unparse_ty_no_lwt ctxt ut >>? fun (ut, ctxt) -> - return ctxt (T_option, [ ut ], annot) - | List_t (ut, tname, _) -> - unparse_ty_no_lwt ctxt ut >>? fun (t, ctxt) -> - return ctxt (T_list, [ t ], unparse_type_annot tname) - | Set_t (ut, tname) -> - let t = unparse_comparable_ty ut in - return ctxt (T_set, [ t ], unparse_type_annot tname) - | Map_t (uta, utr, tname, _) -> - let ta = unparse_comparable_ty uta in - unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> - return ctxt (T_map, [ ta; tr ], unparse_type_annot tname) - | Big_map_t (uta, utr, tname) -> - let ta = unparse_comparable_ty uta in - unparse_ty_no_lwt ctxt utr >>? fun (tr, ctxt) -> - return ctxt (T_big_map, [ ta; tr ], unparse_type_annot tname) +let rec unparse_ty_no_lwt : + type a. context -> a ty -> (Script.node * context) tzresult = + fun ctxt ty -> + Gas.consume ctxt Unparse_costs.cycle + >>? fun ctxt -> + let return ctxt (name, args, annot) = + let result = Prim (-1, name, args, annot) in + Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot) + >>? fun ctxt -> ok (result, ctxt) + in + match ty with + | Unit_t tname -> + return ctxt (T_unit, [], unparse_type_annot tname) + | Int_t tname -> + return ctxt (T_int, [], unparse_type_annot tname) + | Nat_t tname -> + return ctxt (T_nat, [], unparse_type_annot tname) + | String_t tname -> + return ctxt (T_string, [], unparse_type_annot tname) + | Bytes_t tname -> + return ctxt (T_bytes, [], unparse_type_annot tname) + | Mutez_t tname -> + return ctxt (T_mutez, [], unparse_type_annot tname) + | Bool_t tname -> + return ctxt (T_bool, [], unparse_type_annot tname) + | Key_hash_t tname -> + return ctxt (T_key_hash, [], unparse_type_annot tname) + | Key_t tname -> + return ctxt (T_key, [], unparse_type_annot tname) + | Timestamp_t tname -> + return ctxt (T_timestamp, [], unparse_type_annot tname) + | Address_t tname -> + return ctxt (T_address, [], unparse_type_annot tname) + | Signature_t tname -> + return ctxt (T_signature, [], unparse_type_annot tname) + | Operation_t tname -> + return ctxt (T_operation, [], unparse_type_annot tname) + | Chain_id_t tname -> + return ctxt (T_chain_id, [], unparse_type_annot tname) + | Contract_t (ut, tname) -> + unparse_ty_no_lwt ctxt ut + >>? fun (t, ctxt) -> + return ctxt (T_contract, [t], unparse_type_annot tname) + | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname, _) -> + let annot = unparse_type_annot tname in + unparse_ty_no_lwt ctxt utl + >>? fun (utl, ctxt) -> + let tl = add_field_annot l_field l_var utl in + unparse_ty_no_lwt ctxt utr + >>? fun (utr, ctxt) -> + let tr = add_field_annot r_field r_var utr in + return ctxt (T_pair, [tl; tr], annot) + | Union_t ((utl, l_field), (utr, r_field), tname, _) -> + let annot = unparse_type_annot tname in + unparse_ty_no_lwt ctxt utl + >>? fun (utl, ctxt) -> + let tl = add_field_annot l_field None utl in + unparse_ty_no_lwt ctxt utr + >>? fun (utr, ctxt) -> + let tr = add_field_annot r_field None utr in + return ctxt (T_or, [tl; tr], annot) + | Lambda_t (uta, utr, tname) -> + unparse_ty_no_lwt ctxt uta + >>? fun (ta, ctxt) -> + unparse_ty_no_lwt ctxt utr + >>? fun (tr, ctxt) -> + return ctxt (T_lambda, [ta; tr], unparse_type_annot tname) + | Option_t (ut, tname, _) -> + let annot = unparse_type_annot tname in + unparse_ty_no_lwt ctxt ut + >>? fun (ut, ctxt) -> return ctxt (T_option, [ut], annot) + | List_t (ut, tname, _) -> + unparse_ty_no_lwt ctxt ut + >>? fun (t, ctxt) -> return ctxt (T_list, [t], unparse_type_annot tname) + | Set_t (ut, tname) -> + let t = unparse_comparable_ty ut in + return ctxt (T_set, [t], unparse_type_annot tname) + | Map_t (uta, utr, tname, _) -> + let ta = unparse_comparable_ty uta in + unparse_ty_no_lwt ctxt utr + >>? fun (tr, ctxt) -> + return ctxt (T_map, [ta; tr], unparse_type_annot tname) + | Big_map_t (uta, utr, tname) -> + let ta = unparse_comparable_ty uta in + unparse_ty_no_lwt ctxt utr + >>? fun (tr, ctxt) -> + return ctxt (T_big_map, [ta; tr], unparse_type_annot tname) let unparse_ty ctxt ty = Lwt.return (unparse_ty_no_lwt ctxt ty) let rec strip_var_annots = function - | Int _ | String _ | Bytes _ as atom -> atom - | Seq (loc, args) -> Seq (loc, List.map strip_var_annots args) + | (Int _ | String _ | Bytes _) as atom -> + atom + | Seq (loc, args) -> + Seq (loc, List.map strip_var_annots args) | Prim (loc, name, args, annots) -> - let not_var_annot s = Compare.Char.(String.get s 0 <> '@') in + let not_var_annot s = Compare.Char.(s.[0] <> '@') in let annots = List.filter not_var_annot annots in Prim (loc, name, List.map strip_var_annots args, annots) let serialize_ty_for_error ctxt ty = - unparse_ty_no_lwt ctxt ty |> - record_trace Cannot_serialize_error >|? fun (ty, ctxt) -> - strip_locations (strip_var_annots ty), ctxt + unparse_ty_no_lwt ctxt ty + |> record_trace Cannot_serialize_error + >|? fun (ty, ctxt) -> (strip_locations (strip_var_annots ty), ctxt) -let rec unparse_stack - : type a. context -> a stack_ty -> ((Script.expr * Script.annot) list * context) tzresult Lwt.t - = fun ctxt -> function - | Empty_t -> return ([], ctxt) - | Item_t (ty, rest, annot) -> - unparse_ty ctxt ty >>=? fun (uty, ctxt) -> - unparse_stack ctxt rest >>=? fun (urest, ctxt) -> - return ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt) +let rec unparse_stack : + type a. + context -> + a stack_ty -> + ((Script.expr * Script.annot) list * context) tzresult Lwt.t = + fun ctxt -> function + | Empty_t -> + return ([], ctxt) + | Item_t (ty, rest, annot) -> + unparse_ty ctxt ty + >>=? fun (uty, ctxt) -> + unparse_stack ctxt rest + >>=? fun (urest, ctxt) -> + return ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt) let serialize_stack_for_error ctxt stack_ty = trace Cannot_serialize_error (unparse_stack ctxt stack_ty) -let name_of_ty - : type a. a ty -> type_annot option - = function - | Unit_t tname -> tname - | Int_t tname -> tname - | Nat_t tname -> tname - | String_t tname -> tname - | Bytes_t tname -> tname - | Mutez_t tname -> tname - | Bool_t tname -> tname - | Key_hash_t tname -> tname - | Key_t tname -> tname - | Timestamp_t tname -> tname - | Address_t tname -> tname - | Signature_t tname -> tname - | Operation_t tname -> tname - | Chain_id_t tname -> tname - | Contract_t (_, tname) -> tname - | Pair_t (_, _, tname, _) -> tname - | Union_t (_, _, tname, _) -> tname - | Lambda_t (_, _, tname) -> tname - | Option_t (_, tname, _) -> tname - | List_t (_, tname, _) -> tname - | Set_t (_, tname) -> tname - | Map_t (_, _, tname, _) -> tname - | Big_map_t (_, _, tname) -> tname +let name_of_ty : type a. a ty -> type_annot option = function + | Unit_t tname -> + tname + | Int_t tname -> + tname + | Nat_t tname -> + tname + | String_t tname -> + tname + | Bytes_t tname -> + tname + | Mutez_t tname -> + tname + | Bool_t tname -> + tname + | Key_hash_t tname -> + tname + | Key_t tname -> + tname + | Timestamp_t tname -> + tname + | Address_t tname -> + tname + | Signature_t tname -> + tname + | Operation_t tname -> + tname + | Chain_id_t tname -> + tname + | Contract_t (_, tname) -> + tname + | Pair_t (_, _, tname, _) -> + tname + | Union_t (_, _, tname, _) -> + tname + | Lambda_t (_, _, tname) -> + tname + | Option_t (_, tname, _) -> + tname + | List_t (_, tname, _) -> + tname + | Set_t (_, tname) -> + tname + | Map_t (_, _, tname, _) -> + tname + | Big_map_t (_, _, tname) -> + tname (* ---- Equality witnesses --------------------------------------------------*) type ('ta, 'tb) eq = Eq : ('same, 'same) eq -let comparable_ty_eq - : type ta tb. +let rec comparable_ty_eq : + type ta tb s. context -> - ta comparable_ty -> tb comparable_ty -> - (ta comparable_ty, tb comparable_ty) eq tzresult - = fun ctxt ta tb -> match ta, tb with - | Int_key _, Int_key _ -> Ok Eq - | Nat_key _, Nat_key _ -> Ok Eq - | String_key _, String_key _ -> Ok Eq - | Bytes_key _, Bytes_key _ -> Ok Eq - | Mutez_key _, Mutez_key _ -> Ok Eq - | Bool_key _, Bool_key _ -> Ok Eq - | Key_hash_key _, Key_hash_key _ -> Ok Eq - | Timestamp_key _, Timestamp_key _ -> Ok Eq - | Address_key _, Address_key _ -> Ok Eq - | _, _ -> - serialize_ty_for_error ctxt (ty_of_comparable_ty ta) >>? fun (ta, ctxt) -> - serialize_ty_for_error ctxt (ty_of_comparable_ty tb) >>? fun (tb, _ctxt) -> - error (Inconsistent_types (ta, tb)) + (ta, s) comparable_struct -> + (tb, s) comparable_struct -> + (((ta, s) comparable_struct, (tb, s) comparable_struct) eq * context) + tzresult = + fun ctxt ta tb -> + Gas.consume ctxt Typecheck_costs.cycle + >>? fun ctxt -> + match (ta, tb) with + | (Int_key _, Int_key _) -> + Ok + ((Eq : ((ta, s) comparable_struct, (tb, s) comparable_struct) eq), ctxt) + | (Nat_key _, Nat_key _) -> + Ok (Eq, ctxt) + | (String_key _, String_key _) -> + Ok (Eq, ctxt) + | (Bytes_key _, Bytes_key _) -> + Ok (Eq, ctxt) + | (Mutez_key _, Mutez_key _) -> + Ok (Eq, ctxt) + | (Bool_key _, Bool_key _) -> + Ok (Eq, ctxt) + | (Key_hash_key _, Key_hash_key _) -> + Ok (Eq, ctxt) + | (Timestamp_key _, Timestamp_key _) -> + Ok (Eq, ctxt) + | (Address_key _, Address_key _) -> + Ok (Eq, ctxt) + | ( Pair_key ((lefta, _), (righta, _), _), + Pair_key ((leftb, _), (rightb, _), _) ) -> + comparable_ty_eq ctxt lefta leftb + >>? fun (Eq, ctxt) -> + comparable_ty_eq ctxt righta rightb + >>? fun (Eq, ctxt) -> + Ok + ((Eq : ((ta, s) comparable_struct, (tb, s) comparable_struct) eq), ctxt) + | (_, _) -> + serialize_ty_for_error ctxt (ty_of_comparable_ty ta) + >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt (ty_of_comparable_ty tb) + >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb)) let record_inconsistent ctxt ta tb = record_trace_eval (fun () -> - serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> - serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) -> - Inconsistent_types (ta, tb)) + serialize_ty_for_error ctxt ta + >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb + >|? fun (tb, _ctxt) -> Inconsistent_types (ta, tb)) let record_inconsistent_type_annotations ctxt loc ta tb = record_trace_eval (fun () -> - serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> - serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) -> - Inconsistent_type_annotations (loc, ta, tb)) + serialize_ty_for_error ctxt ta + >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb + >|? fun (tb, _ctxt) -> Inconsistent_type_annotations (loc, ta, tb)) -let rec ty_eq - : type ta tb. context -> ta ty -> tb ty -> ((ta ty, tb ty) eq * context) tzresult - = fun ctxt ta tb -> - let ok (eq : (ta ty, tb ty) eq) ctxt nb_args : +let rec ty_eq : + type ta tb. + context -> ta ty -> tb ty -> ((ta ty, tb ty) eq * context) tzresult = + fun ctxt ta tb -> + let ok (eq : (ta ty, tb ty) eq) ctxt nb_args : ((ta ty, tb ty) eq * context) tzresult = - Gas.consume ctxt (Typecheck_costs.type_ (2 * nb_args)) >>? fun ctxt -> - Ok (eq, ctxt) in - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - match ta, tb with - | Unit_t _, Unit_t _ -> ok Eq ctxt 0 - | Int_t _, Int_t _ -> ok Eq ctxt 0 - | Nat_t _, Nat_t _ -> ok Eq ctxt 0 - | Key_t _, Key_t _ -> ok Eq ctxt 0 - | Key_hash_t _, Key_hash_t _ -> ok Eq ctxt 0 - | String_t _, String_t _ -> ok Eq ctxt 0 - | Bytes_t _, Bytes_t _ -> ok Eq ctxt 0 - | Signature_t _, Signature_t _ -> ok Eq ctxt 0 - | Mutez_t _, Mutez_t _ -> ok Eq ctxt 0 - | Timestamp_t _, Timestamp_t _ -> ok Eq ctxt 0 - | Chain_id_t _, Chain_id_t _ -> ok Eq ctxt 0 - | Address_t _, Address_t _ -> ok Eq ctxt 0 - | Bool_t _, Bool_t _ -> ok Eq ctxt 0 - | Operation_t _, Operation_t _ -> ok Eq ctxt 0 - | Map_t (tal, tar, _, _), Map_t (tbl, tbr, _, _) -> - (comparable_ty_eq ctxt tal tbl >>? fun Eq -> - ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> - (ok Eq ctxt 2)) |> - record_inconsistent ctxt ta tb - | Big_map_t (tal, tar, _), Big_map_t (tbl, tbr, _) -> - (comparable_ty_eq ctxt tal tbl >>? fun Eq -> - ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> - (ok Eq ctxt 2)) |> - record_inconsistent ctxt ta tb - | Set_t (ea, _), Set_t (eb, _) -> - (comparable_ty_eq ctxt ea eb >>? fun Eq -> - (ok Eq ctxt 1)) |> - record_inconsistent ctxt ta tb - | Pair_t ((tal, _, _), (tar, _, _), _, _), - Pair_t ((tbl, _, _), (tbr, _, _), _, _) -> - (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> - ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> - (ok Eq ctxt 2)) |> - record_inconsistent ctxt ta tb - | Union_t ((tal, _), (tar, _), _, _), - Union_t ((tbl, _), (tbr, _), _, _) -> - (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> - ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> - (ok Eq ctxt 2)) |> - record_inconsistent ctxt ta tb - | Lambda_t (tal, tar, _), Lambda_t (tbl, tbr, _) -> - (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> - ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> - (ok Eq ctxt 2)) |> - record_inconsistent ctxt ta tb - | Contract_t (tal, _), Contract_t (tbl, _) -> - (ty_eq ctxt tal tbl >>? fun (Eq, ctxt) -> - (ok Eq ctxt 1)) |> - record_inconsistent ctxt ta tb - | Option_t (tva, _, _), Option_t (tvb, _, _) -> - (ty_eq ctxt tva tvb >>? fun (Eq, ctxt) -> - (ok Eq ctxt 1)) |> - record_inconsistent ctxt ta tb - | List_t (tva, _, _), List_t (tvb, _, _) -> - (ty_eq ctxt tva tvb >>? fun (Eq, ctxt) -> - (ok Eq ctxt 1)) |> - record_inconsistent ctxt ta tb - | _, _ -> - serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> - serialize_ty_for_error ctxt tb >>? fun (tb, _ctxt) -> - error (Inconsistent_types (ta, tb)) + Gas.consume ctxt (Typecheck_costs.type_ (2 * nb_args)) + >>? fun ctxt -> Ok (eq, ctxt) + in + Gas.consume ctxt Typecheck_costs.cycle + >>? fun ctxt -> + match (ta, tb) with + | (Unit_t _, Unit_t _) -> + ok Eq ctxt 0 + | (Int_t _, Int_t _) -> + ok Eq ctxt 0 + | (Nat_t _, Nat_t _) -> + ok Eq ctxt 0 + | (Key_t _, Key_t _) -> + ok Eq ctxt 0 + | (Key_hash_t _, Key_hash_t _) -> + ok Eq ctxt 0 + | (String_t _, String_t _) -> + ok Eq ctxt 0 + | (Bytes_t _, Bytes_t _) -> + ok Eq ctxt 0 + | (Signature_t _, Signature_t _) -> + ok Eq ctxt 0 + | (Mutez_t _, Mutez_t _) -> + ok Eq ctxt 0 + | (Timestamp_t _, Timestamp_t _) -> + ok Eq ctxt 0 + | (Chain_id_t _, Chain_id_t _) -> + ok Eq ctxt 0 + | (Address_t _, Address_t _) -> + ok Eq ctxt 0 + | (Bool_t _, Bool_t _) -> + ok Eq ctxt 0 + | (Operation_t _, Operation_t _) -> + ok Eq ctxt 0 + | (Map_t (tal, tar, _, _), Map_t (tbl, tbr, _, _)) -> + comparable_ty_eq ctxt tal tbl + >>? (fun (Eq, ctxt) -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2) + |> record_inconsistent ctxt ta tb + | (Big_map_t (tal, tar, _), Big_map_t (tbl, tbr, _)) -> + comparable_ty_eq ctxt tal tbl + >>? (fun (Eq, ctxt) -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2) + |> record_inconsistent ctxt ta tb + | (Set_t (ea, _), Set_t (eb, _)) -> + comparable_ty_eq ctxt ea eb + >>? (fun (Eq, ctxt) -> ok Eq ctxt 1) + |> record_inconsistent ctxt ta tb + | ( Pair_t ((tal, _, _), (tar, _, _), _, _), + Pair_t ((tbl, _, _), (tbr, _, _), _, _) ) -> + ty_eq ctxt tal tbl + >>? (fun (Eq, ctxt) -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2) + |> record_inconsistent ctxt ta tb + | (Union_t ((tal, _), (tar, _), _, _), Union_t ((tbl, _), (tbr, _), _, _)) -> + ty_eq ctxt tal tbl + >>? (fun (Eq, ctxt) -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2) + |> record_inconsistent ctxt ta tb + | (Lambda_t (tal, tar, _), Lambda_t (tbl, tbr, _)) -> + ty_eq ctxt tal tbl + >>? (fun (Eq, ctxt) -> + ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2) + |> record_inconsistent ctxt ta tb + | (Contract_t (tal, _), Contract_t (tbl, _)) -> + ty_eq ctxt tal tbl + >>? (fun (Eq, ctxt) -> ok Eq ctxt 1) + |> record_inconsistent ctxt ta tb + | (Option_t (tva, _, _), Option_t (tvb, _, _)) -> + ty_eq ctxt tva tvb + >>? (fun (Eq, ctxt) -> ok Eq ctxt 1) + |> record_inconsistent ctxt ta tb + | (List_t (tva, _, _), List_t (tvb, _, _)) -> + ty_eq ctxt tva tvb + >>? (fun (Eq, ctxt) -> ok Eq ctxt 1) + |> record_inconsistent ctxt ta tb + | (_, _) -> + serialize_ty_for_error ctxt ta + >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb + >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb)) -let rec stack_ty_eq - : type ta tb. context -> int -> ta stack_ty -> tb stack_ty -> - ((ta stack_ty, tb stack_ty) eq * context) tzresult - = fun ctxt lvl ta tb -> - match ta, tb with - | Item_t (tva, ra, _), Item_t (tvb, rb, _) -> - ty_eq ctxt tva tvb |> - record_trace (Bad_stack_item lvl) >>? fun (Eq, ctxt) -> - stack_ty_eq ctxt (lvl + 1) ra rb >>? fun (Eq, ctxt) -> - (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult) - | Empty_t, Empty_t -> Ok (Eq, ctxt) - | _, _ -> error Bad_stack_length +let rec stack_ty_eq : + type ta tb. + context -> + int -> + ta stack_ty -> + tb stack_ty -> + ((ta stack_ty, tb stack_ty) eq * context) tzresult = + fun ctxt lvl ta tb -> + match (ta, tb) with + | (Item_t (tva, ra, _), Item_t (tvb, rb, _)) -> + ty_eq ctxt tva tvb + |> record_trace (Bad_stack_item lvl) + >>? fun (Eq, ctxt) -> + stack_ty_eq ctxt (lvl + 1) ra rb + >>? fun (Eq, ctxt) -> + (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult) + | (Empty_t, Empty_t) -> + Ok (Eq, ctxt) + | (_, _) -> + error Bad_stack_length -let merge_comparable_types - : type ta. legacy: bool -> ta comparable_ty -> ta comparable_ty -> ta comparable_ty tzresult - = fun ~legacy ta tb -> - match ta, tb with - | Int_key annot_a, Int_key annot_b -> - merge_type_annot ~legacy annot_a annot_b >|? fun annot -> - Int_key annot - | Nat_key annot_a, Nat_key annot_b -> - merge_type_annot ~legacy annot_a annot_b >|? fun annot -> - Nat_key annot - | String_key annot_a, String_key annot_b -> - merge_type_annot ~legacy annot_a annot_b >|? fun annot -> - String_key annot - | Bytes_key annot_a, Bytes_key annot_b -> - merge_type_annot ~legacy annot_a annot_b >|? fun annot -> - Bytes_key annot - | Mutez_key annot_a, Mutez_key annot_b -> - merge_type_annot ~legacy annot_a annot_b >|? fun annot -> - Mutez_key annot - | Bool_key annot_a, Bool_key annot_b -> - merge_type_annot ~legacy annot_a annot_b >|? fun annot -> - Bool_key annot - | Key_hash_key annot_a, Key_hash_key annot_b -> - merge_type_annot ~legacy annot_a annot_b >|? fun annot -> - Key_hash_key annot - | Timestamp_key annot_a, Timestamp_key annot_b -> - merge_type_annot ~legacy annot_a annot_b >|? fun annot -> - Timestamp_key annot - | Address_key annot_a, Address_key annot_b -> - merge_type_annot ~legacy annot_a annot_b >|? fun annot -> - Address_key annot - | _, _ -> assert false (* FIXME: fix injectivity of some types *) +let rec merge_comparable_types : + type ta s. + legacy:bool -> + (ta, s) comparable_struct -> + (ta, s) comparable_struct -> + (ta, s) comparable_struct tzresult = + fun ~legacy ta tb -> + match (ta, tb) with + | (Int_key annot_a, Int_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Int_key annot + | (Nat_key annot_a, Nat_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Nat_key annot + | (String_key annot_a, String_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> String_key annot + | (Bytes_key annot_a, Bytes_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bytes_key annot + | (Mutez_key annot_a, Mutez_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Mutez_key annot + | (Bool_key annot_a, Bool_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bool_key annot + | (Key_hash_key annot_a, Key_hash_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> Key_hash_key annot + | (Timestamp_key annot_a, Timestamp_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> Timestamp_key annot + | (Address_key annot_a, Address_key annot_b) -> + merge_type_annot ~legacy annot_a annot_b + >|? fun annot -> Address_key annot + | ( Pair_key ((left_a, annot_left_a), (right_a, annot_right_a), annot_a), + Pair_key ((left_b, annot_left_b), (right_b, annot_right_b), annot_b) ) -> + merge_type_annot ~legacy annot_a annot_b + >>? fun annot -> + merge_field_annot ~legacy annot_left_a annot_left_b + >>? fun annot_left -> + merge_field_annot ~legacy annot_right_a annot_right_b + >>? fun annot_right -> + merge_comparable_types ~legacy left_a left_b + >>? fun left -> + merge_comparable_types ~legacy right_a right_b + >|? fun right -> + Pair_key ((left, annot_left), (right, annot_right), annot) + | (_, _) -> + assert false + +(* FIXME: fix injectivity of some types *) let merge_types : - type b. legacy: bool -> context -> Script.location -> b ty -> b ty -> (b ty * context) tzresult = fun ~legacy -> - let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult - = fun ctxt ty1 ty2 -> - match ty1, ty2 with - | Unit_t tn1, Unit_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Unit_t tname, ctxt - | Int_t tn1, Int_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Int_t tname, ctxt - | Nat_t tn1, Nat_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Nat_t tname, ctxt - | Key_t tn1, Key_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Key_t tname, ctxt - | Key_hash_t tn1, Key_hash_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Key_hash_t tname, ctxt - | String_t tn1, String_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - String_t tname, ctxt - | Bytes_t tn1, Bytes_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Bytes_t tname, ctxt - | Signature_t tn1, Signature_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Signature_t tname, ctxt - | Mutez_t tn1, Mutez_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Mutez_t tname, ctxt - | Timestamp_t tn1, Timestamp_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Timestamp_t tname, ctxt - | Address_t tn1, Address_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Address_t tname, ctxt - | Bool_t tn1, Bool_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Bool_t tname, ctxt - | Chain_id_t tn1, Chain_id_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Chain_id_t tname, ctxt - | Operation_t tn1, Operation_t tn2 -> - merge_type_annot ~legacy tn1 tn2 >|? fun tname -> - Operation_t tname, ctxt - | Map_t (tal, tar, tn1, has_big_map), Map_t (tbl, tbr, tn2, _) -> - merge_type_annot ~legacy tn1 tn2 >>? fun tname -> - help ctxt tar tbr >>? fun (value, ctxt) -> - ty_eq ctxt tar value >>? fun (Eq, ctxt) -> - merge_comparable_types ~legacy tal tbl >|? fun tk -> - Map_t (tk, value, tname, has_big_map), ctxt - | Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2) -> - merge_type_annot ~legacy tn1 tn2 >>? fun tname -> - help ctxt tar tbr >>? fun (value, ctxt) -> - ty_eq ctxt tar value >>? fun (Eq, ctxt) -> - merge_comparable_types ~legacy tal tbl >|? fun tk -> - Big_map_t (tk, value, tname), ctxt - | Set_t (ea, tn1), Set_t (eb, tn2) -> - merge_type_annot ~legacy tn1 tn2 >>? fun tname -> - merge_comparable_types ~legacy ea eb >|? fun e -> - Set_t (e, tname), ctxt - | Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1, has_big_map), - Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2, _) -> - merge_type_annot ~legacy tn1 tn2 >>? fun tname -> - merge_field_annot ~legacy l_field1 l_field2 >>? fun l_field -> - merge_field_annot ~legacy r_field1 r_field2 >>? fun r_field -> - let l_var = merge_var_annot l_var1 l_var2 in - let r_var = merge_var_annot r_var1 r_var2 in - help ctxt tal tbl >>? fun (left_ty, ctxt) -> - help ctxt tar tbr >|? fun (right_ty, ctxt) -> - Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname, has_big_map), - ctxt - | Union_t ((tal, tal_annot), (tar, tar_annot), tn1, has_big_map), - Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2, _) -> - merge_type_annot ~legacy tn1 tn2 >>? fun tname -> - merge_field_annot ~legacy tal_annot tbl_annot >>? fun left_annot -> - merge_field_annot ~legacy tar_annot tbr_annot >>? fun right_annot -> - help ctxt tal tbl >>? fun (left_ty, ctxt) -> - help ctxt tar tbr >|? fun (right_ty, ctxt) -> - Union_t ((left_ty, left_annot), (right_ty, right_annot), tname, has_big_map), - ctxt - | Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2) -> - merge_type_annot ~legacy tn1 tn2 >>? fun tname -> - help ctxt tal tbl >>? fun (left_ty, ctxt) -> - help ctxt tar tbr >|? fun (right_ty, ctxt) -> - Lambda_t (left_ty, right_ty, tname), ctxt - | Contract_t (tal, tn1), Contract_t (tbl, tn2) -> - merge_type_annot ~legacy tn1 tn2 >>? fun tname -> - help ctxt tal tbl >|? fun (arg_ty, ctxt) -> - Contract_t (arg_ty, tname), ctxt - | Option_t (tva, tn1, has_big_map), - Option_t (tvb, tn2, _) -> - merge_type_annot ~legacy tn1 tn2 >>? fun tname -> - help ctxt tva tvb >|? fun (ty, ctxt) -> - Option_t (ty, tname, has_big_map), ctxt - | List_t (tva, tn1, has_big_map), List_t (tvb, tn2, _) -> - merge_type_annot ~legacy tn1 tn2 >>? fun tname -> - help ctxt tva tvb >|? fun (ty, ctxt) -> - List_t (ty, tname, has_big_map), ctxt - | _, _ -> assert false - in (fun ctxt loc ty1 ty2 -> - record_inconsistent_type_annotations ctxt loc ty1 ty2 - (help ctxt ty1 ty2)) + type b. + legacy:bool -> + context -> + Script.location -> + b ty -> + b ty -> + (b ty * context) tzresult = + fun ~legacy -> + let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult = + fun ctxt ty1 ty2 -> + match (ty1, ty2) with + | (Unit_t tn1, Unit_t tn2) -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Unit_t tname, ctxt) + | (Int_t tn1, Int_t tn2) -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Int_t tname, ctxt) + | (Nat_t tn1, Nat_t tn2) -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Nat_t tname, ctxt) + | (Key_t tn1, Key_t tn2) -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Key_t tname, ctxt) + | (Key_hash_t tn1, Key_hash_t tn2) -> + merge_type_annot ~legacy tn1 tn2 + >|? fun tname -> (Key_hash_t tname, ctxt) + | (String_t tn1, String_t tn2) -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (String_t tname, ctxt) + | (Bytes_t tn1, Bytes_t tn2) -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bytes_t tname, ctxt) + | (Signature_t tn1, Signature_t tn2) -> + merge_type_annot ~legacy tn1 tn2 + >|? fun tname -> (Signature_t tname, ctxt) + | (Mutez_t tn1, Mutez_t tn2) -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Mutez_t tname, ctxt) + | (Timestamp_t tn1, Timestamp_t tn2) -> + merge_type_annot ~legacy tn1 tn2 + >|? fun tname -> (Timestamp_t tname, ctxt) + | (Address_t tn1, Address_t tn2) -> + merge_type_annot ~legacy tn1 tn2 + >|? fun tname -> (Address_t tname, ctxt) + | (Bool_t tn1, Bool_t tn2) -> + merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bool_t tname, ctxt) + | (Chain_id_t tn1, Chain_id_t tn2) -> + merge_type_annot ~legacy tn1 tn2 + >|? fun tname -> (Chain_id_t tname, ctxt) + | (Operation_t tn1, Operation_t tn2) -> + merge_type_annot ~legacy tn1 tn2 + >|? fun tname -> (Operation_t tname, ctxt) + | (Map_t (tal, tar, tn1, has_big_map), Map_t (tbl, tbr, tn2, _)) -> + merge_type_annot ~legacy tn1 tn2 + >>? fun tname -> + help ctxt tar tbr + >>? fun (value, ctxt) -> + ty_eq ctxt tar value + >>? fun (Eq, ctxt) -> + merge_comparable_types ~legacy tal tbl + >|? fun tk -> (Map_t (tk, value, tname, has_big_map), ctxt) + | (Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2)) -> + merge_type_annot ~legacy tn1 tn2 + >>? fun tname -> + help ctxt tar tbr + >>? fun (value, ctxt) -> + ty_eq ctxt tar value + >>? fun (Eq, ctxt) -> + merge_comparable_types ~legacy tal tbl + >|? fun tk -> (Big_map_t (tk, value, tname), ctxt) + | (Set_t (ea, tn1), Set_t (eb, tn2)) -> + merge_type_annot ~legacy tn1 tn2 + >>? fun tname -> + merge_comparable_types ~legacy ea eb + >|? fun e -> (Set_t (e, tname), ctxt) + | ( Pair_t + ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1, has_big_map), + Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2, _) ) -> + merge_type_annot ~legacy tn1 tn2 + >>? fun tname -> + merge_field_annot ~legacy l_field1 l_field2 + >>? fun l_field -> + merge_field_annot ~legacy r_field1 r_field2 + >>? fun r_field -> + let l_var = merge_var_annot l_var1 l_var2 in + let r_var = merge_var_annot r_var1 r_var2 in + help ctxt tal tbl + >>? fun (left_ty, ctxt) -> + help ctxt tar tbr + >|? fun (right_ty, ctxt) -> + ( Pair_t + ( (left_ty, l_field, l_var), + (right_ty, r_field, r_var), + tname, + has_big_map ), + ctxt ) + | ( Union_t ((tal, tal_annot), (tar, tar_annot), tn1, has_big_map), + Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2, _) ) -> + merge_type_annot ~legacy tn1 tn2 + >>? fun tname -> + merge_field_annot ~legacy tal_annot tbl_annot + >>? fun left_annot -> + merge_field_annot ~legacy tar_annot tbr_annot + >>? fun right_annot -> + help ctxt tal tbl + >>? fun (left_ty, ctxt) -> + help ctxt tar tbr + >|? fun (right_ty, ctxt) -> + ( Union_t + ((left_ty, left_annot), (right_ty, right_annot), tname, has_big_map), + ctxt ) + | (Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2)) -> + merge_type_annot ~legacy tn1 tn2 + >>? fun tname -> + help ctxt tal tbl + >>? fun (left_ty, ctxt) -> + help ctxt tar tbr + >|? fun (right_ty, ctxt) -> (Lambda_t (left_ty, right_ty, tname), ctxt) + | (Contract_t (tal, tn1), Contract_t (tbl, tn2)) -> + merge_type_annot ~legacy tn1 tn2 + >>? fun tname -> + help ctxt tal tbl + >|? fun (arg_ty, ctxt) -> (Contract_t (arg_ty, tname), ctxt) + | (Option_t (tva, tn1, has_big_map), Option_t (tvb, tn2, _)) -> + merge_type_annot ~legacy tn1 tn2 + >>? fun tname -> + help ctxt tva tvb + >|? fun (ty, ctxt) -> (Option_t (ty, tname, has_big_map), ctxt) + | (List_t (tva, tn1, has_big_map), List_t (tvb, tn2, _)) -> + merge_type_annot ~legacy tn1 tn2 + >>? fun tname -> + help ctxt tva tvb + >|? fun (ty, ctxt) -> (List_t (ty, tname, has_big_map), ctxt) + | (_, _) -> + assert false + in + fun ctxt loc ty1 ty2 -> + record_inconsistent_type_annotations ctxt loc ty1 ty2 (help ctxt ty1 ty2) -let merge_stacks - : type ta. legacy: bool -> Script.location -> context -> ta stack_ty -> ta stack_ty -> - (ta stack_ty * context) tzresult - = fun ~legacy loc -> - let rec help : type a. context -> a stack_ty -> a stack_ty -> - (a stack_ty * context) tzresult - = fun ctxt stack1 stack2 -> - match stack1, stack2 with - | Empty_t, Empty_t -> ok (Empty_t, ctxt) - | Item_t (ty1, rest1, annot1), - Item_t (ty2, rest2, annot2) -> - let annot = merge_var_annot annot1 annot2 in - merge_types ~legacy ctxt loc ty1 ty2 >>? fun (ty, ctxt) -> - help ctxt rest1 rest2 >|? fun (rest, ctxt) -> - Item_t (ty, rest, annot), ctxt - in help +let merge_stacks : + type ta. + legacy:bool -> + Script.location -> + context -> + ta stack_ty -> + ta stack_ty -> + (ta stack_ty * context) tzresult = + fun ~legacy loc -> + let rec help : + type a. + context -> a stack_ty -> a stack_ty -> (a stack_ty * context) tzresult = + fun ctxt stack1 stack2 -> + match (stack1, stack2) with + | (Empty_t, Empty_t) -> + ok (Empty_t, ctxt) + | (Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2)) -> + let annot = merge_var_annot annot1 annot2 in + merge_types ~legacy ctxt loc ty1 ty2 + >>? fun (ty, ctxt) -> + help ctxt rest1 rest2 + >|? fun (rest, ctxt) -> (Item_t (ty, rest, annot), ctxt) + in + help -let has_big_map - : type t. t ty -> bool - = function - | Unit_t _ -> false - | Int_t _ -> false - | Nat_t _ -> false - | Signature_t _ -> false - | String_t _ -> false - | Bytes_t _ -> false - | Mutez_t _ -> false - | Key_hash_t _ -> false - | Key_t _ -> false - | Timestamp_t _ -> false - | Address_t _ -> false - | Bool_t _ -> false - | Lambda_t (_, _, _) -> false - | Set_t (_, _) -> false - | Big_map_t (_, _, _) -> true - | Contract_t (_, _) -> false - | Operation_t _ -> false - | Chain_id_t _ -> false - | Pair_t (_, _, _, has_big_map) -> has_big_map - | Union_t (_, _, _, has_big_map) -> has_big_map - | Option_t (_, _, has_big_map) -> has_big_map - | List_t (_, _, has_big_map) -> has_big_map - | Map_t (_, _, _, has_big_map) -> has_big_map +let has_big_map : type t. t ty -> bool = function + | Unit_t _ -> + false + | Int_t _ -> + false + | Nat_t _ -> + false + | Signature_t _ -> + false + | String_t _ -> + false + | Bytes_t _ -> + false + | Mutez_t _ -> + false + | Key_hash_t _ -> + false + | Key_t _ -> + false + | Timestamp_t _ -> + false + | Address_t _ -> + false + | Bool_t _ -> + false + | Lambda_t (_, _, _) -> + false + | Set_t (_, _) -> + false + | Big_map_t (_, _, _) -> + true + | Contract_t (_, _) -> + false + | Operation_t _ -> + false + | Chain_id_t _ -> + false + | Pair_t (_, _, _, has_big_map) -> + has_big_map + | Union_t (_, _, _, has_big_map) -> + has_big_map + | Option_t (_, _, has_big_map) -> + has_big_map + | List_t (_, _, has_big_map) -> + has_big_map + | Map_t (_, _, _, has_big_map) -> + has_big_map (* ---- Type checker results -------------------------------------------------*) type 'bef judgement = | Typed : ('bef, 'aft) descr -> 'bef judgement - | Failed : { descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr } -> 'bef judgement + | Failed : { + descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr; + } + -> 'bef judgement (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) -type ('t, 'f, 'b) branch = - { branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr } [@@unboxed] +type ('t, 'f, 'b) branch = { + branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr; +} +[@@unboxed] +let merge_branches : + type bef a b. + legacy:bool -> + context -> + int -> + a judgement -> + b judgement -> + (a, b, bef) branch -> + (bef judgement * context) tzresult Lwt.t = + fun ~legacy ctxt loc btr bfr {branch} -> + match (btr, bfr) with + | (Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf)) -> + let unmatched_branches () = + serialize_stack_for_error ctxt aftbt + >>=? fun (aftbt, ctxt) -> + serialize_stack_for_error ctxt aftbf + >>|? fun (aftbf, _ctxt) -> Unmatched_branches (loc, aftbt, aftbf) + in + trace_eval + unmatched_branches + ( Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf) + >>=? fun (Eq, ctxt) -> + Lwt.return (merge_stacks ~legacy loc ctxt aftbt aftbf) + >>=? fun (merged_stack, ctxt) -> + return + ( Typed + (branch + {dbt with aft = merged_stack} + {dbf with aft = merged_stack}), + ctxt ) ) + | (Failed {descr = descrt}, Failed {descr = descrf}) -> + let descr ret = branch (descrt ret) (descrf ret) in + return (Failed {descr}, ctxt) + | (Typed dbt, Failed {descr = descrf}) -> + return (Typed (branch dbt (descrf dbt.aft)), ctxt) + | (Failed {descr = descrt}, Typed dbf) -> + return (Typed (branch (descrt dbf.aft) dbf), ctxt) -let merge_branches - : type bef a b. legacy: bool -> context -> int -> a judgement -> b judgement -> - (a, b, bef) branch -> - (bef judgement * context) tzresult Lwt.t - = fun ~legacy ctxt loc btr bfr { branch } -> - match btr, bfr with - | Typed ({ aft = aftbt ; _ } as dbt), Typed ({ aft = aftbf ; _ } as dbf) -> - let unmatched_branches () = - serialize_stack_for_error ctxt aftbt >>=? fun (aftbt, ctxt) -> - serialize_stack_for_error ctxt aftbf >>|? fun (aftbf, _ctxt) -> - Unmatched_branches (loc, aftbt, aftbf) in - trace_eval unmatched_branches - (Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf) >>=? fun (Eq, ctxt) -> - Lwt.return (merge_stacks ~legacy loc ctxt aftbt aftbf) >>=? fun (merged_stack, ctxt) -> - return ( - Typed (branch {dbt with aft=merged_stack} {dbf with aft=merged_stack}), - ctxt)) - | Failed { descr = descrt }, Failed { descr = descrf } -> - let descr ret = - branch (descrt ret) (descrf ret) in - return (Failed { descr }, ctxt) - | Typed dbt, Failed { descr = descrf } -> - return (Typed (branch dbt (descrf dbt.aft)), ctxt) - | Failed { descr = descrt }, Typed dbf -> - return (Typed (branch (descrt dbf.aft) dbf), ctxt) - -let rec parse_comparable_ty - : context -> Script.node -> (ex_comparable_ty * context) tzresult - = fun ctxt ty -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >>? fun ctxt -> - match ty with - | Prim (loc, T_int, [], annot) -> - parse_type_annot loc annot >|? fun tname -> - Ex_comparable_ty ( Int_key tname ), ctxt - | Prim (loc, T_nat, [], annot) -> - parse_type_annot loc annot >|? fun tname -> - Ex_comparable_ty ( Nat_key tname ), ctxt - | Prim (loc, T_string, [], annot) -> - parse_type_annot loc annot >|? fun tname -> - Ex_comparable_ty ( String_key tname ), ctxt - | Prim (loc, T_bytes, [], annot) -> - parse_type_annot loc annot >|? fun tname -> - Ex_comparable_ty ( Bytes_key tname ), ctxt - | Prim (loc, T_mutez, [], annot) -> - parse_type_annot loc annot >|? fun tname -> - Ex_comparable_ty ( Mutez_key tname ), ctxt - | Prim (loc, T_bool, [], annot) -> - parse_type_annot loc annot >|? fun tname -> - Ex_comparable_ty ( Bool_key tname ), ctxt - | Prim (loc, T_key_hash, [], annot) -> - parse_type_annot loc annot >|? fun tname -> - Ex_comparable_ty ( Key_hash_key tname ), ctxt - | Prim (loc, T_timestamp, [], annot) -> - parse_type_annot loc annot >|? fun tname -> - Ex_comparable_ty ( Timestamp_key tname ), ctxt - | Prim (loc, T_address, [], annot) -> - parse_type_annot loc annot >|? fun tname -> - Ex_comparable_ty ( Address_key tname ), ctxt - | Prim (loc, (T_int | T_nat - | T_string | T_mutez | T_bool - | T_key | T_address | T_timestamp as prim), l, _) -> - error (Invalid_arity (loc, prim, 0, List.length l)) - | Prim (loc, (T_pair | T_or | T_set | T_map - | T_list | T_option | T_lambda - | T_unit | T_signature | T_contract), _, _) -> - error (Comparable_type_expected (loc, Micheline.strip_locations ty)) - | expr -> - error @@ unexpected expr [] Type_namespace - [ T_int ; T_nat ; - T_string ; T_mutez ; T_bool ; - T_key ; T_key_hash ; T_timestamp ] +let rec parse_comparable_ty : + context -> Script.node -> (ex_comparable_ty * context) tzresult = + fun ctxt ty -> + Gas.consume ctxt Typecheck_costs.cycle + >>? fun ctxt -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >>? fun ctxt -> + match ty with + | Prim (loc, T_int, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Int_key tname), ctxt) + | Prim (loc, T_nat, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Nat_key tname), ctxt) + | Prim (loc, T_string, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (String_key tname), ctxt) + | Prim (loc, T_bytes, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Bytes_key tname), ctxt) + | Prim (loc, T_mutez, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Mutez_key tname), ctxt) + | Prim (loc, T_bool, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Bool_key tname), ctxt) + | Prim (loc, T_key_hash, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Key_hash_key tname), ctxt) + | Prim (loc, T_timestamp, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Timestamp_key tname), ctxt) + | Prim (loc, T_address, [], annot) -> + parse_type_annot loc annot + >|? fun tname -> (Ex_comparable_ty (Address_key tname), ctxt) + | Prim + ( loc, + ( ( T_int + | T_nat + | T_string + | T_mutez + | T_bool + | T_key + | T_address + | T_timestamp ) as prim ), + l, + _ ) -> + error (Invalid_arity (loc, prim, 0, List.length l)) + | Prim (loc, T_pair, [left; right], annot) -> ( + parse_type_annot loc annot + >>? fun pname -> + extract_field_annot left + >>? fun (left, left_annot) -> + extract_field_annot right + >>? fun (right, right_annot) -> + parse_comparable_ty ctxt right + >>? fun (Ex_comparable_ty right, ctxt) -> + parse_comparable_ty ctxt left + >>? fun (Ex_comparable_ty left, ctxt) -> + let right = (right, right_annot) in + match left with + | Pair_key _ -> + error (Comparable_type_expected (loc, Micheline.strip_locations ty)) + | Int_key tname -> + ok + ( Ex_comparable_ty + (Pair_key ((Int_key tname, left_annot), right, pname)), + ctxt ) + | Nat_key tname -> + ok + ( Ex_comparable_ty + (Pair_key ((Nat_key tname, left_annot), right, pname)), + ctxt ) + | String_key tname -> + ok + ( Ex_comparable_ty + (Pair_key ((String_key tname, left_annot), right, pname)), + ctxt ) + | Bytes_key tname -> + ok + ( Ex_comparable_ty + (Pair_key ((Bytes_key tname, left_annot), right, pname)), + ctxt ) + | Mutez_key tname -> + ok + ( Ex_comparable_ty + (Pair_key ((Mutez_key tname, left_annot), right, pname)), + ctxt ) + | Bool_key tname -> + ok + ( Ex_comparable_ty + (Pair_key ((Bool_key tname, left_annot), right, pname)), + ctxt ) + | Key_hash_key tname -> + ok + ( Ex_comparable_ty + (Pair_key ((Key_hash_key tname, left_annot), right, pname)), + ctxt ) + | Timestamp_key tname -> + ok + ( Ex_comparable_ty + (Pair_key ((Timestamp_key tname, left_annot), right, pname)), + ctxt ) + | Address_key tname -> + ok + ( Ex_comparable_ty + (Pair_key ((Address_key tname, left_annot), right, pname)), + ctxt ) ) + | Prim (loc, T_pair, l, _) -> + error (Invalid_arity (loc, T_pair, 2, List.length l)) + | Prim + ( loc, + ( T_or + | T_set + | T_map + | T_list + | T_option + | T_lambda + | T_unit + | T_signature + | T_contract ), + _, + _ ) -> + error (Comparable_type_expected (loc, Micheline.strip_locations ty)) + | expr -> + error + @@ unexpected + expr + [] + Type_namespace + [ T_int; + T_nat; + T_string; + T_mutez; + T_bool; + T_key; + T_key_hash; + T_timestamp ] and parse_packable_ty : - context -> legacy:bool -> - Script.node -> (ex_ty * context) tzresult - = fun ctxt ~legacy -> - parse_ty ctxt ~legacy ~allow_big_map:false ~allow_operation:false ~allow_contract:legacy + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = + fun ctxt ~legacy -> + parse_ty + ctxt + ~legacy + ~allow_big_map:false + ~allow_operation:false + ~allow_contract:legacy and parse_parameter_ty : - context -> legacy:bool -> - Script.node -> (ex_ty * context) tzresult - = fun ctxt ~legacy -> - parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:true + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = + fun ctxt ~legacy -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:false + ~allow_contract:true and parse_any_ty : - context -> legacy:bool -> - Script.node -> (ex_ty * context) tzresult - = fun ctxt ~legacy -> - parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:true ~allow_contract:true + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = + fun ctxt ~legacy -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:true + ~allow_contract:true and parse_ty : - context -> - legacy: bool -> - allow_big_map: bool -> - allow_operation: bool -> - allow_contract: bool -> - Script.node -> (ex_ty * context) tzresult - = fun ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract node -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - match node with - | Prim (loc, T_unit, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Unit_t ty_name), ctxt - | Prim (loc, T_int, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Int_t ty_name), ctxt - | Prim (loc, T_nat, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Nat_t ty_name), ctxt - | Prim (loc, T_string, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (String_t ty_name), ctxt - | Prim (loc, T_bytes, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Bytes_t ty_name), ctxt - | Prim (loc, T_mutez, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Mutez_t ty_name), ctxt - | Prim (loc, T_bool, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Bool_t ty_name), ctxt - | Prim (loc, T_key, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Key_t ty_name), ctxt - | Prim (loc, T_key_hash, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Key_hash_t ty_name), ctxt - | Prim (loc, T_timestamp, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Timestamp_t ty_name), ctxt - | Prim (loc, T_address, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Address_t ty_name), ctxt - | Prim (loc, T_signature, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Signature_t ty_name), ctxt - | Prim (loc, T_operation, [], annot) -> - if allow_operation then - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Operation_t ty_name), ctxt - else - error (Unexpected_operation loc) - | Prim (loc, T_chain_id, [], annot) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 0) >|? fun ctxt -> - Ex_ty (Chain_id_t ty_name), ctxt - | Prim (loc, T_contract, [ utl ], annot) -> - if allow_contract then - parse_parameter_ty ctxt ~legacy utl >>? fun (Ex_ty tl, ctxt) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> - Ex_ty (Contract_t (tl, ty_name)), ctxt - else - error (Unexpected_contract loc) - | Prim (loc, T_pair, [ utl; utr ], annot) -> - extract_field_annot utl >>? fun (utl, left_field) -> - extract_field_annot utr >>? fun (utr, right_field) -> - parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl >>? fun (Ex_ty tl, ctxt) -> - parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Pair_t ((tl, left_field, None), (tr, right_field, None), ty_name, has_big_map tl || has_big_map tr)), ctxt - | Prim (loc, T_or, [ utl; utr ], annot) -> - extract_field_annot utl >>? fun (utl, left_constr) -> - extract_field_annot utr >>? fun (utr, right_constr) -> - parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl >>? fun (Ex_ty tl, ctxt) -> - parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Union_t ((tl, left_constr), (tr, right_constr), ty_name, has_big_map tl || has_big_map tr)), ctxt - | Prim (loc, T_lambda, [ uta; utr ], annot) -> - parse_any_ty ctxt ~legacy uta >>? fun (Ex_ty ta, ctxt) -> - parse_any_ty ctxt ~legacy utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt - | Prim (loc, T_option, [ ut ], annot) -> - begin if legacy then - (* legacy semantics with (broken) field annotations *) - extract_field_annot ut >>? fun (ut, _some_constr) -> - parse_composed_type_annot loc annot >>? fun (ty_name, _none_constr, _) -> - ok (ut, ty_name) - else - parse_type_annot loc annot >>? fun ty_name -> - ok (ut, ty_name) - end >>? fun (ut, ty_name) -> - parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut >>? fun (Ex_ty t, ctxt) -> - Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Option_t (t, ty_name, has_big_map t)), ctxt - | Prim (loc, T_list, [ ut ], annot) -> - parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut >>? fun (Ex_ty t, ctxt) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> - Ex_ty (List_t (t, ty_name, has_big_map t)), ctxt - | Prim (loc, T_set, [ ut ], annot) -> - parse_comparable_ty ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 1) >|? fun ctxt -> - Ex_ty (Set_t (t, ty_name)), ctxt - | Prim (loc, T_map, [ uta; utr ], annot) -> - parse_comparable_ty ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr >>? fun (Ex_ty tr, ctxt) -> - parse_type_annot loc annot >>? fun ty_name -> - Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - Ex_ty (Map_t (ta, tr, ty_name, has_big_map tr)), ctxt - | Prim (loc, T_big_map, args, annot) - when allow_big_map -> - parse_big_map_ty ctxt ~legacy loc args annot >>? fun (big_map_ty, ctxt) -> - Gas.consume ctxt (Typecheck_costs.type_ 2) >|? fun ctxt -> - big_map_ty, ctxt - | Prim (loc, T_big_map, _, _) -> - error (Unexpected_big_map loc) - | Prim (loc, (T_unit | T_signature - | T_int | T_nat - | T_string | T_bytes | T_mutez | T_bool - | T_key | T_key_hash - | T_timestamp | T_address as prim), l, _) -> - error (Invalid_arity (loc, prim, 0, List.length l)) - | Prim (loc, (T_set | T_list | T_option | T_contract as prim), l, _) -> - error (Invalid_arity (loc, prim, 1, List.length l)) - | Prim (loc, (T_pair | T_or | T_map | T_lambda as prim), l, _) -> - error (Invalid_arity (loc, prim, 2, List.length l)) - | expr -> - error @@ unexpected expr [] Type_namespace - [ T_pair ; T_or ; T_set ; T_map ; - T_list ; T_option ; T_lambda ; - T_unit ; T_signature ; T_contract ; - T_int ; T_nat ; T_operation ; - T_string ; T_bytes ; T_mutez ; T_bool ; - T_key ; T_key_hash ; T_timestamp ; T_chain_id ] + context -> + legacy:bool -> + allow_big_map:bool -> + allow_operation:bool -> + allow_contract:bool -> + Script.node -> + (ex_ty * context) tzresult = + fun ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract node -> + Gas.consume ctxt Typecheck_costs.cycle + >>? fun ctxt -> + match node with + | Prim (loc, T_unit, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Unit_t ty_name), ctxt) + | Prim (loc, T_int, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Int_t ty_name), ctxt) + | Prim (loc, T_nat, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Nat_t ty_name), ctxt) + | Prim (loc, T_string, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (String_t ty_name), ctxt) + | Prim (loc, T_bytes, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Bytes_t ty_name), ctxt) + | Prim (loc, T_mutez, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Mutez_t ty_name), ctxt) + | Prim (loc, T_bool, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Bool_t ty_name), ctxt) + | Prim (loc, T_key, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Key_t ty_name), ctxt) + | Prim (loc, T_key_hash, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Key_hash_t ty_name), ctxt) + | Prim (loc, T_timestamp, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Timestamp_t ty_name), ctxt) + | Prim (loc, T_address, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Address_t ty_name), ctxt) + | Prim (loc, T_signature, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Signature_t ty_name), ctxt) + | Prim (loc, T_operation, [], annot) -> + if allow_operation then + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Operation_t ty_name), ctxt) + else error (Unexpected_operation loc) + | Prim (loc, T_chain_id, [], annot) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 0) + >|? fun ctxt -> (Ex_ty (Chain_id_t ty_name), ctxt) + | Prim (loc, T_contract, [utl], annot) -> + if allow_contract then + parse_parameter_ty ctxt ~legacy utl + >>? fun (Ex_ty tl, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 1) + >|? fun ctxt -> (Ex_ty (Contract_t (tl, ty_name)), ctxt) + else error (Unexpected_contract loc) + | Prim (loc, T_pair, [utl; utr], annot) -> + extract_field_annot utl + >>? fun (utl, left_field) -> + extract_field_annot utr + >>? fun (utr, right_field) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl + >>? fun (Ex_ty tl, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr + >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 2) + >|? fun ctxt -> + ( Ex_ty + (Pair_t + ( (tl, left_field, None), + (tr, right_field, None), + ty_name, + has_big_map tl || has_big_map tr )), + ctxt ) + | Prim (loc, T_or, [utl; utr], annot) -> + extract_field_annot utl + >>? fun (utl, left_constr) -> + extract_field_annot utr + >>? fun (utr, right_constr) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl + >>? fun (Ex_ty tl, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr + >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 2) + >|? fun ctxt -> + ( Ex_ty + (Union_t + ( (tl, left_constr), + (tr, right_constr), + ty_name, + has_big_map tl || has_big_map tr )), + ctxt ) + | Prim (loc, T_lambda, [uta; utr], annot) -> + parse_any_ty ctxt ~legacy uta + >>? fun (Ex_ty ta, ctxt) -> + parse_any_ty ctxt ~legacy utr + >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 2) + >|? fun ctxt -> (Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt) + | Prim (loc, T_option, [ut], annot) -> + ( if legacy then + (* legacy semantics with (broken) field annotations *) + extract_field_annot ut + >>? fun (ut, _some_constr) -> + parse_composed_type_annot loc annot + >>? fun (ty_name, _none_constr, _) -> ok (ut, ty_name) + else parse_type_annot loc annot >>? fun ty_name -> ok (ut, ty_name) ) + >>? fun (ut, ty_name) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut + >>? fun (Ex_ty t, ctxt) -> + Gas.consume ctxt (Typecheck_costs.type_ 2) + >|? fun ctxt -> (Ex_ty (Option_t (t, ty_name, has_big_map t)), ctxt) + | Prim (loc, T_list, [ut], annot) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut + >>? fun (Ex_ty t, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 1) + >|? fun ctxt -> (Ex_ty (List_t (t, ty_name, has_big_map t)), ctxt) + | Prim (loc, T_set, [ut], annot) -> + parse_comparable_ty ctxt ut + >>? fun (Ex_comparable_ty t, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 1) + >|? fun ctxt -> (Ex_ty (Set_t (t, ty_name)), ctxt) + | Prim (loc, T_map, [uta; utr], annot) -> + parse_comparable_ty ctxt uta + >>? fun (Ex_comparable_ty ta, ctxt) -> + parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr + >>? fun (Ex_ty tr, ctxt) -> + parse_type_annot loc annot + >>? fun ty_name -> + Gas.consume ctxt (Typecheck_costs.type_ 2) + >|? fun ctxt -> (Ex_ty (Map_t (ta, tr, ty_name, has_big_map tr)), ctxt) + | Prim (loc, T_big_map, args, annot) when allow_big_map -> + parse_big_map_ty ctxt ~legacy loc args annot + >>? fun (big_map_ty, ctxt) -> + Gas.consume ctxt (Typecheck_costs.type_ 2) + >|? fun ctxt -> (big_map_ty, ctxt) + | Prim (loc, T_big_map, _, _) -> + error (Unexpected_big_map loc) + | Prim + ( loc, + ( ( T_unit + | T_signature + | T_int + | T_nat + | T_string + | T_bytes + | T_mutez + | T_bool + | T_key + | T_key_hash + | T_timestamp + | T_address ) as prim ), + l, + _ ) -> + error (Invalid_arity (loc, prim, 0, List.length l)) + | Prim (loc, ((T_set | T_list | T_option | T_contract) as prim), l, _) -> + error (Invalid_arity (loc, prim, 1, List.length l)) + | Prim (loc, ((T_pair | T_or | T_map | T_lambda) as prim), l, _) -> + error (Invalid_arity (loc, prim, 2, List.length l)) + | expr -> + error + @@ unexpected + expr + [] + Type_namespace + [ T_pair; + T_or; + T_set; + T_map; + T_list; + T_option; + T_lambda; + T_unit; + T_signature; + T_contract; + T_int; + T_nat; + T_operation; + T_string; + T_bytes; + T_mutez; + T_bool; + T_key; + T_key_hash; + T_timestamp; + T_chain_id ] and parse_big_map_ty ctxt ~legacy big_map_loc args map_annot = - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - begin match args with - | [ key_ty ; value_ty ] -> - parse_comparable_ty ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_packable_ty ctxt ~legacy value_ty - >>? fun (Ex_ty value_ty, ctxt) -> - parse_type_annot big_map_loc map_annot >|? fun map_name -> - let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in - Ex_ty big_map_ty, ctxt - | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) - end + Gas.consume ctxt Typecheck_costs.cycle + >>? fun ctxt -> + match args with + | [key_ty; value_ty] -> + parse_comparable_ty ctxt key_ty + >>? fun (Ex_comparable_ty key_ty, ctxt) -> + parse_packable_ty ctxt ~legacy value_ty + >>? fun (Ex_ty value_ty, ctxt) -> + parse_type_annot big_map_loc map_annot + >|? fun map_name -> + let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in + (Ex_ty big_map_ty, ctxt) + | args -> + error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) and parse_storage_ty : - context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult - = fun ctxt ~legacy node -> - match node with - | Prim (loc, T_pair, - [ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ], - storage_annot) when legacy -> - begin match storage_annot with - | [] -> - parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy node - | [ single ] when Compare.Int.(String.length single > 0) && Compare.Char.(String.get single 0 = '%') -> - parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy node - | _ -> - (* legacy semantics of big maps used the wrong annotation parser *) - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - parse_big_map_ty ctxt ~legacy big_map_loc args map_annot >>? fun (Ex_ty big_map_ty, ctxt) -> - parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy remaining_storage - >>? fun (Ex_ty remaining_storage, ctxt) -> - parse_composed_type_annot loc storage_annot - >>? fun (ty_name, map_field, storage_field) -> - Gas.consume ctxt (Typecheck_costs.type_ 5) >|? fun ctxt -> - Ex_ty (Pair_t ((big_map_ty, map_field, None), - (remaining_storage, storage_field, None), - ty_name, true)), - ctxt - end + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = + fun ctxt ~legacy node -> + match node with + | Prim + ( loc, + T_pair, + [Prim (big_map_loc, T_big_map, args, map_annot); remaining_storage], + storage_annot ) + when legacy -> ( + match storage_annot with + | [] -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:false + ~allow_contract:legacy + node + | [single] + when Compare.Int.(String.length single > 0) + && Compare.Char.(single.[0] = '%') -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:false + ~allow_contract:legacy + node | _ -> - parse_ty ctxt ~legacy ~allow_big_map:true ~allow_operation:false ~allow_contract:legacy node + (* legacy semantics of big maps used the wrong annotation parser *) + Gas.consume ctxt Typecheck_costs.cycle + >>? fun ctxt -> + parse_big_map_ty ctxt ~legacy big_map_loc args map_annot + >>? fun (Ex_ty big_map_ty, ctxt) -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:false + ~allow_contract:legacy + remaining_storage + >>? fun (Ex_ty remaining_storage, ctxt) -> + parse_composed_type_annot loc storage_annot + >>? fun (ty_name, map_field, storage_field) -> + Gas.consume ctxt (Typecheck_costs.type_ 5) + >|? fun ctxt -> + ( Ex_ty + (Pair_t + ( (big_map_ty, map_field, None), + (remaining_storage, storage_field, None), + ty_name, + true )), + ctxt ) ) + | _ -> + parse_ty + ctxt + ~legacy + ~allow_big_map:true + ~allow_operation:false + ~allow_contract:legacy + node let check_packable ~legacy loc root = let rec check : type t. t ty -> unit tzresult = function - | Big_map_t _ -> error (Unexpected_big_map loc) - | Operation_t _ -> error (Unexpected_operation loc) - | Unit_t _ -> ok () - | Int_t _ -> ok () - | Nat_t _ -> ok () - | Signature_t _ -> ok () - | String_t _ -> ok () - | Bytes_t _ -> ok () - | Mutez_t _ -> ok () - | Key_hash_t _ -> ok () - | Key_t _ -> ok () - | Timestamp_t _ -> ok () - | Address_t _ -> ok () - | Bool_t _ -> ok () - | Chain_id_t _ -> ok () + | Big_map_t _ -> + error (Unexpected_big_map loc) + | Operation_t _ -> + error (Unexpected_operation loc) + | Unit_t _ -> + ok () + | Int_t _ -> + ok () + | Nat_t _ -> + ok () + | Signature_t _ -> + ok () + | String_t _ -> + ok () + | Bytes_t _ -> + ok () + | Mutez_t _ -> + ok () + | Key_hash_t _ -> + ok () + | Key_t _ -> + ok () + | Timestamp_t _ -> + ok () + | Address_t _ -> + ok () + | Bool_t _ -> + ok () + | Chain_id_t _ -> + ok () | Pair_t ((l_ty, _, _), (r_ty, _, _), _, _) -> check l_ty >>? fun () -> check r_ty | Union_t ((l_ty, _), (r_ty, _), _, _) -> check l_ty >>? fun () -> check r_ty - | Option_t (v_ty, _, _) -> check v_ty - | List_t (elt_ty, _, _) -> check elt_ty - | Set_t (_, _) -> ok () - | Map_t (_, elt_ty, _, _) -> check elt_ty - | Lambda_t (_l_ty, _r_ty, _) -> ok () - | Contract_t (_, _) when legacy -> ok () - | Contract_t (_, _) -> error (Unexpected_contract loc) in + | Option_t (v_ty, _, _) -> + check v_ty + | List_t (elt_ty, _, _) -> + check elt_ty + | Set_t (_, _) -> + ok () + | Map_t (_, elt_ty, _, _) -> + check elt_ty + | Lambda_t (_l_ty, _r_ty, _) -> + ok () + | Contract_t (_, _) when legacy -> + ok () + | Contract_t (_, _) -> + error (Unexpected_contract loc) + in check root type ex_script = Ex_script : ('a, 'c) script -> ex_script type _ dig_proof_argument = - Dig_proof_argument - : ((('x * 'rest), 'rest, 'bef, 'aft) stack_prefix_preservation_witness - * ('x ty * var_annot option) - * 'aft stack_ty) - -> 'bef dig_proof_argument + | Dig_proof_argument : + ( ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * ('x ty * var_annot option) + * 'aft stack_ty ) + -> 'bef dig_proof_argument type (_, _) dug_proof_argument = - Dug_proof_argument - : (('rest, ('x * 'rest), 'bef, 'aft) stack_prefix_preservation_witness - * unit - * 'aft stack_ty) - -> ('bef, 'x) dug_proof_argument + | Dug_proof_argument : + ( ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * unit + * 'aft stack_ty ) + -> ('bef, 'x) dug_proof_argument -type (_) dipn_proof_argument = - Dipn_proof_argument - : (('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness - * (context * ('fbef, 'faft) descr) - * 'aft stack_ty) - -> 'bef dipn_proof_argument +type _ dipn_proof_argument = + | Dipn_proof_argument : + ( ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + * (context * ('fbef, 'faft) descr) + * 'aft stack_ty ) + -> 'bef dipn_proof_argument -type (_) dropn_proof_argument = - Dropn_proof_argument - : (('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness - * 'rest stack_ty - * 'aft stack_ty) - -> 'bef dropn_proof_argument +type _ dropn_proof_argument = + | Dropn_proof_argument : + ( ('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness + * 'rest stack_ty + * 'aft stack_ty ) + -> 'bef dropn_proof_argument (* Lwt versions *) let parse_var_annot loc ?default annot = Lwt.return (parse_var_annot loc ?default annot) + let parse_entrypoint_annot loc ?default annot = Lwt.return (parse_entrypoint_annot loc ?default annot) + let parse_constr_annot loc ?if_special_first ?if_special_second annot = - Lwt.return (parse_constr_annot loc ?if_special_first ?if_special_second annot) -let parse_two_var_annot loc annot = - Lwt.return (parse_two_var_annot loc annot) -let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot ~value_annot = - Lwt.return (parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot ~value_annot) + Lwt.return + (parse_constr_annot loc ?if_special_first ?if_special_second annot) + +let parse_two_var_annot loc annot = Lwt.return (parse_two_var_annot loc annot) + +let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot + ~value_annot = + Lwt.return + (parse_destr_annot + loc + annot + ~default_accessor + ~field_name + ~pair_annot + ~value_annot) + let parse_var_type_annot loc annot = Lwt.return (parse_var_type_annot loc annot) - let find_entrypoint (type full) (full : full ty) ~root_name entrypoint = - let rec find_entrypoint - : type t. t ty -> string -> ((Script.node -> Script.node) * ex_ty) - = fun t entrypoint -> match t with - | Union_t ((tl, al), (tr, ar), _, _) -> - if match al with None -> false | Some (`Field_annot l) -> Compare.String.(l = entrypoint) then - ((fun e -> Prim (0, D_Left, [ e ], [])), Ex_ty tl) - else if match ar with None -> false | Some (`Field_annot r) -> Compare.String.(r = entrypoint) then - ((fun e -> Prim (0, D_Right, [ e ], [])), Ex_ty tr) - else begin try - let (f, t) = find_entrypoint tl entrypoint in - ((fun e -> Prim (0, D_Left, [ f e ], [])), t) - with Not_found -> - let (f, t) = find_entrypoint tr entrypoint in - ((fun e -> Prim (0, D_Right, [ f e ], [])), t) - end - | _ -> raise Not_found in - let entrypoint = if Compare.String.(entrypoint = "") then "default" else entrypoint in + let rec find_entrypoint : + type t. t ty -> string -> (Script.node -> Script.node) * ex_ty = + fun t entrypoint -> + match t with + | Union_t ((tl, al), (tr, ar), _, _) -> ( + if + match al with + | None -> + false + | Some (`Field_annot l) -> + Compare.String.(l = entrypoint) + then ((fun e -> Prim (0, D_Left, [e], [])), Ex_ty tl) + else if + match ar with + | None -> + false + | Some (`Field_annot r) -> + Compare.String.(r = entrypoint) + then ((fun e -> Prim (0, D_Right, [e], [])), Ex_ty tr) + else + try + let (f, t) = find_entrypoint tl entrypoint in + ((fun e -> Prim (0, D_Left, [f e], [])), t) + with Not_found -> + let (f, t) = find_entrypoint tr entrypoint in + ((fun e -> Prim (0, D_Right, [f e], [])), t) ) + | _ -> + raise Not_found + in + let entrypoint = + if Compare.String.(entrypoint = "") then "default" else entrypoint + in if Compare.Int.(String.length entrypoint > 31) then error (Entrypoint_name_too_long entrypoint) - else match root_name with + else + match root_name with | Some root_name when Compare.String.(entrypoint = root_name) -> ok ((fun e -> e), Ex_ty full) - | _ -> - try ok (find_entrypoint full entrypoint) with Not_found -> + | _ -> ( + try ok (find_entrypoint full entrypoint) + with Not_found -> ( match entrypoint with - | "default" -> ok ((fun e -> e), Ex_ty full) - | _ -> error (No_such_entrypoint entrypoint) + | "default" -> + ok ((fun e -> e), Ex_ty full) + | _ -> + error (No_such_entrypoint entrypoint) ) ) -let find_entrypoint_for_type - (type full) (type exp) ~(full : full ty) ~(expected : exp ty) ~root_name entrypoint ctxt - : (context * string * exp ty) tzresult = - match entrypoint, root_name with - | "default", Some "root" -> - begin match find_entrypoint full ~root_name entrypoint with - | Error _ as err -> err - | Ok (_, Ex_ty ty) -> - match ty_eq ctxt expected ty with - | Ok (Eq, ctxt) -> - ok (ctxt, "default", (ty : exp ty)) - | Error _ -> - ty_eq ctxt expected full >>? fun (Eq, ctxt) -> - ok (ctxt, "root", (full : exp ty)) - end +let find_entrypoint_for_type (type full exp) ~(full : full ty) + ~(expected : exp ty) ~root_name entrypoint ctxt : + (context * string * exp ty) tzresult = + match (entrypoint, root_name) with + | ("default", Some "root") -> ( + match find_entrypoint full ~root_name entrypoint with + | Error _ as err -> + err + | Ok (_, Ex_ty ty) -> ( + match ty_eq ctxt expected ty with + | Ok (Eq, ctxt) -> + ok (ctxt, "default", (ty : exp ty)) + | Error _ -> + ty_eq ctxt expected full + >>? fun (Eq, ctxt) -> ok (ctxt, "root", (full : exp ty)) ) ) | _ -> - find_entrypoint full ~root_name entrypoint >>? fun (_, Ex_ty ty) -> - ty_eq ctxt expected ty >>? fun (Eq, ctxt) -> - ok (ctxt, entrypoint, (ty : exp ty)) - + find_entrypoint full ~root_name entrypoint + >>? fun (_, Ex_ty ty) -> + ty_eq ctxt expected ty + >>? fun (Eq, ctxt) -> ok (ctxt, entrypoint, (ty : exp ty)) module Entrypoints = Set.Make (String) exception Duplicate of string + exception Too_long of string let well_formed_entrypoints (type full) (full : full ty) ~root_name = - let merge path annot (type t) (ty : t ty) reachable ((first_unreachable, all) as acc) = + let merge path annot (type t) (ty : t ty) reachable + ((first_unreachable, all) as acc) = match annot with - | None | Some (`Field_annot "") -> + | None | Some (`Field_annot "") -> ( if reachable then acc - else begin match ty with - | Union_t _ -> acc - | _ -> match first_unreachable with - | None -> (Some (List.rev path), all) - | Some _ -> acc - end + else + match ty with + | Union_t _ -> + acc + | _ -> ( + match first_unreachable with + | None -> + (Some (List.rev path), all) + | Some _ -> + acc ) ) | Some (`Field_annot name) -> if Compare.Int.(String.length name > 31) then raise (Too_long name) else if Entrypoints.mem name all then raise (Duplicate name) - else (first_unreachable, Entrypoints.add name all) in - let rec check - : type t. t ty -> prim list -> bool -> (prim list) option * Entrypoints.t -> (prim list) option * Entrypoints.t - = fun t path reachable acc -> - match t with - | Union_t ((tl, al), (tr, ar), _, _) -> - let acc = merge (D_Left :: path) al tl reachable acc in - let acc = merge (D_Right :: path) ar tr reachable acc in - let acc = check tl (D_Left :: path) (match al with Some _ -> true | None -> reachable) acc in - check tr (D_Right :: path) (match ar with Some _ -> true | None -> reachable) acc - | _ -> acc in + else (first_unreachable, Entrypoints.add name all) + in + let rec check : + type t. + t ty -> + prim list -> + bool -> + prim list option * Entrypoints.t -> + prim list option * Entrypoints.t = + fun t path reachable acc -> + match t with + | Union_t ((tl, al), (tr, ar), _, _) -> + let acc = merge (D_Left :: path) al tl reachable acc in + let acc = merge (D_Right :: path) ar tr reachable acc in + let acc = + check + tl + (D_Left :: path) + (match al with Some _ -> true | None -> reachable) + acc + in + check + tr + (D_Right :: path) + (match ar with Some _ -> true | None -> reachable) + acc + | _ -> + acc + in try - let init, reachable = match root_name with - | None | Some "" -> Entrypoints.empty, false - | Some name -> Entrypoints.singleton name, true in - let first_unreachable, all = check full [] reachable (None, init) in + let (init, reachable) = + match root_name with + | None | Some "" -> + (Entrypoints.empty, false) + | Some name -> + (Entrypoints.singleton name, true) + in + let (first_unreachable, all) = check full [] reachable (None, init) in if not (Entrypoints.mem "default" all) then ok () - else match first_unreachable with - | None -> ok () - | Some path -> error (Unreachable_entrypoint path) + else + match first_unreachable with + | None -> + ok () + | Some path -> + error (Unreachable_entrypoint path) with - | Duplicate name -> error (Duplicate_entrypoint name) - | Too_long name -> error (Entrypoint_name_too_long name) + | Duplicate name -> + error (Duplicate_entrypoint name) + | Too_long name -> + error (Entrypoint_name_too_long name) -let rec parse_data - : type a. - ?type_logger: type_logger -> - context -> legacy: bool -> a ty -> Script.node -> (a * context) tzresult Lwt.t - = fun ?type_logger ctxt ~legacy ty script_data -> - Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> - let error () = - Lwt.return (serialize_ty_for_error ctxt ty) >>|? fun (ty, _ctxt) -> - Invalid_constant (location script_data, strip_locations script_data, ty) in - let traced body = - trace_eval error body in - let parse_items ?type_logger loc ctxt expr key_type value_type items item_wrapper = - let length = List.length items in - fold_left_s - (fun (last_value, map, ctxt) item -> - Lwt.return (Gas.consume ctxt (Typecheck_costs.map_element length)) >>=? fun ctxt -> - match item with - | Prim (_, D_Elt, [ k; v ], _) -> - parse_comparable_data ?type_logger ctxt key_type k >>=? fun (k, ctxt) -> - parse_data ?type_logger ctxt ~legacy value_type v >>=? fun (v, ctxt) -> - begin match last_value with - | Some value -> - if Compare.Int.(0 <= (compare_comparable key_type value k)) - then - if Compare.Int.(0 = (compare_comparable key_type value k)) - then fail (Duplicate_map_keys (loc, strip_locations expr)) - else fail (Unordered_map_keys (loc, strip_locations expr)) - else return_unit - | None -> return_unit - end >>=? fun () -> - return (Some k, map_update k (Some (item_wrapper v)) map, ctxt) - | Prim (loc, D_Elt, l, _) -> - fail @@ Invalid_arity (loc, D_Elt, 2, List.length l) - | Prim (loc, name, _, _) -> - fail @@ Invalid_primitive (loc, [ D_Elt ], name) - | Int _ | String _ | Bytes _ | Seq _ -> - error () >>=? fail) - (None, empty_map key_type, ctxt) items |> traced >>|? fun (_, items, ctxt) -> - (items, ctxt) in - match ty, script_data with - (* Unit *) - | Unit_t _, Prim (loc, D_Unit, [], annot) -> - (if legacy then return () else - fail_unexpected_annot loc annot) >>=? fun () -> - Lwt.return (Gas.consume ctxt Typecheck_costs.unit) >>|? fun ctxt -> - ((() : a), ctxt) - | Unit_t _, Prim (loc, D_Unit, l, _) -> - traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l))) - | Unit_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ D_Unit ])) - (* Booleans *) - | Bool_t _, Prim (loc, D_True, [], annot) -> - (if legacy then return () else - fail_unexpected_annot loc annot) >>=? fun () -> - Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> - (true, ctxt) - | Bool_t _, Prim (loc, D_False, [], annot) -> - (if legacy then return () else - fail_unexpected_annot loc annot) >>=? fun () -> - Lwt.return (Gas.consume ctxt Typecheck_costs.bool) >>|? fun ctxt -> - (false, ctxt) - | Bool_t _, Prim (loc, (D_True | D_False as c), l, _) -> - traced (fail (Invalid_arity (loc, c, 0, List.length l))) - | Bool_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ D_True ; D_False ])) - (* Strings *) - | String_t _, String (_, v) -> - Lwt.return (Gas.consume ctxt (Typecheck_costs.string (String.length v))) >>=? fun ctxt -> - let rec check_printable_ascii i = - if Compare.Int.(i < 0) then true - else match String.get v i with - | '\n' | '\x20'..'\x7E' -> check_printable_ascii (i - 1) - | _ -> false in - if check_printable_ascii (String.length v - 1) then - return (v, ctxt) - else - error () >>=? fail - | String_t _, expr -> - traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) - (* Byte sequences *) - | Bytes_t _, Bytes (_, v) -> - Lwt.return (Gas.consume ctxt (Typecheck_costs.string (MBytes.length v))) >>=? fun ctxt -> - return (v, ctxt) - | Bytes_t _, expr -> - traced (fail (Invalid_kind (location expr, [ Bytes_kind ], kind expr))) - (* Integers *) - | Int_t _, Int (_, v) -> - Lwt.return (Gas.consume ctxt (Typecheck_costs.z v)) >>=? fun ctxt -> - return (Script_int.of_zint v, ctxt) - | Nat_t _, Int (_, v) -> - Lwt.return (Gas.consume ctxt (Typecheck_costs.z v)) >>=? fun ctxt -> - let v = Script_int.of_zint v in - if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then - return (Script_int.abs v, ctxt) - else - error () >>=? fail - | Int_t _, expr -> - traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) - | Nat_t _, expr -> - traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) - (* Tez amounts *) - | Mutez_t _, Int (_, v) -> - Lwt.return ( - Gas.consume ctxt Typecheck_costs.tez >>? fun ctxt -> - Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64 - ) >>=? fun ctxt -> - begin try - match Tez.of_mutez (Z.to_int64 v) with - | None -> raise Exit - | Some tez -> return (tez, ctxt) - with _ -> - error () >>=? fail - end - | Mutez_t _, expr -> - traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) - (* Timestamps *) - | Timestamp_t _, (Int (_, v)) (* As unparsed with [Optimized] or out of bounds [Readable]. *) -> - Lwt.return (Gas.consume ctxt (Typecheck_costs.z v)) >>=? fun ctxt -> - return (Script_timestamp.of_zint v, ctxt) - | Timestamp_t _, String (_, s) (* As unparsed with [Redable]. *) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt -> - begin match Script_timestamp.of_string s with - | Some v -> return (v, ctxt) - | None -> error () >>=? fail - end - | Timestamp_t _, expr -> - traced (fail (Invalid_kind (location expr, [ String_kind ; Int_kind ], kind expr))) - (* IDs *) - | Key_t _, Bytes (_, bytes) -> (* As unparsed with [Optimized]. *) - Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt -> - begin match Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes with - | Some k -> return (k, ctxt) - | None -> error () >>=? fail - end - | Key_t _, String (_, s) -> (* As unparsed with [Readable]. *) - Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt -> - begin match Signature.Public_key.of_b58check_opt s with - | Some k -> return (k, ctxt) - | None -> error () >>=? fail - end - | Key_t _, expr -> - traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) - | Key_hash_t _, Bytes (_, bytes) -> (* As unparsed with [Optimized]. *) - Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) >>=? fun ctxt -> - begin - match Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes with - | Some k -> return (k, ctxt) - | None -> error () >>=? fail - end - | Key_hash_t _, String (_, s) (* As unparsed with [Readable]. *) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) >>=? fun ctxt -> - begin match Signature.Public_key_hash.of_b58check_opt s with - | Some k -> return (k, ctxt) - | None -> error () >>=? fail - end - | Key_hash_t _, expr -> - traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) - (* Signatures *) - | Signature_t _, Bytes (_, bytes) (* As unparsed with [Optimized]. *) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt -> - begin match Data_encoding.Binary.of_bytes Signature.encoding bytes with - | Some k -> return (k, ctxt) - | None -> error () >>=? fail - end - | Signature_t _, String (_, s) (* As unparsed with [Readable]. *) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt -> - begin match Signature.of_b58check_opt s with - | Some s -> return (s, ctxt) - | None -> error () >>=? fail - end - | Signature_t _, expr -> - traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) - (* Operations *) - | Operation_t _, _ -> - (* operations cannot appear in parameters or storage, - the protocol should never parse the bytes of an operation *) - assert false - (* Chain_ids *) - | Chain_id_t _, Bytes (_, bytes) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id) >>=? fun ctxt -> - begin match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with - | Some k -> return (k, ctxt) - | None -> error () >>=? fail - end - | Chain_id_t _, String (_, s) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id) >>=? fun ctxt -> - begin match Chain_id.of_b58check_opt s with - | Some s -> return (s, ctxt) - | None -> error () >>=? fail - end - | Chain_id_t _, expr -> - traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) - (* Addresses *) - | Address_t _, Bytes (loc, bytes) (* As unparsed with [O[ptimized]. *) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> - begin - match Data_encoding.Binary.of_bytes - Data_encoding.(tup2 Contract.encoding Variable.string) - bytes with - | Some (c, entrypoint) -> - if Compare.Int.(String.length entrypoint > 31) then - fail (Entrypoint_name_too_long entrypoint) - else - begin match entrypoint with - | "" -> return "default" - | "default" -> fail (Unexpected_annotation loc) - | name -> return name end >>=? fun entrypoint -> - return ((c, entrypoint), ctxt) - | None -> error () >>=? fail - end - | Address_t _, String (loc, s) (* As unparsed with [Readable]. *) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> - begin match String.index_opt s '%' with - | None -> return (s, "default") - | Some pos -> - let len = String.length s - pos - 1 in - let name = String.sub s (pos + 1) len in - if Compare.Int.(len > 31) then - fail (Entrypoint_name_too_long name) - else - match String.sub s 0 pos, name with - | _, "default" -> traced (fail (Unexpected_annotation loc)) - | addr_and_name -> return addr_and_name - end >>=? fun (addr, entrypoint) -> - Lwt.return (Contract.of_b58check addr) >>=? fun c -> - return ((c, entrypoint), ctxt) - | Address_t _, expr -> - traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) - (* Contracts *) - | Contract_t (ty, _), Bytes (loc, bytes) (* As unparsed with [Optimized]. *) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> - begin - match Data_encoding.Binary.of_bytes - Data_encoding.(tup2 Contract.encoding Variable.string) - bytes with - | Some (c, entrypoint) -> - if Compare.Int.(String.length entrypoint > 31) then - fail (Entrypoint_name_too_long entrypoint) - else - begin match entrypoint with - | "" -> return "default" - | "default" -> traced (fail (Unexpected_annotation loc)) - | name -> return name end >>=? fun entrypoint -> - traced (parse_contract ~legacy ctxt loc ty c ~entrypoint) >>=? fun (ctxt, _) -> - return ((ty, (c, entrypoint)), ctxt) - | None -> error () >>=? fail - end - | Contract_t (ty, _), String (loc, s) (* As unparsed with [Readable]. *) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> - begin match String.index_opt s '%' with - | None -> return (s, "default") - | Some pos -> - let len = String.length s - pos - 1 in - let name = String.sub s (pos + 1) len in - if Compare.Int.(len > 31) then - fail (Entrypoint_name_too_long name) - else - match String.sub s 0 pos, name with - | _, "default" -> traced (fail (Unexpected_annotation loc)) - | addr_and_name -> return addr_and_name - end >>=? fun (addr, entrypoint) -> - traced (Lwt.return (Contract.of_b58check addr)) >>=? fun c -> - parse_contract ~legacy ctxt loc ty c ~entrypoint >>=? fun (ctxt, _) -> - return ((ty, (c, entrypoint)), ctxt) - | Contract_t _, expr -> - traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) - (* Pairs *) - | Pair_t ((ta, _, _), (tb, _, _), _, _), Prim (loc, D_Pair, [ va; vb ], annot) -> - (if legacy then return () else - fail_unexpected_annot loc annot) >>=? fun () -> - Lwt.return (Gas.consume ctxt Typecheck_costs.pair) >>=? fun ctxt -> - traced @@ - parse_data ?type_logger ctxt ~legacy ta va >>=? fun (va, ctxt) -> - parse_data ?type_logger ctxt ~legacy tb vb >>=? fun (vb, ctxt) -> - return ((va, vb), ctxt) - | Pair_t _, Prim (loc, D_Pair, l, _) -> - fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) - | Pair_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ D_Pair ])) - (* Unions *) - | Union_t ((tl, _), _, _, _), Prim (loc, D_Left, [ v ], annot) -> - (if legacy then return () else - fail_unexpected_annot loc annot) >>=? fun () -> - Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> - traced @@ - parse_data ?type_logger ctxt ~legacy tl v >>=? fun (v, ctxt) -> - return (L v, ctxt) - | Union_t _, Prim (loc, D_Left, l, _) -> - fail @@ Invalid_arity (loc, D_Left, 1, List.length l) - | Union_t (_, (tr, _), _, _), Prim (loc, D_Right, [ v ], annot) -> - fail_unexpected_annot loc annot >>=? fun () -> - Lwt.return (Gas.consume ctxt Typecheck_costs.union) >>=? fun ctxt -> - traced @@ - parse_data ?type_logger ctxt ~legacy tr v >>=? fun (v, ctxt) -> - return (R v, ctxt) - | Union_t _, Prim (loc, D_Right, l, _) -> - fail @@ Invalid_arity (loc, D_Right, 1, List.length l) - | Union_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ D_Left ; D_Right ])) - (* Lambdas *) - | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt -> - traced @@ - parse_returning Lambda ?type_logger ctxt ~legacy (ta, Some (`Var_annot "@arg")) tr script_instr - | Lambda_t _, expr -> - traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) - (* Options *) - | Option_t (t, _, _), Prim (loc, D_Some, [ v ], annot) -> - (if legacy then return () else - fail_unexpected_annot loc annot) >>=? fun () -> - Lwt.return (Gas.consume ctxt Typecheck_costs.some) >>=? fun ctxt -> - traced @@ - parse_data ?type_logger ctxt ~legacy t v >>=? fun (v, ctxt) -> - return (Some v, ctxt) - | Option_t _, Prim (loc, D_Some, l, _) -> - fail @@ Invalid_arity (loc, D_Some, 1, List.length l) - | Option_t (_, _, _), Prim (loc, D_None, [], annot) -> - (if legacy then return () else - fail_unexpected_annot loc annot) >>=? fun () -> - Lwt.return (Gas.consume ctxt Typecheck_costs.none) >>=? fun ctxt -> - return (None, ctxt) - | Option_t _, Prim (loc, D_None, l, _) -> - fail @@ Invalid_arity (loc, D_None, 0, List.length l) - | Option_t _, expr -> - traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ])) - (* Lists *) - | List_t (t, _ty_name, _), Seq (_loc, items) -> - traced @@ - fold_right_s - (fun v (rest, ctxt) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.list_element) >>=? fun ctxt -> - parse_data ?type_logger ctxt ~legacy t v >>=? fun (v, ctxt) -> - return ((v :: rest), ctxt)) - items ([], ctxt) - | List_t _, expr -> - traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) - (* Sets *) - | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> - let length = List.length vs in - traced @@ - fold_left_s - (fun (last_value, set, ctxt) v -> - Lwt.return (Gas.consume ctxt (Typecheck_costs.set_element length)) >>=? fun ctxt -> - parse_comparable_data ?type_logger ctxt t v >>=? fun (v, ctxt) -> - begin match last_value with - | Some value -> - if Compare.Int.(0 <= (compare_comparable t value v)) - then - if Compare.Int.(0 = (compare_comparable t value v)) - then fail (Duplicate_set_values (loc, strip_locations expr)) - else fail (Unordered_set_values (loc, strip_locations expr)) - else return_unit - | None -> return_unit - end >>=? fun () -> - Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.set_update v false set)) >>=? fun ctxt -> - return (Some v, set_update v true set, ctxt)) - (None, empty_set t, ctxt) vs >>|? fun (_, set, ctxt) -> - (set, ctxt) - | Set_t _, expr -> - traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) - (* Maps *) - | Map_t (tk, tv, _ty_name, _), (Seq (loc, vs) as expr) -> - parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) - | Map_t _, expr -> - traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) - | Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr) -> - parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) -> - ({ id = None ; diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) - | Big_map_t (tk, tv, _ty_name), Int (loc, id) -> - Big_map.exists ctxt id >>=? begin function - | _, None -> - traced (fail (Invalid_big_map (loc, id))) - | ctxt, Some (btk, btv) -> - Lwt.return begin - parse_comparable_ty ctxt (Micheline.root btk) >>? fun (Ex_comparable_ty btk, ctxt) -> - parse_packable_ty ctxt ~legacy (Micheline.root btv) >>? fun (Ex_ty btv, ctxt) -> - comparable_ty_eq ctxt tk btk >>? fun Eq -> - ty_eq ctxt tv btv >>? fun (Eq, ctxt) -> - ok ({ id = Some id ; diff = empty_map tk ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) - end - end - | Big_map_t (_tk, _tv, _), expr -> - traced (fail (Invalid_kind (location expr, [ Seq_kind ; Int_kind ], kind expr))) - -and parse_comparable_data - : type a. +let rec parse_data : + type a. ?type_logger:type_logger -> - context -> a comparable_ty -> Script.node -> (a * context) tzresult Lwt.t - = fun ?type_logger ctxt ty script_data -> - parse_data ?type_logger ctxt ~legacy: false (ty_of_comparable_ty ty) script_data + context -> + legacy:bool -> + a ty -> + Script.node -> + (a * context) tzresult Lwt.t = + fun ?type_logger ctxt ~legacy ty script_data -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) + >>=? fun ctxt -> + let error () = + Lwt.return (serialize_ty_for_error ctxt ty) + >>|? fun (ty, _ctxt) -> + Invalid_constant (location script_data, strip_locations script_data, ty) + in + let traced body = trace_eval error body in + let parse_items ?type_logger loc ctxt expr key_type value_type items + item_wrapper = + let length = List.length items in + fold_left_s + (fun (last_value, map, ctxt) item -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.map_element length)) + >>=? fun ctxt -> + match item with + | Prim (_, D_Elt, [k; v], _) -> + parse_comparable_data ?type_logger ctxt key_type k + >>=? fun (k, ctxt) -> + parse_data ?type_logger ctxt ~legacy value_type v + >>=? fun (v, ctxt) -> + ( match last_value with + | Some value -> + if Compare.Int.(0 <= compare_comparable key_type value k) then + if Compare.Int.(0 = compare_comparable key_type value k) then + fail (Duplicate_map_keys (loc, strip_locations expr)) + else fail (Unordered_map_keys (loc, strip_locations expr)) + else return_unit + | None -> + return_unit ) + >>=? fun () -> + return (Some k, map_update k (Some (item_wrapper v)) map, ctxt) + | Prim (loc, D_Elt, l, _) -> + fail @@ Invalid_arity (loc, D_Elt, 2, List.length l) + | Prim (loc, name, _, _) -> + fail @@ Invalid_primitive (loc, [D_Elt], name) + | Int _ | String _ | Bytes _ | Seq _ -> + error () >>=? fail) + (None, empty_map key_type, ctxt) + items + |> traced + >>|? fun (_, items, ctxt) -> (items, ctxt) + in + match (ty, script_data) with + (* Unit *) + | (Unit_t _, Prim (loc, D_Unit, [], annot)) -> + (if legacy then return () else fail_unexpected_annot loc annot) + >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.unit) + >>|? fun ctxt -> ((() : a), ctxt) + | (Unit_t _, Prim (loc, D_Unit, l, _)) -> + traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l))) + | (Unit_t _, expr) -> + traced (fail (unexpected expr [] Constant_namespace [D_Unit])) + (* Booleans *) + | (Bool_t _, Prim (loc, D_True, [], annot)) -> + (if legacy then return () else fail_unexpected_annot loc annot) + >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.bool) + >>|? fun ctxt -> (true, ctxt) + | (Bool_t _, Prim (loc, D_False, [], annot)) -> + (if legacy then return () else fail_unexpected_annot loc annot) + >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.bool) + >>|? fun ctxt -> (false, ctxt) + | (Bool_t _, Prim (loc, ((D_True | D_False) as c), l, _)) -> + traced (fail (Invalid_arity (loc, c, 0, List.length l))) + | (Bool_t _, expr) -> + traced (fail (unexpected expr [] Constant_namespace [D_True; D_False])) + (* Strings *) + | (String_t _, String (_, v)) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.string (String.length v))) + >>=? fun ctxt -> + let rec check_printable_ascii i = + if Compare.Int.(i < 0) then true + else + match v.[i] with + | '\n' | '\x20' .. '\x7E' -> + check_printable_ascii (i - 1) + | _ -> + false + in + if check_printable_ascii (String.length v - 1) then return (v, ctxt) + else error () >>=? fail + | (String_t _, expr) -> + traced (fail (Invalid_kind (location expr, [String_kind], kind expr))) + (* Byte sequences *) + | (Bytes_t _, Bytes (_, v)) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.string (MBytes.length v))) + >>=? fun ctxt -> return (v, ctxt) + | (Bytes_t _, expr) -> + traced (fail (Invalid_kind (location expr, [Bytes_kind], kind expr))) + (* Integers *) + | (Int_t _, Int (_, v)) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.z v)) + >>=? fun ctxt -> return (Script_int.of_zint v, ctxt) + | (Nat_t _, Int (_, v)) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.z v)) + >>=? fun ctxt -> + let v = Script_int.of_zint v in + if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then + return (Script_int.abs v, ctxt) + else error () >>=? fail + | (Int_t _, expr) -> + traced (fail (Invalid_kind (location expr, [Int_kind], kind expr))) + | (Nat_t _, expr) -> + traced (fail (Invalid_kind (location expr, [Int_kind], kind expr))) + (* Tez amounts *) + | (Mutez_t _, Int (_, v)) -> ( + Lwt.return + ( Gas.consume ctxt Typecheck_costs.tez + >>? fun ctxt -> + Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64 ) + >>=? fun ctxt -> + try + match Tez.of_mutez (Z.to_int64 v) with + | None -> + raise Exit + | Some tez -> + return (tez, ctxt) + with _ -> error () >>=? fail ) + | (Mutez_t _, expr) -> + traced (fail (Invalid_kind (location expr, [Int_kind], kind expr))) + (* Timestamps *) + | (Timestamp_t _, Int (_, v)) + (* As unparsed with [Optimized] or out of bounds [Readable]. *) -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.z v)) + >>=? fun ctxt -> return (Script_timestamp.of_zint v, ctxt) + | (Timestamp_t _, String (_, s)) (* As unparsed with [Redable]. *) -> ( + Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) + >>=? fun ctxt -> + match Script_timestamp.of_string s with + | Some v -> + return (v, ctxt) + | None -> + error () >>=? fail ) + | (Timestamp_t _, expr) -> + traced + (fail + (Invalid_kind (location expr, [String_kind; Int_kind], kind expr))) + (* IDs *) + | (Key_t _, Bytes (_, bytes)) -> ( + (* As unparsed with [Optimized]. *) + Lwt.return (Gas.consume ctxt Typecheck_costs.key) + >>=? fun ctxt -> + match + Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes + with + | Some k -> + return (k, ctxt) + | None -> + error () >>=? fail ) + | (Key_t _, String (_, s)) -> ( + (* As unparsed with [Readable]. *) + Lwt.return (Gas.consume ctxt Typecheck_costs.key) + >>=? fun ctxt -> + match Signature.Public_key.of_b58check_opt s with + | Some k -> + return (k, ctxt) + | None -> + error () >>=? fail ) + | (Key_t _, expr) -> + traced + (fail + (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr))) + | (Key_hash_t _, Bytes (_, bytes)) -> ( + (* As unparsed with [Optimized]. *) + Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) + >>=? fun ctxt -> + match + Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes + with + | Some k -> + return (k, ctxt) + | None -> + error () >>=? fail ) + | (Key_hash_t _, String (_, s)) (* As unparsed with [Readable]. *) -> ( + Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) + >>=? fun ctxt -> + match Signature.Public_key_hash.of_b58check_opt s with + | Some k -> + return (k, ctxt) + | None -> + error () >>=? fail ) + | (Key_hash_t _, expr) -> + traced + (fail + (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr))) + (* Signatures *) + | (Signature_t _, Bytes (_, bytes)) (* As unparsed with [Optimized]. *) -> ( + Lwt.return (Gas.consume ctxt Typecheck_costs.signature) + >>=? fun ctxt -> + match Data_encoding.Binary.of_bytes Signature.encoding bytes with + | Some k -> + return (k, ctxt) + | None -> + error () >>=? fail ) + | (Signature_t _, String (_, s)) (* As unparsed with [Readable]. *) -> ( + Lwt.return (Gas.consume ctxt Typecheck_costs.signature) + >>=? fun ctxt -> + match Signature.of_b58check_opt s with + | Some s -> + return (s, ctxt) + | None -> + error () >>=? fail ) + | (Signature_t _, expr) -> + traced + (fail + (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr))) + (* Operations *) + | (Operation_t _, _) -> + (* operations cannot appear in parameters or storage, + the protocol should never parse the bytes of an operation *) + assert false + (* Chain_ids *) + | (Chain_id_t _, Bytes (_, bytes)) -> ( + Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id) + >>=? fun ctxt -> + match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with + | Some k -> + return (k, ctxt) + | None -> + error () >>=? fail ) + | (Chain_id_t _, String (_, s)) -> ( + Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id) + >>=? fun ctxt -> + match Chain_id.of_b58check_opt s with + | Some s -> + return (s, ctxt) + | None -> + error () >>=? fail ) + | (Chain_id_t _, expr) -> + traced + (fail + (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr))) + (* Addresses *) + | (Address_t _, Bytes (loc, bytes)) (* As unparsed with [O[ptimized]. *) -> ( + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) + >>=? fun ctxt -> + match + Data_encoding.Binary.of_bytes + Data_encoding.(tup2 Contract.encoding Variable.string) + bytes + with + | Some (c, entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + fail (Entrypoint_name_too_long entrypoint) + else + ( match entrypoint with + | "" -> + return "default" + | "default" -> + fail (Unexpected_annotation loc) + | name -> + return name ) + >>=? fun entrypoint -> return ((c, entrypoint), ctxt) + | None -> + error () >>=? fail ) + | (Address_t _, String (loc, s)) (* As unparsed with [Readable]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) + >>=? fun ctxt -> + ( match String.index_opt s '%' with + | None -> + return (s, "default") + | Some pos -> ( + let len = String.length s - pos - 1 in + let name = String.sub s (pos + 1) len in + if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name) + else + match (String.sub s 0 pos, name) with + | (_, "default") -> + traced (fail (Unexpected_annotation loc)) + | addr_and_name -> + return addr_and_name ) ) + >>=? fun (addr, entrypoint) -> + Lwt.return (Contract.of_b58check addr) + >>=? fun c -> return ((c, entrypoint), ctxt) + | (Address_t _, expr) -> + traced + (fail + (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr))) + (* Contracts *) + | (Contract_t (ty, _), Bytes (loc, bytes)) + (* As unparsed with [Optimized]. *) -> ( + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) + >>=? fun ctxt -> + match + Data_encoding.Binary.of_bytes + Data_encoding.(tup2 Contract.encoding Variable.string) + bytes + with + | Some (c, entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + fail (Entrypoint_name_too_long entrypoint) + else + ( match entrypoint with + | "" -> + return "default" + | "default" -> + traced (fail (Unexpected_annotation loc)) + | name -> + return name ) + >>=? fun entrypoint -> + traced (parse_contract ~legacy ctxt loc ty c ~entrypoint) + >>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt) + | None -> + error () >>=? fail ) + | (Contract_t (ty, _), String (loc, s)) (* As unparsed with [Readable]. *) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.contract) + >>=? fun ctxt -> + ( match String.index_opt s '%' with + | None -> + return (s, "default") + | Some pos -> ( + let len = String.length s - pos - 1 in + let name = String.sub s (pos + 1) len in + if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name) + else + match (String.sub s 0 pos, name) with + | (_, "default") -> + traced (fail (Unexpected_annotation loc)) + | addr_and_name -> + return addr_and_name ) ) + >>=? fun (addr, entrypoint) -> + traced (Lwt.return (Contract.of_b58check addr)) + >>=? fun c -> + parse_contract ~legacy ctxt loc ty c ~entrypoint + >>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt) + | (Contract_t _, expr) -> + traced + (fail + (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr))) + (* Pairs *) + | (Pair_t ((ta, _, _), (tb, _, _), _, _), Prim (loc, D_Pair, [va; vb], annot)) + -> + (if legacy then return () else fail_unexpected_annot loc annot) + >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.pair) + >>=? fun ctxt -> + traced @@ parse_data ?type_logger ctxt ~legacy ta va + >>=? fun (va, ctxt) -> + parse_data ?type_logger ctxt ~legacy tb vb + >>=? fun (vb, ctxt) -> return ((va, vb), ctxt) + | (Pair_t _, Prim (loc, D_Pair, l, _)) -> + fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) + | (Pair_t _, expr) -> + traced (fail (unexpected expr [] Constant_namespace [D_Pair])) + (* Unions *) + | (Union_t ((tl, _), _, _, _), Prim (loc, D_Left, [v], annot)) -> + (if legacy then return () else fail_unexpected_annot loc annot) + >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.union) + >>=? fun ctxt -> + traced @@ parse_data ?type_logger ctxt ~legacy tl v + >>=? fun (v, ctxt) -> return (L v, ctxt) + | (Union_t _, Prim (loc, D_Left, l, _)) -> + fail @@ Invalid_arity (loc, D_Left, 1, List.length l) + | (Union_t (_, (tr, _), _, _), Prim (loc, D_Right, [v], annot)) -> + fail_unexpected_annot loc annot + >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.union) + >>=? fun ctxt -> + traced @@ parse_data ?type_logger ctxt ~legacy tr v + >>=? fun (v, ctxt) -> return (R v, ctxt) + | (Union_t _, Prim (loc, D_Right, l, _)) -> + fail @@ Invalid_arity (loc, D_Right, 1, List.length l) + | (Union_t _, expr) -> + traced (fail (unexpected expr [] Constant_namespace [D_Left; D_Right])) + (* Lambdas *) + | (Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr)) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) + >>=? fun ctxt -> + traced + @@ parse_returning + Lambda + ?type_logger + ctxt + ~legacy + (ta, Some (`Var_annot "@arg")) + tr + script_instr + | (Lambda_t _, expr) -> + traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr))) + (* Options *) + | (Option_t (t, _, _), Prim (loc, D_Some, [v], annot)) -> + (if legacy then return () else fail_unexpected_annot loc annot) + >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.some) + >>=? fun ctxt -> + traced @@ parse_data ?type_logger ctxt ~legacy t v + >>=? fun (v, ctxt) -> return (Some v, ctxt) + | (Option_t _, Prim (loc, D_Some, l, _)) -> + fail @@ Invalid_arity (loc, D_Some, 1, List.length l) + | (Option_t (_, _, _), Prim (loc, D_None, [], annot)) -> + (if legacy then return () else fail_unexpected_annot loc annot) + >>=? fun () -> + Lwt.return (Gas.consume ctxt Typecheck_costs.none) + >>=? fun ctxt -> return (None, ctxt) + | (Option_t _, Prim (loc, D_None, l, _)) -> + fail @@ Invalid_arity (loc, D_None, 0, List.length l) + | (Option_t _, expr) -> + traced (fail (unexpected expr [] Constant_namespace [D_Some; D_None])) + (* Lists *) + | (List_t (t, _ty_name, _), Seq (_loc, items)) -> + traced + @@ fold_right_s + (fun v (rest, ctxt) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.list_element) + >>=? fun ctxt -> + parse_data ?type_logger ctxt ~legacy t v + >>=? fun (v, ctxt) -> return (v :: rest, ctxt)) + items + ([], ctxt) + | (List_t _, expr) -> + traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr))) + (* Sets *) + | (Set_t (t, _ty_name), (Seq (loc, vs) as expr)) -> + let length = List.length vs in + traced + @@ fold_left_s + (fun (last_value, set, ctxt) v -> + Lwt.return (Gas.consume ctxt (Typecheck_costs.set_element length)) + >>=? fun ctxt -> + parse_comparable_data ?type_logger ctxt t v + >>=? fun (v, ctxt) -> + ( match last_value with + | Some value -> + if Compare.Int.(0 <= compare_comparable t value v) then + if Compare.Int.(0 = compare_comparable t value v) then + fail (Duplicate_set_values (loc, strip_locations expr)) + else fail (Unordered_set_values (loc, strip_locations expr)) + else return_unit + | None -> + return_unit ) + >>=? fun () -> + Lwt.return + (Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Legacy.set_update v false set)) + >>=? fun ctxt -> return (Some v, set_update v true set, ctxt)) + (None, empty_set t, ctxt) + vs + >>|? fun (_, set, ctxt) -> (set, ctxt) + | (Set_t _, expr) -> + traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr))) + (* Maps *) + | (Map_t (tk, tv, _ty_name, _), (Seq (loc, vs) as expr)) -> + parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) + | (Map_t _, expr) -> + traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr))) + | (Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr)) -> + parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) + >>|? fun (diff, ctxt) -> + ( {id = None; diff; key_type = ty_of_comparable_ty tk; value_type = tv}, + ctxt ) + | (Big_map_t (tk, tv, _ty_name), Int (loc, id)) -> ( + Big_map.exists ctxt id + >>=? function + | (_, None) -> + traced (fail (Invalid_big_map (loc, id))) + | (ctxt, Some (btk, btv)) -> + Lwt.return + ( parse_comparable_ty ctxt (Micheline.root btk) + >>? fun (Ex_comparable_ty btk, ctxt) -> + parse_packable_ty ctxt ~legacy (Micheline.root btv) + >>? fun (Ex_ty btv, ctxt) -> + comparable_ty_eq ctxt tk btk + >>? fun (Eq, ctxt) -> + ty_eq ctxt tv btv + >>? fun (Eq, ctxt) -> + ok + ( { + id = Some id; + diff = empty_map tk; + key_type = ty_of_comparable_ty tk; + value_type = tv; + }, + ctxt ) ) ) + | (Big_map_t (_tk, _tv, _), expr) -> + traced + (fail (Invalid_kind (location expr, [Seq_kind; Int_kind], kind expr))) -and parse_returning - : type arg ret. - ?type_logger: type_logger -> - tc_context -> context -> legacy:bool -> - arg ty * var_annot option -> ret ty -> Script.node -> - ((arg, ret) lambda * context) tzresult Lwt.t = - fun ?type_logger tc_context ctxt ~legacy (arg, arg_annot) ret script_instr -> - parse_instr ?type_logger tc_context ctxt ~legacy - script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function - | (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), ctxt) -> - trace_eval - (fun () -> - Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) -> - serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> - Bad_return (loc, stack_ty, ret)) - (Lwt.return (ty_eq ctxt ty ret) >>=? fun (Eq, ctxt) -> - Lwt.return (merge_types ~legacy ctxt loc ty ret) >>=? fun (_ret, ctxt) -> - return ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt)) - | (Typed { loc ; aft = stack_ty ; _ }, ctxt) -> - Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) -> - serialize_stack_for_error ctxt stack_ty >>=? fun (stack_ty, _ctxt) -> - fail (Bad_return (loc, stack_ty, ret)) - | (Failed { descr }, ctxt) -> - return ((Lam (descr (Item_t (ret, Empty_t, None)), script_instr) - : (arg, ret) lambda), ctxt) +and parse_comparable_data : + type a. + ?type_logger:type_logger -> + context -> + a comparable_ty -> + Script.node -> + (a * context) tzresult Lwt.t = + fun ?type_logger ctxt ty script_data -> + parse_data + ?type_logger + ctxt + ~legacy:false + (ty_of_comparable_ty ty) + script_data + +and parse_returning : + type arg ret. + ?type_logger:type_logger -> + tc_context -> + context -> + legacy:bool -> + arg ty * var_annot option -> + ret ty -> + Script.node -> + ((arg, ret) lambda * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt ~legacy (arg, arg_annot) ret script_instr -> + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + script_instr + (Item_t (arg, Empty_t, arg_annot)) + >>=? function + | (Typed ({loc; aft = Item_t (ty, Empty_t, _) as stack_ty; _} as descr), ctxt) + -> + trace_eval + (fun () -> + Lwt.return (serialize_ty_for_error ctxt ret) + >>=? fun (ret, ctxt) -> + serialize_stack_for_error ctxt stack_ty + >>|? fun (stack_ty, _ctxt) -> Bad_return (loc, stack_ty, ret)) + ( Lwt.return (ty_eq ctxt ty ret) + >>=? fun (Eq, ctxt) -> + Lwt.return (merge_types ~legacy ctxt loc ty ret) + >>=? fun (_ret, ctxt) -> + return ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt) ) + | (Typed {loc; aft = stack_ty; _}, ctxt) -> + Lwt.return (serialize_ty_for_error ctxt ret) + >>=? fun (ret, ctxt) -> + serialize_stack_for_error ctxt stack_ty + >>=? fun (stack_ty, _ctxt) -> fail (Bad_return (loc, stack_ty, ret)) + | (Failed {descr}, ctxt) -> + return + ( ( Lam (descr (Item_t (ret, Empty_t, None)), script_instr) + : (arg, ret) lambda ), + ctxt ) and parse_int32 (n : (location, prim) Micheline.node) : int tzresult = let error' () = - Invalid_syntactic_constant (location n, strip_locations n, - "a positive 32-bit integer (between 0 and " - ^ (Int32.to_string Int32.max_int) ^ ")") in + Invalid_syntactic_constant + ( location n, + strip_locations n, + "a positive 32-bit integer (between 0 and " + ^ Int32.to_string Int32.max_int + ^ ")" ) + in match n with - | Micheline.Int (_, n') -> - begin try - let n'' = Z.to_int n' in - if (Compare.Int.(0 <= n'')) && (Compare.Int.(n'' <= Int32.to_int Int32.max_int)) then - ok n'' - else - error @@ error' () - with _ -> - error @@ error' () - end - | _ -> error @@ error' () + | Micheline.Int (_, n') -> ( + try + let n'' = Z.to_int n' in + if + Compare.Int.(0 <= n'') + && Compare.Int.(n'' <= Int32.to_int Int32.max_int) + then ok n'' + else error @@ error' () + with _ -> error @@ error' () ) + | _ -> + error @@ error' () -and parse_instr - : type bef. - ?type_logger: type_logger -> - tc_context -> context -> legacy: bool -> - Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = - fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> - let _check_item check loc name n m = - trace_eval (fun () -> - serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> - Bad_stack (loc, name, m, stack_ty)) @@ - trace (Bad_stack_item n) @@ - Lwt.return check in - let check_item_ty - (type a) (type b) - ctxt (exp : a ty) (got : b ty) loc name n m - : ((a, b) eq * a ty * context) tzresult Lwt.t = - trace_eval (fun () -> - serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> - Bad_stack (loc, name, m, stack_ty)) @@ - trace (Bad_stack_item n) @@ Lwt.return begin - ty_eq ctxt exp got >>? fun (Eq, ctxt) -> - merge_types ~legacy ctxt loc exp got >>? fun (ty, ctxt) -> - ok ((Eq : (a, b) eq), (ty : a ty), ctxt) - end in - let check_item_comparable_ty - (type a) (type b) - (exp : a comparable_ty) (got : b comparable_ty) loc name n m - : ((a, b) eq * a comparable_ty) tzresult Lwt.t = - trace_eval (fun () -> - serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> - Bad_stack (loc, name, m, stack_ty)) @@ - trace (Bad_stack_item n) @@ Lwt.return begin - comparable_ty_eq ctxt exp got >>? fun Eq -> - merge_comparable_types ~legacy exp got >>? fun ty -> - ok ((Eq : (a, b) eq), (ty : a comparable_ty)) - end in - let log_stack ctxt loc stack_ty aft = - match type_logger, script_instr with - | None, _ - | Some _, (Seq (-1, _) | Int _ | String _ | Bytes _) -> return_unit - | Some log, (Prim _ | Seq _) -> - (* Unparsing for logging done in an unlimited context as this +and parse_instr : + type bef. + ?type_logger:type_logger -> + tc_context -> + context -> + legacy:bool -> + Script.node -> + bef stack_ty -> + (bef judgement * context) tzresult Lwt.t = + fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> + let _check_item check loc name n m = + trace_eval (fun () -> + serialize_stack_for_error ctxt stack_ty + >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty)) + @@ trace (Bad_stack_item n) @@ Lwt.return check + in + let check_item_ty (type a b) ctxt (exp : a ty) (got : b ty) loc name n m : + ((a, b) eq * a ty * context) tzresult Lwt.t = + trace_eval (fun () -> + serialize_stack_for_error ctxt stack_ty + >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty)) + @@ trace (Bad_stack_item n) + @@ Lwt.return + ( ty_eq ctxt exp got + >>? fun (Eq, ctxt) -> + merge_types ~legacy ctxt loc exp got + >>? fun (ty, ctxt) -> ok ((Eq : (a, b) eq), (ty : a ty), ctxt) ) + in + let check_item_comparable_ty (type a b) (exp : a comparable_ty) + (got : b comparable_ty) loc name n m : + ((a, b) eq * a comparable_ty * context) tzresult Lwt.t = + trace_eval (fun () -> + serialize_stack_for_error ctxt stack_ty + >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty)) + @@ trace (Bad_stack_item n) + @@ Lwt.return + ( comparable_ty_eq ctxt exp got + >>? fun (Eq, ctxt) -> + merge_comparable_types ~legacy exp got + >>? fun ty -> ok ((Eq : (a, b) eq), (ty : a comparable_ty), ctxt) ) + in + let log_stack ctxt loc stack_ty aft = + match (type_logger, script_instr) with + | (None, _) | (Some _, (Seq (-1, _) | Int _ | String _ | Bytes _)) -> + return_unit + | (Some log, (Prim _ | Seq _)) -> + (* Unparsing for logging done in an unlimited context as this is used only by the client and not the protocol *) - let ctxt = Gas.set_unlimited ctxt in - unparse_stack ctxt stack_ty >>=? fun (stack_ty, _) -> - unparse_stack ctxt aft >>=? fun (aft, _) -> - log loc stack_ty aft; - return_unit - in - let outer_return = return in - let return : type bef . - context -> bef judgement -> (bef judgement * context) tzresult Lwt.t = fun ctxt judgement -> - match judgement with - | Typed { instr ; loc ; aft ; _ } -> - let maximum_type_size = Constants.michelson_maximum_type_size ctxt in - let type_size = - type_size_of_stack_head aft - ~up_to:(number_of_generated_growing_types instr) in - if Compare.Int.(type_size > maximum_type_size) then - fail (Type_too_large (loc, type_size, maximum_type_size)) - else - return (judgement, ctxt) - | Failed _ -> - return (judgement, ctxt) in - let typed ctxt loc instr aft = - log_stack ctxt loc stack_ty aft >>=? fun () -> - Lwt.return @@ Gas.consume ctxt (Typecheck_costs.instr instr) >>=? fun ctxt -> - return ctxt (Typed { loc ; instr ; bef = stack_ty ; aft }) in - Lwt.return @@ Gas.consume ctxt Typecheck_costs.cycle >>=? fun ctxt -> - match script_instr, stack_ty with - (* stack ops *) - | Prim (loc, I_DROP, [], annot), - Item_t (_, rest, _) -> - (fail_unexpected_annot loc annot >>=? fun () -> - typed ctxt loc Drop rest : (bef judgement * context) tzresult Lwt.t) - | Prim (loc, I_DROP, [n], result_annot), whole_stack -> - Lwt.return (parse_int32 n) >>=? fun whole_n -> - let rec make_proof_argument - : type tstk . int -> (tstk stack_ty) -> (tstk dropn_proof_argument) tzresult Lwt.t = - fun n stk -> - match (Compare.Int.(n = 0)), stk with - true, rest -> - outer_return @@ (Dropn_proof_argument (Rest, rest, rest)) - | false, Item_t (v, rest, annot) -> - make_proof_argument (n - 1) rest - >>=? fun (Dropn_proof_argument (n', stack_after_drops, aft')) -> - outer_return @@ (Dropn_proof_argument (Prefix n', stack_after_drops, Item_t (v, aft', annot))) - | _, _ -> - serialize_stack_for_error ctxt whole_stack >>=? fun (whole_stack, _ctxt) -> - fail (Bad_stack (loc, I_DROP, whole_n, whole_stack)) + let ctxt = Gas.set_unlimited ctxt in + unparse_stack ctxt stack_ty + >>=? fun (stack_ty, _) -> + unparse_stack ctxt aft + >>=? fun (aft, _) -> log loc stack_ty aft ; return_unit + in + let outer_return = return in + let return : + type bef. + context -> bef judgement -> (bef judgement * context) tzresult Lwt.t = + fun ctxt judgement -> + match judgement with + | Typed {instr; loc; aft; _} -> + let maximum_type_size = Constants.michelson_maximum_type_size ctxt in + let type_size = + type_size_of_stack_head + aft + ~up_to:(number_of_generated_growing_types instr) in - fail_unexpected_annot loc result_annot >>=? fun () -> - make_proof_argument whole_n whole_stack >>=? fun (Dropn_proof_argument (n', stack_after_drops, _aft)) -> - typed ctxt loc (Dropn (whole_n, n')) stack_after_drops - | Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _ -> - (* Technically, the arities 0 and 1 are allowed but the error only mentions 1. + if Compare.Int.(type_size > maximum_type_size) then + fail (Type_too_large (loc, type_size, maximum_type_size)) + else return (judgement, ctxt) + | Failed _ -> + return (judgement, ctxt) + in + let typed ctxt loc instr aft = + log_stack ctxt loc stack_ty aft + >>=? fun () -> + Lwt.return @@ Gas.consume ctxt (Typecheck_costs.instr instr) + >>=? fun ctxt -> return ctxt (Typed {loc; instr; bef = stack_ty; aft}) + in + Lwt.return @@ Gas.consume ctxt Typecheck_costs.cycle + >>=? fun ctxt -> + match (script_instr, stack_ty) with + (* stack ops *) + | (Prim (loc, I_DROP, [], annot), Item_t (_, rest, _)) -> + ( fail_unexpected_annot loc annot >>=? fun () -> typed ctxt loc Drop rest + : (bef judgement * context) tzresult Lwt.t ) + | (Prim (loc, I_DROP, [n], result_annot), whole_stack) -> + Lwt.return (parse_int32 n) + >>=? fun whole_n -> + let rec make_proof_argument : + type tstk. + int -> tstk stack_ty -> tstk dropn_proof_argument tzresult Lwt.t = + fun n stk -> + match (Compare.Int.(n = 0), stk) with + | (true, rest) -> + outer_return @@ Dropn_proof_argument (Rest, rest, rest) + | (false, Item_t (v, rest, annot)) -> + make_proof_argument (n - 1) rest + >>=? fun (Dropn_proof_argument (n', stack_after_drops, aft')) -> + outer_return + @@ Dropn_proof_argument + (Prefix n', stack_after_drops, Item_t (v, aft', annot)) + | (_, _) -> + serialize_stack_for_error ctxt whole_stack + >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DROP, whole_n, whole_stack)) + in + fail_unexpected_annot loc result_annot + >>=? fun () -> + make_proof_argument whole_n whole_stack + >>=? fun (Dropn_proof_argument (n', stack_after_drops, _aft)) -> + typed ctxt loc (Dropn (whole_n, n')) stack_after_drops + | (Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _) -> + (* Technically, the arities 0 and 1 are allowed but the error only mentions 1. However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *) - fail (Invalid_arity (loc, I_DROP, 1, List.length l)) - | Prim (loc, I_DUP, [], annot), - Item_t (v, rest, stack_annot) -> - parse_var_annot loc annot ~default:stack_annot >>=? fun annot -> - typed ctxt loc Dup - (Item_t (v, Item_t (v, rest, stack_annot), annot)) - | Prim (loc, I_DIG, [n], result_annot), stack -> - let rec make_proof_argument - : type tstk . int -> (tstk stack_ty) -> (tstk dig_proof_argument) tzresult Lwt.t = - fun n stk -> - match (Compare.Int.(n = 0)), stk with - true, Item_t (v, rest, annot) -> - outer_return @@ (Dig_proof_argument (Rest, (v, annot), rest)) - | false, Item_t (v, rest, annot) -> - make_proof_argument (n - 1) rest - >>=? fun (Dig_proof_argument (n', (x, xv), aft')) -> - outer_return @@ (Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot))) - | _, _ -> - serialize_stack_for_error ctxt stack >>=? fun (whole_stack, _ctxt) -> - fail (Bad_stack (loc, I_DIG, 1, whole_stack)) - in - Lwt.return (parse_int32 n) >>=? fun n -> - fail_unexpected_annot loc result_annot >>=? fun () -> - make_proof_argument n stack >>=? fun (Dig_proof_argument (n', (x, stack_annot), aft)) -> - typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot)) - | Prim (loc, I_DIG, ([] | _ :: _ :: _ as l), _), _ -> - fail (Invalid_arity (loc, I_DIG, 1, List.length l)) - | Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack, stack_annot) -> - Lwt.return (parse_int32 n) >>=? fun whole_n -> - let rec make_proof_argument - : type tstk x . int -> x ty -> var_annot option -> (tstk stack_ty) - -> ((tstk, x) dug_proof_argument) tzresult Lwt.t = - fun n x stack_annot stk -> - match (Compare.Int.(n = 0)), stk with - true, rest -> - outer_return @@ (Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot))) - | false, Item_t (v, rest, annot) -> - make_proof_argument (n - 1) x stack_annot rest - >>=? fun (Dug_proof_argument (n', (), aft')) -> - outer_return @@ (Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot))) - | _, _ -> - serialize_stack_for_error ctxt whole_stack >>=? fun (whole_stack, _ctxt) -> - fail (Bad_stack (loc, I_DUG, whole_n, whole_stack)) - in - fail_unexpected_annot loc result_annot >>=? fun () -> - make_proof_argument whole_n x stack_annot whole_stack >>=? fun (Dug_proof_argument (n', (), aft)) -> - typed ctxt loc (Dug (whole_n, n')) aft - | Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack) -> - fail_unexpected_annot loc result_annot >>=? fun () -> - serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> - fail (Bad_stack (loc, I_DUG, 1, stack)) - | Prim (loc, I_DUG, ([] | _ :: _ :: _ as l), _), _ -> - fail (Invalid_arity (loc, I_DUG, 1, List.length l)) - | Prim (loc, I_SWAP, [], annot), - Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) -> - fail_unexpected_annot loc annot >>=? fun () -> - typed ctxt loc Swap - (Item_t (w, Item_t (v, rest, cur_top_annot), stack_annot)) - | Prim (loc, I_PUSH, [ t ; d ], annot), - stack -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ parse_packable_ty ctxt ~legacy t >>=? fun (Ex_ty t, ctxt) -> - parse_data ?type_logger ctxt ~legacy t d >>=? fun (v, ctxt) -> - typed ctxt loc (Const v) (Item_t (t, stack, annot)) - | Prim (loc, I_UNIT, [], annot), - stack -> - parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot)) - (* options *) - | Prim (loc, I_SOME, [], annot), - Item_t (t, rest, _) -> - parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc Cons_some - (Item_t (Option_t (t, ty_name, has_big_map t), rest, annot)) - | Prim (loc, I_NONE, [ t ], annot), - stack -> - Lwt.return @@ parse_any_ty ctxt ~legacy t >>=? fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc (Cons_none t) - (Item_t (Option_t (t, ty_name, has_big_map t), stack, annot)) - | Prim (loc, I_IF_NONE, [ bt ; bf ], annot), - (Item_t (Option_t (t, _, _), rest, option_annot) as bef) -> - check_kind [ Seq_kind ] bt >>=? fun () -> - check_kind [ Seq_kind ] bf >>=? fun () -> - fail_unexpected_annot loc annot >>=? fun () -> - let annot = gen_access_annot option_annot default_some_annot in - parse_instr ?type_logger tc_context ctxt ~legacy bt rest >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt ~legacy bf (Item_t (t, rest, annot)) >>=? fun (bfr, ctxt) -> - let branch ibt ibf = - { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> - return ctxt judgement - (* pairs *) - | Prim (loc, I_PAIR, [], annot), - Item_t (a, Item_t (b, rest, snd_annot), fst_annot) -> - parse_constr_annot loc annot - ~if_special_first:(var_to_field_annot fst_annot) - ~if_special_second:(var_to_field_annot snd_annot) - >>=? fun (annot, ty_name, l_field, r_field) -> - typed ctxt loc Cons_pair - (Item_t (Pair_t((a, l_field, fst_annot), (b, r_field, snd_annot), ty_name, has_big_map a || has_big_map b), rest, annot)) - | Prim (loc, I_CAR, [], annot), - Item_t (Pair_t ((a, expected_field_annot, a_annot), _, _, _), rest, pair_annot) -> - parse_destr_annot loc annot - ~pair_annot - ~value_annot:a_annot - ~field_name:expected_field_annot - ~default_accessor:default_car_annot - >>=? fun (annot, field_annot) -> - Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () -> - typed ctxt loc Car (Item_t (a, rest, annot)) - | Prim (loc, I_CDR, [], annot), - Item_t (Pair_t (_, (b, expected_field_annot, b_annot), _, _), rest, pair_annot) -> - parse_destr_annot loc annot - ~pair_annot - ~value_annot:b_annot - ~field_name:expected_field_annot - ~default_accessor:default_cdr_annot - >>=? fun (annot, field_annot) -> - Lwt.return @@ check_correct_field field_annot expected_field_annot >>=? fun () -> - typed ctxt loc Cdr (Item_t (b, rest, annot)) - (* unions *) - | Prim (loc, I_LEFT, [ tr ], annot), - Item_t (tl, rest, stack_annot) -> - Lwt.return @@ parse_any_ty ctxt ~legacy tr >>=? fun (Ex_ty tr, ctxt) -> - parse_constr_annot loc annot - ~if_special_first:(var_to_field_annot stack_annot) - >>=? fun (annot, tname, l_field, r_field) -> - typed ctxt loc Left (Item_t (Union_t ((tl, l_field), (tr, r_field), tname, has_big_map tl || has_big_map tr), rest, annot)) - | Prim (loc, I_RIGHT, [ tl ], annot), - Item_t (tr, rest, stack_annot) -> - Lwt.return @@ parse_any_ty ctxt ~legacy tl >>=? fun (Ex_ty tl, ctxt) -> - parse_constr_annot loc annot - ~if_special_second:(var_to_field_annot stack_annot) - >>=? fun (annot, tname, l_field, r_field) -> - typed ctxt loc Right (Item_t (Union_t ((tl, l_field), (tr, r_field), tname, has_big_map tl || has_big_map tr), rest, annot)) - | Prim (loc, I_IF_LEFT, [ bt ; bf ], annot), - (Item_t (Union_t ((tl, l_field), (tr, r_field), _, _), rest, union_annot) as bef) -> - check_kind [ Seq_kind ] bt >>=? fun () -> - check_kind [ Seq_kind ] bf >>=? fun () -> - fail_unexpected_annot loc annot >>=? fun () -> - let left_annot = gen_access_annot union_annot l_field ~default:default_left_annot in - let right_annot = gen_access_annot union_annot r_field ~default:default_right_annot in - parse_instr ?type_logger tc_context ctxt ~legacy bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt ~legacy bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> - let branch ibt ibf = - { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> - return ctxt judgement - (* lists *) - | Prim (loc, I_NIL, [ t ], annot), - stack -> - Lwt.return @@ parse_any_ty ctxt ~legacy t >>=? fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc Nil (Item_t (List_t (t, ty_name, has_big_map t), stack, annot)) - | Prim (loc, I_CONS, [], annot), - Item_t (tv, Item_t (List_t (t, ty_name, has_big_map), rest, _), _) -> - check_item_ty ctxt tv t loc I_CONS 1 2 >>=? fun (Eq, t, ctxt) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Cons_list (Item_t (List_t (t, ty_name, has_big_map), rest, annot)) - | Prim (loc, I_IF_CONS, [ bt ; bf ], annot), - (Item_t (List_t (t, ty_name, has_big_map), rest, list_annot) as bef) -> - check_kind [ Seq_kind ] bt >>=? fun () -> - check_kind [ Seq_kind ] bf >>=? fun () -> - fail_unexpected_annot loc annot >>=? fun () -> - let hd_annot = gen_access_annot list_annot default_hd_annot in - let tl_annot = gen_access_annot list_annot default_tl_annot in - parse_instr ?type_logger tc_context ctxt ~legacy bt - (Item_t (t, Item_t (List_t (t, ty_name, has_big_map), rest, tl_annot), hd_annot)) - >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt ~legacy bf - rest >>=? fun (bfr, ctxt) -> - let branch ibt ibf = - { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> - return ctxt judgement - | Prim (loc, I_SIZE, [], annot), - Item_t (List_t _, rest, _) -> - parse_var_type_annot loc annot >>=? fun (annot, tname) -> - typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot)) - | Prim (loc, I_MAP, [ body ], annot), - (Item_t (List_t (elt, _, _), starting_rest, list_annot)) -> - check_kind [ Seq_kind ] body >>=? fun () -> - parse_var_type_annot loc annot - >>=? fun (ret_annot, list_ty_name) -> - let elt_annot = gen_access_annot list_annot default_elt_annot in - parse_instr ?type_logger tc_context ctxt ~legacy - body (Item_t (elt, starting_rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> + fail (Invalid_arity (loc, I_DROP, 1, List.length l)) + | (Prim (loc, I_DUP, [], annot), Item_t (v, rest, stack_annot)) -> + parse_var_annot loc annot ~default:stack_annot + >>=? fun annot -> + typed ctxt loc Dup (Item_t (v, Item_t (v, rest, stack_annot), annot)) + | (Prim (loc, I_DIG, [n], result_annot), stack) -> + let rec make_proof_argument : + type tstk. + int -> tstk stack_ty -> tstk dig_proof_argument tzresult Lwt.t = + fun n stk -> + match (Compare.Int.(n = 0), stk) with + | (true, Item_t (v, rest, annot)) -> + outer_return @@ Dig_proof_argument (Rest, (v, annot), rest) + | (false, Item_t (v, rest, annot)) -> + make_proof_argument (n - 1) rest + >>=? fun (Dig_proof_argument (n', (x, xv), aft')) -> + outer_return + @@ Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot)) + | (_, _) -> + serialize_stack_for_error ctxt stack + >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DIG, 1, whole_stack)) + in + Lwt.return (parse_int32 n) + >>=? fun n -> + fail_unexpected_annot loc result_annot + >>=? fun () -> + make_proof_argument n stack + >>=? fun (Dig_proof_argument (n', (x, stack_annot), aft)) -> + typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot)) + | (Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _) -> + fail (Invalid_arity (loc, I_DIG, 1, List.length l)) + | (Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack, stack_annot)) + -> + Lwt.return (parse_int32 n) + >>=? fun whole_n -> + let rec make_proof_argument : + type tstk x. + int -> + x ty -> + var_annot option -> + tstk stack_ty -> + (tstk, x) dug_proof_argument tzresult Lwt.t = + fun n x stack_annot stk -> + match (Compare.Int.(n = 0), stk) with + | (true, rest) -> + outer_return + @@ Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot)) + | (false, Item_t (v, rest, annot)) -> + make_proof_argument (n - 1) x stack_annot rest + >>=? fun (Dug_proof_argument (n', (), aft')) -> + outer_return + @@ Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot)) + | (_, _) -> + serialize_stack_for_error ctxt whole_stack + >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DUG, whole_n, whole_stack)) + in + fail_unexpected_annot loc result_annot + >>=? fun () -> + make_proof_argument whole_n x stack_annot whole_stack + >>=? fun (Dug_proof_argument (n', (), aft)) -> + typed ctxt loc (Dug (whole_n, n')) aft + | (Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack)) -> + fail_unexpected_annot loc result_annot + >>=? fun () -> + serialize_stack_for_error ctxt stack + >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_DUG, 1, stack)) + | (Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _) -> + fail (Invalid_arity (loc, I_DUG, 1, List.length l)) + | ( Prim (loc, I_SWAP, [], annot), + Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) ) -> + fail_unexpected_annot loc annot + >>=? fun () -> + typed + ctxt + loc + Swap + (Item_t (w, Item_t (v, rest, cur_top_annot), stack_annot)) + | (Prim (loc, I_PUSH, [t; d], annot), stack) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ parse_packable_ty ctxt ~legacy t + >>=? fun (Ex_ty t, ctxt) -> + parse_data ?type_logger ctxt ~legacy t d + >>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, annot)) + | (Prim (loc, I_UNIT, [], annot), stack) -> + parse_var_type_annot loc annot + >>=? fun (annot, ty_name) -> + typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot)) + (* options *) + | (Prim (loc, I_SOME, [], annot), Item_t (t, rest, _)) -> + parse_var_type_annot loc annot + >>=? fun (annot, ty_name) -> + typed + ctxt + loc + Cons_some + (Item_t (Option_t (t, ty_name, has_big_map t), rest, annot)) + | (Prim (loc, I_NONE, [t], annot), stack) -> + Lwt.return @@ parse_any_ty ctxt ~legacy t + >>=? fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot + >>=? fun (annot, ty_name) -> + typed + ctxt + loc + (Cons_none t) + (Item_t (Option_t (t, ty_name, has_big_map t), stack, annot)) + | ( Prim (loc, I_IF_NONE, [bt; bf], annot), + (Item_t (Option_t (t, _, _), rest, option_annot) as bef) ) -> + check_kind [Seq_kind] bt + >>=? fun () -> + check_kind [Seq_kind] bf + >>=? fun () -> + fail_unexpected_annot loc annot + >>=? fun () -> + let annot = gen_access_annot option_annot default_some_annot in + parse_instr ?type_logger tc_context ctxt ~legacy bt rest + >>=? fun (btr, ctxt) -> + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + bf + (Item_t (t, rest, annot)) + >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + {loc; instr = If_none (ibt, ibf); bef; aft = ibt.aft} + in + merge_branches ~legacy ctxt loc btr bfr {branch} + >>=? fun (judgement, ctxt) -> return ctxt judgement + (* pairs *) + | ( Prim (loc, I_PAIR, [], annot), + Item_t (a, Item_t (b, rest, snd_annot), fst_annot) ) -> + parse_constr_annot + loc + annot + ~if_special_first:(var_to_field_annot fst_annot) + ~if_special_second:(var_to_field_annot snd_annot) + >>=? fun (annot, ty_name, l_field, r_field) -> + typed + ctxt + loc + Cons_pair + (Item_t + ( Pair_t + ( (a, l_field, fst_annot), + (b, r_field, snd_annot), + ty_name, + has_big_map a || has_big_map b ), + rest, + annot )) + | ( Prim (loc, I_CAR, [], annot), + Item_t + (Pair_t ((a, expected_field_annot, a_annot), _, _, _), rest, pair_annot) + ) -> + parse_destr_annot + loc + annot + ~pair_annot + ~value_annot:a_annot + ~field_name:expected_field_annot + ~default_accessor:default_car_annot + >>=? fun (annot, field_annot) -> + Lwt.return @@ check_correct_field field_annot expected_field_annot + >>=? fun () -> typed ctxt loc Car (Item_t (a, rest, annot)) + | ( Prim (loc, I_CDR, [], annot), + Item_t + (Pair_t (_, (b, expected_field_annot, b_annot), _, _), rest, pair_annot) + ) -> + parse_destr_annot + loc + annot + ~pair_annot + ~value_annot:b_annot + ~field_name:expected_field_annot + ~default_accessor:default_cdr_annot + >>=? fun (annot, field_annot) -> + Lwt.return @@ check_correct_field field_annot expected_field_annot + >>=? fun () -> typed ctxt loc Cdr (Item_t (b, rest, annot)) + (* unions *) + | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest, stack_annot)) -> + Lwt.return @@ parse_any_ty ctxt ~legacy tr + >>=? fun (Ex_ty tr, ctxt) -> + parse_constr_annot + loc + annot + ~if_special_first:(var_to_field_annot stack_annot) + >>=? fun (annot, tname, l_field, r_field) -> + typed + ctxt + loc + Left + (Item_t + ( Union_t + ( (tl, l_field), + (tr, r_field), + tname, + has_big_map tl || has_big_map tr ), + rest, + annot )) + | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest, stack_annot)) -> + Lwt.return @@ parse_any_ty ctxt ~legacy tl + >>=? fun (Ex_ty tl, ctxt) -> + parse_constr_annot + loc + annot + ~if_special_second:(var_to_field_annot stack_annot) + >>=? fun (annot, tname, l_field, r_field) -> + typed + ctxt + loc + Right + (Item_t + ( Union_t + ( (tl, l_field), + (tr, r_field), + tname, + has_big_map tl || has_big_map tr ), + rest, + annot )) + | ( Prim (loc, I_IF_LEFT, [bt; bf], annot), + ( Item_t (Union_t ((tl, l_field), (tr, r_field), _, _), rest, union_annot) + as bef ) ) -> + check_kind [Seq_kind] bt + >>=? fun () -> + check_kind [Seq_kind] bf + >>=? fun () -> + fail_unexpected_annot loc annot + >>=? fun () -> + let left_annot = + gen_access_annot union_annot l_field ~default:default_left_annot + in + let right_annot = + gen_access_annot union_annot r_field ~default:default_right_annot + in + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + bt + (Item_t (tl, rest, left_annot)) + >>=? fun (btr, ctxt) -> + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + bf + (Item_t (tr, rest, right_annot)) + >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + {loc; instr = If_left (ibt, ibf); bef; aft = ibt.aft} + in + merge_branches ~legacy ctxt loc btr bfr {branch} + >>=? fun (judgement, ctxt) -> return ctxt judgement + (* lists *) + | (Prim (loc, I_NIL, [t], annot), stack) -> + Lwt.return @@ parse_any_ty ctxt ~legacy t + >>=? fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot + >>=? fun (annot, ty_name) -> + typed + ctxt + loc + Nil + (Item_t (List_t (t, ty_name, has_big_map t), stack, annot)) + | ( Prim (loc, I_CONS, [], annot), + Item_t (tv, Item_t (List_t (t, ty_name, has_big_map), rest, _), _) ) -> + check_item_ty ctxt tv t loc I_CONS 1 2 + >>=? fun (Eq, t, ctxt) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Cons_list + (Item_t (List_t (t, ty_name, has_big_map), rest, annot)) + | ( Prim (loc, I_IF_CONS, [bt; bf], annot), + (Item_t (List_t (t, ty_name, has_big_map), rest, list_annot) as bef) ) -> + check_kind [Seq_kind] bt + >>=? fun () -> + check_kind [Seq_kind] bf + >>=? fun () -> + fail_unexpected_annot loc annot + >>=? fun () -> + let hd_annot = gen_access_annot list_annot default_hd_annot in + let tl_annot = gen_access_annot list_annot default_tl_annot in + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + bt + (Item_t + ( t, + Item_t (List_t (t, ty_name, has_big_map), rest, tl_annot), + hd_annot )) + >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bf rest + >>=? fun (bfr, ctxt) -> + let branch ibt ibf = + {loc; instr = If_cons (ibt, ibf); bef; aft = ibt.aft} + in + merge_branches ~legacy ctxt loc btr bfr {branch} + >>=? fun (judgement, ctxt) -> return ctxt judgement + | (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _)) -> + parse_var_type_annot loc annot + >>=? fun (annot, tname) -> + typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_MAP, [body], annot), + Item_t (List_t (elt, _, _), starting_rest, list_annot) ) -> ( + check_kind [Seq_kind] body + >>=? fun () -> + parse_var_type_annot loc annot + >>=? fun (ret_annot, list_ty_name) -> + let elt_annot = gen_access_annot list_annot default_elt_annot in + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t (elt, starting_rest, elt_annot)) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft = Item_t (ret, rest, _); _} as ibody) -> + let invalid_map_body () = + serialize_stack_for_error ctxt ibody.aft + >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft) + in + trace_eval + invalid_map_body + ( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest + >>=? fun (rest, ctxt) -> + typed + ctxt + loc + (List_map ibody) + (Item_t + (List_t (ret, list_ty_name, has_big_map ret), rest, ret_annot)) + ) + | Typed {aft; _} -> + serialize_stack_for_error ctxt aft + >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft)) + | Failed _ -> + fail (Invalid_map_block_fail loc) ) + | ( Prim (loc, I_ITER, [body], annot), + Item_t (List_t (elt, _, _), rest, list_annot) ) -> ( + check_kind [Seq_kind] body + >>=? fun () -> + fail_unexpected_annot loc annot + >>=? fun () -> + let elt_annot = gen_access_annot list_annot default_elt_annot in + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t (elt, rest, elt_annot)) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft; _} as ibody) -> + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft + >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest + >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft) + in + trace_eval + invalid_iter_body + ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest + >>=? fun (rest, ctxt) -> typed ctxt loc (List_iter ibody) rest ) + | Failed {descr} -> + typed ctxt loc (List_iter (descr rest)) rest ) + (* sets *) + | (Prim (loc, I_EMPTY_SET, [t], annot), rest) -> + Lwt.return @@ parse_comparable_ty ctxt t + >>=? fun (Ex_comparable_ty t, ctxt) -> + parse_var_type_annot loc annot + >>=? fun (annot, tname) -> + typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot)) + | ( Prim (loc, I_ITER, [body], annot), + Item_t (Set_t (comp_elt, _), rest, set_annot) ) -> ( + check_kind [Seq_kind] body + >>=? fun () -> + fail_unexpected_annot loc annot + >>=? fun () -> + let elt_annot = gen_access_annot set_annot default_elt_annot in + let elt = ty_of_comparable_ty comp_elt in + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t (elt, rest, elt_annot)) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft; _} as ibody) -> + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft + >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest + >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft) + in + trace_eval + invalid_iter_body + ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest + >>=? fun (rest, ctxt) -> typed ctxt loc (Set_iter ibody) rest ) + | Failed {descr} -> + typed ctxt loc (Set_iter (descr rest)) rest ) + | ( Prim (loc, I_MEM, [], annot), + Item_t (v, Item_t (Set_t (elt, _), rest, _), _) ) -> + let elt = ty_of_comparable_ty elt in + parse_var_type_annot loc annot + >>=? fun (annot, tname) -> + check_item_ty ctxt elt v loc I_MEM 1 2 + >>=? fun (Eq, _, ctxt) -> + typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot)) + | ( Prim (loc, I_UPDATE, [], annot), + Item_t + ( v, + Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _), + _ ) ) -> ( + match comparable_ty_of_ty v with + | None -> + unparse_ty ctxt v + >>=? fun (v, _ctxt) -> + fail (Comparable_type_expected (loc, Micheline.strip_locations v)) + | Some v -> + parse_var_annot loc annot ~default:set_annot + >>=? fun annot -> + check_item_comparable_ty elt v loc I_UPDATE 1 3 + >>=? fun (Eq, elt, ctxt) -> + typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) ) + | (Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Set_size (Item_t (Nat_t None, rest, annot)) + (* maps *) + | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) -> + Lwt.return @@ parse_comparable_ty ctxt tk + >>=? fun (Ex_comparable_ty tk, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy tv + >>=? fun (Ex_ty tv, ctxt) -> + parse_var_type_annot loc annot + >>=? fun (annot, ty_name) -> + typed + ctxt + loc + (Empty_map (tk, tv)) + (Item_t (Map_t (tk, tv, ty_name, has_big_map tv), stack, annot)) + | ( Prim (loc, I_MAP, [body], annot), + Item_t (Map_t (ck, elt, _, _), starting_rest, _map_annot) ) -> ( + let k = ty_of_comparable_ty ck in + check_kind [Seq_kind] body + >>=? fun () -> + parse_var_type_annot loc annot + >>=? fun (ret_annot, ty_name) -> + let k_name = field_to_var_annot default_key_annot in + let e_name = field_to_var_annot default_elt_annot in + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t + ( Pair_t + ((k, None, k_name), (elt, None, e_name), None, has_big_map elt), + starting_rest, + None )) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft = Item_t (ret, rest, _); _} as ibody) -> + let invalid_map_body () = + serialize_stack_for_error ctxt ibody.aft + >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft) + in + trace_eval + invalid_map_body + ( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest + >>=? fun (rest, ctxt) -> + typed + ctxt + loc + (Map_map ibody) + (Item_t + (Map_t (ck, ret, ty_name, has_big_map ret), rest, ret_annot)) + ) + | Typed {aft; _} -> + serialize_stack_for_error ctxt aft + >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft)) + | Failed _ -> + fail (Invalid_map_block_fail loc) ) + | ( Prim (loc, I_ITER, [body], annot), + Item_t (Map_t (comp_elt, element_ty, _, _), rest, _map_annot) ) -> ( + check_kind [Seq_kind] body + >>=? fun () -> + fail_unexpected_annot loc annot + >>=? fun () -> + let k_name = field_to_var_annot default_key_annot in + let e_name = field_to_var_annot default_elt_annot in + let key = ty_of_comparable_ty comp_elt in + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t + ( Pair_t + ( (key, None, k_name), + (element_ty, None, e_name), + None, + has_big_map element_ty ), + rest, + None )) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft; _} as ibody) -> + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft + >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest + >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft) + in + trace_eval + invalid_iter_body + ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest + >>=? fun (rest, ctxt) -> typed ctxt loc (Map_iter ibody) rest ) + | Failed {descr} -> + typed ctxt loc (Map_iter (descr rest)) rest ) + | ( Prim (loc, I_MEM, [], annot), + Item_t (vk, Item_t (Map_t (ck, _, _, _), rest, _), _) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_MEM 1 2 + >>=? fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot)) + | ( Prim (loc, I_GET, [], annot), + Item_t (vk, Item_t (Map_t (ck, elt, _, has_big_map), rest, _), _) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_GET 1 2 + >>=? fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Map_get + (Item_t (Option_t (elt, None, has_big_map), rest, annot)) + | ( Prim (loc, I_UPDATE, [], annot), + Item_t + ( vk, + Item_t + ( Option_t (vv, _, _), + Item_t (Map_t (ck, v, map_name, has_big_map), rest, map_annot), + _ ), + _ ) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_UPDATE 1 3 + >>=? fun (Eq, _, ctxt) -> + check_item_ty ctxt vv v loc I_UPDATE 2 3 + >>=? fun (Eq, v, ctxt) -> + parse_var_annot loc annot ~default:map_annot + >>=? fun annot -> + typed + ctxt + loc + Map_update + (Item_t (Map_t (ck, v, map_name, has_big_map), rest, annot)) + | (Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _, _), rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot)) + (* big_map *) + | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) -> + Lwt.return @@ parse_comparable_ty ctxt tk + >>=? fun (Ex_comparable_ty tk, ctxt) -> + Lwt.return @@ parse_packable_ty ctxt ~legacy tv + >>=? fun (Ex_ty tv, ctxt) -> + parse_var_type_annot loc annot + >>=? fun (annot, ty_name) -> + typed + ctxt + loc + (Empty_big_map (tk, tv)) + (Item_t (Big_map_t (tk, tv, ty_name), stack, annot)) + | ( Prim (loc, I_MEM, [], annot), + Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) ) -> + let k = ty_of_comparable_ty map_key in + check_item_ty ctxt set_key k loc I_MEM 1 2 + >>=? fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot)) + | ( Prim (loc, I_GET, [], annot), + Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) ) -> + let k = ty_of_comparable_ty ck in + check_item_ty ctxt vk k loc I_GET 1 2 + >>=? fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Big_map_get + (Item_t (Option_t (elt, None, has_big_map elt), rest, annot)) + | ( Prim (loc, I_UPDATE, [], annot), + Item_t + ( set_key, + Item_t + ( Option_t (set_value, _, _), + Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot), + _ ), + _ ) ) -> + let k = ty_of_comparable_ty map_key in + check_item_ty ctxt set_key k loc I_UPDATE 1 3 + >>=? fun (Eq, _, ctxt) -> + check_item_ty ctxt set_value map_value loc I_UPDATE 2 3 + >>=? fun (Eq, map_value, ctxt) -> + parse_var_annot loc annot ~default:map_annot + >>=? fun annot -> + typed + ctxt + loc + Big_map_update + (Item_t (Big_map_t (map_key, map_value, map_name), rest, annot)) + (* control *) + | (Seq (loc, []), stack) -> + typed ctxt loc Nop stack + | (Seq (loc, [single]), stack) -> ( + parse_instr ?type_logger tc_context ctxt ~legacy single stack + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ({aft; _} as instr) -> + let nop = {bef = aft; loc; aft; instr = Nop} in + typed ctxt loc (Seq (instr, nop)) aft + | Failed {descr; _} -> + let descr aft = + let nop = {bef = aft; loc; aft; instr = Nop} in + let descr = descr aft in + {descr with instr = Seq (descr, nop)} + in + return ctxt (Failed {descr}) ) + | (Seq (loc, hd :: tl), stack) -> ( + parse_instr ?type_logger tc_context ctxt ~legacy hd stack + >>=? fun (judgement, ctxt) -> + match judgement with + | Failed _ -> + fail (Fail_not_in_tail_position (Micheline.location hd)) + | Typed ({aft = middle; _} as ihd) -> ( + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + (Seq (-1, tl)) + middle + >>=? fun (judgement, ctxt) -> match judgement with - | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> - let invalid_map_body () = - serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) -> - Invalid_map_body (loc, aft) in - trace_eval invalid_map_body - (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> - typed ctxt loc (List_map ibody) - (Item_t (List_t (ret, list_ty_name, has_big_map ret), rest, ret_annot))) - | Typed { aft ; _ } -> - serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> - fail (Invalid_map_body (loc, aft)) - | Failed _ -> fail (Invalid_map_block_fail loc) - end - | Prim (loc, I_ITER, [ body ], annot), - Item_t (List_t (elt, _, _), rest, list_annot) -> - check_kind [ Seq_kind ] body >>=? fun () -> - fail_unexpected_annot loc annot >>=? fun () -> - let elt_annot = gen_access_annot list_annot default_elt_annot in - parse_instr ?type_logger tc_context ctxt ~legacy - body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> - match judgement with - | Typed ({ aft ; _ } as ibody) -> - let invalid_iter_body () = - serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> - serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> - Invalid_iter_body (loc, rest, aft) in - trace_eval invalid_iter_body - (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest >>=? fun (rest, ctxt) -> - typed ctxt loc (List_iter ibody) rest) - | Failed { descr } -> - typed ctxt loc (List_iter (descr rest)) rest - end - (* sets *) - | Prim (loc, I_EMPTY_SET, [ t ], annot), - rest -> - Lwt.return @@ parse_comparable_ty ctxt t >>=? fun (Ex_comparable_ty t, ctxt) -> - parse_var_type_annot loc annot >>=? fun (annot, tname) -> - typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot)) - | Prim (loc, I_ITER, [ body ], annot), - Item_t (Set_t (comp_elt, _), rest, set_annot) -> - check_kind [ Seq_kind ] body >>=? fun () -> - fail_unexpected_annot loc annot >>=? fun () -> - let elt_annot = gen_access_annot set_annot default_elt_annot in - let elt = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt ~legacy - body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> - match judgement with - | Typed ({ aft ; _ } as ibody) -> - let invalid_iter_body () = - serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> - serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> - Invalid_iter_body (loc, rest, aft) in - trace_eval invalid_iter_body - (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest >>=? fun (rest, ctxt) -> - typed ctxt loc (Set_iter ibody) rest) - | Failed { descr } -> - typed ctxt loc (Set_iter (descr rest)) rest - end - | Prim (loc, I_MEM, [], annot), - Item_t (v, Item_t (Set_t (elt, _), rest, _), _) -> - let elt = ty_of_comparable_ty elt in - parse_var_type_annot loc annot >>=? fun (annot, tname) -> - check_item_ty ctxt elt v loc I_MEM 1 2 >>=? fun (Eq, _, ctxt) -> - typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot)) - | Prim (loc, I_UPDATE, [], annot), - Item_t (v, Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _), _) -> - begin match comparable_ty_of_ty v with - | None -> - unparse_ty ctxt v >>=? fun (v, _ctxt) -> - fail (Comparable_type_expected (loc, Micheline.strip_locations v)) - | Some v -> - parse_var_annot loc annot ~default:set_annot >>=? fun annot -> - check_item_comparable_ty elt v loc I_UPDATE 1 3 >>=? fun (Eq, elt) -> - typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) - end - | Prim (loc, I_SIZE, [], annot), - Item_t (Set_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Set_size (Item_t (Nat_t None, rest, annot)) - (* maps *) - | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], annot), - stack -> - Lwt.return @@ parse_comparable_ty ctxt tk >>=? fun (Ex_comparable_ty tk, ctxt) -> - Lwt.return @@ parse_any_ty ctxt ~legacy tv >>=? fun (Ex_ty tv, ctxt) -> - parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv, ty_name, has_big_map tv), stack, annot)) - | Prim (loc, I_MAP, [ body ], annot), - Item_t (Map_t (ck, elt, _, _), starting_rest, _map_annot) -> - let k = ty_of_comparable_ty ck in - check_kind [ Seq_kind ] body >>=? fun () -> - parse_var_type_annot loc annot >>=? fun (ret_annot, ty_name) -> - let k_name = field_to_var_annot default_key_annot in - let e_name = field_to_var_annot default_elt_annot in - parse_instr ?type_logger tc_context ctxt ~legacy - body (Item_t (Pair_t ((k, None, k_name), (elt, None, e_name), None, has_big_map elt), - starting_rest, None)) >>=? begin fun (judgement, ctxt) -> - match judgement with - | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> - let invalid_map_body () = - serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) -> - Invalid_map_body (loc, aft) in - trace_eval invalid_map_body - (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest >>=? fun (rest, ctxt) -> - typed ctxt loc (Map_map ibody) - (Item_t (Map_t (ck, ret, ty_name, has_big_map ret), rest, ret_annot))) - | Typed { aft ; _ } -> - serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> - fail (Invalid_map_body (loc, aft)) - | Failed _ -> fail (Invalid_map_block_fail loc) - end - | Prim (loc, I_ITER, [ body ], annot), - Item_t (Map_t (comp_elt, element_ty, _, _), rest, _map_annot) -> - check_kind [ Seq_kind ] body >>=? fun () -> - fail_unexpected_annot loc annot >>=? fun () -> - let k_name = field_to_var_annot default_key_annot in - let e_name = field_to_var_annot default_elt_annot in - let key = ty_of_comparable_ty comp_elt in - parse_instr ?type_logger tc_context ctxt ~legacy body - (Item_t (Pair_t ((key, None, k_name), (element_ty, None, e_name), None, has_big_map element_ty), - rest, None)) - >>=? begin fun (judgement, ctxt) -> match judgement with - | Typed ({ aft ; _ } as ibody) -> - let invalid_iter_body () = - serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> - serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> - Invalid_iter_body (loc, rest, aft) in - trace_eval invalid_iter_body - (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest >>=? fun (rest, ctxt) -> - typed ctxt loc (Map_iter ibody) rest) - | Failed { descr } -> - typed ctxt loc (Map_iter (descr rest)) rest - end - | Prim (loc, I_MEM, [], annot), - Item_t (vk, Item_t (Map_t (ck, _, _, _), rest, _), _) -> - let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_MEM 1 2 >>=? fun (Eq, _, ctxt) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot)) - | Prim (loc, I_GET, [], annot), - Item_t (vk, Item_t (Map_t (ck, elt, _, has_big_map), rest, _), _) -> - let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, _, ctxt) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Map_get (Item_t (Option_t (elt, None, has_big_map), rest, annot)) - | Prim (loc, I_UPDATE, [], annot), - Item_t (vk, Item_t (Option_t (vv, _, _), - Item_t (Map_t (ck, v, map_name, has_big_map), rest, map_annot), _), _) -> - let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_UPDATE 1 3 >>=? fun (Eq, _, ctxt) -> - check_item_ty ctxt vv v loc I_UPDATE 2 3 >>=? fun (Eq, v, ctxt) -> - parse_var_annot loc annot ~default:map_annot >>=? fun annot -> - typed ctxt loc Map_update (Item_t (Map_t (ck, v, map_name, has_big_map), rest, annot)) - | Prim (loc, I_SIZE, [], annot), - Item_t (Map_t (_, _, _, _), rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot)) - (* big_map *) - | Prim (loc, I_EMPTY_BIG_MAP, [ tk ; tv ], annot), - stack -> - Lwt.return @@ parse_comparable_ty ctxt tk >>=? fun (Ex_comparable_ty tk, ctxt) -> - Lwt.return @@ parse_packable_ty ctxt ~legacy tv >>=? fun (Ex_ty tv, ctxt) -> - parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - typed ctxt loc (Empty_big_map (tk, tv)) (Item_t (Big_map_t (tk, tv, ty_name), stack, annot)) - | Prim (loc, I_MEM, [], annot), - Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) -> - let k = ty_of_comparable_ty map_key in - check_item_ty ctxt set_key k loc I_MEM 1 2 >>=? fun (Eq, _, ctxt) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot)) - | Prim (loc, I_GET, [], annot), - Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) -> - let k = ty_of_comparable_ty ck in - check_item_ty ctxt vk k loc I_GET 1 2 >>=? fun (Eq, _, ctxt) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Big_map_get (Item_t (Option_t (elt, None, has_big_map elt), rest, annot)) - | Prim (loc, I_UPDATE, [], annot), - Item_t (set_key, - Item_t (Option_t (set_value, _, _), - Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot), _), _) -> - let k = ty_of_comparable_ty map_key in - check_item_ty ctxt set_key k loc I_UPDATE 1 3 >>=? fun (Eq, _, ctxt) -> - check_item_ty ctxt set_value map_value loc I_UPDATE 2 3 >>=? fun (Eq, map_value, ctxt) -> - parse_var_annot loc annot ~default:map_annot >>=? fun annot -> - typed ctxt loc Big_map_update (Item_t (Big_map_t (map_key, map_value, map_name), rest, annot)) - (* control *) - | Seq (loc, []), - stack -> - typed ctxt loc Nop stack - | Seq (loc, [ single ]), - stack -> - parse_instr ?type_logger tc_context ctxt ~legacy single - stack >>=? begin fun (judgement, ctxt) -> - match judgement with - | Typed ({ aft ; _ } as instr) -> - let nop = { bef = aft ; loc = loc ; aft ; instr = Nop } in - typed ctxt loc (Seq (instr, nop)) aft - | Failed { descr ; _ } -> - let descr aft = - let nop = { bef = aft ; loc = loc ; aft ; instr = Nop } in - let descr = descr aft in - { descr with instr = Seq (descr, nop) } in - return ctxt (Failed { descr }) - end - | Seq (loc, hd :: tl), - stack -> - parse_instr ?type_logger tc_context ctxt ~legacy hd - stack >>=? begin fun (judgement, ctxt) -> - match judgement with - | Failed _ -> - fail (Fail_not_in_tail_position (Micheline.location hd)) - | Typed ({ aft = middle ; _ } as ihd) -> - parse_instr ?type_logger tc_context ctxt ~legacy (Seq (-1, tl)) - middle >>=? fun (judgement, ctxt) -> - match judgement with - | Failed { descr } -> - let descr ret = - { loc ; instr = Seq (ihd, descr ret) ; - bef = stack ; aft = ret } in - return ctxt (Failed { descr }) - | Typed itl -> - typed ctxt loc (Seq (ihd, itl)) itl.aft - end - | Prim (loc, I_IF, [ bt ; bf ], annot), - (Item_t (Bool_t _, rest, _) as bef) -> - check_kind [ Seq_kind ] bt >>=? fun () -> - check_kind [ Seq_kind ] bf >>=? fun () -> - fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~legacy bt rest >>=? fun (btr, ctxt) -> - parse_instr ?type_logger tc_context ctxt ~legacy bf rest >>=? fun (bfr, ctxt) -> - let branch ibt ibf = - { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches ~legacy ctxt loc btr bfr { branch } >>=? fun (judgement, ctxt) -> - return ctxt judgement - | Prim (loc, I_LOOP, [ body ], annot), - (Item_t (Bool_t _, rest, _stack_annot) as stack) -> - check_kind [ Seq_kind ] body >>=? fun () -> - fail_unexpected_annot loc annot >>=? fun () -> - parse_instr ?type_logger tc_context ctxt ~legacy body - rest >>=? begin fun (judgement, ctxt) -> - match judgement with - | Typed ibody -> - let unmatched_branches () = - serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> - serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) -> - Unmatched_branches (loc, aft, stack) in - trace_eval unmatched_branches - (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> - typed ctxt loc (Loop ibody) rest) - | Failed { descr } -> - let ibody = descr stack in - typed ctxt loc (Loop ibody) rest - end - | Prim (loc, I_LOOP_LEFT, [ body ], annot), - (Item_t (Union_t ((tl, l_field), (tr, _), _, _), rest, union_annot) as stack) -> - check_kind [ Seq_kind ] body >>=? fun () -> - parse_var_annot loc annot >>=? fun annot -> - let l_annot = gen_access_annot union_annot l_field ~default:default_left_annot in - parse_instr ?type_logger tc_context ctxt ~legacy body - (Item_t (tl, rest, l_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with - | Typed ibody -> - let unmatched_branches () = - serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> - serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) -> - Unmatched_branches (loc, aft, stack) in - trace_eval unmatched_branches - (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack >>=? fun (_stack, ctxt) -> - typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot))) - | Failed { descr } -> - let ibody = descr stack in - typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) - end - | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], annot), - stack -> - Lwt.return @@ parse_any_ty ctxt ~legacy arg - >>=? fun (Ex_ty arg, ctxt) -> - Lwt.return @@ parse_any_ty ctxt ~legacy ret - >>=? fun (Ex_ty ret, ctxt) -> - check_kind [ Seq_kind ] code >>=? fun () -> - parse_var_annot loc annot >>=? fun annot -> - parse_returning Lambda ?type_logger ctxt ~legacy - (arg, default_arg_annot) ret code >>=? fun (lambda, ctxt) -> - typed ctxt loc (Lambda lambda) (Item_t (Lambda_t (arg, ret, None), stack, annot)) - | Prim (loc, I_EXEC, [], annot), - Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) -> - check_item_ty ctxt arg param loc I_EXEC 1 2 >>=? fun (Eq, _, ctxt) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Exec (Item_t (ret, rest, annot)) - | Prim (loc, I_APPLY, [], annot), - Item_t (capture, Item_t (Lambda_t (Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot, _), ret, _), rest, _), _) -> - Lwt.return @@ check_packable ~legacy:false loc capture_ty >>=? fun () -> - check_item_ty ctxt capture capture_ty loc I_APPLY 1 2 >>=? fun (Eq, capture_ty, ctxt) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc (Apply capture_ty) (Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot)) - | Prim (loc, I_DIP, [ code ], annot), - Item_t (v, rest, stack_annot) -> - fail_unexpected_annot loc annot >>=? fun () -> - check_kind [ Seq_kind ] code >>=? fun () -> - parse_instr ?type_logger (add_dip v stack_annot tc_context) ctxt ~legacy code - rest >>=? begin fun (judgement, ctxt) -> match judgement with - | Typed descr -> - typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot)) - | Failed _ -> - fail (Fail_not_in_tail_position loc) - end - | Prim (loc, I_DIP, [n; code], result_annot), stack - when (match parse_int32 n with Ok _ -> true | Error _ -> false) -> - let rec make_proof_argument - : type tstk . int - (* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) - -> tc_context - -> (tstk stack_ty) - -> (tstk dipn_proof_argument) tzresult Lwt.t = - fun n inner_tc_context stk -> - match (Compare.Int.(n = 0)), stk with - true, rest -> - (parse_instr ?type_logger inner_tc_context ctxt ~legacy code - rest) >>=? begin fun (judgement, ctxt) -> match judgement with - | Typed descr -> - outer_return @@ (Dipn_proof_argument (Rest, (ctxt, descr), descr.aft)) - | Failed _ -> - fail (Fail_not_in_tail_position loc) - end - | false, Item_t (v, rest, annot) -> - make_proof_argument (n - 1) (add_dip v annot tc_context) rest - >>=? fun (Dipn_proof_argument (n', descr, aft')) -> - outer_return @@ (Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot))) - | _, _ -> - serialize_stack_for_error ctxt stack >>=? fun (whole_stack, _ctxt) -> - fail (Bad_stack (loc, I_DIP, 1, whole_stack)) - in - Lwt.return (parse_int32 n) >>=? fun n -> - fail_unexpected_annot loc result_annot >>=? fun () -> - make_proof_argument n tc_context stack >>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) -> - (* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *) - typed new_ctxt loc (Dipn (n, n', descr)) aft - | Prim (loc, I_DIP, ([] | _ :: _ :: _ :: _ as l), _), _ -> - (* Technically, the arities 1 and 2 are allowed but the error only mentions 2. + | Failed {descr} -> + let descr ret = + {loc; instr = Seq (ihd, descr ret); bef = stack; aft = ret} + in + return ctxt (Failed {descr}) + | Typed itl -> + typed ctxt loc (Seq (ihd, itl)) itl.aft ) ) + | (Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t _, rest, _) as bef)) -> + check_kind [Seq_kind] bt + >>=? fun () -> + check_kind [Seq_kind] bf + >>=? fun () -> + fail_unexpected_annot loc annot + >>=? fun () -> + parse_instr ?type_logger tc_context ctxt ~legacy bt rest + >>=? fun (btr, ctxt) -> + parse_instr ?type_logger tc_context ctxt ~legacy bf rest + >>=? fun (bfr, ctxt) -> + let branch ibt ibf = {loc; instr = If (ibt, ibf); bef; aft = ibt.aft} in + merge_branches ~legacy ctxt loc btr bfr {branch} + >>=? fun (judgement, ctxt) -> return ctxt judgement + | ( Prim (loc, I_LOOP, [body], annot), + (Item_t (Bool_t _, rest, _stack_annot) as stack) ) -> ( + check_kind [Seq_kind] body + >>=? fun () -> + fail_unexpected_annot loc annot + >>=? fun () -> + parse_instr ?type_logger tc_context ctxt ~legacy body rest + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ibody -> + let unmatched_branches () = + serialize_stack_for_error ctxt ibody.aft + >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt stack + >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack) + in + trace_eval + unmatched_branches + ( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack + >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop ibody) rest ) + | Failed {descr} -> + let ibody = descr stack in + typed ctxt loc (Loop ibody) rest ) + | ( Prim (loc, I_LOOP_LEFT, [body], annot), + ( Item_t (Union_t ((tl, l_field), (tr, _), _, _), rest, union_annot) as + stack ) ) -> ( + check_kind [Seq_kind] body + >>=? fun () -> + parse_var_annot loc annot + >>=? fun annot -> + let l_annot = + gen_access_annot union_annot l_field ~default:default_left_annot + in + parse_instr + ?type_logger + tc_context + ctxt + ~legacy + body + (Item_t (tl, rest, l_annot)) + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed ibody -> + let unmatched_branches () = + serialize_stack_for_error ctxt ibody.aft + >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt stack + >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack) + in + trace_eval + unmatched_branches + ( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack + >>=? fun (_stack, ctxt) -> + typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) ) + | Failed {descr} -> + let ibody = descr stack in + typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) ) + | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) -> + Lwt.return @@ parse_any_ty ctxt ~legacy arg + >>=? fun (Ex_ty arg, ctxt) -> + Lwt.return @@ parse_any_ty ctxt ~legacy ret + >>=? fun (Ex_ty ret, ctxt) -> + check_kind [Seq_kind] code + >>=? fun () -> + parse_var_annot loc annot + >>=? fun annot -> + parse_returning + Lambda + ?type_logger + ctxt + ~legacy + (arg, default_arg_annot) + ret + code + >>=? fun (lambda, ctxt) -> + typed + ctxt + loc + (Lambda lambda) + (Item_t (Lambda_t (arg, ret, None), stack, annot)) + | ( Prim (loc, I_EXEC, [], annot), + Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) ) -> + check_item_ty ctxt arg param loc I_EXEC 1 2 + >>=? fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>=? fun annot -> typed ctxt loc Exec (Item_t (ret, rest, annot)) + | ( Prim (loc, I_APPLY, [], annot), + Item_t + ( capture, + Item_t + ( Lambda_t + ( Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot, _), + ret, + _ ), + rest, + _ ), + _ ) ) -> + Lwt.return @@ check_packable ~legacy:false loc capture_ty + >>=? fun () -> + check_item_ty ctxt capture capture_ty loc I_APPLY 1 2 + >>=? fun (Eq, capture_ty, ctxt) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + (Apply capture_ty) + (Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot)) + | (Prim (loc, I_DIP, [code], annot), Item_t (v, rest, stack_annot)) -> ( + fail_unexpected_annot loc annot + >>=? fun () -> + check_kind [Seq_kind] code + >>=? fun () -> + parse_instr + ?type_logger + (add_dip v stack_annot tc_context) + ctxt + ~legacy + code + rest + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed descr -> + typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot)) + | Failed _ -> + fail (Fail_not_in_tail_position loc) ) + | (Prim (loc, I_DIP, [n; code], result_annot), stack) + when match parse_int32 n with Ok _ -> true | Error _ -> false -> + let rec make_proof_argument : + type tstk. + int + (* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) -> + tc_context -> + tstk stack_ty -> + tstk dipn_proof_argument tzresult Lwt.t = + fun n inner_tc_context stk -> + match (Compare.Int.(n = 0), stk) with + | (true, rest) -> ( + parse_instr ?type_logger inner_tc_context ctxt ~legacy code rest + >>=? fun (judgement, ctxt) -> + match judgement with + | Typed descr -> + outer_return + @@ Dipn_proof_argument (Rest, (ctxt, descr), descr.aft) + | Failed _ -> + fail (Fail_not_in_tail_position loc) ) + | (false, Item_t (v, rest, annot)) -> + make_proof_argument (n - 1) (add_dip v annot tc_context) rest + >>=? fun (Dipn_proof_argument (n', descr, aft')) -> + outer_return + @@ Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot)) + | (_, _) -> + serialize_stack_for_error ctxt stack + >>=? fun (whole_stack, _ctxt) -> + fail (Bad_stack (loc, I_DIP, 1, whole_stack)) + in + Lwt.return (parse_int32 n) + >>=? fun n -> + fail_unexpected_annot loc result_annot + >>=? fun () -> + make_proof_argument n tc_context stack + >>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) -> + (* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *) + typed new_ctxt loc (Dipn (n, n', descr)) aft + | (Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _) -> + (* Technically, the arities 1 and 2 are allowed but the error only mentions 2. However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *) - fail (Invalid_arity (loc, I_DIP, 2, List.length l)) - | Prim (loc, I_FAILWITH, [], annot), - Item_t (v, _rest, _) -> - fail_unexpected_annot loc annot >>=? fun () -> - let descr aft = { loc ; instr = Failwith v ; bef = stack_ty ; aft } in - log_stack ctxt loc stack_ty Empty_t >>=? fun () -> - return ctxt (Failed { descr }) - (* timestamp operations *) - | Prim (loc, I_ADD, [], annot), - Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Add_timestamp_to_seconds - (Item_t (Timestamp_t tname, rest, annot)) - | Prim (loc, I_ADD, [], annot), - Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Add_seconds_to_timestamp - (Item_t (Timestamp_t tname, rest, annot)) - | Prim (loc, I_SUB, [], annot), - Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Sub_timestamp_seconds - (Item_t (Timestamp_t tname, rest, annot)) - | Prim (loc, I_SUB, [], annot), - Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Diff_timestamps - (Item_t (Int_t tname, rest, annot)) - (* string operations *) - | Prim (loc, I_CONCAT, [], annot), - Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Concat_string_pair - (Item_t (String_t tname, rest, annot)) - | Prim (loc, I_CONCAT, [], annot), - Item_t (List_t (String_t tname, _, _), rest, list_annot) -> - parse_var_annot ~default:list_annot loc annot >>=? fun annot -> - typed ctxt loc Concat_string - (Item_t (String_t tname, rest, annot)) - | Prim (loc, I_SLICE, [], annot), - Item_t (Nat_t _, Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _), _) -> - parse_var_annot - ~default:(gen_access_annot string_annot default_slice_annot) - loc annot >>=? fun annot -> - typed ctxt loc Slice_string - (Item_t (Option_t (String_t tname, None, false), rest, annot)) - | Prim (loc, I_SIZE, [], annot), - Item_t (String_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc String_size (Item_t (Nat_t None, rest, annot)) - (* bytes operations *) - | Prim (loc, I_CONCAT, [], annot), - Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Concat_bytes_pair - (Item_t (Bytes_t tname, rest, annot)) - | Prim (loc, I_CONCAT, [], annot), - Item_t (List_t (Bytes_t tname, _, _), rest, list_annot) -> - parse_var_annot ~default:list_annot loc annot >>=? fun annot -> - typed ctxt loc Concat_bytes - (Item_t (Bytes_t tname, rest, annot)) - | Prim (loc, I_SLICE, [], annot), - Item_t (Nat_t _, Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _), _) -> - parse_var_annot - ~default:(gen_access_annot bytes_annot default_slice_annot) - loc annot >>=? fun annot -> - typed ctxt loc Slice_bytes - (Item_t (Option_t (Bytes_t tname, None, false), rest, annot)) - | Prim (loc, I_SIZE, [], annot), - Item_t (Bytes_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Bytes_size (Item_t (Nat_t None, rest, annot)) - (* currency operations *) - | Prim (loc, I_ADD, [], annot), - Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Add_tez - (Item_t (Mutez_t tname, rest, annot)) - | Prim (loc, I_SUB, [], annot), - Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Sub_tez - (Item_t (Mutez_t tname, rest, annot)) - | Prim (loc, I_MUL, [], annot), - Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) -> (* no type name check *) - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Mul_teznat - (Item_t (Mutez_t tname, rest, annot)) - | Prim (loc, I_MUL, [], annot), - Item_t (Nat_t _, Item_t (Mutez_t tname, rest, _), _) -> (* no type name check *) - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Mul_nattez - (Item_t (Mutez_t tname, rest, annot)) - (* boolean operations *) - | Prim (loc, I_OR, [], annot), - Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Or - (Item_t (Bool_t tname, rest, annot)) - | Prim (loc, I_AND, [], annot), - Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc And - (Item_t (Bool_t tname, rest, annot)) - | Prim (loc, I_XOR, [], annot), - Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Xor - (Item_t (Bool_t tname, rest, annot)) - | Prim (loc, I_NOT, [], annot), - Item_t (Bool_t tname, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Not - (Item_t (Bool_t tname, rest, annot)) - (* integer operations *) - | Prim (loc, I_ABS, [], annot), - Item_t (Int_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Abs_int - (Item_t (Nat_t None, rest, annot)) - | Prim (loc, I_ISNAT, [], annot), - Item_t (Int_t _, rest, int_annot) -> - parse_var_annot loc annot ~default:int_annot >>=? fun annot -> - typed ctxt loc Is_nat - (Item_t (Option_t (Nat_t None, None, false), rest, annot)) - | Prim (loc, I_INT, [], annot), - Item_t (Nat_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Int_nat - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_NEG, [], annot), - Item_t (Int_t tname, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Neg_int - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_NEG, [], annot), - Item_t (Nat_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Neg_nat - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_ADD, [], annot), - Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Add_intint - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_ADD, [], annot), - Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Add_intnat - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_ADD, [], annot), - Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Add_natint - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_ADD, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Add_natnat - (Item_t (Nat_t tname, rest, annot)) - | Prim (loc, I_SUB, [], annot), - Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Sub_int - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_SUB, [], annot), - Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Sub_int - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_SUB, [], annot), - Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Sub_int - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_SUB, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun _tname -> - typed ctxt loc Sub_int - (Item_t (Int_t None, rest, annot)) - | Prim (loc, I_MUL, [], annot), - Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Mul_intint - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_MUL, [], annot), - Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Mul_intnat - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_MUL, [], annot), - Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Mul_natint - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_MUL, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Mul_natnat - (Item_t (Nat_t tname, rest, annot)) - | Prim (loc, I_EDIV, [], annot), - Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Ediv_teznat - (Item_t (Option_t - (Pair_t ((Mutez_t tname, None, None), - (Mutez_t tname, None, None), None, false), - None, false), rest, annot)) - | Prim (loc, I_EDIV, [], annot), - Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Ediv_tez - (Item_t (Option_t (Pair_t ((Nat_t None, None, None), - (Mutez_t tname, None, None), None, false), - None, false), rest, annot)) - | Prim (loc, I_EDIV, [], annot), - Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Ediv_intint - (Item_t (Option_t - (Pair_t ((Int_t tname, None, None), - (Nat_t None, None, None), None, false), - None, false), rest, annot)) - | Prim (loc, I_EDIV, [], annot), - Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Ediv_intnat - (Item_t (Option_t - (Pair_t ((Int_t tname, None, None), - (Nat_t None, None, None), None, false), - None, false), rest, annot)) - | Prim (loc, I_EDIV, [], annot), - Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Ediv_natint - (Item_t (Option_t (Pair_t ((Int_t None, None, None), - (Nat_t tname, None, None), None, false), - None, false), rest, annot)) - | Prim (loc, I_EDIV, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Ediv_natnat - (Item_t (Option_t (Pair_t ((Nat_t tname, None, None), - (Nat_t tname, None, None), None, false), - None, false), rest, annot)) - | Prim (loc, I_LSL, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Lsl_nat - (Item_t (Nat_t tname, rest, annot)) - | Prim (loc, I_LSR, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Lsr_nat - (Item_t (Nat_t tname, rest, annot)) - | Prim (loc, I_OR, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Or_nat - (Item_t (Nat_t tname, rest, annot)) - | Prim (loc, I_AND, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc And_nat - (Item_t (Nat_t tname, rest, annot)) - | Prim (loc, I_AND, [], annot), - Item_t (Int_t _, Item_t (Nat_t tname, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc And_int_nat - (Item_t (Nat_t tname, rest, annot)) - | Prim (loc, I_XOR, [], annot), - Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot ~legacy tn1 tn2 >>=? fun tname -> - typed ctxt loc Xor_nat - (Item_t (Nat_t tname, rest, annot)) - | Prim (loc, I_NOT, [], annot), - Item_t (Int_t tname, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Not_int - (Item_t (Int_t tname, rest, annot)) - | Prim (loc, I_NOT, [], annot), - Item_t (Nat_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Not_nat - (Item_t (Int_t None, rest, annot)) - (* comparison *) - | Prim (loc, I_COMPARE, [], annot), - Item_t (t1, Item_t (t2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 >>=? fun (Eq, t, ctxt) -> - begin match comparable_ty_of_ty t with - | None -> - Lwt.return (serialize_ty_for_error ctxt t) >>=? fun (t, _ctxt) -> - fail (Comparable_type_expected (loc, t)) - | Some key -> - typed ctxt loc (Compare key) - (Item_t (Int_t None, rest, annot)) - end - (* comparators *) - | Prim (loc, I_EQ, [], annot), - Item_t (Int_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Eq - (Item_t (Bool_t None, rest, annot)) - | Prim (loc, I_NEQ, [], annot), - Item_t (Int_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Neq - (Item_t (Bool_t None, rest, annot)) - | Prim (loc, I_LT, [], annot), - Item_t (Int_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Lt - (Item_t (Bool_t None, rest, annot)) - | Prim (loc, I_GT, [], annot), - Item_t (Int_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Gt - (Item_t (Bool_t None, rest, annot)) - | Prim (loc, I_LE, [], annot), - Item_t (Int_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Le - (Item_t (Bool_t None, rest, annot)) - | Prim (loc, I_GE, [], annot), - Item_t (Int_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Ge - (Item_t (Bool_t None, rest, annot)) - (* annotations *) - | Prim (loc, I_CAST, [ cast_t ], annot), - Item_t (t, stack, item_annot) -> - parse_var_annot loc annot ~default:item_annot >>=? fun annot -> - (Lwt.return @@ parse_any_ty ctxt ~legacy cast_t) - >>=? fun (Ex_ty cast_t, ctxt) -> - Lwt.return @@ ty_eq ctxt cast_t t >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ~legacy ctxt loc cast_t t >>=? fun (_, ctxt) -> - typed ctxt loc Nop (Item_t (cast_t, stack, annot)) - | Prim (loc, I_RENAME, [], annot), - Item_t (t, stack, _) -> - parse_var_annot loc annot >>=? fun annot -> (* can erase annot *) - typed ctxt loc Nop (Item_t (t, stack, annot)) - (* packing *) - | Prim (loc, I_PACK, [], annot), - Item_t (t, rest, unpacked_annot) -> - Lwt.return (check_packable ~legacy:true (* allow to pack contracts for hash/signature checks *) loc t) >>=? fun () -> - parse_var_annot loc annot ~default:(gen_access_annot unpacked_annot default_pack_annot) - >>=? fun annot -> - typed ctxt loc (Pack t) - (Item_t (Bytes_t None, rest, annot)) - | Prim (loc, I_UNPACK, [ ty ], annot), - Item_t (Bytes_t _, rest, packed_annot) -> - Lwt.return @@ parse_packable_ty ctxt ~legacy ty >>=? fun (Ex_ty t, ctxt) -> - parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> - let annot = default_annot annot ~default:(gen_access_annot packed_annot default_unpack_annot) in - typed ctxt loc (Unpack t) (Item_t (Option_t (t, ty_name, false (* cannot unpack big_maps *)), rest, annot)) - (* protocol *) - | Prim (loc, I_ADDRESS, [], annot), - Item_t (Contract_t _, rest, contract_annot) -> - parse_var_annot loc annot ~default:(gen_access_annot contract_annot default_addr_annot) - >>=? fun annot -> - typed ctxt loc Address - (Item_t (Address_t None, rest, annot)) - | Prim (loc, I_CONTRACT, [ ty ], annot), - Item_t (Address_t _, rest, addr_annot) -> - Lwt.return @@ parse_parameter_ty ctxt ~legacy ty >>=? fun (Ex_ty t, ctxt) -> - parse_entrypoint_annot loc annot ~default:(gen_access_annot addr_annot default_contract_annot) - >>=? fun (annot, entrypoint) -> - Lwt.return @@ begin match entrypoint with - | None -> Ok "default" - | Some (`Field_annot "default") -> error (Unexpected_annotation loc) - | Some (`Field_annot entrypoint) -> - if Compare.Int.(String.length entrypoint > 31) then - error (Entrypoint_name_too_long entrypoint) - else Ok entrypoint - end >>=? fun entrypoint -> - typed ctxt loc (Contract (t, entrypoint)) - (Item_t (Option_t (Contract_t (t, None), None, false), rest, annot)) - | Prim (loc, I_TRANSFER_TOKENS, [], annot), - Item_t (p, Item_t - (Mutez_t _, Item_t - (Contract_t (cp, _), rest, _), _), _) -> - check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4 >>=? fun (Eq, _, ctxt) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot)) - | Prim (loc, I_SET_DELEGATE, [], annot), - Item_t (Option_t (Key_hash_t _, _, _), rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot)) - | Prim (loc, I_CREATE_ACCOUNT, [], annot), + fail (Invalid_arity (loc, I_DIP, 2, List.length l)) + | (Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest, _)) -> + fail_unexpected_annot loc annot + >>=? fun () -> + let descr aft = {loc; instr = Failwith v; bef = stack_ty; aft} in + log_stack ctxt loc stack_ty Empty_t + >>=? fun () -> return ctxt (Failed {descr}) + (* timestamp operations *) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Add_timestamp_to_seconds + (Item_t (Timestamp_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Add_seconds_to_timestamp + (Item_t (Timestamp_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Sub_timestamp_seconds + (Item_t (Timestamp_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Diff_timestamps (Item_t (Int_t tname, rest, annot)) + (* string operations *) + | ( Prim (loc, I_CONCAT, [], annot), + Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Concat_string_pair (Item_t (String_t tname, rest, annot)) + | ( Prim (loc, I_CONCAT, [], annot), + Item_t (List_t (String_t tname, _, _), rest, list_annot) ) -> + parse_var_annot ~default:list_annot loc annot + >>=? fun annot -> + typed ctxt loc Concat_string (Item_t (String_t tname, rest, annot)) + | ( Prim (loc, I_SLICE, [], annot), Item_t - (Key_hash_t _, Item_t - (Option_t (Key_hash_t _, _, _), Item_t - (Bool_t _, Item_t - (Mutez_t _, rest, _), _), _), _) -> - if legacy - then begin - (* For existing contracts, this instruction is still allowed *) - parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> - typed ctxt loc Create_account - (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) - end - else - (* For new contracts this instruction is not allowed anymore *) - fail (Deprecated_instruction I_CREATE_ACCOUNT) - | Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), - Item_t (Key_hash_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Implicit_account - (Item_t (Contract_t (Unit_t None, None), rest, annot)) - | Prim (loc, I_CREATE_CONTRACT, [ (Seq _ as code)], annot), + ( Nat_t _, + Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _), + _ ) ) -> + parse_var_annot + ~default:(gen_access_annot string_annot default_slice_annot) + loc + annot + >>=? fun annot -> + typed + ctxt + loc + Slice_string + (Item_t (Option_t (String_t tname, None, false), rest, annot)) + | (Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc String_size (Item_t (Nat_t None, rest, annot)) + (* bytes operations *) + | ( Prim (loc, I_CONCAT, [], annot), + Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Concat_bytes_pair (Item_t (Bytes_t tname, rest, annot)) + | ( Prim (loc, I_CONCAT, [], annot), + Item_t (List_t (Bytes_t tname, _, _), rest, list_annot) ) -> + parse_var_annot ~default:list_annot loc annot + >>=? fun annot -> + typed ctxt loc Concat_bytes (Item_t (Bytes_t tname, rest, annot)) + | ( Prim (loc, I_SLICE, [], annot), Item_t - (Key_hash_t _, Item_t - (Option_t (Key_hash_t _, _, _), Item_t - (Bool_t _, Item_t - (Bool_t _, Item_t - (Mutez_t _, Item_t - (ginit, rest, _), _), _), _), _), _) -> - if legacy then begin - (* For existing contracts, this instruction is still allowed *) - parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> - let cannonical_code = fst @@ Micheline.extract_locations code in - Lwt.return @@ parse_toplevel ~legacy cannonical_code >>=? fun (arg_type, storage_type, code_field, root_name) -> - trace - (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) - (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type) - >>=? fun (Ex_ty arg_type, ctxt) -> - begin - if legacy then Error_monad.return () else - Lwt.return (well_formed_entrypoints ~root_name arg_type) - end >>=? fun () -> - trace - (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) - (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type) - >>=? fun (Ex_ty storage_type, ctxt) -> - let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) - ~default:default_param_annot in - let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) - ~default:default_storage_annot in - let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None, - has_big_map arg_type || has_big_map storage_type) in - let ret_type_full = - Pair_t ((List_t (Operation_t None, None, false), None, None), - (storage_type, None, None), None, - has_big_map storage_type) in - trace - (Ill_typed_contract (cannonical_code, [])) - (parse_returning (Toplevel { storage_type ; param_type = arg_type ; root_name ; - legacy_create_contract_literal = true }) - ctxt ~legacy ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? - fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; - aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> - Lwt.return @@ ty_eq ctxt arg arg_type_full >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full >>=? fun (_, ctxt) -> - Lwt.return @@ ty_eq ctxt ret ret_type_full >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full >>=? fun (_, ctxt) -> - Lwt.return @@ ty_eq ctxt storage_type ginit >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit >>=? fun (_, ctxt) -> - typed ctxt loc (Create_contract (storage_type, arg_type, lambda, root_name)) - (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) - end - else - (* For new contracts this instruction is not allowed anymore *) - fail (Deprecated_instruction I_CREATE_CONTRACT) - | Prim (loc, I_CREATE_CONTRACT, [ (Seq _ as code)], annot), - (* Removed the instruction's arguments manager, spendable and delegatable *) + ( Nat_t _, + Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _), + _ ) ) -> + parse_var_annot + ~default:(gen_access_annot bytes_annot default_slice_annot) + loc + annot + >>=? fun annot -> + typed + ctxt + loc + Slice_bytes + (Item_t (Option_t (Bytes_t tname, None, false), rest, annot)) + | (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Bytes_size (Item_t (Nat_t None, rest, annot)) + (* currency operations *) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Add_tez (Item_t (Mutez_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Sub_tez (Item_t (Mutez_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) -> + (* no type name check *) + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Mul_teznat (Item_t (Mutez_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Nat_t _, Item_t (Mutez_t tname, rest, _), _) ) -> + (* no type name check *) + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Mul_nattez (Item_t (Mutez_t tname, rest, annot)) + (* boolean operations *) + | ( Prim (loc, I_OR, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> typed ctxt loc Or (Item_t (Bool_t tname, rest, annot)) + | ( Prim (loc, I_AND, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> typed ctxt loc And (Item_t (Bool_t tname, rest, annot)) + | ( Prim (loc, I_XOR, [], annot), + Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> typed ctxt loc Xor (Item_t (Bool_t tname, rest, annot)) + | (Prim (loc, I_NOT, [], annot), Item_t (Bool_t tname, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> typed ctxt loc Not (Item_t (Bool_t tname, rest, annot)) + (* integer operations *) + | (Prim (loc, I_ABS, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Abs_int (Item_t (Nat_t None, rest, annot)) + | (Prim (loc, I_ISNAT, [], annot), Item_t (Int_t _, rest, int_annot)) -> + parse_var_annot loc annot ~default:int_annot + >>=? fun annot -> + typed + ctxt + loc + Is_nat + (Item_t (Option_t (Nat_t None, None, false), rest, annot)) + | (Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Int_nat (Item_t (Int_t None, rest, annot)) + | (Prim (loc, I_NEG, [], annot), Item_t (Int_t tname, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Neg_int (Item_t (Int_t tname, rest, annot)) + | (Prim (loc, I_NEG, [], annot), Item_t (Nat_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Neg_nat (Item_t (Int_t None, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Add_intint (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Add_intnat (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Add_natint (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_ADD, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Add_natnat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_SUB, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun _tname -> + typed ctxt loc Sub_int (Item_t (Int_t None, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Mul_intint (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Mul_intnat (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Mul_natint (Item_t (Int_t tname, rest, annot)) + | ( Prim (loc, I_MUL, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Mul_natnat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Ediv_teznat + (Item_t + ( Option_t + ( Pair_t + ( (Mutez_t tname, None, None), + (Mutez_t tname, None, None), + None, + false ), + None, + false ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed + ctxt + loc + Ediv_tez + (Item_t + ( Option_t + ( Pair_t + ( (Nat_t None, None, None), + (Mutez_t tname, None, None), + None, + false ), + None, + false ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed + ctxt + loc + Ediv_intint + (Item_t + ( Option_t + ( Pair_t + ( (Int_t tname, None, None), + (Nat_t None, None, None), + None, + false ), + None, + false ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Ediv_intnat + (Item_t + ( Option_t + ( Pair_t + ( (Int_t tname, None, None), + (Nat_t None, None, None), + None, + false ), + None, + false ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Ediv_natint + (Item_t + ( Option_t + ( Pair_t + ( (Int_t None, None, None), + (Nat_t tname, None, None), + None, + false ), + None, + false ), + rest, + annot )) + | ( Prim (loc, I_EDIV, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed + ctxt + loc + Ediv_natnat + (Item_t + ( Option_t + ( Pair_t + ( (Nat_t tname, None, None), + (Nat_t tname, None, None), + None, + false ), + None, + false ), + rest, + annot )) + | ( Prim (loc, I_LSL, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Lsl_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_LSR, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Lsr_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_OR, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Or_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_AND, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc And_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_AND, [], annot), + Item_t (Int_t _, Item_t (Nat_t tname, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc And_int_nat (Item_t (Nat_t tname, rest, annot)) + | ( Prim (loc, I_XOR, [], annot), + Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + Lwt.return @@ merge_type_annot ~legacy tn1 tn2 + >>=? fun tname -> + typed ctxt loc Xor_nat (Item_t (Nat_t tname, rest, annot)) + | (Prim (loc, I_NOT, [], annot), Item_t (Int_t tname, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Not_int (Item_t (Int_t tname, rest, annot)) + | (Prim (loc, I_NOT, [], annot), Item_t (Nat_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Not_nat (Item_t (Int_t None, rest, annot)) + (* comparison *) + | (Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest, _), _)) + -> ( + parse_var_annot loc annot + >>=? fun annot -> + check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 + >>=? fun (Eq, t, ctxt) -> + match comparable_ty_of_ty t with + | None -> + Lwt.return (serialize_ty_for_error ctxt t) + >>=? fun (t, _ctxt) -> fail (Comparable_type_expected (loc, t)) + | Some key -> + typed ctxt loc (Compare key) (Item_t (Int_t None, rest, annot)) ) + (* comparators *) + | (Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> typed ctxt loc Eq (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_NEQ, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> typed ctxt loc Neq (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_LT, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> typed ctxt loc Lt (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_GT, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> typed ctxt loc Gt (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_LE, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> typed ctxt loc Le (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_GE, [], annot), Item_t (Int_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> typed ctxt loc Ge (Item_t (Bool_t None, rest, annot)) + (* annotations *) + | (Prim (loc, I_CAST, [cast_t], annot), Item_t (t, stack, item_annot)) -> + parse_var_annot loc annot ~default:item_annot + >>=? fun annot -> + Lwt.return @@ parse_any_ty ctxt ~legacy cast_t + >>=? fun (Ex_ty cast_t, ctxt) -> + Lwt.return @@ ty_eq ctxt cast_t t + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc cast_t t + >>=? fun (_, ctxt) -> typed ctxt loc Nop (Item_t (cast_t, stack, annot)) + | (Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + (* can erase annot *) + typed ctxt loc Nop (Item_t (t, stack, annot)) + (* packing *) + | (Prim (loc, I_PACK, [], annot), Item_t (t, rest, unpacked_annot)) -> + Lwt.return + (check_packable + ~legacy:true + (* allow to pack contracts for hash/signature checks *) loc + t) + >>=? fun () -> + parse_var_annot + loc + annot + ~default:(gen_access_annot unpacked_annot default_pack_annot) + >>=? fun annot -> + typed ctxt loc (Pack t) (Item_t (Bytes_t None, rest, annot)) + | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest, packed_annot)) + -> + Lwt.return @@ parse_packable_ty ctxt ~legacy ty + >>=? fun (Ex_ty t, ctxt) -> + parse_var_type_annot loc annot + >>=? fun (annot, ty_name) -> + let annot = + default_annot + annot + ~default:(gen_access_annot packed_annot default_unpack_annot) + in + typed + ctxt + loc + (Unpack t) + (Item_t + ( Option_t (t, ty_name, false (* cannot unpack big_maps *)), + rest, + annot )) + (* protocol *) + | ( Prim (loc, I_ADDRESS, [], annot), + Item_t (Contract_t _, rest, contract_annot) ) -> + parse_var_annot + loc + annot + ~default:(gen_access_annot contract_annot default_addr_annot) + >>=? fun annot -> + typed ctxt loc Address (Item_t (Address_t None, rest, annot)) + | ( Prim (loc, I_CONTRACT, [ty], annot), + Item_t (Address_t _, rest, addr_annot) ) -> + Lwt.return @@ parse_parameter_ty ctxt ~legacy ty + >>=? fun (Ex_ty t, ctxt) -> + parse_entrypoint_annot + loc + annot + ~default:(gen_access_annot addr_annot default_contract_annot) + >>=? fun (annot, entrypoint) -> + ( Lwt.return + @@ + match entrypoint with + | None -> + Ok "default" + | Some (`Field_annot "default") -> + error (Unexpected_annotation loc) + | Some (`Field_annot entrypoint) -> + if Compare.Int.(String.length entrypoint > 31) then + error (Entrypoint_name_too_long entrypoint) + else Ok entrypoint ) + >>=? fun entrypoint -> + typed + ctxt + loc + (Contract (t, entrypoint)) + (Item_t (Option_t (Contract_t (t, None), None, false), rest, annot)) + | ( Prim (loc, I_TRANSFER_TOKENS, [], annot), + Item_t (p, Item_t (Mutez_t _, Item_t (Contract_t (cp, _), rest, _), _), _) + ) -> + check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4 + >>=? fun (Eq, _, ctxt) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot)) + | ( Prim (loc, I_SET_DELEGATE, [], annot), + Item_t (Option_t (Key_hash_t _, _, _), rest, _) ) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot)) + | ( Prim (loc, I_CREATE_ACCOUNT, [], annot), Item_t - (Option_t (Key_hash_t _, _, _), Item_t - (Mutez_t _, Item_t - (ginit, rest, _), _), _) -> - parse_two_var_annot loc annot >>=? fun (op_annot, addr_annot) -> + ( Key_hash_t _, + Item_t + ( Option_t (Key_hash_t _, _, _), + Item_t (Bool_t _, Item_t (Mutez_t _, rest, _), _), + _ ), + _ ) ) -> + if legacy then + (* For existing contracts, this instruction is still allowed *) + parse_two_var_annot loc annot + >>=? fun (op_annot, addr_annot) -> + typed + ctxt + loc + Create_account + (Item_t + ( Operation_t None, + Item_t (Address_t None, rest, addr_annot), + op_annot )) + else + (* For new contracts this instruction is not allowed anymore *) + fail (Deprecated_instruction I_CREATE_ACCOUNT) + | (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _)) + -> + parse_var_annot loc annot + >>=? fun annot -> + typed + ctxt + loc + Implicit_account + (Item_t (Contract_t (Unit_t None, None), rest, annot)) + | ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot), + Item_t + ( Key_hash_t _, + Item_t + ( Option_t (Key_hash_t _, _, _), + Item_t + ( Bool_t _, + Item_t + ( Bool_t _, + Item_t (Mutez_t _, Item_t (ginit, rest, _), _), + _ ), + _ ), + _ ), + _ ) ) -> + if legacy then + (* For existing contracts, this instruction is still allowed *) + parse_two_var_annot loc annot + >>=? fun (op_annot, addr_annot) -> let cannonical_code = fst @@ Micheline.extract_locations code in - Lwt.return @@ parse_toplevel ~legacy cannonical_code >>=? fun (arg_type, storage_type, code_field, root_name) -> + Lwt.return @@ parse_toplevel ~legacy cannonical_code + >>=? fun (arg_type, storage_type, code_field, root_name) -> trace - (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) + (Ill_formed_type + (Some "parameter", cannonical_code, location arg_type)) (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type) >>=? fun (Ex_ty arg_type, ctxt) -> - begin - if legacy then Error_monad.return () else - Lwt.return (well_formed_entrypoints ~root_name arg_type) - end >>=? fun () -> + ( if legacy then Error_monad.return () + else Lwt.return (well_formed_entrypoints ~root_name arg_type) ) + >>=? fun () -> trace - (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) + (Ill_formed_type + (Some "storage", cannonical_code, location storage_type)) (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type) >>=? fun (Ex_ty storage_type, ctxt) -> - let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) - ~default:default_param_annot in - let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) - ~default:default_storage_annot in - let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None, - has_big_map arg_type || has_big_map storage_type) in + let arg_annot = + default_annot + (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot + in + let storage_annot = + default_annot + (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot + in + let arg_type_full = + Pair_t + ( (arg_type, None, arg_annot), + (storage_type, None, storage_annot), + None, + has_big_map arg_type || has_big_map storage_type ) + in let ret_type_full = - Pair_t ((List_t (Operation_t None, None, false), None, None), - (storage_type, None, None), None, has_big_map storage_type) in + Pair_t + ( (List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), + None, + has_big_map storage_type ) + in trace (Ill_typed_contract (cannonical_code, [])) - (parse_returning (Toplevel { storage_type ; param_type = arg_type ; root_name ; - legacy_create_contract_literal = false }) - ctxt ~legacy ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? - fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; - aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> - Lwt.return @@ ty_eq ctxt arg arg_type_full >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full >>=? fun (_, ctxt) -> - Lwt.return @@ ty_eq ctxt ret ret_type_full >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full >>=? fun (_, ctxt) -> - Lwt.return @@ ty_eq ctxt storage_type ginit >>=? fun (Eq, ctxt) -> - Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit >>=? fun (_, ctxt) -> - typed ctxt loc (Create_contract_2 (storage_type, arg_type, lambda, root_name)) - (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) - | Prim (loc, I_NOW, [], annot), - stack -> - parse_var_annot loc annot ~default:default_now_annot >>=? fun annot -> - typed ctxt loc Now (Item_t (Timestamp_t None, stack, annot)) - | Prim (loc, I_AMOUNT, [], annot), - stack -> - parse_var_annot loc annot ~default:default_amount_annot >>=? fun annot -> - typed ctxt loc Amount - (Item_t (Mutez_t None, stack, annot)) - | Prim (loc, I_CHAIN_ID, [], annot), - stack -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc ChainId - (Item_t (Chain_id_t None, stack, annot)) - | Prim (loc, I_BALANCE, [], annot), - stack -> - parse_var_annot loc annot ~default:default_balance_annot >>=? fun annot -> - typed ctxt loc Balance - (Item_t (Mutez_t None, stack, annot)) - | Prim (loc, I_HASH_KEY, [], annot), - Item_t (Key_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Hash_key - (Item_t (Key_hash_t None, rest, annot)) - | Prim (loc, I_CHECK_SIGNATURE, [], annot), - Item_t (Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest, _), _), _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Check_signature - (Item_t (Bool_t None, rest, annot)) - | Prim (loc, I_BLAKE2B, [], annot), - Item_t (Bytes_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Blake2b - (Item_t (Bytes_t None, rest, annot)) - | Prim (loc, I_SHA256, [], annot), - Item_t (Bytes_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Sha256 - (Item_t (Bytes_t None, rest, annot)) - | Prim (loc, I_SHA512, [], annot), - Item_t (Bytes_t _, rest, _) -> - parse_var_annot loc annot >>=? fun annot -> - typed ctxt loc Sha512 - (Item_t (Bytes_t None, rest, annot)) - | Prim (loc, I_STEPS_TO_QUOTA, [], annot), - stack -> - if legacy - then begin - (* For existing contracts, this instruction is still allowed *) - parse_var_annot loc annot ~default:default_steps_annot >>=? fun annot -> - typed ctxt loc Steps_to_quota - (Item_t (Nat_t None, stack, annot)) - end - else - (* For new contracts this instruction is not allowed anymore *) - fail (Deprecated_instruction I_STEPS_TO_QUOTA) - | Prim (loc, I_SOURCE, [], annot), - stack -> - parse_var_annot loc annot ~default:default_source_annot >>=? fun annot -> - typed ctxt loc Source - (Item_t (Address_t None, stack, annot)) - | Prim (loc, I_SENDER, [], annot), - stack -> - parse_var_annot loc annot ~default:default_sender_annot >>=? fun annot -> - typed ctxt loc Sender - (Item_t (Address_t None, stack, annot)) - | Prim (loc, I_SELF, [], annot), - stack -> - parse_entrypoint_annot loc annot ~default:default_self_annot - >>=? fun (annot, entrypoint) -> - let entrypoint = Option.unopt_map ~f:(fun (`Field_annot annot) -> annot) ~default:"default" entrypoint in - let rec get_toplevel_type : tc_context -> (bef judgement * context) tzresult Lwt.t = function - | Lambda -> fail (Self_in_lambda loc) - | Dip (_, prev) -> get_toplevel_type prev - | Toplevel { param_type ; root_name ; legacy_create_contract_literal = false} -> - Lwt.return (find_entrypoint param_type ~root_name entrypoint) >>=? fun (_, Ex_ty param_type) -> - typed ctxt loc (Self (param_type, entrypoint)) - (Item_t (Contract_t (param_type, None), stack, annot)) - | Toplevel { param_type ; root_name = _ ; legacy_create_contract_literal = true} -> - typed ctxt loc (Self (param_type, "default")) - (Item_t (Contract_t (param_type, None), stack, annot)) in - get_toplevel_type tc_context - (* Primitive parsing errors *) - | Prim (loc, (I_DUP | I_SWAP | I_SOME | I_UNIT - | I_PAIR | I_CAR | I_CDR | I_CONS | I_CONCAT | I_SLICE - | I_MEM | I_UPDATE | I_MAP - | I_GET | I_EXEC | I_FAILWITH | I_SIZE - | I_ADD | I_SUB - | I_MUL | I_EDIV | I_OR | I_AND | I_XOR - | I_NOT - | I_ABS | I_NEG | I_LSL | I_LSR - | I_COMPARE | I_EQ | I_NEQ - | I_LT | I_GT | I_LE | I_GE - | I_TRANSFER_TOKENS | I_CREATE_ACCOUNT - | I_SET_DELEGATE | I_NOW - | I_IMPLICIT_ACCOUNT | I_AMOUNT | I_BALANCE - | I_CHECK_SIGNATURE | I_HASH_KEY | I_SOURCE | I_SENDER - | I_BLAKE2B | I_SHA256 | I_SHA512 | I_STEPS_TO_QUOTA | I_ADDRESS - as name), (_ :: _ as l), _), _ -> - fail (Invalid_arity (loc, name, 0, List.length l)) - | Prim (loc, (I_NONE | I_LEFT | I_RIGHT | I_NIL | I_MAP | I_ITER - | I_EMPTY_SET | I_DIP | I_LOOP | I_LOOP_LEFT | I_CONTRACT - as name), ([] - | _ :: _ :: _ as l), _), _ -> - fail (Invalid_arity (loc, name, 1, List.length l)) - | Prim (loc, (I_PUSH | I_IF_NONE | I_IF_LEFT | I_IF_CONS - | I_EMPTY_MAP | I_IF - as name), ([] | [ _ ] - | _ :: _ :: _ :: _ as l), _), _ -> - fail (Invalid_arity (loc, name, 2, List.length l)) - | Prim (loc, I_LAMBDA, ([] | [ _ ] - | _ :: _ :: _ :: _ :: _ as l), _), _ -> - fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l)) - (* Stack errors *) - | Prim (loc, (I_ADD | I_SUB | I_MUL | I_EDIV - | I_AND | I_OR | I_XOR | I_LSL | I_LSR as name), [], _), - Item_t (ta, Item_t (tb, _, _), _) -> - Lwt.return @@ serialize_ty_for_error ctxt ta >>=? fun (ta, ctxt) -> - Lwt.return @@ serialize_ty_for_error ctxt tb >>=? fun (tb, _ctxt) -> - fail (Undefined_binop (loc, name, ta, tb)) - | Prim (loc, (I_NEG | I_ABS | I_NOT | I_CONCAT | I_SIZE - | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name), - [], _), - Item_t (t, _, _) -> - Lwt.return @@ serialize_ty_for_error ctxt t >>=? fun (t, _ctxt) -> - fail (Undefined_unop (loc, name, t)) - | Prim (loc, (I_UPDATE | I_SLICE as name), [], _), - stack -> - serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> - fail (Bad_stack (loc, name, 3, stack)) - | Prim (loc, I_CREATE_CONTRACT, _, _), - stack -> - serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> - fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) - | Prim (loc, I_CREATE_ACCOUNT, [], _), - stack -> - serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> - fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack)) - | Prim (loc, I_TRANSFER_TOKENS, [], _), - stack -> - serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> - fail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack)) - | Prim (loc, (I_DROP | I_DUP | I_CAR | I_CDR | I_SOME - | I_BLAKE2B | I_SHA256 | I_SHA512 | I_DIP - | I_IF_NONE | I_LEFT | I_RIGHT | I_IF_LEFT | I_IF - | I_LOOP | I_IF_CONS | I_IMPLICIT_ACCOUNT - | I_NEG | I_ABS | I_INT | I_NOT | I_HASH_KEY - | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name), _, _), - stack -> - serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> - fail (Bad_stack (loc, name, 1, stack)) - | Prim (loc, (I_SWAP | I_PAIR | I_CONS - | I_GET | I_MEM | I_EXEC - | I_CHECK_SIGNATURE | I_ADD | I_SUB | I_MUL - | I_EDIV | I_AND | I_OR | I_XOR - | I_LSL | I_LSR as name), _, _), - stack -> - serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> - fail (Bad_stack (loc, name, 2, stack)) - (* Generic parsing errors *) - | expr, _ -> - fail @@ unexpected expr [ Seq_kind ] Instr_namespace - [ I_DROP ; I_DUP; I_DIG; I_DUG; - I_SWAP ; I_SOME ; I_UNIT ; - I_PAIR ; I_CAR ; I_CDR ; I_CONS ; - I_MEM ; I_UPDATE ; I_MAP ; I_ITER ; - I_GET ; I_EXEC ; I_FAILWITH ; I_SIZE ; - I_CONCAT ; I_ADD ; I_SUB ; - I_MUL ; I_EDIV ; I_OR ; I_AND ; I_XOR ; - I_NOT ; - I_ABS ; I_INT; I_NEG ; I_LSL ; I_LSR ; - I_COMPARE ; I_EQ ; I_NEQ ; - I_LT ; I_GT ; I_LE ; I_GE ; - I_TRANSFER_TOKENS ; I_CREATE_ACCOUNT ; - I_CREATE_CONTRACT ; I_NOW ; I_AMOUNT ; I_BALANCE ; - I_IMPLICIT_ACCOUNT ; I_CHECK_SIGNATURE ; - I_BLAKE2B ; I_SHA256 ; I_SHA512 ; I_HASH_KEY ; - I_STEPS_TO_QUOTA ; - I_PUSH ; I_NONE ; I_LEFT ; I_RIGHT ; I_NIL ; - I_EMPTY_SET ; I_DIP ; I_LOOP ; - I_IF_NONE ; I_IF_LEFT ; I_IF_CONS ; - I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SENDER ; I_SELF ; I_LAMBDA ] + (parse_returning + (Toplevel + { + storage_type; + param_type = arg_type; + root_name; + legacy_create_contract_literal = true; + }) + ctxt + ~legacy + ?type_logger + (arg_type_full, None) + ret_type_full + code_field) + >>=? fun ( ( Lam + ( { bef = Item_t (arg, Empty_t, _); + aft = Item_t (ret, Empty_t, _); + _ }, + _ ) as lambda ), + ctxt ) -> + Lwt.return @@ ty_eq ctxt arg arg_type_full + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full + >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt ret ret_type_full + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full + >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt storage_type ginit + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit + >>=? fun (_, ctxt) -> + typed + ctxt + loc + (Create_contract (storage_type, arg_type, lambda, root_name)) + (Item_t + ( Operation_t None, + Item_t (Address_t None, rest, addr_annot), + op_annot )) + else + (* For new contracts this instruction is not allowed anymore *) + fail (Deprecated_instruction I_CREATE_CONTRACT) + | ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot), + (* Removed the instruction's arguments manager, spendable and delegatable *) + Item_t + ( Option_t (Key_hash_t _, _, _), + Item_t (Mutez_t _, Item_t (ginit, rest, _), _), + _ ) ) -> + parse_two_var_annot loc annot + >>=? fun (op_annot, addr_annot) -> + let cannonical_code = fst @@ Micheline.extract_locations code in + Lwt.return @@ parse_toplevel ~legacy cannonical_code + >>=? fun (arg_type, storage_type, code_field, root_name) -> + trace + (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) + (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type) + >>=? fun (Ex_ty arg_type, ctxt) -> + ( if legacy then Error_monad.return () + else Lwt.return (well_formed_entrypoints ~root_name arg_type) ) + >>=? fun () -> + trace + (Ill_formed_type + (Some "storage", cannonical_code, location storage_type)) + (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type) + >>=? fun (Ex_ty storage_type, ctxt) -> + let arg_annot = + default_annot + (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot + in + let storage_annot = + default_annot + (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot + in + let arg_type_full = + Pair_t + ( (arg_type, None, arg_annot), + (storage_type, None, storage_annot), + None, + has_big_map arg_type || has_big_map storage_type ) + in + let ret_type_full = + Pair_t + ( (List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), + None, + has_big_map storage_type ) + in + trace + (Ill_typed_contract (cannonical_code, [])) + (parse_returning + (Toplevel + { + storage_type; + param_type = arg_type; + root_name; + legacy_create_contract_literal = false; + }) + ctxt + ~legacy + ?type_logger + (arg_type_full, None) + ret_type_full + code_field) + >>=? fun ( ( Lam + ( { bef = Item_t (arg, Empty_t, _); + aft = Item_t (ret, Empty_t, _); + _ }, + _ ) as lambda ), + ctxt ) -> + Lwt.return @@ ty_eq ctxt arg arg_type_full + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full + >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt ret ret_type_full + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full + >>=? fun (_, ctxt) -> + Lwt.return @@ ty_eq ctxt storage_type ginit + >>=? fun (Eq, ctxt) -> + Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit + >>=? fun (_, ctxt) -> + typed + ctxt + loc + (Create_contract_2 (storage_type, arg_type, lambda, root_name)) + (Item_t + ( Operation_t None, + Item_t (Address_t None, rest, addr_annot), + op_annot )) + | (Prim (loc, I_NOW, [], annot), stack) -> + parse_var_annot loc annot ~default:default_now_annot + >>=? fun annot -> + typed ctxt loc Now (Item_t (Timestamp_t None, stack, annot)) + | (Prim (loc, I_AMOUNT, [], annot), stack) -> + parse_var_annot loc annot ~default:default_amount_annot + >>=? fun annot -> + typed ctxt loc Amount (Item_t (Mutez_t None, stack, annot)) + | (Prim (loc, I_CHAIN_ID, [], annot), stack) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc ChainId (Item_t (Chain_id_t None, stack, annot)) + | (Prim (loc, I_BALANCE, [], annot), stack) -> + parse_var_annot loc annot ~default:default_balance_annot + >>=? fun annot -> + typed ctxt loc Balance (Item_t (Mutez_t None, stack, annot)) + | (Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Hash_key (Item_t (Key_hash_t None, rest, annot)) + | ( Prim (loc, I_CHECK_SIGNATURE, [], annot), + Item_t + (Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest, _), _), _) ) + -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Check_signature (Item_t (Bool_t None, rest, annot)) + | (Prim (loc, I_BLAKE2B, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Blake2b (Item_t (Bytes_t None, rest, annot)) + | (Prim (loc, I_SHA256, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Sha256 (Item_t (Bytes_t None, rest, annot)) + | (Prim (loc, I_SHA512, [], annot), Item_t (Bytes_t _, rest, _)) -> + parse_var_annot loc annot + >>=? fun annot -> + typed ctxt loc Sha512 (Item_t (Bytes_t None, rest, annot)) + | (Prim (loc, I_STEPS_TO_QUOTA, [], annot), stack) -> + if legacy then + (* For existing contracts, this instruction is still allowed *) + parse_var_annot loc annot ~default:default_steps_annot + >>=? fun annot -> + typed ctxt loc Steps_to_quota (Item_t (Nat_t None, stack, annot)) + else + (* For new contracts this instruction is not allowed anymore *) + fail (Deprecated_instruction I_STEPS_TO_QUOTA) + | (Prim (loc, I_SOURCE, [], annot), stack) -> + parse_var_annot loc annot ~default:default_source_annot + >>=? fun annot -> + typed ctxt loc Source (Item_t (Address_t None, stack, annot)) + | (Prim (loc, I_SENDER, [], annot), stack) -> + parse_var_annot loc annot ~default:default_sender_annot + >>=? fun annot -> + typed ctxt loc Sender (Item_t (Address_t None, stack, annot)) + | (Prim (loc, I_SELF, [], annot), stack) -> + parse_entrypoint_annot loc annot ~default:default_self_annot + >>=? fun (annot, entrypoint) -> + let entrypoint = + Option.unopt_map + ~f:(fun (`Field_annot annot) -> annot) + ~default:"default" + entrypoint + in + let rec get_toplevel_type : + tc_context -> (bef judgement * context) tzresult Lwt.t = function + | Lambda -> + fail (Self_in_lambda loc) + | Dip (_, prev) -> + get_toplevel_type prev + | Toplevel + {param_type; root_name; legacy_create_contract_literal = false} -> + Lwt.return (find_entrypoint param_type ~root_name entrypoint) + >>=? fun (_, Ex_ty param_type) -> + typed + ctxt + loc + (Self (param_type, entrypoint)) + (Item_t (Contract_t (param_type, None), stack, annot)) + | Toplevel + {param_type; root_name = _; legacy_create_contract_literal = true} + -> + typed + ctxt + loc + (Self (param_type, "default")) + (Item_t (Contract_t (param_type, None), stack, annot)) + in + get_toplevel_type tc_context + (* Primitive parsing errors *) + | ( Prim + ( loc, + ( ( I_DUP + | I_SWAP + | I_SOME + | I_UNIT + | I_PAIR + | I_CAR + | I_CDR + | I_CONS + | I_CONCAT + | I_SLICE + | I_MEM + | I_UPDATE + | I_MAP + | I_GET + | I_EXEC + | I_FAILWITH + | I_SIZE + | I_ADD + | I_SUB + | I_MUL + | I_EDIV + | I_OR + | I_AND + | I_XOR + | I_NOT + | I_ABS + | I_NEG + | I_LSL + | I_LSR + | I_COMPARE + | I_EQ + | I_NEQ + | I_LT + | I_GT + | I_LE + | I_GE + | I_TRANSFER_TOKENS + | I_CREATE_ACCOUNT + | I_SET_DELEGATE + | I_NOW + | I_IMPLICIT_ACCOUNT + | I_AMOUNT + | I_BALANCE + | I_CHECK_SIGNATURE + | I_HASH_KEY + | I_SOURCE + | I_SENDER + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_STEPS_TO_QUOTA + | I_ADDRESS ) as name ), + (_ :: _ as l), + _ ), + _ ) -> + fail (Invalid_arity (loc, name, 0, List.length l)) + | ( Prim + ( loc, + ( ( I_NONE + | I_LEFT + | I_RIGHT + | I_NIL + | I_MAP + | I_ITER + | I_EMPTY_SET + | I_DIP + | I_LOOP + | I_LOOP_LEFT + | I_CONTRACT ) as name ), + (([] | _ :: _ :: _) as l), + _ ), + _ ) -> + fail (Invalid_arity (loc, name, 1, List.length l)) + | ( Prim + ( loc, + ( ( I_PUSH + | I_IF_NONE + | I_IF_LEFT + | I_IF_CONS + | I_EMPTY_MAP + | I_EMPTY_BIG_MAP + | I_IF ) as name ), + (([] | [_] | _ :: _ :: _ :: _) as l), + _ ), + _ ) -> + fail (Invalid_arity (loc, name, 2, List.length l)) + | (Prim (loc, I_LAMBDA, (([] | [_] | _ :: _ :: _ :: _ :: _) as l), _), _) -> + fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l)) + (* Stack errors *) + | ( Prim + ( loc, + ( ( I_ADD + | I_SUB + | I_MUL + | I_EDIV + | I_AND + | I_OR + | I_XOR + | I_LSL + | I_LSR ) as name ), + [], + _ ), + Item_t (ta, Item_t (tb, _, _), _) ) -> + Lwt.return @@ serialize_ty_for_error ctxt ta + >>=? fun (ta, ctxt) -> + Lwt.return @@ serialize_ty_for_error ctxt tb + >>=? fun (tb, _ctxt) -> fail (Undefined_binop (loc, name, ta, tb)) + | ( Prim + ( loc, + ( ( I_NEG + | I_ABS + | I_NOT + | I_CONCAT + | I_SIZE + | I_EQ + | I_NEQ + | I_LT + | I_GT + | I_LE + | I_GE ) as name ), + [], + _ ), + Item_t (t, _, _) ) -> + Lwt.return @@ serialize_ty_for_error ctxt t + >>=? fun (t, _ctxt) -> fail (Undefined_unop (loc, name, t)) + | (Prim (loc, ((I_UPDATE | I_SLICE) as name), [], _), stack) -> + serialize_stack_for_error ctxt stack + >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 3, stack)) + | (Prim (loc, I_CREATE_CONTRACT, _, _), stack) -> + serialize_stack_for_error ctxt stack + >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) + | (Prim (loc, I_CREATE_ACCOUNT, [], _), stack) -> + serialize_stack_for_error ctxt stack + >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack)) + | (Prim (loc, I_TRANSFER_TOKENS, [], _), stack) -> + serialize_stack_for_error ctxt stack + >>=? fun (stack, _ctxt) -> + fail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack)) + | ( Prim + ( loc, + ( ( I_DROP + | I_DUP + | I_CAR + | I_CDR + | I_SOME + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_DIP + | I_IF_NONE + | I_LEFT + | I_RIGHT + | I_IF_LEFT + | I_IF + | I_LOOP + | I_IF_CONS + | I_IMPLICIT_ACCOUNT + | I_NEG + | I_ABS + | I_INT + | I_NOT + | I_HASH_KEY + | I_EQ + | I_NEQ + | I_LT + | I_GT + | I_LE + | I_GE ) as name ), + _, + _ ), + stack ) -> + serialize_stack_for_error ctxt stack + >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 1, stack)) + | ( Prim + ( loc, + ( ( I_SWAP + | I_PAIR + | I_CONS + | I_GET + | I_MEM + | I_EXEC + | I_CHECK_SIGNATURE + | I_ADD + | I_SUB + | I_MUL + | I_EDIV + | I_AND + | I_OR + | I_XOR + | I_LSL + | I_LSR ) as name ), + _, + _ ), + stack ) -> + serialize_stack_for_error ctxt stack + >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 2, stack)) + (* Generic parsing errors *) + | (expr, _) -> + fail + @@ unexpected + expr + [Seq_kind] + Instr_namespace + [ I_DROP; + I_DUP; + I_DIG; + I_DUG; + I_SWAP; + I_SOME; + I_UNIT; + I_PAIR; + I_CAR; + I_CDR; + I_CONS; + I_MEM; + I_UPDATE; + I_MAP; + I_ITER; + I_GET; + I_EXEC; + I_FAILWITH; + I_SIZE; + I_CONCAT; + I_ADD; + I_SUB; + I_MUL; + I_EDIV; + I_OR; + I_AND; + I_XOR; + I_NOT; + I_ABS; + I_INT; + I_NEG; + I_LSL; + I_LSR; + I_COMPARE; + I_EQ; + I_NEQ; + I_LT; + I_GT; + I_LE; + I_GE; + I_TRANSFER_TOKENS; + I_CREATE_ACCOUNT; + I_CREATE_CONTRACT; + I_NOW; + I_AMOUNT; + I_BALANCE; + I_IMPLICIT_ACCOUNT; + I_CHECK_SIGNATURE; + I_BLAKE2B; + I_SHA256; + I_SHA512; + I_HASH_KEY; + I_STEPS_TO_QUOTA; + I_PUSH; + I_NONE; + I_LEFT; + I_RIGHT; + I_NIL; + I_EMPTY_SET; + I_DIP; + I_LOOP; + I_IF_NONE; + I_IF_LEFT; + I_IF_CONS; + I_EMPTY_MAP; + I_EMPTY_BIG_MAP; + I_IF; + I_SOURCE; + I_SENDER; + I_SELF; + I_LAMBDA ] -and parse_contract - : type arg. legacy: bool -> context -> Script.location -> arg ty -> Contract.t -> entrypoint:string -> - (context * arg typed_contract) tzresult Lwt.t - = fun ~legacy ctxt loc arg contract ~entrypoint -> - Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt -> - Contract.exists ctxt contract >>=? function - | false -> fail (Invalid_contract (loc, contract)) - | true -> - Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> - trace - (Invalid_contract (loc, contract)) @@ - Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> match code with - | None -> - Lwt.return - (ty_eq ctxt arg (Unit_t None) >>? fun (Eq, ctxt) -> - match entrypoint with - | "default" -> - let contract : arg typed_contract = (arg, (contract, entrypoint)) in - ok (ctxt, contract) - | entrypoint -> error (No_such_entrypoint entrypoint)) - | Some code -> - Script.force_decode ctxt code >>=? fun (code, ctxt) -> - Lwt.return - (parse_toplevel ~legacy:true code >>? fun (arg_type, _, _, root_name) -> - parse_parameter_ty ctxt ~legacy:true arg_type >>? fun (Ex_ty targ, ctxt) -> - let return ctxt targ entrypoint = - merge_types ~legacy ctxt loc targ arg >>? fun (arg, ctxt) -> - let contract : arg typed_contract = (arg, (contract, entrypoint)) in - ok (ctxt, contract) in - find_entrypoint_for_type ~full:targ ~expected:arg ~root_name entrypoint ctxt >>? fun (ctxt, entrypoint, targ) -> - merge_types ~legacy ctxt loc targ arg >>? fun (targ, ctxt) -> - return ctxt targ entrypoint) +and parse_contract : + type arg. + legacy:bool -> + context -> + Script.location -> + arg ty -> + Contract.t -> + entrypoint:string -> + (context * arg typed_contract) tzresult Lwt.t = + fun ~legacy ctxt loc arg contract ~entrypoint -> + Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists + >>=? fun ctxt -> + Contract.exists ctxt contract + >>=? function + | false -> + fail (Invalid_contract (loc, contract)) + | true -> ( + Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script + >>=? fun ctxt -> + trace (Invalid_contract (loc, contract)) + @@ Contract.get_script_code ctxt contract + >>=? fun (ctxt, code) -> + match code with + | None -> + Lwt.return + ( ty_eq ctxt arg (Unit_t None) + >>? fun (Eq, ctxt) -> + match entrypoint with + | "default" -> + let contract : arg typed_contract = + (arg, (contract, entrypoint)) + in + ok (ctxt, contract) + | entrypoint -> + error (No_such_entrypoint entrypoint) ) + | Some code -> + Script.force_decode ctxt code + >>=? fun (code, ctxt) -> + Lwt.return + ( parse_toplevel ~legacy:true code + >>? fun (arg_type, _, _, root_name) -> + parse_parameter_ty ctxt ~legacy:true arg_type + >>? fun (Ex_ty targ, ctxt) -> + let return ctxt targ entrypoint = + merge_types ~legacy ctxt loc targ arg + >>? fun (arg, ctxt) -> + let contract : arg typed_contract = + (arg, (contract, entrypoint)) + in + ok (ctxt, contract) + in + find_entrypoint_for_type + ~full:targ + ~expected:arg + ~root_name + entrypoint + ctxt + >>? fun (ctxt, entrypoint, targ) -> + merge_types ~legacy ctxt loc targ arg + >>? fun (targ, ctxt) -> return ctxt targ entrypoint ) ) (* Same as the one above, 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. This can still fail on gas exhaustion. *) -and parse_contract_for_script - : type arg. legacy: bool -> context -> Script.location -> arg ty -> Contract.t -> entrypoint:string -> - (context * arg typed_contract option) tzresult Lwt.t - = fun ~legacy ctxt loc arg contract ~entrypoint -> - Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists >>=? fun ctxt -> - Contract.exists ctxt contract >>=? function - | false -> return (ctxt, None) - | true -> - Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> - trace - (Invalid_contract (loc, contract)) @@ - Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> match code with (* can only fail because of gas *) - | None -> - begin match entrypoint with - | "default" -> - Lwt.return - (match ty_eq ctxt arg (Unit_t None) with - | Ok (Eq, ctxt) -> - let contract : arg typed_contract = (arg, (contract, entrypoint)) in - ok (ctxt, Some contract) - | Error _ -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - ok (ctxt, None)) - | _ -> return (ctxt, None) - end - | Some code -> - Script.force_decode ctxt code >>=? fun (code, ctxt) -> (* can only fail because of gas *) - Lwt.return - (match parse_toplevel ~legacy:true code with - | Error _ -> error (Invalid_contract (loc, contract)) - | Ok (arg_type, _, _, root_name) -> - match parse_parameter_ty ctxt ~legacy:true arg_type with - | Error _ -> - error (Invalid_contract (loc, contract)) - | Ok (Ex_ty targ, ctxt) -> - match - find_entrypoint_for_type ~full:targ ~expected:arg ~root_name entrypoint ctxt >>? fun (ctxt, entrypoint, targ) -> - merge_types ~legacy ctxt loc targ arg >>? fun (targ, ctxt) -> - merge_types ~legacy ctxt loc targ arg >>? fun (arg, ctxt) -> - let contract : arg typed_contract = (arg, (contract, entrypoint)) in - ok (ctxt, Some contract) - with - | Ok res -> ok res - | Error _ -> - (* overapproximation by checking if targ = targ, +and parse_contract_for_script : + type arg. + legacy:bool -> + context -> + Script.location -> + arg ty -> + Contract.t -> + entrypoint:string -> + (context * arg typed_contract option) tzresult Lwt.t = + fun ~legacy ctxt loc arg contract ~entrypoint -> + Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists + >>=? fun ctxt -> + match (Contract.is_implicit contract, entrypoint) with + | (Some _, "default") -> + (* An implicit account on the "default" entrypoint always exists and has type unit. *) + Lwt.return + ( match ty_eq ctxt arg (Unit_t None) with + | Ok (Eq, ctxt) -> + let contract : arg typed_contract = + (arg, (contract, entrypoint)) + in + ok (ctxt, Some contract) + | Error _ -> + Gas.consume ctxt Typecheck_costs.cycle + >>? fun ctxt -> ok (ctxt, None) ) + | (Some _, _) -> + Lwt.return @@ Gas.consume ctxt Typecheck_costs.cycle + >>=? fun ctxt -> + (* An implicit account on any other entrypoint is not a valid contract. *) + return (ctxt, None) + | (None, _) -> ( + (* Originated account *) + Contract.exists ctxt contract + >>=? function + | false -> + return (ctxt, None) + | true -> ( + Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script + >>=? fun ctxt -> + trace (Invalid_contract (loc, contract)) + @@ Contract.get_script_code ctxt contract + >>=? fun (ctxt, code) -> + match code with + | None -> + (* Since protocol 005, we have the invariant that all originated accounts have code *) + assert false + | Some code -> + Script.force_decode ctxt code + >>=? fun (code, ctxt) -> + (* can only fail because of gas *) + Lwt.return + ( match parse_toplevel ~legacy:true code with + | Error _ -> + error (Invalid_contract (loc, contract)) + | Ok (arg_type, _, _, root_name) -> ( + match parse_parameter_ty ctxt ~legacy:true arg_type with + | Error _ -> + error (Invalid_contract (loc, contract)) + | Ok (Ex_ty targ, ctxt) -> ( + match + find_entrypoint_for_type + ~full:targ + ~expected:arg + ~root_name + entrypoint + ctxt + >>? fun (ctxt, entrypoint, targ) -> + merge_types ~legacy ctxt loc targ arg + >>? fun (targ, ctxt) -> + merge_types ~legacy ctxt loc targ arg + >>? fun (arg, ctxt) -> + let contract : arg typed_contract = + (arg, (contract, entrypoint)) + in + ok (ctxt, Some contract) + with + | Ok res -> + ok res + | Error _ -> + (* overapproximation by checking if targ = targ, can only fail because of gas *) - ty_eq ctxt targ targ >>? fun (Eq, ctxt) -> - merge_types ~legacy ctxt loc targ targ >>? fun (_, ctxt) -> - ok (ctxt, None)) + ty_eq ctxt targ targ + >>? fun (Eq, ctxt) -> + merge_types ~legacy ctxt loc targ targ + >>? fun (_, ctxt) -> ok (ctxt, None) ) ) ) ) ) -and parse_toplevel - : legacy: bool -> Script.expr -> (Script.node * Script.node * Script.node * string option) tzresult - = fun ~legacy toplevel -> - record_trace (Ill_typed_contract (toplevel, [])) @@ - match root toplevel with - | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) - | String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind)) - | Bytes (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Bytes_kind)) - | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind)) - | Seq (_, fields) -> - let rec find_fields p s c fields = - match fields with - | [] -> ok (p, s, c) - | Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind)) - | String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_kind)) - | Bytes (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Bytes_kind)) - | Seq (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind)) - | Prim (loc, K_parameter, [ arg ], annot) :: rest -> - begin match p with - | None -> find_fields (Some (arg, loc, annot)) s c rest - | Some _ -> error (Duplicate_field (loc, K_parameter)) - end - | Prim (loc, K_storage, [ arg ], annot) :: rest -> - begin match s with - | None -> find_fields p (Some (arg, loc, annot)) c rest - | Some _ -> error (Duplicate_field (loc, K_storage)) - end - | Prim (loc, K_code, [ arg ], annot) :: rest -> - begin match c with - | None -> find_fields p s (Some (arg, loc, annot)) rest - | Some _ -> error (Duplicate_field (loc, K_code)) - end - | Prim (loc, (K_parameter | K_storage | K_code as name), args, _) :: _ -> - error (Invalid_arity (loc, name, 1, List.length args)) - | Prim (loc, name, _, _) :: _ -> - let allowed = [ K_parameter ; K_storage ; K_code ] in - error (Invalid_primitive (loc, allowed, name)) - in - find_fields None None None fields >>? function - | (None, _, _) -> error (Missing_field K_parameter) - | (Some _, None, _) -> error (Missing_field K_storage) - | (Some _, Some _, None) -> error (Missing_field K_code) - | (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot)) -> - let maybe_root_name = - (* root name can be attached to either the parameter +and parse_toplevel : + legacy:bool -> + Script.expr -> + (Script.node * Script.node * Script.node * string option) tzresult = + fun ~legacy toplevel -> + record_trace (Ill_typed_contract (toplevel, [])) + @@ + match root toplevel with + | Int (loc, _) -> + error (Invalid_kind (loc, [Seq_kind], Int_kind)) + | String (loc, _) -> + error (Invalid_kind (loc, [Seq_kind], String_kind)) + | Bytes (loc, _) -> + error (Invalid_kind (loc, [Seq_kind], Bytes_kind)) + | Prim (loc, _, _, _) -> + error (Invalid_kind (loc, [Seq_kind], Prim_kind)) + | Seq (_, fields) -> ( + let rec find_fields p s c fields = + match fields with + | [] -> + ok (p, s, c) + | Int (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], Int_kind)) + | String (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], String_kind)) + | Bytes (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], Bytes_kind)) + | Seq (loc, _) :: _ -> + error (Invalid_kind (loc, [Prim_kind], Seq_kind)) + | Prim (loc, K_parameter, [arg], annot) :: rest -> ( + match p with + | None -> + find_fields (Some (arg, loc, annot)) s c rest + | Some _ -> + error (Duplicate_field (loc, K_parameter)) ) + | Prim (loc, K_storage, [arg], annot) :: rest -> ( + match s with + | None -> + find_fields p (Some (arg, loc, annot)) c rest + | Some _ -> + error (Duplicate_field (loc, K_storage)) ) + | Prim (loc, K_code, [arg], annot) :: rest -> ( + match c with + | None -> + find_fields p s (Some (arg, loc, annot)) rest + | Some _ -> + error (Duplicate_field (loc, K_code)) ) + | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _) + :: _ -> + error (Invalid_arity (loc, name, 1, List.length args)) + | Prim (loc, name, _, _) :: _ -> + let allowed = [K_parameter; K_storage; K_code] in + error (Invalid_primitive (loc, allowed, name)) + in + find_fields None None None fields + >>? function + | (None, _, _) -> + error (Missing_field K_parameter) + | (Some _, None, _) -> + error (Missing_field K_storage) + | (Some _, Some _, None) -> + error (Missing_field K_code) + | (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot)) + -> + let maybe_root_name = + (* root name can be attached to either the parameter primitive or the toplevel constructor *) - Script_ir_annot.extract_field_annot p >>? fun (p, root_name) -> - match root_name with - | Some (`Field_annot root_name) -> - ok (p, pannot, Some root_name) - | None -> - match pannot with - | [ single ] when Compare.Int.(String.length single > 0) && Compare.Char.(String.get single 0 = '%') -> - ok (p, [], Some (String.sub single 1 (String.length single - 1))) - | _ -> ok (p, pannot, None) in - if legacy then - (* legacy semantics ignores spurious annotations *) - let p, root_name = match maybe_root_name with Ok (p, _, root_name) -> (p, root_name) | Error _ -> (p, None) in - ok (p, s, c, root_name) - else - (* only one field annot is allowed to set the root entrypoint name *) - maybe_root_name >>? fun (p, pannot, root_name) -> - Script_ir_annot.error_unexpected_annot ploc pannot >>? fun () -> - Script_ir_annot.error_unexpected_annot cloc carrot >>? fun () -> - Script_ir_annot.error_unexpected_annot sloc sannot >>? fun () -> - ok (p, s, c, root_name) + Script_ir_annot.extract_field_annot p + >>? fun (p, root_name) -> + match root_name with + | Some (`Field_annot root_name) -> + ok (p, pannot, Some root_name) + | None -> ( + match pannot with + | [single] + when Compare.Int.(String.length single > 0) + && Compare.Char.(single.[0] = '%') -> + ok + ( p, + [], + Some (String.sub single 1 (String.length single - 1)) ) + | _ -> + ok (p, pannot, None) ) + in + if legacy then + (* legacy semantics ignores spurious annotations *) + let (p, root_name) = + match maybe_root_name with + | Ok (p, _, root_name) -> + (p, root_name) + | Error _ -> + (p, None) + in + ok (p, s, c, root_name) + else + (* only one field annot is allowed to set the root entrypoint name *) + maybe_root_name + >>? fun (p, pannot, root_name) -> + Script_ir_annot.error_unexpected_annot ploc pannot + >>? fun () -> + Script_ir_annot.error_unexpected_annot cloc carrot + >>? fun () -> + Script_ir_annot.error_unexpected_annot sloc sannot + >>? fun () -> ok (p, s, c, root_name) ) -let parse_script - : ?type_logger: type_logger -> - context -> legacy: bool -> Script.t -> (ex_script * context) tzresult Lwt.t - = fun ?type_logger ctxt ~legacy { code ; storage } -> - Script.force_decode ctxt code >>=? fun (code, ctxt) -> - Script.force_decode ctxt storage >>=? fun (storage, ctxt) -> - Lwt.return @@ parse_toplevel ~legacy code >>=? fun (arg_type, storage_type, code_field, root_name) -> - trace - (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type)) - >>=? fun (Ex_ty arg_type, ctxt) -> - begin - if legacy then return () else - Lwt.return (well_formed_entrypoints ~root_name arg_type) - end >>=? fun () -> - trace - (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_storage_ty ctxt ~legacy storage_type)) - >>=? fun (Ex_ty storage_type, ctxt) -> - let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) - ~default:default_param_annot in - let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) - ~default:default_storage_annot in - let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None, - has_big_map arg_type || has_big_map storage_type) in - let ret_type_full = - Pair_t ((List_t (Operation_t None, None, false), None, None), - (storage_type, None, None), None, has_big_map storage_type) in - trace_eval - (fun () -> - Lwt.return @@ serialize_ty_for_error ctxt storage_type >>|? fun (storage_type, _ctxt) -> - Ill_typed_data (None, storage, storage_type)) - (parse_data ?type_logger ctxt ~legacy storage_type (root storage)) >>=? fun (storage, ctxt) -> - trace - (Ill_typed_contract (code, [])) - (parse_returning (Toplevel { storage_type ; param_type = arg_type ; root_name ; - legacy_create_contract_literal = false}) - ctxt ~legacy ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> - return (Ex_script { code ; arg_type ; storage ; storage_type ; root_name }, ctxt) +let parse_script : + ?type_logger:type_logger -> + context -> + legacy:bool -> + Script.t -> + (ex_script * context) tzresult Lwt.t = + fun ?type_logger ctxt ~legacy {code; storage} -> + Script.force_decode ctxt code + >>=? fun (code, ctxt) -> + Script.force_decode ctxt storage + >>=? fun (storage, ctxt) -> + Lwt.return @@ parse_toplevel ~legacy code + >>=? fun (arg_type, storage_type, code_field, root_name) -> + trace + (Ill_formed_type (Some "parameter", code, location arg_type)) + (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type)) + >>=? fun (Ex_ty arg_type, ctxt) -> + ( if legacy then return () + else Lwt.return (well_formed_entrypoints ~root_name arg_type) ) + >>=? fun () -> + trace + (Ill_formed_type (Some "storage", code, location storage_type)) + (Lwt.return (parse_storage_ty ctxt ~legacy storage_type)) + >>=? fun (Ex_ty storage_type, ctxt) -> + let arg_annot = + default_annot + (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot + in + let storage_annot = + default_annot + (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot + in + let arg_type_full = + Pair_t + ( (arg_type, None, arg_annot), + (storage_type, None, storage_annot), + None, + has_big_map arg_type || has_big_map storage_type ) + in + let ret_type_full = + Pair_t + ( (List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), + None, + has_big_map storage_type ) + in + trace_eval + (fun () -> + Lwt.return @@ serialize_ty_for_error ctxt storage_type + >>|? fun (storage_type, _ctxt) -> + Ill_typed_data (None, storage, storage_type)) + (parse_data ?type_logger ctxt ~legacy storage_type (root storage)) + >>=? fun (storage, ctxt) -> + trace + (Ill_typed_contract (code, [])) + (parse_returning + (Toplevel + { + storage_type; + param_type = arg_type; + root_name; + legacy_create_contract_literal = false; + }) + ctxt + ~legacy + ?type_logger + (arg_type_full, None) + ret_type_full + code_field) + >>=? fun (code, ctxt) -> + return (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt) -let typecheck_code - : context -> Script.expr -> (type_map * context) tzresult Lwt.t - = fun ctxt code -> - let legacy = false in - Lwt.return @@ parse_toplevel ~legacy code >>=? fun (arg_type, storage_type, code_field, root_name) -> - let type_map = ref [] in - trace - (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type)) - >>=? fun (Ex_ty arg_type, ctxt) -> - begin - if legacy then return () else - Lwt.return (well_formed_entrypoints ~root_name arg_type) - end >>=? fun () -> - trace - (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_storage_ty ctxt ~legacy storage_type)) - >>=? fun (Ex_ty storage_type, ctxt) -> - let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) - ~default:default_param_annot in - let storage_annot = default_annot (type_to_var_annot (name_of_ty storage_type)) - ~default:default_storage_annot in - let arg_type_full = Pair_t ((arg_type, None, arg_annot), - (storage_type, None, storage_annot), None, - has_big_map arg_type || has_big_map storage_type) in - let ret_type_full = - Pair_t ((List_t (Operation_t None, None, false), None, None), - (storage_type, None, None), None, - has_big_map storage_type) in - let result = - parse_returning - (Toplevel { storage_type ; param_type = arg_type ; root_name ; - legacy_create_contract_literal = false }) - ctxt ~legacy - ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) - (arg_type_full, None) ret_type_full code_field in - trace - (Ill_typed_contract (code, !type_map)) - result >>=? fun (Lam _, ctxt) -> - return (!type_map, ctxt) +let typecheck_code : + context -> Script.expr -> (type_map * context) tzresult Lwt.t = + fun ctxt code -> + let legacy = false in + Lwt.return @@ parse_toplevel ~legacy code + >>=? fun (arg_type, storage_type, code_field, root_name) -> + let type_map = ref [] in + trace + (Ill_formed_type (Some "parameter", code, location arg_type)) + (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type)) + >>=? fun (Ex_ty arg_type, ctxt) -> + ( if legacy then return () + else Lwt.return (well_formed_entrypoints ~root_name arg_type) ) + >>=? fun () -> + trace + (Ill_formed_type (Some "storage", code, location storage_type)) + (Lwt.return (parse_storage_ty ctxt ~legacy storage_type)) + >>=? fun (Ex_ty storage_type, ctxt) -> + let arg_annot = + default_annot + (type_to_var_annot (name_of_ty arg_type)) + ~default:default_param_annot + in + let storage_annot = + default_annot + (type_to_var_annot (name_of_ty storage_type)) + ~default:default_storage_annot + in + let arg_type_full = + Pair_t + ( (arg_type, None, arg_annot), + (storage_type, None, storage_annot), + None, + has_big_map arg_type || has_big_map storage_type ) + in + let ret_type_full = + Pair_t + ( (List_t (Operation_t None, None, false), None, None), + (storage_type, None, None), + None, + has_big_map storage_type ) + in + let result = + parse_returning + (Toplevel + { + storage_type; + param_type = arg_type; + root_name; + legacy_create_contract_literal = false; + }) + ctxt + ~legacy + ~type_logger:(fun loc bef aft -> + type_map := (loc, (bef, aft)) :: !type_map) + (arg_type_full, None) + ret_type_full + code_field + in + trace (Ill_typed_contract (code, !type_map)) result + >>=? fun (Lam _, ctxt) -> return (!type_map, ctxt) -let typecheck_data - : ?type_logger: type_logger -> - context -> Script.expr * Script.expr -> context tzresult Lwt.t - = fun ?type_logger ctxt (data, exp_ty) -> - let legacy = false in - trace - (Ill_formed_type (None, exp_ty, 0)) - (Lwt.return @@ parse_packable_ty ctxt ~legacy (root exp_ty)) - >>=? fun (Ex_ty exp_ty, ctxt) -> - trace_eval - (fun () -> - Lwt.return @@ serialize_ty_for_error ctxt exp_ty >>|? fun (exp_ty, _ctxt) -> - Ill_typed_data (None, data, exp_ty)) - (parse_data ?type_logger ctxt ~legacy exp_ty (root data)) >>=? fun (_, ctxt) -> - return ctxt +let typecheck_data : + ?type_logger:type_logger -> + context -> + Script.expr * Script.expr -> + context tzresult Lwt.t = + fun ?type_logger ctxt (data, exp_ty) -> + let legacy = false in + trace + (Ill_formed_type (None, exp_ty, 0)) + (Lwt.return @@ parse_parameter_ty ctxt ~legacy (root exp_ty)) + >>=? fun (Ex_ty exp_ty, ctxt) -> + trace_eval + (fun () -> + Lwt.return @@ serialize_ty_for_error ctxt exp_ty + >>|? fun (exp_ty, _ctxt) -> Ill_typed_data (None, data, exp_ty)) + (parse_data ?type_logger ctxt ~legacy exp_ty (root data)) + >>=? fun (_, ctxt) -> return ctxt module Entrypoints_map = Map.Make (String) -let list_entrypoints (type full) (full : full ty) ctxt ~root_name = - let merge path annot (type t) (ty : t ty) reachable ((unreachables, all) as acc) = +let list_entrypoints (type full) (full : full ty) ctxt ~root_name = + let merge path annot (type t) (ty : t ty) reachable + ((unreachables, all) as acc) = match annot with - | None | Some (`Field_annot "") -> - ok @@ - if reachable then acc else - begin match ty with - | Union_t _ -> acc - | _ -> ( (List.rev path)::unreachables, all ) - end + | None | Some (`Field_annot "") -> ( + ok + @@ + if reachable then acc + else + match ty with + | Union_t _ -> + acc + | _ -> + (List.rev path :: unreachables, all) ) | Some (`Field_annot name) -> - if Compare.Int.(String.length name > 31) then ok ((List.rev path)::unreachables, all) - else if Entrypoints_map.mem name all then ok ((List.rev path)::unreachables, all) - else unparse_ty_no_lwt ctxt ty >>? fun (unparsed_ty , _) -> - ok (unreachables, Entrypoints_map.add name ((List.rev path),unparsed_ty) all) + if Compare.Int.(String.length name > 31) then + ok (List.rev path :: unreachables, all) + else if Entrypoints_map.mem name all then + ok (List.rev path :: unreachables, all) + else + unparse_ty_no_lwt ctxt ty + >>? fun (unparsed_ty, _) -> + ok + ( unreachables, + Entrypoints_map.add name (List.rev path, unparsed_ty) all ) in - let rec fold_tree - : type t. t ty -> + let rec fold_tree : + type t. + t ty -> prim list -> bool -> - prim list list * (prim list * Script.node) Entrypoints_map.t -> - (prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult - = fun t path reachable acc -> - match t with - | Union_t ((tl, al), (tr, ar), _, _) -> - merge (D_Left :: path) al tl reachable acc >>? fun acc -> - merge (D_Right :: path) ar tr reachable acc >>? fun acc -> - fold_tree tl (D_Left :: path) (match al with Some _ -> true | None -> reachable) acc >>? fun acc -> - fold_tree tr (D_Right :: path) (match ar with Some _ -> true | None -> reachable) acc - | _ -> ok acc in - unparse_ty_no_lwt ctxt full >>? fun (unparsed_full , _) -> - let init, reachable = match root_name with - | None | Some "" -> Entrypoints_map.empty, false - | Some name -> Entrypoints_map.singleton name ([],unparsed_full), true in + prim list list * (prim list * Script.node) Entrypoints_map.t -> + (prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult = + fun t path reachable acc -> + match t with + | Union_t ((tl, al), (tr, ar), _, _) -> + merge (D_Left :: path) al tl reachable acc + >>? fun acc -> + merge (D_Right :: path) ar tr reachable acc + >>? fun acc -> + fold_tree + tl + (D_Left :: path) + (match al with Some _ -> true | None -> reachable) + acc + >>? fun acc -> + fold_tree + tr + (D_Right :: path) + (match ar with Some _ -> true | None -> reachable) + acc + | _ -> + ok acc + in + unparse_ty_no_lwt ctxt full + >>? fun (unparsed_full, _) -> + let (init, reachable) = + match root_name with + | None | Some "" -> + (Entrypoints_map.empty, false) + | Some name -> + (Entrypoints_map.singleton name ([], unparsed_full), true) + in fold_tree full [] reachable ([], init) (* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) -let rec unparse_data - : type a. context -> unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t - = fun ctxt mode ty a -> - Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> - match ty, a with - | Unit_t _, () -> - Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> - return (Prim (-1, D_Unit, [], []), ctxt) - | Int_t _, v -> - Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> - return (Int (-1, Script_int.to_zint v), ctxt) - | Nat_t _, v -> - Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> - return (Int (-1, Script_int.to_zint v), ctxt) - | String_t _, s -> - Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> - return (String (-1, s), ctxt) - | Bytes_t _, s -> - Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> - return (Bytes (-1, s), ctxt) - | Bool_t _, true -> - Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_True, [], []), ctxt) - | Bool_t _, false -> - Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_False, [], []), ctxt) - | Timestamp_t _, t -> - Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> - begin - match mode with - | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) - | Readable -> - match Script_timestamp.to_notation t with - | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) - | Some s -> return (String (-1, s), ctxt) - end - | Address_t _, (c, entrypoint) -> - Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let entrypoint = match entrypoint with "default" -> "" | name -> name in - let bytes = Data_encoding.Binary.to_bytes_exn - Data_encoding.(tup2 Contract.encoding Variable.string) - (c, entrypoint) in - return (Bytes (-1, bytes), ctxt) - | Readable -> - let notation = match entrypoint with - | "default" -> Contract.to_b58check c - | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in - return (String (-1, notation), ctxt) - end - | Contract_t _, (_, (c, entrypoint)) -> - Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let entrypoint = match entrypoint with "default" -> "" | name -> name in - let bytes = Data_encoding.Binary.to_bytes_exn - Data_encoding.(tup2 Contract.encoding Variable.string) - (c, entrypoint) in - return (Bytes (-1, bytes), ctxt) - | Readable -> - let notation = match entrypoint with - | "default" -> Contract.to_b58check c - | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in - return (String (-1, notation), ctxt) - end - | Signature_t _, s -> - Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.to_b58check s), ctxt) - end - | Mutez_t _, v -> - Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> - return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) - | Key_t _, k -> - Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.Public_key.to_b58check k), ctxt) - end - | Key_hash_t _, k -> - Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) - end - | Operation_t _, (op, _big_map_diff) -> - let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in - Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> - return (Bytes (-1, bytes), ctxt) - | Chain_id_t _, chain_id -> - let bytes = Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id in - Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes)) >>=? fun ctxt -> - return (Bytes (-1, bytes), ctxt) - | Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r) -> - Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> - unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> - unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Pair, [ l; r ], []), ctxt) - | Union_t ((tl, _), _, _, _), L l -> - Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> - unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> - return (Prim (-1, D_Left, [ l ], []), ctxt) - | Union_t (_, (tr, _), _, _), R r -> - Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> - unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Right, [ r ], []), ctxt) - | Option_t (t, _, _), Some v -> - Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> - unparse_data ctxt mode t v >>=? fun (v, ctxt) -> - return (Prim (-1, D_Some, [ v ], []), ctxt) - | Option_t _, None -> - Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> - return (Prim (-1, D_None, [], []), ctxt) - | List_t (t, _, _), items -> - fold_left_s - (fun (l, ctxt) element -> - Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> - unparse_data ctxt mode t element >>=? fun (unparsed, ctxt) -> - return (unparsed :: l, ctxt)) - ([], ctxt) - items >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, List.rev items), ctxt) - | Set_t (t, _), set -> - let t = ty_of_comparable_ty t in - fold_left_s - (fun (l, ctxt) item -> - Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> - unparse_data ctxt mode t item >>=? fun (item, ctxt) -> - return (item :: l, ctxt)) - ([], ctxt) - (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items), ctxt) - | Map_t (kt, vt, _, _), map -> - let kt = ty_of_comparable_ty kt in - fold_left_s - (fun (l, ctxt) (k, v) -> - Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> - unparse_data ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt mode vt v >>=? fun (value, ctxt) -> - return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) - ([], ctxt) - (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items), ctxt) - | Big_map_t (kt, vt, _), { id = None ; diff = (module Diff) ; _ } -> - (* this branch is to allow roundtrip of big map literals *) - let kt = ty_of_comparable_ty kt in - fold_left_s - (fun (l, ctxt) (k, v) -> - Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> - unparse_data ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt mode vt v >>=? fun (value, ctxt) -> - return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) - ([], ctxt) - (Diff.OPS.fold - (fun k v acc -> match v with | None -> acc | Some v -> (k, v) :: acc) - (fst Diff.boxed) []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items), ctxt) - | Big_map_t (_kt, _kv, _), { id = Some id ; diff = (module Diff) ; _ } -> - if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then - return (Micheline.Int (-1, id), ctxt) - else - (* this can only be the result of an execution and the map +let rec unparse_data : + type a. + context -> + unparsing_mode -> + a ty -> + a -> + (Script.node * context) tzresult Lwt.t = + fun ctxt mode ty a -> + Lwt.return (Gas.consume ctxt Unparse_costs.cycle) + >>=? fun ctxt -> + match (ty, a) with + | (Unit_t _, ()) -> + Lwt.return (Gas.consume ctxt Unparse_costs.unit) + >>=? fun ctxt -> return (Prim (-1, D_Unit, [], []), ctxt) + | (Int_t _, v) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) + >>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt) + | (Nat_t _, v) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) + >>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt) + | (String_t _, s) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) + >>=? fun ctxt -> return (String (-1, s), ctxt) + | (Bytes_t _, s) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) + >>=? fun ctxt -> return (Bytes (-1, s), ctxt) + | (Bool_t _, true) -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) + >>=? fun ctxt -> return (Prim (-1, D_True, [], []), ctxt) + | (Bool_t _, false) -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) + >>=? fun ctxt -> return (Prim (-1, D_False, [], []), ctxt) + | (Timestamp_t _, t) -> ( + Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) + >>=? fun ctxt -> + match mode with + | Optimized -> + return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Readable -> ( + match Script_timestamp.to_notation t with + | None -> + return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Some s -> + return (String (-1, s), ctxt) ) ) + | (Address_t _, (c, entrypoint)) -> ( + Lwt.return (Gas.consume ctxt Unparse_costs.contract) + >>=? fun ctxt -> + match mode with + | Optimized -> + let entrypoint = + match entrypoint with "default" -> "" | name -> name + in + let bytes = + Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) + in + return (Bytes (-1, bytes), ctxt) + | Readable -> + let notation = + match entrypoint with + | "default" -> + Contract.to_b58check c + | entrypoint -> + Contract.to_b58check c ^ "%" ^ entrypoint + in + return (String (-1, notation), ctxt) ) + | (Contract_t _, (_, (c, entrypoint))) -> ( + Lwt.return (Gas.consume ctxt Unparse_costs.contract) + >>=? fun ctxt -> + match mode with + | Optimized -> + let entrypoint = + match entrypoint with "default" -> "" | name -> name + in + let bytes = + Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Contract.encoding Variable.string) + (c, entrypoint) + in + return (Bytes (-1, bytes), ctxt) + | Readable -> + let notation = + match entrypoint with + | "default" -> + Contract.to_b58check c + | entrypoint -> + Contract.to_b58check c ^ "%" ^ entrypoint + in + return (String (-1, notation), ctxt) ) + | (Signature_t _, s) -> ( + Lwt.return (Gas.consume ctxt Unparse_costs.signature) + >>=? fun ctxt -> + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.to_b58check s), ctxt) ) + | (Mutez_t _, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.tez) + >>=? fun ctxt -> return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) + | (Key_t _, k) -> ( + Lwt.return (Gas.consume ctxt Unparse_costs.key) + >>=? fun ctxt -> + match mode with + | Optimized -> + let bytes = + Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k + in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key.to_b58check k), ctxt) ) + | (Key_hash_t _, k) -> ( + Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) + >>=? fun ctxt -> + match mode with + | Optimized -> + let bytes = + Data_encoding.Binary.to_bytes_exn + Signature.Public_key_hash.encoding + k + in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) ) + | (Operation_t _, (op, _big_map_diff)) -> + let bytes = + Data_encoding.Binary.to_bytes_exn + Operation.internal_operation_encoding + op + in + Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) + >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt) + | (Chain_id_t _, chain_id) -> + let bytes = + Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id + in + Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes)) + >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt) + | (Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r)) -> + Lwt.return (Gas.consume ctxt Unparse_costs.pair) + >>=? fun ctxt -> + unparse_data ctxt mode tl l + >>=? fun (l, ctxt) -> + unparse_data ctxt mode tr r + >>=? fun (r, ctxt) -> return (Prim (-1, D_Pair, [l; r], []), ctxt) + | (Union_t ((tl, _), _, _, _), L l) -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) + >>=? fun ctxt -> + unparse_data ctxt mode tl l + >>=? fun (l, ctxt) -> return (Prim (-1, D_Left, [l], []), ctxt) + | (Union_t (_, (tr, _), _, _), R r) -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) + >>=? fun ctxt -> + unparse_data ctxt mode tr r + >>=? fun (r, ctxt) -> return (Prim (-1, D_Right, [r], []), ctxt) + | (Option_t (t, _, _), Some v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.some) + >>=? fun ctxt -> + unparse_data ctxt mode t v + >>=? fun (v, ctxt) -> return (Prim (-1, D_Some, [v], []), ctxt) + | (Option_t _, None) -> + Lwt.return (Gas.consume ctxt Unparse_costs.none) + >>=? fun ctxt -> return (Prim (-1, D_None, [], []), ctxt) + | (List_t (t, _, _), items) -> + fold_left_s + (fun (l, ctxt) element -> + Lwt.return (Gas.consume ctxt Unparse_costs.list_element) + >>=? fun ctxt -> + unparse_data ctxt mode t element + >>=? fun (unparsed, ctxt) -> return (unparsed :: l, ctxt)) + ([], ctxt) + items + >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, List.rev items), ctxt) + | (Set_t (t, _), set) -> + let t = ty_of_comparable_ty t in + fold_left_s + (fun (l, ctxt) item -> + Lwt.return (Gas.consume ctxt Unparse_costs.set_element) + >>=? fun ctxt -> + unparse_data ctxt mode t item + >>=? fun (item, ctxt) -> return (item :: l, ctxt)) + ([], ctxt) + (set_fold (fun e acc -> e :: acc) set []) + >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt) + | (Map_t (kt, vt, _, _), map) -> + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) + >>=? fun ctxt -> + unparse_data ctxt mode kt k + >>=? fun (key, ctxt) -> + unparse_data ctxt mode vt v + >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt)) + ([], ctxt) + (map_fold (fun k v acc -> (k, v) :: acc) map []) + >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt) + | (Big_map_t (kt, vt, _), {id = None; diff = (module Diff); _}) -> + (* this branch is to allow roundtrip of big map literals *) + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) + >>=? fun ctxt -> + unparse_data ctxt mode kt k + >>=? fun (key, ctxt) -> + unparse_data ctxt mode vt v + >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt)) + ([], ctxt) + (Diff.OPS.fold + (fun k v acc -> + match v with None -> acc | Some v -> (k, v) :: acc) + (fst Diff.boxed) + []) + >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt) + | (Big_map_t (_kt, _kv, _), {id = Some id; diff = (module Diff); _}) -> + if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then + return (Micheline.Int (-1, id), ctxt) + else + (* this can only be the result of an execution and the map must have been flushed at this point *) - assert false - | Lambda_t _, Lam (_, original_code) -> - unparse_code ctxt mode original_code + assert false + | (Lambda_t _, Lam (_, original_code)) -> + unparse_code ctxt mode original_code (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) and unparse_code ctxt mode = let legacy = true in function - | Prim (loc, I_PUSH, [ ty ; data ], annot) -> - Lwt.return (parse_packable_ty ctxt ~legacy ty) >>=? fun (Ex_ty t, ctxt) -> - parse_data ctxt ~legacy t data >>=? fun (data, ctxt) -> - unparse_data ctxt mode t data >>=? fun (data, ctxt) -> - Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt -> - return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) + | Prim (loc, I_PUSH, [ty; data], annot) -> + Lwt.return (parse_packable_ty ctxt ~legacy ty) + >>=? fun (Ex_ty t, ctxt) -> + parse_data ctxt ~legacy t data + >>=? fun (data, ctxt) -> + unparse_data ctxt mode t data + >>=? fun (data, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) + >>=? fun ctxt -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) | Seq (loc, items) -> fold_left_s (fun (l, ctxt) item -> - unparse_code ctxt mode item >>=? fun (item, ctxt) -> - return (item :: l, ctxt)) - ([], ctxt) items >>=? fun (items, ctxt) -> - Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt -> - return (Micheline.Seq (loc, List.rev items), ctxt) + unparse_code ctxt mode item + >>=? fun (item, ctxt) -> return (item :: l, ctxt)) + ([], ctxt) + items + >>=? fun (items, ctxt) -> + Lwt.return + (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) + >>=? fun ctxt -> return (Micheline.Seq (loc, List.rev items), ctxt) | Prim (loc, prim, items, annot) -> fold_left_s (fun (l, ctxt) item -> - unparse_code ctxt mode item >>=? fun (item, ctxt) -> - return (item :: l, ctxt)) - ([], ctxt) items >>=? fun (items, ctxt) -> - Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt -> - return (Prim (loc, prim, List.rev items, annot), ctxt) - | Int _ | String _ | Bytes _ as atom -> return (atom, ctxt) + unparse_code ctxt mode item + >>=? fun (item, ctxt) -> return (item :: l, ctxt)) + ([], ctxt) + items + >>=? fun (items, ctxt) -> + Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) + >>=? fun ctxt -> return (Prim (loc, prim, List.rev items, annot), ctxt) + | (Int _ | String _ | Bytes _) as atom -> + return (atom, ctxt) (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) -let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type ; root_name } = - let Lam (_, original_code) = code in - unparse_code ctxt mode original_code >>=? fun (code, ctxt) -> - unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) -> - unparse_ty ctxt arg_type >>=? fun (arg_type, ctxt) -> - unparse_ty ctxt storage_type >>=? fun (storage_type, ctxt) -> - let arg_type = add_field_annot (Option.map ~f:(fun n -> `Field_annot n) root_name) None arg_type in +let unparse_script ctxt mode {code; arg_type; storage; storage_type; root_name} + = + let (Lam (_, original_code)) = code in + unparse_code ctxt mode original_code + >>=? fun (code, ctxt) -> + unparse_data ctxt mode storage_type storage + >>=? fun (storage, ctxt) -> + unparse_ty ctxt arg_type + >>=? fun (arg_type, ctxt) -> + unparse_ty ctxt storage_type + >>=? fun (storage_type, ctxt) -> + let arg_type = + add_field_annot + (Option.map ~f:(fun n -> `Field_annot n) root_name) + None + arg_type + in let open Micheline in let code = - Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ; - Prim (-1, K_storage, [ storage_type ], []) ; - Prim (-1, K_code, [ code ], []) ]) in + Seq + ( -1, + [ Prim (-1, K_parameter, [arg_type], []); + Prim (-1, K_storage, [storage_type], []); + Prim (-1, K_code, [code], []) ] ) + in Lwt.return - (Gas.consume ctxt (Unparse_costs.seq_cost 3) >>? fun ctxt -> - Gas.consume ctxt (Unparse_costs.prim_cost 1 []) >>? fun ctxt -> - Gas.consume ctxt (Unparse_costs.prim_cost 1 []) >>? fun ctxt -> - Gas.consume ctxt (Unparse_costs.prim_cost 1 [])) >>=? fun ctxt -> - return ({ code = lazy_expr (strip_locations code) ; - storage = lazy_expr (strip_locations storage) }, ctxt) + ( Gas.consume ctxt (Unparse_costs.seq_cost 3) + >>? fun ctxt -> + Gas.consume ctxt (Unparse_costs.prim_cost 1 []) + >>? fun ctxt -> + Gas.consume ctxt (Unparse_costs.prim_cost 1 []) + >>? fun ctxt -> Gas.consume ctxt (Unparse_costs.prim_cost 1 []) ) + >>=? fun ctxt -> + return + ( { + code = lazy_expr (strip_locations code); + storage = lazy_expr (strip_locations storage); + }, + ctxt ) let pack_data ctxt typ data = - unparse_data ctxt Optimized typ data >>=? fun (unparsed, ctxt) -> - let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in - Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt -> - let bytes = MBytes.concat "" [ MBytes.of_string "\005" ; bytes ] in - Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt -> - return (bytes, ctxt) + unparse_data ctxt Optimized typ data + >>=? fun (unparsed, ctxt) -> + let bytes = + Data_encoding.Binary.to_bytes_exn + expr_encoding + (Micheline.strip_locations unparsed) + in + Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) + >>=? fun ctxt -> + let bytes = MBytes.concat "" [MBytes.of_string "\005"; bytes] in + Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) + >>=? fun ctxt -> return (bytes, ctxt) let hash_data ctxt typ data = - pack_data ctxt typ data >>=? fun (bytes, ctxt) -> - Lwt.return @@ Gas.consume ctxt - (Michelson_v1_gas.Cost_of.Legacy.hash bytes Script_expr_hash.size) >>=? fun ctxt -> - return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt) + pack_data ctxt typ data + >>=? fun (bytes, ctxt) -> + Lwt.return + @@ Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Legacy.hash bytes Script_expr_hash.size) + >>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [bytes]), ctxt) (* ---------------- Big map -------------------------------------------------*) let empty_big_map tk tv = - { id = None ; diff = empty_map tk ; key_type = ty_of_comparable_ty tk ; value_type = tv } + { + id = None; + diff = empty_map tk; + key_type = ty_of_comparable_ty tk; + value_type = tv; + } -let big_map_mem ctxt key { id ; diff ; key_type ; _ } = - match map_get key diff, id with - | None, None -> return (false, ctxt) - | None, Some id -> hash_data ctxt key_type key >>=? fun (hash, ctxt) -> - Alpha_context.Big_map.mem ctxt id hash >>=? fun (ctxt, res) -> - return (res, ctxt) - | Some None, _ -> return (false, ctxt) - | Some (Some _), _ -> return (true, ctxt) +let big_map_mem ctxt key {id; diff; key_type; _} = + match (map_get key diff, id) with + | (None, None) -> + return (false, ctxt) + | (None, Some id) -> + hash_data ctxt key_type key + >>=? fun (hash, ctxt) -> + Alpha_context.Big_map.mem ctxt id hash + >>=? fun (ctxt, res) -> return (res, ctxt) + | (Some None, _) -> + return (false, ctxt) + | (Some (Some _), _) -> + return (true, ctxt) -let big_map_get ctxt key { id ; diff ; key_type ; value_type } = - match map_get key diff, id with - | Some x, _ -> return (x, ctxt) - | None, None -> return (None, ctxt) - | None, Some id -> - hash_data ctxt key_type key >>=? fun (hash, ctxt) -> - Alpha_context.Big_map.get_opt - ctxt id hash >>=? begin function - | (ctxt, None) -> return (None, ctxt) - | (ctxt, Some value) -> - parse_data ctxt ~legacy:true value_type - (Micheline.root value) >>=? fun (x, ctxt) -> - return (Some x, ctxt) - end +let big_map_get ctxt key {id; diff; key_type; value_type} = + match (map_get key diff, id) with + | (Some x, _) -> + return (x, ctxt) + | (None, None) -> + return (None, ctxt) + | (None, Some id) -> ( + hash_data ctxt key_type key + >>=? fun (hash, ctxt) -> + Alpha_context.Big_map.get_opt ctxt id hash + >>=? function + | (ctxt, None) -> + return (None, ctxt) + | (ctxt, Some value) -> + parse_data ctxt ~legacy:true value_type (Micheline.root value) + >>=? fun (x, ctxt) -> return (Some x, ctxt) ) -let big_map_update key value ({ diff ; _ } as map) = - { map with diff = map_set key value diff } +let big_map_update key value ({diff; _} as map) = + {map with diff = map_set key value diff} module Ids = Set.Make (Compare.Z) @@ -3873,15 +5802,18 @@ type big_map_ids = Ids.t let no_big_map_id = Ids.empty -let diff_of_big_map ctxt fresh mode ~ids { id ; key_type ; value_type ; diff } = - Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff)) >>=? fun ctxt -> - begin match id with - | Some id -> - if Ids.mem id ids then - fresh ctxt >>=? fun (ctxt, duplicate) -> - return (ctxt, [ Contract.Copy (id, duplicate) ], duplicate) - else - (* The first occurence encountered of a big_map reuses the +let diff_of_big_map ctxt fresh mode ~ids {id; key_type; value_type; diff} = + Lwt.return + (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff)) + >>=? fun ctxt -> + ( match id with + | Some id -> + if Ids.mem id ids then + fresh ctxt + >>=? fun (ctxt, duplicate) -> + return (ctxt, [Contract.Copy (id, duplicate)], duplicate) + else + (* The first occurence 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 @@ -3889,171 +5821,277 @@ let diff_of_big_map ctxt fresh mode ~ids { id ; key_type ; value_type ; diff } = this diff first in the accumulator of `extract_big_map_updates`, and this accumulator is not reversed before being flattened. *) - return (ctxt, [], id) - | None -> - fresh ctxt >>=? fun (ctxt, id) -> - unparse_ty ctxt key_type >>=? fun (kt, ctxt) -> - unparse_ty ctxt value_type >>=? fun (kv, ctxt) -> - return (ctxt, [ Contract.Alloc { big_map = id ; - key_type = Micheline.strip_locations kt ; - value_type = Micheline.strip_locations kv } ], id) - end >>=? fun (ctxt, init, big_map) -> + return (ctxt, [], id) + | None -> + fresh ctxt + >>=? fun (ctxt, id) -> + unparse_ty ctxt key_type + >>=? fun (kt, ctxt) -> + unparse_ty ctxt value_type + >>=? fun (kv, ctxt) -> + return + ( ctxt, + [ Contract.Alloc + { + big_map = id; + key_type = Micheline.strip_locations kt; + value_type = Micheline.strip_locations kv; + } ], + id ) ) + >>=? fun (ctxt, init, big_map) -> let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in fold_left_s (fun (acc, ctxt) (key, value) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> - hash_data ctxt key_type key >>=? fun (diff_key_hash, ctxt) -> - unparse_data ctxt mode key_type key >>=? fun (key_node, ctxt) -> - let diff_key = Micheline.strip_locations key_node in - begin - match value with - | None -> return (None, ctxt) - | Some x -> - begin - unparse_data ctxt mode value_type x >>=? fun (node, ctxt) -> - return (Some (Micheline.strip_locations node), ctxt) - end - end >>=? fun (diff_value, ctxt) -> - let diff_item = Contract.Update { big_map ; diff_key ; diff_key_hash ; diff_value } in - return (diff_item :: acc, ctxt)) - ([], ctxt) pairs >>=? fun (diff, ctxt) -> - return (init @ diff, big_map, ctxt) + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) + >>=? fun ctxt -> + hash_data ctxt key_type key + >>=? fun (diff_key_hash, ctxt) -> + unparse_data ctxt mode key_type key + >>=? fun (key_node, ctxt) -> + let diff_key = Micheline.strip_locations key_node in + ( match value with + | None -> + return (None, ctxt) + | Some x -> + unparse_data ctxt mode value_type x + >>=? fun (node, ctxt) -> + return (Some (Micheline.strip_locations node), ctxt) ) + >>=? fun (diff_value, ctxt) -> + let diff_item = + Contract.Update {big_map; diff_key; diff_key_hash; diff_value} + in + return (diff_item :: acc, ctxt)) + ([], ctxt) + pairs + >>=? fun (diff, ctxt) -> return (init @ diff, big_map, ctxt) -let rec extract_big_map_updates - : type a. context -> (context -> (context * Big_map.id) tzresult Lwt.t) -> - unparsing_mode -> Ids.t -> Contract.big_map_diff list -> a ty -> a -> - (context * a * Ids.t * Contract.big_map_diff list) tzresult Lwt.t - = fun ctxt fresh mode ids acc ty x -> - match (ty, x) with - | Big_map_t (_, _, _), map -> - diff_of_big_map ctxt fresh mode ids map >>=? fun (diff, id, ctxt) -> - let (module Map) = map.diff in - let map = { map with diff = empty_map Map.key_ty ; id = Some id } in - return (ctxt, map, Ids.add id ids, diff :: acc) - | Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> - extract_big_map_updates ctxt fresh mode ids acc tyl xl >>=? fun (ctxt, xl, ids, acc) -> - extract_big_map_updates ctxt fresh mode ids acc tyr xr >>=? fun (ctxt, xr, ids, acc) -> - return (ctxt, (xl, xr), ids, acc) - | Union_t ((ty, _), (_, _), _, true), L x -> - Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> - extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> - return (ctxt, L x, ids, acc) - | Union_t ((_, _), (ty, _), _, true), R x -> - Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> - extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> - return (ctxt, R x, ids, acc) - | Option_t (ty, _, true), Some x -> - Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> - extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> - return (ctxt, Some x, ids, acc) - | List_t (ty, _, true), l -> - fold_left_s - (fun (ctxt, l, ids, acc) x -> - Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> - extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> - return (ctxt, x :: l, ids, acc)) - (ctxt, [], ids, acc) l >>=? fun (ctxt, l, ids, acc) -> - return (ctxt, List.rev l, ids, acc) - | Map_t (_, ty, _, true), ((module M) as m) -> - Lwt.return (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m)) >>=? fun ctxt -> - fold_left_s - (fun (ctxt, m, ids, acc) (k, x) -> - Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> - extract_big_map_updates ctxt fresh mode ids acc ty x >>=? fun (ctxt, x, ids, acc) -> - return (ctxt, M.OPS.add k x m, ids, acc)) - (ctxt, M.OPS.empty, ids, acc) (M.OPS.bindings (fst M.boxed)) >>=? fun (ctxt, m, ids, acc) -> - let module M = struct - module OPS = M.OPS - type key = M.key - type value = M.value - let key_ty = M.key_ty - let boxed = m, (snd M.boxed) - end in - return (ctxt, (module M : Boxed_map with type key = M.key and type value = M.value), ids, acc) - | Option_t (_, _, true), None -> return (ctxt, None, ids, acc) - | List_t (_, _, false), v -> return (ctxt, v, ids, acc) - | Map_t (_, _, _, false), v -> return (ctxt, v, ids, acc) - | Option_t (_, _, false), None -> return (ctxt, None, ids, acc) - | Pair_t (_, _, _, false), v -> return (ctxt, v, ids, acc) - | Union_t (_, _, _, false), v -> return (ctxt, v, ids, acc) - | Option_t (_, _, false), v -> return (ctxt, v, ids, acc) - | Chain_id_t _, v -> return (ctxt, v, ids, acc) - | Set_t (_, _), v -> return (ctxt, v, ids, acc) - | Unit_t _, v -> return (ctxt, v, ids, acc) - | Int_t _, v -> return (ctxt, v, ids, acc) - | Nat_t _, v -> return (ctxt, v, ids, acc) - | Signature_t _, v -> return (ctxt, v, ids, acc) - | String_t _, v -> return (ctxt, v, ids, acc) - | Bytes_t _, v -> return (ctxt, v, ids, acc) - | Mutez_t _, v -> return (ctxt, v, ids, acc) - | Key_hash_t _, v -> return (ctxt, v, ids, acc) - | Key_t _, v -> return (ctxt, v, ids, acc) - | Timestamp_t _, v -> return (ctxt, v, ids, acc) - | Address_t _, v -> return (ctxt, v, ids, acc) - | Bool_t _, v -> return (ctxt, v, ids, acc) - | Lambda_t (_, _, _), v -> return (ctxt, v, ids, acc) - | Contract_t (_, _), v -> return (ctxt, v, ids, acc) - | Operation_t _, _ -> assert false (* called only on parameters and storage, which cannot contain operations *) +let rec extract_big_map_updates : + type a. + context -> + (context -> (context * Big_map.id) tzresult Lwt.t) -> + unparsing_mode -> + Ids.t -> + Contract.big_map_diff list -> + a ty -> + a -> + (context * a * Ids.t * Contract.big_map_diff list) tzresult Lwt.t = + fun ctxt fresh mode ids acc ty x -> + match (ty, x) with + | (Big_map_t (_, _, _), map) -> + diff_of_big_map ctxt fresh mode ids map + >>=? fun (diff, id, ctxt) -> + let (module Map) = map.diff in + let map = {map with diff = empty_map Map.key_ty; id = Some id} in + return (ctxt, map, Ids.add id ids, diff :: acc) + | (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) + >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc tyl xl + >>=? fun (ctxt, xl, ids, acc) -> + extract_big_map_updates ctxt fresh mode ids acc tyr xr + >>=? fun (ctxt, xr, ids, acc) -> return (ctxt, (xl, xr), ids, acc) + | (Union_t ((ty, _), (_, _), _, true), L x) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) + >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x + >>=? fun (ctxt, x, ids, acc) -> return (ctxt, L x, ids, acc) + | (Union_t ((_, _), (ty, _), _, true), R x) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) + >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x + >>=? fun (ctxt, x, ids, acc) -> return (ctxt, R x, ids, acc) + | (Option_t (ty, _, true), Some x) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) + >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x + >>=? fun (ctxt, x, ids, acc) -> return (ctxt, Some x, ids, acc) + | (List_t (ty, _, true), l) -> + fold_left_s + (fun (ctxt, l, ids, acc) x -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) + >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x + >>=? fun (ctxt, x, ids, acc) -> return (ctxt, x :: l, ids, acc)) + (ctxt, [], ids, acc) + l + >>=? fun (ctxt, l, ids, acc) -> return (ctxt, List.rev l, ids, acc) + | (Map_t (_, ty, _, true), ((module M) as m)) -> + Lwt.return + (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m)) + >>=? fun ctxt -> + fold_left_s + (fun (ctxt, m, ids, acc) (k, x) -> + Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) + >>=? fun ctxt -> + extract_big_map_updates ctxt fresh mode ids acc ty x + >>=? fun (ctxt, x, ids, acc) -> + return (ctxt, M.OPS.add k x m, ids, acc)) + (ctxt, M.OPS.empty, ids, acc) + (M.OPS.bindings (fst M.boxed)) + >>=? fun (ctxt, m, ids, acc) -> + let module M = struct + module OPS = M.OPS + + type key = M.key + + type value = M.value + + let key_ty = M.key_ty + + let boxed = (m, snd M.boxed) + end in + return + ( ctxt, + (module M : Boxed_map with type key = M.key and type value = M.value), + ids, + acc ) + | (Option_t (_, _, true), None) -> + return (ctxt, None, ids, acc) + | (List_t (_, _, false), v) -> + return (ctxt, v, ids, acc) + | (Map_t (_, _, _, false), v) -> + return (ctxt, v, ids, acc) + | (Option_t (_, _, false), None) -> + return (ctxt, None, ids, acc) + | (Pair_t (_, _, _, false), v) -> + return (ctxt, v, ids, acc) + | (Union_t (_, _, _, false), v) -> + return (ctxt, v, ids, acc) + | (Option_t (_, _, false), v) -> + return (ctxt, v, ids, acc) + | (Chain_id_t _, v) -> + return (ctxt, v, ids, acc) + | (Set_t (_, _), v) -> + return (ctxt, v, ids, acc) + | (Unit_t _, v) -> + return (ctxt, v, ids, acc) + | (Int_t _, v) -> + return (ctxt, v, ids, acc) + | (Nat_t _, v) -> + return (ctxt, v, ids, acc) + | (Signature_t _, v) -> + return (ctxt, v, ids, acc) + | (String_t _, v) -> + return (ctxt, v, ids, acc) + | (Bytes_t _, v) -> + return (ctxt, v, ids, acc) + | (Mutez_t _, v) -> + return (ctxt, v, ids, acc) + | (Key_hash_t _, v) -> + return (ctxt, v, ids, acc) + | (Key_t _, v) -> + return (ctxt, v, ids, acc) + | (Timestamp_t _, v) -> + return (ctxt, v, ids, acc) + | (Address_t _, v) -> + return (ctxt, v, ids, acc) + | (Bool_t _, v) -> + return (ctxt, v, ids, acc) + | (Lambda_t (_, _, _), v) -> + return (ctxt, v, ids, acc) + | (Contract_t (_, _), v) -> + return (ctxt, v, ids, acc) + | (Operation_t _, _) -> + assert false + +(* called only on parameters and storage, which cannot contain operations *) let collect_big_maps ctxt ty x = - let rec collect - : type a. context -> a ty -> a -> Ids.t -> (Ids.t * context) tzresult - = fun ctxt ty x acc -> - match (ty, x) with - | Big_map_t (_, _, _), { id = Some id } -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - ok (Ids.add id acc, ctxt) - | Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr) -> - collect ctxt tyl xl acc >>? fun (acc, ctxt) -> - collect ctxt tyr xr acc - | Union_t ((ty, _), (_, _), _, true), L x -> - collect ctxt ty x acc - | Union_t ((_, _), (ty, _), _, true), R x -> - collect ctxt ty x acc - | Option_t (ty, _, true), Some x -> - collect ctxt ty x acc - | List_t (ty, _, true), l -> - List.fold_left (fun acc x -> acc >>? fun (acc, ctxt) -> collect ctxt ty x acc) (ok (acc, ctxt)) l - | Map_t (_, ty, _, true), m -> - map_fold (fun _ v acc -> acc >>? fun (acc, ctxt) -> collect ctxt ty v acc) m (ok (acc, ctxt)) - | List_t (_, _, false), _ -> ok (acc, ctxt) - | Map_t (_, _, _, false), _ -> ok (acc, ctxt) - | Big_map_t (_, _, _), { id = None } -> ok (acc, ctxt) - | Option_t (_, _, true), None -> ok (acc, ctxt) - | Option_t (_, _, false), _ -> ok (acc, ctxt) - | Union_t (_, _, _, false), _ -> ok (acc, ctxt) - | Pair_t (_, _, _, false), _ -> ok (acc, ctxt) - | Chain_id_t _, _ -> ok (acc, ctxt) - | Set_t (_, _), _ -> ok (acc, ctxt) - | Unit_t _, _ -> ok (acc, ctxt) - | Int_t _, _ -> ok (acc, ctxt) - | Nat_t _, _ -> ok (acc, ctxt) - | Signature_t _, _ -> ok (acc, ctxt) - | String_t _, _ -> ok (acc, ctxt) - | Bytes_t _, _ -> ok (acc, ctxt) - | Mutez_t _, _ -> ok (acc, ctxt) - | Key_hash_t _, _ -> ok (acc, ctxt) - | Key_t _, _ -> ok (acc, ctxt) - | Timestamp_t _, _ -> ok (acc, ctxt) - | Address_t _, _ -> ok (acc, ctxt) - | Bool_t _, _ -> ok (acc, ctxt) - | Lambda_t (_, _, _), _ -> ok (acc, ctxt) - | Contract_t (_, _), _ -> ok (acc, ctxt) - | Operation_t _, _ -> assert false (* called only on parameters and storage, which cannot contain operations *) in + let rec collect : + type a. context -> a ty -> a -> Ids.t -> (Ids.t * context) tzresult = + fun ctxt ty x acc -> + match (ty, x) with + | (Big_map_t (_, _, _), {id = Some id}) -> + Gas.consume ctxt Typecheck_costs.cycle + >>? fun ctxt -> ok (Ids.add id acc, ctxt) + | (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) -> + collect ctxt tyl xl acc >>? fun (acc, ctxt) -> collect ctxt tyr xr acc + | (Union_t ((ty, _), (_, _), _, true), L x) -> + collect ctxt ty x acc + | (Union_t ((_, _), (ty, _), _, true), R x) -> + collect ctxt ty x acc + | (Option_t (ty, _, true), Some x) -> + collect ctxt ty x acc + | (List_t (ty, _, true), l) -> + List.fold_left + (fun acc x -> acc >>? fun (acc, ctxt) -> collect ctxt ty x acc) + (ok (acc, ctxt)) + l + | (Map_t (_, ty, _, true), m) -> + map_fold + (fun _ v acc -> acc >>? fun (acc, ctxt) -> collect ctxt ty v acc) + m + (ok (acc, ctxt)) + | (List_t (_, _, false), _) -> + ok (acc, ctxt) + | (Map_t (_, _, _, false), _) -> + ok (acc, ctxt) + | (Big_map_t (_, _, _), {id = None}) -> + ok (acc, ctxt) + | (Option_t (_, _, true), None) -> + ok (acc, ctxt) + | (Option_t (_, _, false), _) -> + ok (acc, ctxt) + | (Union_t (_, _, _, false), _) -> + ok (acc, ctxt) + | (Pair_t (_, _, _, false), _) -> + ok (acc, ctxt) + | (Chain_id_t _, _) -> + ok (acc, ctxt) + | (Set_t (_, _), _) -> + ok (acc, ctxt) + | (Unit_t _, _) -> + ok (acc, ctxt) + | (Int_t _, _) -> + ok (acc, ctxt) + | (Nat_t _, _) -> + ok (acc, ctxt) + | (Signature_t _, _) -> + ok (acc, ctxt) + | (String_t _, _) -> + ok (acc, ctxt) + | (Bytes_t _, _) -> + ok (acc, ctxt) + | (Mutez_t _, _) -> + ok (acc, ctxt) + | (Key_hash_t _, _) -> + ok (acc, ctxt) + | (Key_t _, _) -> + ok (acc, ctxt) + | (Timestamp_t _, _) -> + ok (acc, ctxt) + | (Address_t _, _) -> + ok (acc, ctxt) + | (Bool_t _, _) -> + ok (acc, ctxt) + | (Lambda_t (_, _, _), _) -> + ok (acc, ctxt) + | (Contract_t (_, _), _) -> + ok (acc, ctxt) + | (Operation_t _, _) -> + assert false + (* called only on parameters and storage, which cannot contain operations *) + in Lwt.return (collect ctxt ty x no_big_map_id) -let extract_big_map_diff ctxt mode - ~temporary ~to_duplicate ~to_update - ty v = +let extract_big_map_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v = let to_duplicate = Ids.diff to_duplicate to_update in - let fresh = if temporary then (fun c -> return (Big_map.fresh_temporary c)) else Big_map.fresh in - extract_big_map_updates ctxt fresh mode to_duplicate [] ty v >>=? fun (ctxt, v, alive, diffs) -> - let diffs = if temporary then diffs else + let fresh = + if temporary then fun c -> return (Big_map.fresh_temporary c) + else Big_map.fresh + in + extract_big_map_updates ctxt fresh mode to_duplicate [] ty v + >>=? fun (ctxt, v, alive, diffs) -> + let diffs = + if temporary then diffs + else let dead = Ids.diff to_update alive in - Ids.fold (fun id acc -> Contract.Clear id :: acc) dead [] :: diffs in + Ids.fold (fun id acc -> Contract.Clear id :: acc) dead [] :: diffs + in match diffs with - | [] -> return (v, None, ctxt) - | diffs -> return (v, Some (List.flatten diffs (* do not reverse *)), ctxt) + | [] -> + return (v, None, ctxt) + | diffs -> + return (v, Some (List.flatten diffs (* do not reverse *)), ctxt) let list_of_big_map_ids ids = Ids.elements ids diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli index 4781e86ef..af93ffdb5 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_ir_translator.mli @@ -28,160 +28,248 @@ open Script_tc_errors type ('ta, 'tb) eq = Eq : ('same, 'same) eq -type ex_comparable_ty = Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> ex_comparable_ty +type ex_comparable_ty = + | Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> ex_comparable_ty + type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty + type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty + type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script + type tc_context = | Lambda : tc_context | Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context - | Toplevel : { storage_type : 'sto Script_typed_ir.ty ; - param_type : 'param Script_typed_ir.ty ; - root_name : string option ; - legacy_create_contract_literal : bool } -> tc_context + | Toplevel : { + storage_type : 'sto Script_typed_ir.ty; + param_type : 'param Script_typed_ir.ty; + root_name : string option; + legacy_create_contract_literal : bool; + } + -> tc_context + type 'bef judgement = | Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement - | Failed : - { descr : 'aft. 'aft Script_typed_ir.stack_ty -> ('bef, 'aft) Script_typed_ir.descr } -> 'bef judgement + | Failed : { + descr : + 'aft. 'aft Script_typed_ir.stack_ty -> + ('bef, 'aft) Script_typed_ir.descr; + } + -> 'bef judgement type unparsing_mode = Optimized | Readable type type_logger = - int -> (Script.expr * Script.annot) list -> (Script.expr * Script.annot) list -> unit + int -> + (Script.expr * Script.annot) list -> + (Script.expr * Script.annot) list -> + unit (* ---- Sets and Maps -------------------------------------------------------*) val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set + val set_fold : - ('elt -> 'acc -> 'acc) -> - 'elt Script_typed_ir.set -> 'acc -> 'acc + ('elt -> 'acc -> 'acc) -> 'elt Script_typed_ir.set -> 'acc -> 'acc + val set_update : 'a -> bool -> 'a Script_typed_ir.set -> 'a Script_typed_ir.set + val set_mem : 'elt -> 'elt Script_typed_ir.set -> bool + val set_size : 'elt Script_typed_ir.set -> Script_int.n Script_int.num -val empty_map : 'a Script_typed_ir.comparable_ty -> ('a, 'b) Script_typed_ir.map +val empty_map : + 'a Script_typed_ir.comparable_ty -> ('a, 'b) Script_typed_ir.map + val map_fold : ('key -> 'value -> 'acc -> 'acc) -> - ('key, 'value) Script_typed_ir.map -> 'acc -> 'acc -val map_update : - 'a -> 'b option -> ('a, 'b) Script_typed_ir.map -> ('a, 'b) Script_typed_ir.map -val map_mem : 'key -> ('key, 'value) Script_typed_ir.map -> bool -val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option -val map_key_ty : ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty -val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num + ('key, 'value) Script_typed_ir.map -> + 'acc -> + 'acc -val empty_big_map : 'a Script_typed_ir.comparable_ty -> 'b Script_typed_ir.ty -> ('a, 'b) Script_typed_ir.big_map -val big_map_mem : - context -> 'key -> - ('key, 'value) Script_typed_ir.big_map -> - (bool * context) tzresult Lwt.t -val big_map_get : - context -> 'key -> - ('key, 'value) Script_typed_ir.big_map -> - ('value option * context) tzresult Lwt.t -val big_map_update : - 'key -> 'value option -> ('key, 'value) Script_typed_ir.big_map -> - ('key, 'value) Script_typed_ir.big_map +val map_update : + 'a -> + 'b option -> + ('a, 'b) Script_typed_ir.map -> + ('a, 'b) Script_typed_ir.map val has_big_map : 't Script_typed_ir.ty -> bool +val ty_of_comparable_ty : ('a, 's) Script_typed_ir.comparable_struct -> 'a Script_typed_ir.ty +val map_mem : 'key -> ('key, 'value) Script_typed_ir.map -> bool + +val map_get : 'key -> ('key, 'value) Script_typed_ir.map -> 'value option + +val map_key_ty : + ('a, 'b) Script_typed_ir.map -> 'a Script_typed_ir.comparable_ty + +val map_size : ('a, 'b) Script_typed_ir.map -> Script_int.n Script_int.num + +val empty_big_map : + 'a Script_typed_ir.comparable_ty -> + 'b Script_typed_ir.ty -> + ('a, 'b) Script_typed_ir.big_map + +val big_map_mem : + context -> + 'key -> + ('key, 'value) Script_typed_ir.big_map -> + (bool * context) tzresult Lwt.t + +val big_map_get : + context -> + 'key -> + ('key, 'value) Script_typed_ir.big_map -> + ('value option * context) tzresult Lwt.t + +val big_map_update : + 'key -> + 'value option -> + ('key, 'value) Script_typed_ir.big_map -> + ('key, 'value) Script_typed_ir.big_map val ty_eq : context -> - 'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty -> + 'ta Script_typed_ir.ty -> + 'tb Script_typed_ir.ty -> (('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult val compare_comparable : 'a Script_typed_ir.comparable_ty -> 'a -> 'a -> int -val ty_of_comparable_ty : ('a, 's) Script_typed_ir.comparable_struct -> 'a Script_typed_ir.ty - val parse_data : - ?type_logger: type_logger -> - context -> legacy: bool -> - 'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t + ?type_logger:type_logger -> + context -> + legacy:bool -> + 'a Script_typed_ir.ty -> + Script.node -> + ('a * context) tzresult Lwt.t + val unparse_data : - context -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a -> + context -> + unparsing_mode -> + 'a Script_typed_ir.ty -> + 'a -> (Script.node * context) tzresult Lwt.t val parse_instr : - ?type_logger: type_logger -> - tc_context -> context -> legacy: bool -> - Script.node -> 'bef Script_typed_ir.stack_ty -> ('bef judgement * context) tzresult Lwt.t + ?type_logger:type_logger -> + tc_context -> + context -> + legacy:bool -> + Script.node -> + 'bef Script_typed_ir.stack_ty -> + ('bef judgement * context) tzresult Lwt.t val parse_ty : - context -> legacy: bool -> - allow_big_map: bool -> - allow_operation: bool -> - allow_contract: bool -> - Script.node -> (ex_ty * context) tzresult + context -> + legacy:bool -> + allow_big_map:bool -> + allow_operation:bool -> + allow_contract:bool -> + Script.node -> + (ex_ty * context) tzresult val parse_packable_ty : - context -> legacy: bool -> Script.node -> (ex_ty * context) tzresult + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult val unparse_ty : context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t val parse_toplevel : - legacy: bool -> Script.expr -> (Script.node * Script.node * Script.node * string option) tzresult + legacy:bool -> + Script.expr -> + (Script.node * Script.node * Script.node * string option) tzresult val add_field_annot : - [ `Field_annot of string ] option -> [ `Var_annot of string ] option -> Script.node -> Script.node + [`Field_annot of string] option -> + [`Var_annot of string] option -> + Script.node -> + Script.node val typecheck_code : context -> Script.expr -> (type_map * context) tzresult Lwt.t val typecheck_data : - ?type_logger: type_logger -> - context -> Script.expr * Script.expr -> context tzresult Lwt.t + ?type_logger:type_logger -> + context -> + Script.expr * Script.expr -> + context tzresult Lwt.t val parse_script : - ?type_logger: type_logger -> - context -> legacy: bool -> Script.t -> (ex_script * context) tzresult Lwt.t + ?type_logger:type_logger -> + context -> + legacy:bool -> + Script.t -> + (ex_script * context) tzresult Lwt.t (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) val unparse_script : - context -> unparsing_mode -> - ('a, 'b) Script_typed_ir.script -> (Script.t * context) tzresult Lwt.t + context -> + unparsing_mode -> + ('a, 'b) Script_typed_ir.script -> + (Script.t * context) tzresult Lwt.t val parse_contract : - legacy: bool -> context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> - entrypoint: string -> + legacy:bool -> + context -> + Script.location -> + 'a Script_typed_ir.ty -> + Contract.t -> + entrypoint:string -> (context * 'a Script_typed_ir.typed_contract) tzresult Lwt.t val parse_contract_for_script : - legacy: bool -> context -> Script.location -> 'a Script_typed_ir.ty -> Contract.t -> - entrypoint: string -> + legacy:bool -> + context -> + Script.location -> + 'a Script_typed_ir.ty -> + Contract.t -> + entrypoint:string -> (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t val find_entrypoint : - 't Script_typed_ir.ty -> root_name: string option -> string -> ((Script.node -> Script.node) * ex_ty) tzresult + 't Script_typed_ir.ty -> + root_name:string option -> + string -> + ((Script.node -> Script.node) * ex_ty) tzresult module Entrypoints_map : S.MAP with type key = string val list_entrypoints : 't Script_typed_ir.ty -> context -> - root_name: string option -> - (Michelson_v1_primitives.prim list list * - (Michelson_v1_primitives.prim list * Script.node) Entrypoints_map.t) - tzresult + root_name:string option -> + ( Michelson_v1_primitives.prim list list + * (Michelson_v1_primitives.prim list * Script.node) Entrypoints_map.t ) + tzresult -val pack_data : context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t -val hash_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script_expr_hash.t * context) tzresult Lwt.t +val pack_data : + context -> 'a Script_typed_ir.ty -> 'a -> (MBytes.t * context) tzresult Lwt.t + +val hash_data : + context -> + 'a Script_typed_ir.ty -> + 'a -> + (Script_expr_hash.t * context) tzresult Lwt.t type big_map_ids val no_big_map_id : big_map_ids val collect_big_maps : - context -> 'a Script_typed_ir.ty -> 'a -> (big_map_ids * context) tzresult Lwt.t + context -> + 'a Script_typed_ir.ty -> + 'a -> + (big_map_ids * context) tzresult Lwt.t val list_of_big_map_ids : big_map_ids -> Z.t list val extract_big_map_diff : - context -> unparsing_mode -> - temporary: bool -> - to_duplicate: big_map_ids -> - to_update: big_map_ids -> - 'a Script_typed_ir.ty -> 'a -> + context -> + unparsing_mode -> + temporary:bool -> + to_duplicate:big_map_ids -> + to_update:big_map_ids -> + 'a Script_typed_ir.ty -> + 'a -> ('a * Contract.big_map_diff option * context) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml index 81effec8f..f00b6d0b3 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.ml @@ -35,8 +35,6 @@ type lazy_expr = expr Data_encoding.lazy_t type node = (location, Michelson_v1_primitives.prim) Micheline.node - - let expr_encoding = Micheline.canonical_encoding_v1 ~variant:"michelson_v1" @@ -45,60 +43,57 @@ let expr_encoding = type error += Lazy_script_decode (* `Permanent *) let () = - register_error_kind `Permanent + register_error_kind + `Permanent ~id:"invalid_binary_format" ~title:"Invalid binary format" - ~description:"Could not deserialize some piece of data \ - from its binary representation" + ~description: + "Could not deserialize some piece of data from its binary representation" Data_encoding.empty (function Lazy_script_decode -> Some () | _ -> None) (fun () -> Lazy_script_decode) -let lazy_expr_encoding = - Data_encoding.lazy_encoding expr_encoding +let lazy_expr_encoding = Data_encoding.lazy_encoding expr_encoding -let lazy_expr expr = - Data_encoding.make_lazy expr_encoding expr +let lazy_expr expr = Data_encoding.make_lazy expr_encoding expr -type t = { - code : lazy_expr ; - storage : lazy_expr ; -} +type t = {code : lazy_expr; storage : lazy_expr} let encoding = let open Data_encoding in - def "scripted.contracts" @@ - conv - (fun { code ; storage } -> (code, storage)) - (fun (code, storage) -> { code ; storage }) - (obj2 - (req "code" lazy_expr_encoding) - (req "storage" lazy_expr_encoding)) + def "scripted.contracts" + @@ conv + (fun {code; storage} -> (code, storage)) + (fun (code, storage) -> {code; storage}) + (obj2 (req "code" lazy_expr_encoding) (req "storage" lazy_expr_encoding)) + +let int_node_size_of_numbits n = (1, 1 + ((n + 63) / 64)) + +let int_node_size n = int_node_size_of_numbits (Z.numbits n) + +let string_node_size_of_length s = (1, 1 + ((s + 7) / 8)) + +let string_node_size s = string_node_size_of_length (String.length s) -let int_node_size_of_numbits n = - (1, 1 + (n + 63) / 64) -let int_node_size n = - int_node_size_of_numbits (Z.numbits n) -let string_node_size_of_length s = - (1, 1 + (s + 7) / 8) -let string_node_size s = - string_node_size_of_length (String.length s) let bytes_node_size_of_length s = (* approx cost of indirection to the C heap *) - (2, 1 + (s + 7) / 8 + 12) -let bytes_node_size s = - bytes_node_size_of_length (MBytes.length s) + (2, 1 + ((s + 7) / 8) + 12) + +let bytes_node_size s = bytes_node_size_of_length (MBytes.length s) + let prim_node_size_nonrec_of_lengths n_args annots = - let annots_length = List.fold_left (fun acc s -> acc + String.length s) 0 annots in - if Compare.Int.(annots_length = 0) then - (1 + n_args, 2 + 2 * n_args) - else - (2 + n_args, 4 + 2 * n_args + (annots_length + 7) / 8) + let annots_length = + List.fold_left (fun acc s -> acc + String.length s) 0 annots + in + if Compare.Int.(annots_length = 0) then (1 + n_args, 2 + (2 * n_args)) + else (2 + n_args, 4 + (2 * n_args) + ((annots_length + 7) / 8)) + let prim_node_size_nonrec args annots = let n_args = List.length args in prim_node_size_nonrec_of_lengths n_args annots -let seq_node_size_nonrec_of_length n_args = - (1 + n_args, 2 + 2 * n_args) + +let seq_node_size_nonrec_of_length n_args = (1 + n_args, 2 + (2 * n_args)) + let seq_node_size_nonrec args = let n_args = List.length args in seq_node_size_nonrec_of_length n_args @@ -106,53 +101,64 @@ let seq_node_size_nonrec args = let rec node_size node = let open Micheline in match node with - | Int (_, n) -> int_node_size n - | String (_, s) -> string_node_size s - | Bytes (_, s) -> bytes_node_size s + | Int (_, n) -> + int_node_size n + | String (_, s) -> + string_node_size s + | Bytes (_, s) -> + bytes_node_size s | Prim (_, _, args, annot) -> List.fold_left (fun (blocks, words) node -> - let (nblocks, nwords) = node_size node in - (blocks + nblocks, words + nwords)) + let (nblocks, nwords) = node_size node in + (blocks + nblocks, words + nwords)) (prim_node_size_nonrec args annot) args | Seq (_, args) -> List.fold_left (fun (blocks, words) node -> - let (nblocks, nwords) = node_size node in - (blocks + nblocks, words + nwords)) + let (nblocks, nwords) = node_size node in + (blocks + nblocks, words + nwords)) (seq_node_size_nonrec args) args -let expr_size expr = - node_size (Micheline.root expr) +let expr_size expr = node_size (Micheline.root expr) let traversal_cost node = - let blocks, _words = node_size node in + let (blocks, _words) = node_size node in Gas_limit_repr.step_cost blocks let cost_of_size (blocks, words) = let open Gas_limit_repr in - ((Compare.Int.max 0 (blocks - 1)) *@ alloc_cost 0) +@ - alloc_cost words +@ - step_cost blocks + (Compare.Int.max 0 (blocks - 1) *@ alloc_cost 0) + +@ alloc_cost words +@ step_cost blocks -let node_cost node = - cost_of_size (node_size node) +let node_cost node = cost_of_size (node_size node) let int_node_cost n = cost_of_size (int_node_size n) -let int_node_cost_of_numbits n = cost_of_size (int_node_size_of_numbits n) -let string_node_cost s = cost_of_size (string_node_size s) -let string_node_cost_of_length s = cost_of_size (string_node_size_of_length s) -let bytes_node_cost s = cost_of_size (bytes_node_size s) -let bytes_node_cost_of_length s = cost_of_size (bytes_node_size_of_length s) -let prim_node_cost_nonrec args annot = cost_of_size (prim_node_size_nonrec args annot) -let prim_node_cost_nonrec_of_length n_args annot = cost_of_size (prim_node_size_nonrec_of_lengths n_args annot) -let seq_node_cost_nonrec args = cost_of_size (seq_node_size_nonrec args) -let seq_node_cost_nonrec_of_length n_args = cost_of_size (seq_node_size_nonrec_of_length n_args) -let deserialized_cost expr = - cost_of_size (expr_size expr) +let int_node_cost_of_numbits n = cost_of_size (int_node_size_of_numbits n) + +let string_node_cost s = cost_of_size (string_node_size s) + +let string_node_cost_of_length s = cost_of_size (string_node_size_of_length s) + +let bytes_node_cost s = cost_of_size (bytes_node_size s) + +let bytes_node_cost_of_length s = cost_of_size (bytes_node_size_of_length s) + +let prim_node_cost_nonrec args annot = + cost_of_size (prim_node_size_nonrec args annot) + +let prim_node_cost_nonrec_of_length n_args annot = + cost_of_size (prim_node_size_nonrec_of_lengths n_args annot) + +let seq_node_cost_nonrec args = cost_of_size (seq_node_size_nonrec args) + +let seq_node_cost_nonrec_of_length n_args = + cost_of_size (seq_node_size_nonrec_of_length n_args) + +let deserialized_cost expr = cost_of_size (expr_size expr) let serialized_cost bytes = let open Gas_limit_repr in @@ -164,14 +170,14 @@ let force_decode lexpr = ~fun_value:(fun _ -> false) ~fun_bytes:(fun _ -> true) ~fun_combine:(fun _ _ -> false) - lexpr in + lexpr + in match Data_encoding.force_decode lexpr with | Some v -> - if account_deserialization_cost then - ok (v, deserialized_cost v) - else - ok (v, Gas_limit_repr.free) - | None -> error Lazy_script_decode + if account_deserialization_cost then ok (v, deserialized_cost v) + else ok (v, Gas_limit_repr.free) + | None -> + error Lazy_script_decode let force_bytes expr = let open Gas_limit_repr in @@ -180,14 +186,17 @@ let force_bytes expr = ~fun_value:(fun v -> Some v) ~fun_bytes:(fun _ -> None) ~fun_combine:(fun _ _ -> None) - expr in + expr + in match Data_encoding.force_bytes expr with - | bytes -> - begin match account_serialization_cost with - | Some v -> ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes) - | None -> ok (bytes, Gas_limit_repr.free) - end - | exception _ -> error Lazy_script_decode + | bytes -> ( + match account_serialization_cost with + | Some v -> + ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes) + | None -> + ok (bytes, Gas_limit_repr.free) ) + | exception _ -> + error Lazy_script_decode let minimal_deserialize_cost lexpr = Data_encoding.apply_lazy @@ -199,20 +208,25 @@ let minimal_deserialize_cost lexpr = let unit = Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], [])) -let unit_parameter = - lazy_expr unit +let unit_parameter = lazy_expr unit let is_unit_parameter = let unit_bytes = Data_encoding.force_bytes unit_parameter in Data_encoding.apply_lazy - ~fun_value:(fun v -> match Micheline.root v with Prim (_, Michelson_v1_primitives.D_Unit, [], []) -> true | _ -> false) - ~fun_bytes:(fun b -> MBytes.(=) b unit_bytes) + ~fun_value:(fun v -> + match Micheline.root v with + | Prim (_, Michelson_v1_primitives.D_Unit, [], []) -> + true + | _ -> + false) + ~fun_bytes:(fun b -> MBytes.( = ) b unit_bytes) ~fun_combine:(fun res _ -> res) let rec strip_annotations node = let open Micheline in match node with - | Int (_, _) | String (_, _) | Bytes (_, _) as leaf -> leaf + | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf -> + leaf | Prim (loc, name, args, _) -> Prim (loc, name, List.map strip_annotations args, []) | Seq (loc, args) -> diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli index d44e137e4..514389d20 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_repr.mli @@ -43,25 +43,36 @@ val lazy_expr_encoding : lazy_expr Data_encoding.t val lazy_expr : expr -> lazy_expr -type t = { code : lazy_expr ; storage : lazy_expr } +type t = {code : lazy_expr; storage : lazy_expr} val encoding : t Data_encoding.encoding val deserialized_cost : expr -> Gas_limit_repr.cost val serialized_cost : MBytes.t -> Gas_limit_repr.cost + val traversal_cost : node -> Gas_limit_repr.cost + val node_cost : node -> Gas_limit_repr.cost val int_node_cost : Z.t -> Gas_limit_repr.cost + val int_node_cost_of_numbits : int -> Gas_limit_repr.cost + val string_node_cost : string -> Gas_limit_repr.cost + val string_node_cost_of_length : int -> Gas_limit_repr.cost + val bytes_node_cost : MBytes.t -> Gas_limit_repr.cost + val bytes_node_cost_of_length : int -> Gas_limit_repr.cost + val prim_node_cost_nonrec : expr list -> annot -> Gas_limit_repr.cost + val prim_node_cost_nonrec_of_length : int -> annot -> Gas_limit_repr.cost + val seq_node_cost_nonrec : expr list -> Gas_limit_repr.cost + val seq_node_cost_nonrec_of_length : int -> Gas_limit_repr.cost val force_decode : lazy_expr -> (expr * Gas_limit_repr.cost) tzresult diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml index 3d0e0ea85..0dfeb1e1b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors.ml @@ -26,65 +26,133 @@ open Alpha_context open Script - (* ---- Error definitions ---------------------------------------------------*) (* Auxiliary types for error documentation *) -type namespace = Type_namespace | Constant_namespace | Instr_namespace | Keyword_namespace +type namespace = + | Type_namespace + | Constant_namespace + | Instr_namespace + | Keyword_namespace + type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind + type unparsed_stack_ty = (Script.expr * Script.annot) list + type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list (* Structure errors *) type error += Invalid_arity of Script.location * prim * int * int -type error += Invalid_namespace of Script.location * prim * namespace * namespace + +type error += + | Invalid_namespace of Script.location * prim * namespace * namespace + type error += Invalid_primitive of Script.location * prim list * prim + type error += Invalid_kind of Script.location * kind list * kind + type error += Missing_field of prim + type error += Duplicate_field of Script.location * prim + type error += Unexpected_big_map of Script.location + type error += Unexpected_operation of Script.location + type error += Unexpected_contract of Script.location + type error += No_such_entrypoint of string + type error += Duplicate_entrypoint of string + type error += Unreachable_entrypoint of prim list + type error += Entrypoint_name_too_long of string (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location -type error += Undefined_binop : Script.location * prim * Script.expr * Script.expr -> error + +type error += + | Undefined_binop : + Script.location * prim * Script.expr * Script.expr + -> error + type error += Undefined_unop : Script.location * prim * Script.expr -> error -type error += Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error -type error += Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error -type error += Unmatched_branches : Script.location * unparsed_stack_ty * unparsed_stack_ty -> error + +type error += + | Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error + +type error += + | Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error + +type error += + | Unmatched_branches : + Script.location * unparsed_stack_ty * unparsed_stack_ty + -> error + type error += Self_in_lambda of Script.location + type error += Bad_stack_length + type error += Bad_stack_item of int + type error += Inconsistent_annotations of string * string -type error += Inconsistent_type_annotations : Script.location * Script.expr * Script.expr -> error + +type error += + | Inconsistent_type_annotations : + Script.location * Script.expr * Script.expr + -> error + type error += Inconsistent_field_annotations of string * string + type error += Unexpected_annotation of Script.location + type error += Ungrouped_annotations of Script.location + type error += Invalid_map_body : Script.location * unparsed_stack_ty -> error + type error += Invalid_map_block_fail of Script.location -type error += Invalid_iter_body : Script.location * unparsed_stack_ty * unparsed_stack_ty -> error + +type error += + | Invalid_iter_body : + Script.location * unparsed_stack_ty * unparsed_stack_ty + -> error + type error += Type_too_large : Script.location * int * int -> error (* Value typing errors *) -type error += Invalid_constant : Script.location * Script.expr * Script.expr -> error -type error += Invalid_syntactic_constant : Script.location * Script.expr * string -> error +type error += + | Invalid_constant : Script.location * Script.expr * Script.expr -> error + +type error += + | Invalid_syntactic_constant : + Script.location * Script.expr * string + -> error + type error += Invalid_contract of Script.location * Contract.t + type error += Invalid_big_map of Script.location * Big_map.id -type error += Comparable_type_expected : Script.location * Script.expr -> error + +type error += + | Comparable_type_expected : Script.location * Script.expr -> error + type error += Inconsistent_types : Script.expr * Script.expr -> error + type error += Unordered_map_keys of Script.location * Script.expr + type error += Unordered_set_values of Script.location * Script.expr + type error += Duplicate_map_keys of Script.location * Script.expr + type error += Duplicate_set_values of Script.location * Script.expr (* Toplevel errors *) -type error += Ill_typed_data : string option * Script.expr * Script.expr -> error -type error += Ill_formed_type of string option * Script.expr * Script.location +type error += + | Ill_typed_data : string option * Script.expr * Script.expr -> error + +type error += + | Ill_formed_type of string option * Script.expr * Script.location + type error += Ill_typed_contract : Script.expr * type_map -> error (* Gas related errors *) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml index e8a33c5fe..91ef45d4f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_tc_errors_registration.ml @@ -42,66 +42,67 @@ let type_map_enc = let stack_ty_enc = let open Data_encoding in - (list - (obj2 - (req "type" Script.expr_encoding) - (dft "annots" (list string) []))) + list (obj2 (req "type" Script.expr_encoding) (dft "annots" (list string) [])) (* main registration *) let () = let open Data_encoding in let located enc = - merge_objs - (obj1 (req "location" Script.location_encoding)) - enc in - let arity_enc = - int8 in + merge_objs (obj1 (req "location" Script.location_encoding)) enc + in + let arity_enc = int8 in let namespace_enc = - def "primitiveNamespace" - ~title: "Primitive namespace" + def + "primitiveNamespace" + ~title:"Primitive namespace" ~description: - "One of the three possible namespaces of primitive \ - (data constructor, type name or instruction)." @@ - string_enum [ "type", Type_namespace ; - "constant", Constant_namespace ; - "instruction", Instr_namespace ] in + "One of the three possible namespaces of primitive (data constructor, \ + type name or instruction)." + @@ string_enum + [ ("type", Type_namespace); + ("constant", Constant_namespace); + ("instruction", Instr_namespace) ] + in let kind_enc = - def "expressionKind" - ~title: "Expression kind" + def + "expressionKind" + ~title:"Expression kind" ~description: - "One of the four possible kinds of expression \ - (integer, string, primitive application or sequence)." @@ - string_enum [ "integer", Int_kind ; - "string", String_kind ; - "bytes", Bytes_kind ; - "primitiveApplication", Prim_kind ; - "sequence", Seq_kind ] in + "One of the four possible kinds of expression (integer, string, \ + primitive application or sequence)." + @@ string_enum + [ ("integer", Int_kind); + ("string", String_kind); + ("bytes", Bytes_kind); + ("primitiveApplication", Prim_kind); + ("sequence", Seq_kind) ] + in (* -- Structure errors ---------------------- *) (* Invalid arity *) register_error_kind `Permanent ~id:"michelson_v1.invalid_arity" - ~title: "Invalid arity" + ~title:"Invalid arity" ~description: - "In a script or data expression, a primitive was applied \ - to an unsupported number of arguments." - (located (obj3 - (req "primitive_name" Script.prim_encoding) - (req "expected_arity" arity_enc) - (req "wrong_arity" arity_enc))) + "In a script or data expression, a primitive was applied to an \ + unsupported number of arguments." + (located + (obj3 + (req "primitive_name" Script.prim_encoding) + (req "expected_arity" arity_enc) + (req "wrong_arity" arity_enc))) (function | Invalid_arity (loc, name, exp, got) -> Some (loc, (name, exp, got)) - | _ -> None) - (fun (loc, (name, exp, got)) -> - Invalid_arity (loc, name, exp, got)) ; + | _ -> + None) + (fun (loc, (name, exp, got)) -> Invalid_arity (loc, name, exp, got)) ; (* Missing field *) register_error_kind `Permanent ~id:"michelson_v1.missing_script_field" ~title:"Script is missing a field (parse error)" - ~description: - "When parsing script, a field was expected, but not provided" + ~description:"When parsing script, a field was expected, but not provided" (obj1 (req "prim" prim_encoding)) (function Missing_field prim -> Some prim | _ -> None) (fun prim -> Missing_field prim) ; @@ -109,140 +110,124 @@ let () = register_error_kind `Permanent ~id:"michelson_v1.invalid_primitive" - ~title: "Invalid primitive" - ~description: - "In a script or data expression, a primitive was unknown." - (located (obj2 - (dft "expected_primitive_names" (list prim_encoding) []) - (req "wrong_primitive_name" prim_encoding))) + ~title:"Invalid primitive" + ~description:"In a script or data expression, a primitive was unknown." + (located + (obj2 + (dft "expected_primitive_names" (list prim_encoding) []) + (req "wrong_primitive_name" prim_encoding))) (function - | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) - | _ -> None) - (fun (loc, (exp, got)) -> - Invalid_primitive (loc, exp, got)) ; + | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None) + (fun (loc, (exp, got)) -> Invalid_primitive (loc, exp, got)) ; (* Invalid kind *) register_error_kind `Permanent ~id:"michelson_v1.invalid_expression_kind" - ~title: "Invalid expression kind" + ~title:"Invalid expression kind" ~description: "In a script or data expression, an expression was of the wrong kind \ (for instance a string where only a primitive applications can appear)." - (located (obj2 - (req "expected_kinds" (list kind_enc)) - (req "wrong_kind" kind_enc))) + (located + (obj2 (req "expected_kinds" (list kind_enc)) (req "wrong_kind" kind_enc))) (function - | Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) - | _ -> None) - (fun (loc, (exp, got)) -> - Invalid_kind (loc, exp, got)) ; + | Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None) + (fun (loc, (exp, got)) -> Invalid_kind (loc, exp, got)) ; (* Invalid namespace *) register_error_kind `Permanent ~id:"michelson_v1.invalid_primitive_namespace" - ~title: "Invalid primitive namespace" + ~title:"Invalid primitive namespace" ~description: "In a script or data expression, a primitive was of the wrong namespace." - (located (obj3 - (req "primitive_name" prim_encoding) - (req "expected_namespace" namespace_enc) - (req "wrong_namespace" namespace_enc))) + (located + (obj3 + (req "primitive_name" prim_encoding) + (req "expected_namespace" namespace_enc) + (req "wrong_namespace" namespace_enc))) (function - | Invalid_namespace (loc, name, exp, got) -> Some (loc, (name, exp, got)) - | _ -> None) - (fun (loc, (name, exp, got)) -> - Invalid_namespace (loc, name, exp, got)) ; + | Invalid_namespace (loc, name, exp, got) -> + Some (loc, (name, exp, got)) + | _ -> + None) + (fun (loc, (name, exp, got)) -> Invalid_namespace (loc, name, exp, got)) ; (* Duplicate field *) register_error_kind `Permanent ~id:"michelson_v1.duplicate_script_field" - ~title: "Script has a duplicated field (parse error)" - ~description: - "When parsing script, a field was found more than once" - (obj2 - (req "loc" location_encoding) - (req "prim" prim_encoding)) + ~title:"Script has a duplicated field (parse error)" + ~description:"When parsing script, a field was found more than once" + (obj2 (req "loc" location_encoding) (req "prim" prim_encoding)) (function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None) (fun (loc, prim) -> Duplicate_field (loc, prim)) ; (* Unexpected big_map *) register_error_kind `Permanent ~id:"michelson_v1.unexpected_bigmap" - ~title: "Big map in unauthorized position (type error)" + ~title:"Big map in unauthorized position (type error)" ~description: - "When parsing script, a big_map type was found in a position \ - where it could end up stored inside a big_map, which is \ - forbidden for now." - (obj1 - (req "loc" location_encoding)) + "When parsing script, a big_map type was found in a position where it \ + could end up stored inside a big_map, which is forbidden for now." + (obj1 (req "loc" location_encoding)) (function Unexpected_big_map loc -> Some loc | _ -> None) (fun loc -> Unexpected_big_map loc) ; (* Unexpected operation *) register_error_kind `Permanent ~id:"michelson_v1.unexpected_operation" - ~title: "Operation in unauthorized position (type error)" + ~title:"Operation in unauthorized position (type error)" ~description: - "When parsing script, an operation type was found \ - in the storage or parameter field." - (obj1 - (req "loc" location_encoding)) + "When parsing script, an operation type was found in the storage or \ + parameter field." + (obj1 (req "loc" location_encoding)) (function Unexpected_operation loc -> Some loc | _ -> None) (fun loc -> Unexpected_operation loc) ; (* No such entrypoint *) register_error_kind `Permanent ~id:"michelson_v1.no_such_entrypoint" - ~title: "No such entrypoint (type error)" - ~description: - "An entrypoint was not found when calling a contract." - (obj1 - (req "entrypoint" string)) + ~title:"No such entrypoint (type error)" + ~description:"An entrypoint was not found when calling a contract." + (obj1 (req "entrypoint" string)) (function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None) (fun entrypoint -> No_such_entrypoint entrypoint) ; (* Unreachable entrypoint *) register_error_kind `Permanent ~id:"michelson_v1.unreachable_entrypoint" - ~title: "Unreachable entrypoint (type error)" - ~description: - "An entrypoint in the contract is not reachable." - (obj1 - (req "path" (list prim_encoding))) + ~title:"Unreachable entrypoint (type error)" + ~description:"An entrypoint in the contract is not reachable." + (obj1 (req "path" (list prim_encoding))) (function Unreachable_entrypoint path -> Some path | _ -> None) (fun path -> Unreachable_entrypoint path) ; (* Duplicate entrypoint *) register_error_kind `Permanent ~id:"michelson_v1.duplicate_entrypoint" - ~title: "Duplicate entrypoint (type error)" - ~description: - "Two entrypoints have the same name." - (obj1 - (req "path" string)) + ~title:"Duplicate entrypoint (type error)" + ~description:"Two entrypoints have the same name." + (obj1 (req "path" string)) (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None) (fun entrypoint -> Duplicate_entrypoint entrypoint) ; (* Entrypoint name too long *) register_error_kind `Permanent ~id:"michelson_v1.entrypoint_name_too_long" - ~title: "Entrypoint name too long (type error)" + ~title:"Entrypoint name too long (type error)" ~description: "An entrypoint name exceeds the maximum length of 31 characters." - (obj1 - (req "name" string)) - (function Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None) + (obj1 (req "name" string)) + (function + | Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None) (fun entrypoint -> Entrypoint_name_too_long entrypoint) ; (* Unexpected contract *) register_error_kind `Permanent ~id:"michelson_v1.unexpected_contract" - ~title: "Contract in unauthorized position (type error)" + ~title:"Contract in unauthorized position (type error)" ~description: - "When parsing script, a contract type was found \ - in the storage or parameter field." - (obj1 - (req "loc" location_encoding)) + "When parsing script, a contract type was found in the storage or \ + parameter field." + (obj1 (req "loc" location_encoding)) (function Unexpected_contract loc -> Some loc | _ -> None) (fun loc -> Unexpected_contract loc) ; (* -- Value typing errors ---------------------- *) @@ -255,10 +240,8 @@ let () = (obj2 (req "location" Script.location_encoding) (req "item" Script.expr_encoding)) - (function - | Unordered_map_keys (loc, expr) -> Some (loc, expr) - | _ -> None) - (fun (loc, expr) -> Unordered_map_keys (loc, expr)); + (function Unordered_map_keys (loc, expr) -> Some (loc, expr) | _ -> None) + (fun (loc, expr) -> Unordered_map_keys (loc, expr)) ; (* Duplicate map keys *) register_error_kind `Permanent @@ -268,10 +251,8 @@ let () = (obj2 (req "location" Script.location_encoding) (req "item" Script.expr_encoding)) - (function - | Duplicate_map_keys (loc, expr) -> Some (loc, expr) - | _ -> None) - (fun (loc, expr) -> Duplicate_map_keys (loc, expr)); + (function Duplicate_map_keys (loc, expr) -> Some (loc, expr) | _ -> None) + (fun (loc, expr) -> Duplicate_map_keys (loc, expr)) ; (* Unordered set values *) register_error_kind `Permanent @@ -282,126 +263,117 @@ let () = (req "location" Script.location_encoding) (req "value" Script.expr_encoding)) (function - | Unordered_set_values (loc, expr) -> Some (loc, expr) - | _ -> None) - (fun (loc, expr) -> Unordered_set_values (loc, expr)); + | Unordered_set_values (loc, expr) -> Some (loc, expr) | _ -> None) + (fun (loc, expr) -> Unordered_set_values (loc, expr)) ; (* Duplicate set values *) register_error_kind `Permanent ~id:"michelson_v1.duplicate_set_values_in_literal" ~title:"Sets literals cannot contain duplicate elements" - ~description:"Set literals cannot contain duplicate elements, \ - but a duplicae was found while parsing." + ~description: + "Set literals cannot contain duplicate elements, but a duplicae was \ + found while parsing." (obj2 (req "location" Script.location_encoding) (req "value" Script.expr_encoding)) (function - | Duplicate_set_values (loc, expr) -> Some (loc, expr) - | _ -> None) - (fun (loc, expr) -> Duplicate_set_values (loc, expr)); + | Duplicate_set_values (loc, expr) -> Some (loc, expr) | _ -> None) + (fun (loc, expr) -> Duplicate_set_values (loc, expr)) ; (* -- Instruction typing errors ------------- *) (* Fail not in tail position *) register_error_kind `Permanent ~id:"michelson_v1.fail_not_in_tail_position" - ~title: "FAIL not in tail position" - ~description: - "There is non trivial garbage code after a FAIL instruction." + ~title:"FAIL not in tail position" + ~description:"There is non trivial garbage code after a FAIL instruction." (located empty) - (function - | Fail_not_in_tail_position loc -> Some (loc, ()) - | _ -> None) - (fun (loc, ()) -> - Fail_not_in_tail_position loc) ; + (function Fail_not_in_tail_position loc -> Some (loc, ()) | _ -> None) + (fun (loc, ()) -> Fail_not_in_tail_position loc) ; (* Undefined binary operation *) register_error_kind `Permanent ~id:"michelson_v1.undefined_binop" - ~title: "Undefined binop" + ~title:"Undefined binop" ~description: - "A binary operation is called on operands of types \ - over which it is not defined." - (located (obj3 - (req "operator_name" prim_encoding) - (req "wrong_left_operand_type" Script.expr_encoding) - (req "wrong_right_operand_type" Script.expr_encoding))) + "A binary operation is called on operands of types over which it is not \ + defined." + (located + (obj3 + (req "operator_name" prim_encoding) + (req "wrong_left_operand_type" Script.expr_encoding) + (req "wrong_right_operand_type" Script.expr_encoding))) (function | Undefined_binop (loc, n, tyl, tyr) -> Some (loc, (n, tyl, tyr)) - | _ -> None) - (fun (loc, (n, tyl, tyr)) -> - Undefined_binop (loc, n, tyl, tyr)) ; + | _ -> + None) + (fun (loc, (n, tyl, tyr)) -> Undefined_binop (loc, n, tyl, tyr)) ; (* Undefined unary operation *) register_error_kind `Permanent ~id:"michelson_v1.undefined_unop" - ~title: "Undefined unop" + ~title:"Undefined unop" ~description: - "A unary operation is called on an operand of type \ - over which it is not defined." - (located (obj2 - (req "operator_name" prim_encoding) - (req "wrong_operand_type" Script.expr_encoding))) - (function - | Undefined_unop (loc, n, ty) -> - Some (loc, (n, ty)) - | _ -> None) - (fun (loc, (n, ty)) -> - Undefined_unop (loc, n, ty)) ; + "A unary operation is called on an operand of type over which it is not \ + defined." + (located + (obj2 + (req "operator_name" prim_encoding) + (req "wrong_operand_type" Script.expr_encoding))) + (function Undefined_unop (loc, n, ty) -> Some (loc, (n, ty)) | _ -> None) + (fun (loc, (n, ty)) -> Undefined_unop (loc, n, ty)) ; (* Bad return *) register_error_kind `Permanent ~id:"michelson_v1.bad_return" - ~title: "Bad return" - ~description: - "Unexpected stack at the end of a lambda or script." - (located (obj2 - (req "expected_return_type" Script.expr_encoding) - (req "wrong_stack_type" stack_ty_enc))) - (function - | Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) - | _ -> None) - (fun (loc, (ty, sty)) -> - Bad_return (loc, sty, ty)) ; + ~title:"Bad return" + ~description:"Unexpected stack at the end of a lambda or script." + (located + (obj2 + (req "expected_return_type" Script.expr_encoding) + (req "wrong_stack_type" stack_ty_enc))) + (function Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) | _ -> None) + (fun (loc, (ty, sty)) -> Bad_return (loc, sty, ty)) ; (* Bad stack *) register_error_kind `Permanent ~id:"michelson_v1.bad_stack" - ~title: "Bad stack" - ~description: - "The stack has an unexpected length or contents." - (located (obj3 - (req "primitive_name" prim_encoding) - (req "relevant_stack_portion" int16) - (req "wrong_stack_type" stack_ty_enc))) + ~title:"Bad stack" + ~description:"The stack has an unexpected length or contents." + (located + (obj3 + (req "primitive_name" prim_encoding) + (req "relevant_stack_portion" int16) + (req "wrong_stack_type" stack_ty_enc))) (function - | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) - | _ -> None) - (fun (loc, (name, s, sty)) -> - Bad_stack (loc, name, s, sty)) ; + | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) | _ -> None) + (fun (loc, (name, s, sty)) -> Bad_stack (loc, name, s, sty)) ; (* Inconsistent annotations *) register_error_kind `Permanent ~id:"michelson_v1.inconsistent_annotations" ~title:"Annotations inconsistent between branches" ~description:"The annotations on two types could not be merged" - (obj2 - (req "annot1" string) - (req "annot2" string)) - (function Inconsistent_annotations (annot1, annot2) -> Some (annot1, annot2) - | _ -> None) + (obj2 (req "annot1" string) (req "annot2" string)) + (function + | Inconsistent_annotations (annot1, annot2) -> + Some (annot1, annot2) + | _ -> + None) (fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ; (* Inconsistent field annotations *) register_error_kind `Permanent ~id:"michelson_v1.inconsistent_field_annotations" ~title:"Annotations for field accesses is inconsistent" - ~description:"The specified field does not match the field annotation in the type" - (obj2 - (req "annot1" string) - (req "annot2" string)) - (function Inconsistent_field_annotations (annot1, annot2) -> Some (annot1, annot2) - | _ -> None) + ~description: + "The specified field does not match the field annotation in the type" + (obj2 (req "annot1" string) (req "annot2" string)) + (function + | Inconsistent_field_annotations (annot1, annot2) -> + Some (annot1, annot2) + | _ -> + None) (fun (annot1, annot2) -> Inconsistent_field_annotations (annot1, annot2)) ; (* Inconsistent type annotations *) register_error_kind @@ -409,12 +381,15 @@ let () = ~id:"michelson_v1.inconsistent_type_annotations" ~title:"Types contain inconsistent annotations" ~description:"The two types contain annotations that do not match" - (located (obj2 - (req "type1" Script.expr_encoding) - (req "type2" Script.expr_encoding))) + (located + (obj2 + (req "type1" Script.expr_encoding) + (req "type2" Script.expr_encoding))) (function - | Inconsistent_type_annotations (loc, ty1, ty2) -> Some (loc, (ty1, ty2)) - | _ -> None) + | Inconsistent_type_annotations (loc, ty1, ty2) -> + Some (loc, (ty1, ty2)) + | _ -> + None) (fun (loc, (ty1, ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ; (* Unexpected annotation *) register_error_kind @@ -423,9 +398,8 @@ let () = ~title:"An annotation was encountered where no annotation is expected" ~description:"A node in the syntax tree was impropperly annotated" (located empty) - (function Unexpected_annotation loc -> Some (loc, ()) - | _ -> None) - (fun (loc, ()) -> Unexpected_annotation loc); + (function Unexpected_annotation loc -> Some (loc, ()) | _ -> None) + (fun (loc, ()) -> Unexpected_annotation loc) ; (* Ungrouped annotations *) register_error_kind `Permanent @@ -433,203 +407,167 @@ let () = ~title:"Annotations of the same kind were found spread apart" ~description:"Annotations of the same kind must be grouped" (located empty) - (function Ungrouped_annotations loc -> Some (loc, ()) - | _ -> None) - (fun (loc, ()) -> Ungrouped_annotations loc); + (function Ungrouped_annotations loc -> Some (loc, ()) | _ -> None) + (fun (loc, ()) -> Ungrouped_annotations loc) ; (* Unmatched branches *) register_error_kind `Permanent ~id:"michelson_v1.unmatched_branches" - ~title: "Unmatched branches" + ~title:"Unmatched branches" ~description: - "At the join point at the end of two code branches \ - the stacks have inconsistent lengths or contents." - (located (obj2 - (req "first_stack_type" stack_ty_enc) - (req "other_stack_type" stack_ty_enc))) + "At the join point at the end of two code branches the stacks have \ + inconsistent lengths or contents." + (located + (obj2 + (req "first_stack_type" stack_ty_enc) + (req "other_stack_type" stack_ty_enc))) (function | Unmatched_branches (loc, stya, styb) -> Some (loc, (stya, styb)) - | _ -> None) - (fun (loc, (stya, styb)) -> - Unmatched_branches (loc, stya, styb)) ; + | _ -> + None) + (fun (loc, (stya, styb)) -> Unmatched_branches (loc, stya, styb)) ; (* Bad stack item *) register_error_kind `Permanent ~id:"michelson_v1.bad_stack_item" - ~title: "Bad stack item" + ~title:"Bad stack item" ~description: - "The type of a stack item is unexpected \ - (this error is always accompanied by a more precise one)." + "The type of a stack item is unexpected (this error is always \ + accompanied by a more precise one)." (obj1 (req "item_level" int16)) - (function - | Bad_stack_item n -> Some n - | _ -> None) - (fun n -> - Bad_stack_item n) ; + (function Bad_stack_item n -> Some n | _ -> None) + (fun n -> Bad_stack_item n) ; (* SELF in lambda *) register_error_kind `Permanent ~id:"michelson_v1.self_in_lambda" - ~title: "SELF instruction in lambda" - ~description: - "A SELF instruction was encountered in a lambda expression." + ~title:"SELF instruction in lambda" + ~description:"A SELF instruction was encountered in a lambda expression." (located empty) - (function - | Self_in_lambda loc -> Some (loc, ()) - | _ -> None) - (fun (loc, ()) -> - Self_in_lambda loc) ; + (function Self_in_lambda loc -> Some (loc, ()) | _ -> None) + (fun (loc, ()) -> Self_in_lambda loc) ; (* Bad stack length *) register_error_kind `Permanent ~id:"michelson_v1.inconsistent_stack_lengths" - ~title: "Inconsistent stack lengths" + ~title:"Inconsistent stack lengths" ~description: - "A stack was of an unexpected length \ - (this error is always in the context of a located error)." + "A stack was of an unexpected length (this error is always in the \ + context of a located error)." empty - (function - | Bad_stack_length -> Some () - | _ -> None) - (fun () -> - Bad_stack_length) ; + (function Bad_stack_length -> Some () | _ -> None) + (fun () -> Bad_stack_length) ; (* -- Value typing errors ------------------- *) (* Invalid constant *) register_error_kind `Permanent ~id:"michelson_v1.invalid_constant" - ~title: "Invalid constant" - ~description: - "A data expression was invalid for its expected type." - (located (obj2 - (req "expected_type" Script.expr_encoding) - (req "wrong_expression" Script.expr_encoding))) + ~title:"Invalid constant" + ~description:"A data expression was invalid for its expected type." + (located + (obj2 + (req "expected_type" Script.expr_encoding) + (req "wrong_expression" Script.expr_encoding))) (function - | Invalid_constant (loc, expr, ty) -> - Some (loc, (ty, expr)) - | _ -> None) - (fun (loc, (ty, expr)) -> - Invalid_constant (loc, expr, ty)) ; + | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None) + (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ; (* Invalid syntactic constant *) register_error_kind `Permanent ~id:"invalidSyntacticConstantError" - ~title: "Invalid constant (parse error)" - ~description: - "A compile-time constant was invalid for its expected form." - (located (obj2 - (req "expectedForm" Script.expr_encoding) - (req "wrongExpression" Script.expr_encoding))) + ~title:"Invalid constant (parse error)" + ~description:"A compile-time constant was invalid for its expected form." + (located + (obj2 + (req "expectedForm" Script.expr_encoding) + (req "wrongExpression" Script.expr_encoding))) (function - | Invalid_constant (loc, expr, ty) -> - Some (loc, (ty, expr)) - | _ -> None) - (fun (loc, (ty, expr)) -> - Invalid_constant (loc, expr, ty)) ; + | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None) + (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ; (* Invalid contract *) register_error_kind `Permanent ~id:"michelson_v1.invalid_contract" - ~title: "Invalid contract" + ~title:"Invalid contract" ~description: - "A script or data expression references a contract that does not \ - exist or assumes a wrong type for an existing contract." + "A script or data expression references a contract that does not exist \ + or assumes a wrong type for an existing contract." (located (obj1 (req "contract" Contract.encoding))) - (function - | Invalid_contract (loc, c) -> - Some (loc, c) - | _ -> None) - (fun (loc, c) -> - Invalid_contract (loc, c)) ; + (function Invalid_contract (loc, c) -> Some (loc, c) | _ -> None) + (fun (loc, c) -> Invalid_contract (loc, c)) ; (* Invalid big_map *) register_error_kind `Permanent ~id:"michelson_v1.invalid_big_map" - ~title: "Invalid big_map" + ~title:"Invalid big_map" ~description: - "A script or data expression references a big_map that does not \ - exist or assumes a wrong type for an existing big_map." + "A script or data expression references a big_map that does not exist \ + or assumes a wrong type for an existing big_map." (located (obj1 (req "big_map" z))) - (function - | Invalid_big_map (loc, c) -> - Some (loc, c) - | _ -> None) - (fun (loc, c) -> - Invalid_big_map (loc, c)) ; + (function Invalid_big_map (loc, c) -> Some (loc, c) | _ -> None) + (fun (loc, c) -> Invalid_big_map (loc, c)) ; (* Comparable type expected *) register_error_kind `Permanent ~id:"michelson_v1.comparable_type_expected" - ~title: "Comparable type expected" + ~title:"Comparable type expected" ~description: - "A non comparable type was used in a place where \ - only comparable types are accepted." + "A non comparable type was used in a place where only comparable types \ + are accepted." (located (obj1 (req "wrong_type" Script.expr_encoding))) (function - | Comparable_type_expected (loc, ty) -> Some (loc, ty) - | _ -> None) - (fun (loc, ty) -> - Comparable_type_expected (loc, ty)) ; + | Comparable_type_expected (loc, ty) -> Some (loc, ty) | _ -> None) + (fun (loc, ty) -> Comparable_type_expected (loc, ty)) ; (* Inconsistent types *) register_error_kind `Permanent ~id:"michelson_v1.inconsistent_types" - ~title: "Inconsistent types" + ~title:"Inconsistent types" ~description: - "This is the basic type clash error, \ - that appears in several places where the equality of \ - two types have to be proven, it is always accompanied \ - with another error that provides more context." + "This is the basic type clash error, that appears in several places \ + where the equality of two types have to be proven, it is always \ + accompanied with another error that provides more context." (obj2 (req "first_type" Script.expr_encoding) (req "other_type" Script.expr_encoding)) - (function - | Inconsistent_types (tya, tyb) -> Some (tya, tyb) - | _ -> None) + (function Inconsistent_types (tya, tyb) -> Some (tya, tyb) | _ -> None) (fun (tya, tyb) -> Inconsistent_types (tya, tyb)) ; (* -- Instruction typing errors ------------------- *) (* Invalid map body *) register_error_kind `Permanent ~id:"michelson_v1.invalid_map_body" - ~title: "Invalid map body" - ~description: - "The body of a map block did not match the expected type" - (obj2 - (req "loc" Script.location_encoding) - (req "body_type" stack_ty_enc)) - (function - | Invalid_map_body (loc, stack) -> Some (loc, stack) - | _ -> None) + ~title:"Invalid map body" + ~description:"The body of a map block did not match the expected type" + (obj2 (req "loc" Script.location_encoding) (req "body_type" stack_ty_enc)) + (function Invalid_map_body (loc, stack) -> Some (loc, stack) | _ -> None) (fun (loc, stack) -> Invalid_map_body (loc, stack)) ; (* Invalid map block FAIL *) register_error_kind `Permanent ~id:"michelson_v1.invalid_map_block_fail" ~title:"FAIL instruction occurred as body of map block" - ~description:"FAIL cannot be the only instruction in the body. \ - The propper type of the return list cannot be inferred." + ~description: + "FAIL cannot be the only instruction in the body. The propper type of \ + the return list cannot be inferred." (obj1 (req "loc" Script.location_encoding)) - (function - | Invalid_map_block_fail loc -> Some loc - | _ -> None) + (function Invalid_map_block_fail loc -> Some loc | _ -> None) (fun loc -> Invalid_map_block_fail loc) ; (* Invalid ITER body *) register_error_kind `Permanent ~id:"michelson_v1.invalid_iter_body" ~title:"ITER body returned wrong stack type" - ~description:"The body of an ITER instruction \ - must result in the same stack type as before \ - the ITER." + ~description: + "The body of an ITER instruction must result in the same stack type as \ + before the ITER." (obj3 (req "loc" Script.location_encoding) (req "bef_stack" stack_ty_enc) (req "aft_stack" stack_ty_enc)) (function - | Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) - | _ -> None) + | Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) | _ -> None) (fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ; (* Type too large *) register_error_kind @@ -642,32 +580,29 @@ let () = (req "type_size" uint16) (req "maximum_type_size" uint16)) (function - | Type_too_large (loc, ts, maxts) -> Some (loc, ts, maxts) - | _ -> None) + | Type_too_large (loc, ts, maxts) -> Some (loc, ts, maxts) | _ -> None) (fun (loc, ts, maxts) -> Type_too_large (loc, ts, maxts)) ; (* -- Toplevel errors ------------------- *) (* Ill typed data *) register_error_kind `Permanent ~id:"michelson_v1.ill_typed_data" - ~title: "Ill typed data" + ~title:"Ill typed data" ~description: - "The toplevel error thrown when trying to typecheck \ - a data expression against a given type \ - (always followed by more precise errors)." + "The toplevel error thrown when trying to typecheck a data expression \ + against a given type (always followed by more precise errors)." (obj3 (opt "identifier" string) (req "expected_type" Script.expr_encoding) (req "ill_typed_expression" Script.expr_encoding)) (function - | Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) - | _ -> None) - (fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ; + | Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) | _ -> None) + (fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ; (* Ill formed type *) register_error_kind `Permanent ~id:"michelson_v1.ill_formed_type" - ~title: "Ill formed type" + ~title:"Ill formed type" ~description: "The toplevel error thrown when trying to parse a type expression \ (always followed by more precise errors)." @@ -676,35 +611,32 @@ let () = (req "ill_formed_expression" Script.expr_encoding) (req "location" Script.location_encoding)) (function - | Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) - | _ -> None) - (fun (name, expr, loc) -> - Ill_formed_type (name, expr, loc)) ; + | Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) | _ -> None) + (fun (name, expr, loc) -> Ill_formed_type (name, expr, loc)) ; (* Ill typed contract *) register_error_kind `Permanent ~id:"michelson_v1.ill_typed_contract" - ~title: "Ill typed contract" + ~title:"Ill typed contract" ~description: - "The toplevel error thrown when trying to typecheck \ - a contract code against given input, output and storage types \ - (always followed by more precise errors)." + "The toplevel error thrown when trying to typecheck a contract code \ + against given input, output and storage types (always followed by more \ + precise errors)." (obj2 (req "ill_typed_code" Script.expr_encoding) (req "type_map" type_map_enc)) (function | Ill_typed_contract (expr, type_map) -> Some (expr, type_map) - | _ -> None) - (fun (expr, type_map) -> - Ill_typed_contract (expr, type_map)) ; + | _ -> + None) + (fun (expr, type_map) -> Ill_typed_contract (expr, type_map)) ; (* Cannot serialize error *) register_error_kind `Temporary ~id:"michelson_v1.cannot_serialize_error" ~title:"Not enough gas to serialize error" - ~description:"The error was too big to be serialized with \ - the provided gas" + ~description:"The error was too big to be serialized with the provided gas" Data_encoding.empty (function Cannot_serialize_error -> Some () | _ -> None) (fun () -> Cannot_serialize_error) ; @@ -717,4 +649,4 @@ let () = "A deprecated instruction usage is disallowed in newly created contracts" (obj1 (req "prim" prim_encoding)) (function Deprecated_instruction prim -> Some prim | _ -> None) - (fun prim -> Deprecated_instruction prim) ; + (fun prim -> Deprecated_instruction prim) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.ml index 8c6a48d32..c8474e2e1 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.ml @@ -31,34 +31,27 @@ let of_int64 = Z.of_int64 let of_string x = match Time_repr.of_notation x with - | None -> - begin try Some (Z.of_string x) - with _ -> None - end + | None -> ( + try Some (Z.of_string x) with _ -> None ) | Some time -> Some (of_int64 (Time_repr.to_seconds time)) let to_notation x = try let notation = Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in - if String.equal notation "out_of_range" - then None - else Some notation + if String.equal notation "out_of_range" then None else Some notation with _ -> None let to_num_str = Z.to_string -let to_string x = - match to_notation x with - | None -> to_num_str x - | Some s -> s +let to_string x = match to_notation x with None -> to_num_str x | Some s -> s let diff x y = Script_int_repr.of_zint @@ Z.sub x y let sub_delta t delta = Z.sub t (Script_int_repr.to_zint delta) -let add_delta t delta = - Z.add t (Script_int_repr.to_zint delta) +let add_delta t delta = Z.add t (Script_int_repr.to_zint delta) let to_zint x = x + let of_zint x = x diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.mli index 73496c369..7f2b156d2 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_timestamp_repr.mli @@ -33,10 +33,13 @@ val compare : t -> t -> int (* Convert a timestamp to a notation if possible *) val to_notation : t -> string option + (* Convert a timestamp to a string representation of the seconds *) val to_num_str : t -> string + (* Convert to a notation if possible, or num if not *) val to_string : t -> string + val of_string : string -> t option val diff : t -> t -> z num @@ -46,4 +49,5 @@ val add_delta : t -> z num -> t val sub_delta : t -> z num -> t val to_zint : t -> Z.t + val of_zint : Z.t -> t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml b/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml index d536ecec8..99b5c9b4f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/script_typed_ir.ml @@ -28,11 +28,13 @@ open Script_int (* ---- Auxiliary types -----------------------------------------------------*) -type var_annot = [ `Var_annot of string ] -type type_annot = [ `Type_annot of string ] -type field_annot = [ `Field_annot of string ] +type var_annot = [`Var_annot of string] -type annot = [ var_annot | type_annot | field_annot ] +type type_annot = [`Type_annot of string] + +type field_annot = [`Field_annot of string] + +type annot = [var_annot | type_annot | field_annot] type address = Contract.t * string @@ -41,6 +43,7 @@ type ('a, 'b) pair = 'a * 'b type ('a, 'b) union = L of 'a | R of 'b type comb = Comb + type leaf = Leaf type (_, _) comparable_struct = @@ -51,20 +54,27 @@ type (_, _) comparable_struct = | Mutez_key : type_annot option -> (Tez.t, _) comparable_struct | Bool_key : type_annot option -> (bool, _) comparable_struct | Key_hash_key : type_annot option -> (public_key_hash, _) comparable_struct - | Timestamp_key : type_annot option -> (Script_timestamp.t, _) comparable_struct + | Timestamp_key : + type_annot option + -> (Script_timestamp.t, _) comparable_struct | Address_key : type_annot option -> (address, _) comparable_struct | Pair_key : - (('a, leaf) comparable_struct * field_annot option) * - (('b, _) comparable_struct * field_annot option) * - type_annot option -> (('a, 'b) pair, comb) comparable_struct + (('a, leaf) comparable_struct * field_annot option) + * (('b, comb) comparable_struct * field_annot option) + * type_annot option + -> (('a, 'b) pair, comb) comparable_struct type 'a comparable_ty = ('a, comb) comparable_struct module type Boxed_set = sig type elt + val elt_ty : elt comparable_ty + module OPS : S.SET with type elt = elt + val boxed : OPS.t + val size : int end @@ -72,27 +82,35 @@ type 'elt set = (module Boxed_set with type elt = 'elt) module type Boxed_map = sig type key + type value + val key_ty : key comparable_ty + module OPS : S.MAP with type key = key + val boxed : value OPS.t * int end -type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value) +type ('key, 'value) map = + (module Boxed_map with type key = 'key and type value = 'value) type operation = packed_internal_operation * Contract.big_map_diff option -type ('arg, 'storage) script = - { code : (('arg, 'storage) pair, (operation list, 'storage) pair) lambda ; - arg_type : 'arg ty ; - storage : 'storage ; - storage_type : 'storage ty ; - root_name : string option } +type ('arg, 'storage) script = { + code : (('arg, 'storage) pair, (operation list, 'storage) pair) lambda; + arg_type : 'arg ty; + storage : 'storage; + storage_type : 'storage ty; + root_name : string option; +} and end_of_stack = unit and ('arg, 'ret) lambda = - Lam : ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node -> ('arg, 'ret) lambda + | Lam : + ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node + -> ('arg, 'ret) lambda and 'arg typed_contract = 'arg ty * address @@ -110,33 +128,43 @@ and 'ty ty = | Address_t : type_annot option -> address ty | Bool_t : type_annot option -> bool ty | Pair_t : - ('a ty * field_annot option * var_annot option) * - ('b ty * field_annot option * var_annot option) * - type_annot option * - bool -> ('a, 'b) pair ty + ('a ty * field_annot option * var_annot option) + * ('b ty * field_annot option * var_annot option) + * type_annot option + * bool + -> ('a, 'b) pair ty | Union_t : - ('a ty * field_annot option) * - ('b ty * field_annot option) * - type_annot option * - bool -> ('a, 'b) union ty - | Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty - | Option_t : 'v ty * type_annot option * bool -> 'v option ty + ('a ty * field_annot option) + * ('b ty * field_annot option) + * type_annot option + * bool + -> ('a, 'b) union ty + | Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty + | Option_t : 'v ty * type_annot option * bool -> 'v option ty | List_t : 'v ty * type_annot option * bool -> 'v list ty | Set_t : 'v comparable_ty * type_annot option -> 'v set ty - | Map_t : 'k comparable_ty * 'v ty * type_annot option * bool -> ('k, 'v) map ty - | Big_map_t : 'k comparable_ty * 'v ty * type_annot option -> ('k, 'v) big_map ty + | Map_t : + 'k comparable_ty * 'v ty * type_annot option * bool + -> ('k, 'v) map ty + | Big_map_t : + 'k comparable_ty * 'v ty * type_annot option + -> ('k, 'v) big_map ty | Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty | Operation_t : type_annot option -> operation ty | Chain_id_t : type_annot option -> Chain_id.t ty and 'ty stack_ty = - | Item_t : 'ty ty * 'rest stack_ty * var_annot option -> ('ty * 'rest) stack_ty + | Item_t : + 'ty ty * 'rest stack_ty * var_annot option + -> ('ty * 'rest) stack_ty | Empty_t : end_of_stack stack_ty -and ('key, 'value) big_map = { id : Z.t option ; - diff : ('key, 'value option) map ; - key_type : 'key ty ; - value_type : 'value ty } +and ('key, 'value) big_map = { + id : Z.t option; + diff : ('key, 'value option) map; + key_type : 'key ty; + value_type : 'value ty; +} (* ---- Instructions --------------------------------------------------------*) @@ -151,280 +179,225 @@ and ('key, 'value) big_map = { id : Z.t option ; constructors or type witness parameters. *) and ('bef, 'aft) instr = (* stack ops *) - | Drop : - (_ * 'rest, 'rest) instr - | Dup : - ('top * 'rest, 'top * ('top * 'rest)) instr - | Swap : - ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr - | Const : 'ty -> - ('rest, ('ty * 'rest)) instr + | Drop : (_ * 'rest, 'rest) instr + | Dup : ('top * 'rest, 'top * ('top * 'rest)) instr + | Swap : ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr + | Const : 'ty -> ('rest, 'ty * 'rest) instr (* pairs *) - | Cons_pair : - (('car * ('cdr * 'rest)), (('car, 'cdr) pair * 'rest)) instr - | Car : - (('car, _) pair * 'rest, 'car * 'rest) instr - | Cdr : - ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr + | Cons_pair : ('car * ('cdr * 'rest), ('car, 'cdr) pair * 'rest) instr + | Car : (('car, _) pair * 'rest, 'car * 'rest) instr + | Cdr : ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr (* options *) - | Cons_some : - ('v * 'rest, 'v option * 'rest) instr - | Cons_none : 'a ty -> - ('rest, 'a option * 'rest) instr - | If_none : ('bef, 'aft) descr * ('a * 'bef, 'aft) descr -> - ('a option * 'bef, 'aft) instr + | Cons_some : ('v * 'rest, 'v option * 'rest) instr + | Cons_none : 'a ty -> ('rest, 'a option * 'rest) instr + | If_none : + ('bef, 'aft) descr * ('a * 'bef, 'aft) descr + -> ('a option * 'bef, 'aft) instr (* unions *) - | Left : - ('l * 'rest, (('l, 'r) union * 'rest)) instr - | Right : - ('r * 'rest, (('l, 'r) union * 'rest)) instr - | If_left : ('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr -> - (('l, 'r) union * 'bef, 'aft) instr + | Left : ('l * 'rest, ('l, 'r) union * 'rest) instr + | Right : ('r * 'rest, ('l, 'r) union * 'rest) instr + | If_left : + ('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr + -> (('l, 'r) union * 'bef, 'aft) instr (* lists *) - | Cons_list : - ('a * ('a list * 'rest), ('a list * 'rest)) instr - | Nil : - ('rest, ('a list * 'rest)) instr - | If_cons : ('a * ('a list * 'bef), 'aft) descr * ('bef, 'aft) descr -> - ('a list * 'bef, 'aft) instr - | List_map : ('a * 'rest, 'b * 'rest) descr -> - ('a list * 'rest, 'b list * 'rest) instr - | List_iter : ('a * 'rest, 'rest) descr -> - ('a list * 'rest, 'rest) instr + | Cons_list : ('a * ('a list * 'rest), 'a list * 'rest) instr + | Nil : ('rest, 'a list * 'rest) instr + | If_cons : + ('a * ('a list * 'bef), 'aft) descr * ('bef, 'aft) descr + -> ('a list * 'bef, 'aft) instr + | List_map : + ('a * 'rest, 'b * 'rest) descr + -> ('a list * 'rest, 'b list * 'rest) instr + | List_iter : ('a * 'rest, 'rest) descr -> ('a list * 'rest, 'rest) instr | List_size : ('a list * 'rest, n num * 'rest) instr (* sets *) - | Empty_set : 'a comparable_ty -> - ('rest, 'a set * 'rest) instr - | Set_iter : ('a * 'rest, 'rest) descr -> - ('a set * 'rest, 'rest) instr - | Set_mem : - ('elt * ('elt set * 'rest), bool * 'rest) instr - | Set_update : - ('elt * (bool * ('elt set * 'rest)), 'elt set * 'rest) instr + | Empty_set : 'a comparable_ty -> ('rest, 'a set * 'rest) instr + | Set_iter : ('a * 'rest, 'rest) descr -> ('a set * 'rest, 'rest) instr + | Set_mem : ('elt * ('elt set * 'rest), bool * 'rest) instr + | Set_update : ('elt * (bool * ('elt set * 'rest)), 'elt set * 'rest) instr | Set_size : ('a set * 'rest, n num * 'rest) instr (* maps *) - | Empty_map : 'a comparable_ty * 'v ty -> - ('rest, ('a, 'v) map * 'rest) instr - | Map_map : (('a * 'v) * 'rest, 'r * 'rest) descr -> - (('a, 'v) map * 'rest, ('a, 'r) map * 'rest) instr - | Map_iter : (('a * 'v) * 'rest, 'rest) descr -> - (('a, 'v) map * 'rest, 'rest) instr - | Map_mem : - ('a * (('a, 'v) map * 'rest), bool * 'rest) instr - | Map_get : - ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr - | Map_update : - ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr + | Empty_map : 'a comparable_ty * 'v ty -> ('rest, ('a, 'v) map * 'rest) instr + | Map_map : + (('a * 'v) * 'rest, 'r * 'rest) descr + -> (('a, 'v) map * 'rest, ('a, 'r) map * 'rest) instr + | Map_iter : + (('a * 'v) * 'rest, 'rest) descr + -> (('a, 'v) map * 'rest, 'rest) instr + | Map_mem : ('a * (('a, 'v) map * 'rest), bool * 'rest) instr + | Map_get : ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr + | Map_update + : ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr (* big maps *) - | Empty_big_map : 'a comparable_ty * 'v ty -> - ('rest, ('a, 'v) big_map * 'rest) instr - | Big_map_mem : - ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr - | Big_map_get : - ('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr - | Big_map_update : - ('key * ('value option * (('key, 'value) big_map * 'rest)), ('key, 'value) big_map * 'rest) instr + | Empty_big_map : + 'a comparable_ty * 'v ty + -> ('rest, ('a, 'v) big_map * 'rest) instr + | Big_map_mem : ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr + | Big_map_get : ('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr + | Big_map_update + : ( 'key * ('value option * (('key, 'value) big_map * 'rest)), + ('key, 'value) big_map * 'rest ) + instr (* string operations *) - | Concat_string : - (string list * 'rest, string * 'rest) instr - | Concat_string_pair : - (string * (string * 'rest), string * 'rest) instr - | Slice_string : - (n num * (n num * (string * 'rest)), string option * 'rest) instr - | String_size : - (string * 'rest, n num * 'rest) instr + | Concat_string : (string list * 'rest, string * 'rest) instr + | Concat_string_pair : (string * (string * 'rest), string * 'rest) instr + | Slice_string + : (n num * (n num * (string * 'rest)), string option * 'rest) instr + | String_size : (string * 'rest, n num * 'rest) instr (* bytes operations *) - | Concat_bytes : - (MBytes.t list * 'rest, MBytes.t * 'rest) instr - | Concat_bytes_pair : - (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) instr - | Slice_bytes : - (n num * (n num * (MBytes.t * 'rest)), MBytes.t option * 'rest) instr - | Bytes_size : - (MBytes.t * 'rest, n num * 'rest) instr + | Concat_bytes : (MBytes.t list * 'rest, MBytes.t * 'rest) instr + | Concat_bytes_pair : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) instr + | Slice_bytes + : (n num * (n num * (MBytes.t * 'rest)), MBytes.t option * 'rest) instr + | Bytes_size : (MBytes.t * 'rest, n num * 'rest) instr (* timestamp operations *) - | Add_seconds_to_timestamp : - (z num * (Script_timestamp.t * 'rest), - Script_timestamp.t * 'rest) instr - | Add_timestamp_to_seconds : - (Script_timestamp.t * (z num * 'rest), - Script_timestamp.t * 'rest) instr - | Sub_timestamp_seconds : - (Script_timestamp.t * (z num * 'rest), - Script_timestamp.t * 'rest) instr - | Diff_timestamps : - (Script_timestamp.t * (Script_timestamp.t * 'rest), - z num * 'rest) instr + | Add_seconds_to_timestamp + : ( z num * (Script_timestamp.t * 'rest), + Script_timestamp.t * 'rest ) + instr + | Add_timestamp_to_seconds + : ( Script_timestamp.t * (z num * 'rest), + Script_timestamp.t * 'rest ) + instr + | Sub_timestamp_seconds + : ( Script_timestamp.t * (z num * 'rest), + Script_timestamp.t * 'rest ) + instr + | Diff_timestamps + : ( Script_timestamp.t * (Script_timestamp.t * 'rest), + z num * 'rest ) + instr (* tez operations *) - | Add_tez : - (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr - | Sub_tez : - (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr - | Mul_teznat : - (Tez.t * (n num * 'rest), Tez.t * 'rest) instr - | Mul_nattez : - (n num * (Tez.t * 'rest), Tez.t * 'rest) instr - | Ediv_teznat : - (Tez.t * (n num * 'rest), ((Tez.t, Tez.t) pair) option * 'rest) instr - | Ediv_tez : - (Tez.t * (Tez.t * 'rest), ((n num, Tez.t) pair) option * 'rest) instr + | Add_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Sub_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr + | Mul_teznat : (Tez.t * (n num * 'rest), Tez.t * 'rest) instr + | Mul_nattez : (n num * (Tez.t * 'rest), Tez.t * 'rest) instr + | Ediv_teznat + : (Tez.t * (n num * 'rest), (Tez.t, Tez.t) pair option * 'rest) instr + | Ediv_tez + : (Tez.t * (Tez.t * 'rest), (n num, Tez.t) pair option * 'rest) instr (* boolean operations *) - | Or : - (bool * (bool * 'rest), bool * 'rest) instr - | And : - (bool * (bool * 'rest), bool * 'rest) instr - | Xor : - (bool * (bool * 'rest), bool * 'rest) instr - | Not : - (bool * 'rest, bool * 'rest) instr + | Or : (bool * (bool * 'rest), bool * 'rest) instr + | And : (bool * (bool * 'rest), bool * 'rest) instr + | Xor : (bool * (bool * 'rest), bool * 'rest) instr + | Not : (bool * 'rest, bool * 'rest) instr (* integer operations *) - | Is_nat : - (z num * 'rest, n num option * 'rest) instr - | Neg_nat : - (n num * 'rest, z num * 'rest) instr - | Neg_int : - (z num * 'rest, z num * 'rest) instr - | Abs_int : - (z num * 'rest, n num * 'rest) instr - | Int_nat : - (n num * 'rest, z num * 'rest) instr - | Add_intint : - (z num * (z num * 'rest), z num * 'rest) instr - | Add_intnat : - (z num * (n num * 'rest), z num * 'rest) instr - | Add_natint : - (n num * (z num * 'rest), z num * 'rest) instr - | Add_natnat : - (n num * (n num * 'rest), n num * 'rest) instr - | Sub_int : - ('s num * ('t num * 'rest), z num * 'rest) instr - | Mul_intint : - (z num * (z num * 'rest), z num * 'rest) instr - | Mul_intnat : - (z num * (n num * 'rest), z num * 'rest) instr - | Mul_natint : - (n num * (z num * 'rest), z num * 'rest) instr - | Mul_natnat : - (n num * (n num * 'rest), n num * 'rest) instr - | Ediv_intint : - (z num * (z num * 'rest), ((z num, n num) pair) option * 'rest) instr - | Ediv_intnat : - (z num * (n num * 'rest), ((z num, n num) pair) option * 'rest) instr - | Ediv_natint : - (n num * (z num * 'rest), ((z num, n num) pair) option * 'rest) instr - | Ediv_natnat : - (n num * (n num * 'rest), ((n num, n num) pair) option * 'rest) instr - | Lsl_nat : - (n num * (n num * 'rest), n num * 'rest) instr - | Lsr_nat : - (n num * (n num * 'rest), n num * 'rest) instr - | Or_nat : - (n num * (n num * 'rest), n num * 'rest) instr - | And_nat : - (n num * (n num * 'rest), n num * 'rest) instr - | And_int_nat : - (z num * (n num * 'rest), n num * 'rest) instr - | Xor_nat : - (n num * (n num * 'rest), n num * 'rest) instr - | Not_nat : - (n num * 'rest, z num * 'rest) instr - | Not_int : - (z num * 'rest, z num * 'rest) instr + | Is_nat : (z num * 'rest, n num option * 'rest) instr + | Neg_nat : (n num * 'rest, z num * 'rest) instr + | Neg_int : (z num * 'rest, z num * 'rest) instr + | Abs_int : (z num * 'rest, n num * 'rest) instr + | Int_nat : (n num * 'rest, z num * 'rest) instr + | Add_intint : (z num * (z num * 'rest), z num * 'rest) instr + | Add_intnat : (z num * (n num * 'rest), z num * 'rest) instr + | Add_natint : (n num * (z num * 'rest), z num * 'rest) instr + | Add_natnat : (n num * (n num * 'rest), n num * 'rest) instr + | Sub_int : ('s num * ('t num * 'rest), z num * 'rest) instr + | Mul_intint : (z num * (z num * 'rest), z num * 'rest) instr + | Mul_intnat : (z num * (n num * 'rest), z num * 'rest) instr + | Mul_natint : (n num * (z num * 'rest), z num * 'rest) instr + | Mul_natnat : (n num * (n num * 'rest), n num * 'rest) instr + | Ediv_intint + : (z num * (z num * 'rest), (z num, n num) pair option * 'rest) instr + | Ediv_intnat + : (z num * (n num * 'rest), (z num, n num) pair option * 'rest) instr + | Ediv_natint + : (n num * (z num * 'rest), (z num, n num) pair option * 'rest) instr + | Ediv_natnat + : (n num * (n num * 'rest), (n num, n num) pair option * 'rest) instr + | Lsl_nat : (n num * (n num * 'rest), n num * 'rest) instr + | Lsr_nat : (n num * (n num * 'rest), n num * 'rest) instr + | Or_nat : (n num * (n num * 'rest), n num * 'rest) instr + | And_nat : (n num * (n num * 'rest), n num * 'rest) instr + | And_int_nat : (z num * (n num * 'rest), n num * 'rest) instr + | Xor_nat : (n num * (n num * 'rest), n num * 'rest) instr + | Not_nat : (n num * 'rest, z num * 'rest) instr + | Not_int : (z num * 'rest, z num * 'rest) instr (* control *) - | Seq : ('bef, 'trans) descr * ('trans, 'aft) descr -> - ('bef, 'aft) instr - | If : ('bef, 'aft) descr * ('bef, 'aft) descr -> - (bool * 'bef, 'aft) instr - | Loop : ('rest, bool * 'rest) descr -> - (bool * 'rest, 'rest) instr - | Loop_left : ('a * 'rest, ('a, 'b) union * 'rest) descr -> - (('a, 'b) union * 'rest, 'b * 'rest) instr - | Dip : ('bef, 'aft) descr -> - ('top * 'bef, 'top * 'aft) instr - | Exec : - ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr - | Apply : 'arg ty -> - ('arg * (('arg * 'remaining, 'ret) lambda * 'rest), ('remaining, 'ret) lambda * 'rest) instr - | Lambda : ('arg, 'ret) lambda -> - ('rest, ('arg, 'ret) lambda * 'rest) instr - | Failwith : - 'a ty -> ('a * 'rest, 'aft) instr - | Nop : - ('rest, 'rest) instr + | Seq : ('bef, 'trans) descr * ('trans, 'aft) descr -> ('bef, 'aft) instr + | If : ('bef, 'aft) descr * ('bef, 'aft) descr -> (bool * 'bef, 'aft) instr + | Loop : ('rest, bool * 'rest) descr -> (bool * 'rest, 'rest) instr + | Loop_left : + ('a * 'rest, ('a, 'b) union * 'rest) descr + -> (('a, 'b) union * 'rest, 'b * 'rest) instr + | Dip : ('bef, 'aft) descr -> ('top * 'bef, 'top * 'aft) instr + | Exec : ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr + | Apply : + 'arg ty + -> ( 'arg * (('arg * 'remaining, 'ret) lambda * 'rest), + ('remaining, 'ret) lambda * 'rest ) + instr + | Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr + | Failwith : 'a ty -> ('a * 'rest, 'aft) instr + | Nop : ('rest, 'rest) instr (* comparison *) - | Compare : 'a comparable_ty -> - ('a * ('a * 'rest), z num * 'rest) instr + | Compare : 'a comparable_ty -> ('a * ('a * 'rest), z num * 'rest) instr (* comparators *) - | Eq : - (z num * 'rest, bool * 'rest) instr - | Neq : - (z num * 'rest, bool * 'rest) instr - | Lt : - (z num * 'rest, bool * 'rest) instr - | Gt : - (z num * 'rest, bool * 'rest) instr - | Le : - (z num * 'rest, bool * 'rest) instr - | Ge : - (z num * 'rest, bool * 'rest) instr + | Eq : (z num * 'rest, bool * 'rest) instr + | Neq : (z num * 'rest, bool * 'rest) instr + | Lt : (z num * 'rest, bool * 'rest) instr + | Gt : (z num * 'rest, bool * 'rest) instr + | Le : (z num * 'rest, bool * 'rest) instr + | Ge : (z num * 'rest, bool * 'rest) instr (* protocol *) - | Address : - (_ typed_contract * 'rest, address * 'rest) instr - | Contract : 'p ty * string -> - (address * 'rest, 'p typed_contract option * 'rest) instr - | Transfer_tokens : - ('arg * (Tez.t * ('arg typed_contract * 'rest)), operation * 'rest) instr - | Create_account : - (public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))), - operation * (address * 'rest)) instr - | Implicit_account : - (public_key_hash * 'rest, unit typed_contract * 'rest) instr - | Create_contract : 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option -> - (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))), - operation * (address * 'rest)) instr - | Create_contract_2 : 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option -> - (public_key_hash option * (Tez.t * ('g * 'rest)), operation * (address * 'rest)) instr - | Set_delegate : - (public_key_hash option * 'rest, operation * 'rest) instr - | Now : - ('rest, Script_timestamp.t * 'rest) instr - | Balance : - ('rest, Tez.t * 'rest) instr - | Check_signature : - (public_key * (signature * (MBytes.t * 'rest)), bool * 'rest) instr - | Hash_key : - (public_key * 'rest, public_key_hash * 'rest) instr - | Pack : 'a ty -> - ('a * 'rest, MBytes.t * 'rest) instr - | Unpack : 'a ty -> - (MBytes.t * 'rest, 'a option * 'rest) instr - | Blake2b : - (MBytes.t * 'rest, MBytes.t * 'rest) instr - | Sha256 : - (MBytes.t * 'rest, MBytes.t * 'rest) instr - | Sha512 : - (MBytes.t * 'rest, MBytes.t * 'rest) instr - | Steps_to_quota : (* TODO: check that it always returns a nat *) + | Address : (_ typed_contract * 'rest, address * 'rest) instr + | Contract : + 'p ty * string + -> (address * 'rest, 'p typed_contract option * 'rest) instr + | Transfer_tokens + : ( 'arg * (Tez.t * ('arg typed_contract * 'rest)), + operation * 'rest ) + instr + | Create_account + : ( public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))), + operation * (address * 'rest) ) + instr + | Implicit_account + : (public_key_hash * 'rest, unit typed_contract * 'rest) instr + | Create_contract : + 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option + -> ( public_key_hash + * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))), + operation * (address * 'rest) ) + instr + | Create_contract_2 : + 'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option + -> ( public_key_hash option * (Tez.t * ('g * 'rest)), + operation * (address * 'rest) ) + instr + | Set_delegate : (public_key_hash option * 'rest, operation * 'rest) instr + | Now : ('rest, Script_timestamp.t * 'rest) instr + | Balance : ('rest, Tez.t * 'rest) instr + | Check_signature + : (public_key * (signature * (MBytes.t * 'rest)), bool * 'rest) instr + | Hash_key : (public_key * 'rest, public_key_hash * 'rest) instr + | Pack : 'a ty -> ('a * 'rest, MBytes.t * 'rest) instr + | Unpack : 'a ty -> (MBytes.t * 'rest, 'a option * 'rest) instr + | Blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) instr + | Sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) instr + | Sha512 : (MBytes.t * 'rest, MBytes.t * 'rest) instr + | Steps_to_quota + : (* TODO: check that it always returns a nat *) ('rest, n num * 'rest) instr - | Source : - ('rest, address * 'rest) instr - | Sender : - ('rest, address * 'rest) instr - | Self : 'p ty * string -> - ('rest, 'p typed_contract * 'rest) instr - | Amount : - ('rest, Tez.t * 'rest) instr - | Dig : int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness -> - ('bef, 'x * 'aft) instr - | Dug : int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness -> - ('x * 'bef, 'aft) instr - | Dipn : int * ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness * ('fbef, 'faft) descr -> - ('bef, 'aft) instr - | Dropn : int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness -> - ('bef, 'rest) instr - | ChainId : - ('rest, Chain_id.t * 'rest) instr + | Source : ('rest, address * 'rest) instr + | Sender : ('rest, address * 'rest) instr + | Self : 'p ty * string -> ('rest, 'p typed_contract * 'rest) instr + | Amount : ('rest, Tez.t * 'rest) instr + | Dig : + int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness + -> ('bef, 'x * 'aft) instr + | Dug : + int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness + -> ('x * 'bef, 'aft) instr + | Dipn : + int + * ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + * ('fbef, 'faft) descr + -> ('bef, 'aft) instr + | Dropn : + int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness + -> ('bef, 'rest) instr + | ChainId : ('rest, Chain_id.t * 'rest) instr (* Type witness for operations that work deep in the stack ignoring (and preserving) a prefix. @@ -434,14 +407,16 @@ and ('bef, 'aft) instr = parameters are the shape of the stack without the prefix before and after. The inductive definition makes it so by construction. *) and ('bef, 'aft, 'bef_suffix, 'aft_suffix) stack_prefix_preservation_witness = - | Prefix : ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness - -> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness + | Prefix : + ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness + -> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness | Rest : ('bef, 'aft, 'bef, 'aft) stack_prefix_preservation_witness -and ('bef, 'aft) descr = - { loc : Script.location ; - bef : 'bef stack_ty ; - aft : 'aft stack_ty ; - instr : ('bef, 'aft) instr } +and ('bef, 'aft) descr = { + loc : Script.location; + bef : 'bef stack_ty; + aft : 'aft stack_ty; + instr : ('bef, 'aft) instr; +} type ex_big_map = Ex_bm : ('key, 'value) big_map -> ex_big_map diff --git a/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.ml index 4a18d2a6a..bf949161f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.ml @@ -26,13 +26,17 @@ (* Tezos Protocol Implementation - Random number generation *) type seed = B of State_hash.t + type t = T of State_hash.t + type sequence = S of State_hash.t + type nonce = MBytes.t let nonce_encoding = Data_encoding.Fixed.bytes Constants_repr.nonce_length let init = "Laissez-faire les proprietaires." + let zero_bytes = MBytes.of_string (String.make Nonce_hash.size '\000') let state_hash_encoding = @@ -44,31 +48,25 @@ let state_hash_encoding = let seed_encoding = let open Data_encoding in - conv - (fun (B b) -> b) - (fun b -> B b) - state_hash_encoding + conv (fun (B b) -> b) (fun b -> B b) state_hash_encoding let empty = B (State_hash.hash_bytes [MBytes.of_string init]) let nonce (B state) nonce = - B (State_hash.hash_bytes ( [State_hash.to_bytes state; nonce] )) + B (State_hash.hash_bytes [State_hash.to_bytes state; nonce]) let initialize_new (B state) append = - T (State_hash.hash_bytes - (State_hash.to_bytes state :: zero_bytes :: append )) + T (State_hash.hash_bytes (State_hash.to_bytes state :: zero_bytes :: append)) let xor_higher_bits i b = let higher = MBytes.get_int32 b 0 in let r = Int32.logxor higher i in let res = MBytes.copy b in - MBytes.set_int32 res 0 r; - res + MBytes.set_int32 res 0 r ; res let sequence (T state) n = - State_hash.to_bytes state - |> xor_higher_bits n - |> (fun b -> S (State_hash.hash_bytes [b])) + State_hash.to_bytes state |> xor_higher_bits n + |> fun b -> S (State_hash.hash_bytes [b]) let take (S state) = let b = State_hash.to_bytes state in @@ -76,19 +74,19 @@ let take (S state) = (State_hash.to_bytes h, S h) let take_int32 s bound = - if Compare.Int32.(bound <= 0l) - then invalid_arg "Seed_repr.take_int32" (* FIXME *) + if Compare.Int32.(bound <= 0l) then invalid_arg "Seed_repr.take_int32" + (* FIXME *) else let rec loop s = - let bytes, s = take s in + let (bytes, s) = take s in let r = Int32.abs (MBytes.get_int32 bytes 0) in let drop_if_over = - Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in - if Compare.Int32.(r >= drop_if_over) - then loop s + Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) + in + if Compare.Int32.(r >= drop_if_over) then loop s else let v = Int32.rem r bound in - v, s + (v, s) in loop s @@ -101,15 +99,17 @@ let () = ~title:"Unexpected nonce length" ~description:"Nonce length is incorrect." ~pp:(fun ppf () -> - Format.fprintf ppf "Nonce length is not %i bytes long as it should." - Constants_repr.nonce_length) + Format.fprintf + ppf + "Nonce length is not %i bytes long as it should." + Constants_repr.nonce_length) Data_encoding.empty (function Unexpected_nonce_length -> Some () | _ -> None) (fun () -> Unexpected_nonce_length) let make_nonce nonce = - if Compare.Int.(MBytes.length nonce <> Constants_repr.nonce_length) - then error Unexpected_nonce_length + if Compare.Int.(MBytes.length nonce <> Constants_repr.nonce_length) then + error Unexpected_nonce_length else ok nonce let hash nonce = Nonce_hash.hash_bytes [nonce] @@ -122,18 +122,13 @@ let nonce_hash_key_part = Nonce_hash.to_path let initial_nonce_0 = zero_bytes -let initial_nonce_hash_0 = - hash initial_nonce_0 +let initial_nonce_hash_0 = hash initial_nonce_0 let deterministic_seed seed = nonce seed zero_bytes let initial_seeds n = let 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 + if Compare.Int.(i = 1) then List.rev (elt :: acc) + else loop (elt :: acc) (deterministic_seed elt) (i - 1) + in loop [] (B (State_hash.hash_bytes [])) n diff --git a/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli index d8ed774ce..7319f0a5c 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/seed_repr.mli @@ -32,7 +32,6 @@ The only expected property is: It should be difficult to find a seed such that the generated sequence is a given one. *) - (** {2 Random Generation} *) (** The state of the random number generator *) @@ -91,9 +90,11 @@ val nonce_hash_key_part : Nonce_hash.t -> string list -> string list (** {2 Predefined nonce} *) val initial_nonce_0 : nonce + val initial_nonce_hash_0 : Nonce_hash.t (** {2 Serializers} *) -val nonce_encoding : nonce Data_encoding.t +val nonce_encoding : nonce Data_encoding.t + val seed_encoding : seed Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.ml index 6f855b652..f1f00315d 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.ml @@ -26,9 +26,13 @@ open Misc type error += - | Unknown of { oldest : Cycle_repr.t ; - cycle : Cycle_repr.t ; - latest : Cycle_repr.t } (* `Permanent *) + | Unknown of { + oldest : Cycle_repr.t; + cycle : Cycle_repr.t; + latest : Cycle_repr.t; + } + +(* `Permanent *) let () = register_error_kind @@ -37,46 +41,60 @@ let () = ~title:"Unknown seed" ~description:"The requested seed is not available" ~pp:(fun ppf (oldest, cycle, latest) -> - if Cycle_repr.(cycle < oldest) then - Format.fprintf ppf - "The seed for cycle %a has been cleared from the context \ - \ (oldest known seed is for cycle %a)" - Cycle_repr.pp cycle - Cycle_repr.pp oldest - else - Format.fprintf ppf - "The seed for cycle %a has not been computed yet \ - \ (latest known seed is for cycle %a)" - Cycle_repr.pp cycle - Cycle_repr.pp latest) - Data_encoding.(obj3 - (req "oldest" Cycle_repr.encoding) - (req "requested" Cycle_repr.encoding) - (req "latest" Cycle_repr.encoding)) + if Cycle_repr.(cycle < oldest) then + Format.fprintf + ppf + "The seed for cycle %a has been cleared from the context (oldest \ + known seed is for cycle %a)" + Cycle_repr.pp + cycle + Cycle_repr.pp + oldest + else + Format.fprintf + ppf + "The seed for cycle %a has not been computed yet (latest known \ + seed is for cycle %a)" + Cycle_repr.pp + cycle + Cycle_repr.pp + latest) + Data_encoding.( + obj3 + (req "oldest" Cycle_repr.encoding) + (req "requested" Cycle_repr.encoding) + (req "latest" Cycle_repr.encoding)) (function - | Unknown { oldest ; cycle ; latest } -> Some (oldest, cycle, latest) - | _ -> None) - (fun (oldest, cycle, latest) -> Unknown { oldest ; cycle ; latest }) + | Unknown {oldest; cycle; latest} -> + Some (oldest, cycle, latest) + | _ -> + None) + (fun (oldest, cycle, latest) -> Unknown {oldest; cycle; latest}) let compute_for_cycle c ~revealed cycle = match Cycle_repr.pred cycle with - | None -> assert false (* should not happen *) + | None -> + assert false (* should not happen *) | Some previous_cycle -> let levels = Level_storage.levels_with_commitments_in_cycle c revealed in let combine (c, random_seed, unrevealed) level = - Storage.Seed.Nonce.get c level >>=? function + Storage.Seed.Nonce.get c level + >>=? function | Revealed nonce -> - Storage.Seed.Nonce.delete c level >>=? fun c -> + Storage.Seed.Nonce.delete c level + >>=? fun c -> return (c, Seed_repr.nonce random_seed nonce, unrevealed) | Unrevealed u -> - Storage.Seed.Nonce.delete c level >>=? fun c -> - return (c, random_seed, u :: unrevealed) + Storage.Seed.Nonce.delete c level + >>=? fun c -> return (c, random_seed, u :: unrevealed) in - Storage.Seed.For_cycle.get c previous_cycle >>=? fun prev_seed -> + Storage.Seed.For_cycle.get c previous_cycle + >>=? fun prev_seed -> let seed = Seed_repr.deterministic_seed prev_seed in - fold_left_s combine (c, seed, []) levels >>=? fun (c, seed, unrevealed) -> - Storage.Seed.For_cycle.init c cycle seed >>=? fun c -> - return (c, unrevealed) + fold_left_s combine (c, seed, []) levels + >>=? fun (c, seed, unrevealed) -> + Storage.Seed.For_cycle.init c cycle seed + >>=? fun c -> return (c, unrevealed) let for_cycle ctxt cycle = let preserved = Constants_storage.preserved_cycles ctxt in @@ -85,40 +103,46 @@ let for_cycle ctxt cycle = let latest = if Cycle_repr.(current_cycle = root) then Cycle_repr.add current_cycle (preserved + 1) - else - Cycle_repr.add current_cycle preserved in + else Cycle_repr.add current_cycle preserved + in let oldest = match Cycle_repr.sub current_cycle preserved with - | None -> Cycle_repr.root - | Some oldest -> oldest in - fail_unless Cycle_repr.(oldest <= cycle && cycle <= latest) - (Unknown { oldest ; cycle ; latest }) >>=? fun () -> - Storage.Seed.For_cycle.get ctxt cycle + | None -> + Cycle_repr.root + | Some oldest -> + oldest + in + fail_unless + Cycle_repr.(oldest <= cycle && cycle <= latest) + (Unknown {oldest; cycle; latest}) + >>=? fun () -> Storage.Seed.For_cycle.get ctxt cycle -let clear_cycle c cycle = - Storage.Seed.For_cycle.delete c cycle +let clear_cycle c cycle = Storage.Seed.For_cycle.delete c cycle let init ctxt = let preserved = Constants_storage.preserved_cycles ctxt in List.fold_left2 (fun ctxt c seed -> - ctxt >>=? fun ctxt -> - let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in - Storage.Seed.For_cycle.init ctxt cycle seed) + ctxt + >>=? fun ctxt -> + let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in + Storage.Seed.For_cycle.init ctxt cycle seed) (return ctxt) - (0 --> (preserved+1)) - (Seed_repr.initial_seeds (preserved+2)) + (0 --> (preserved + 1)) + (Seed_repr.initial_seeds (preserved + 2)) let cycle_end ctxt last_cycle = let preserved = Constants_storage.preserved_cycles ctxt in - begin - match Cycle_repr.sub last_cycle preserved with - | None -> return ctxt - | Some cleared_cycle -> - clear_cycle ctxt cleared_cycle - end >>=? fun ctxt -> + ( match Cycle_repr.sub last_cycle preserved with + | None -> + return ctxt + | Some cleared_cycle -> + clear_cycle ctxt cleared_cycle ) + >>=? fun ctxt -> match Cycle_repr.pred last_cycle with - | None -> return (ctxt, []) - | Some revealed -> (* cycle with revelations *) - let inited_seed_cycle = Cycle_repr.add last_cycle (preserved+1) in + | None -> + return (ctxt, []) + | Some revealed -> + (* cycle with revelations *) + let inited_seed_cycle = Cycle_repr.add last_cycle (preserved + 1) in compute_for_cycle ctxt ~revealed inited_seed_cycle diff --git a/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.mli index 2a1fd25a0..37e87efed 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/seed_storage.mli @@ -24,21 +24,24 @@ (*****************************************************************************) type error += - | Unknown of { oldest : Cycle_repr.t ; - cycle : Cycle_repr.t ; - latest : Cycle_repr.t } (* `Permanent *) + | Unknown of { + oldest : Cycle_repr.t; + cycle : Cycle_repr.t; + latest : Cycle_repr.t; + } + +(* `Permanent *) (** Generates the first [preserved_cycles+2] seeds for which there are no nonces. *) -val init: - Raw_context.t -> Raw_context.t tzresult Lwt.t +val init : Raw_context.t -> Raw_context.t tzresult Lwt.t -val for_cycle: - Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t +val for_cycle : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t (** If it is the end of the cycle, computes and stores the seed of cycle at distance [preserved_cycle+2] in the future using the seed of the previous cycle and the revelations of the current one. *) -val cycle_end: - Raw_context.t -> Cycle_repr.t -> +val cycle_end : + Raw_context.t -> + Cycle_repr.t -> (Raw_context.t * Nonce_storage.unrevealed list) tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml b/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml index 3113307f7..44338933c 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/services_registration.ml @@ -26,12 +26,12 @@ open Alpha_context type rpc_context = { - block_hash: Block_hash.t ; - block_header: Block_header.shell_header ; - context: Alpha_context.t ; + block_hash : Block_hash.t; + block_header : Block_header.shell_header; + context : Alpha_context.t; } -let rpc_init ({ block_hash ; block_header ; context } : Updater.rpc_context) = +let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) = let level = block_header.level in let timestamp = block_header.timestamp in let fitness = block_header.fitness in @@ -39,59 +39,55 @@ let rpc_init ({ block_hash ; block_header ; context } : Updater.rpc_context) = ~level ~predecessor_timestamp:timestamp ~timestamp - ~fitness context >>=? fun context -> - return { block_hash ; block_header ; context } + ~fitness + context + >>=? fun context -> return {block_hash; block_header; context} -let rpc_services = ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t) +let rpc_services = + ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t) let register0_fullctxt s f = rpc_services := - RPC_directory.register !rpc_services s - (fun ctxt q i -> - rpc_init ctxt >>=? fun ctxt -> - f ctxt q i) + RPC_directory.register !rpc_services s (fun ctxt q i -> + rpc_init ctxt >>=? fun ctxt -> f ctxt q i) + let opt_register0_fullctxt s f = rpc_services := - RPC_directory.opt_register !rpc_services s - (fun ctxt q i -> - rpc_init ctxt >>=? fun ctxt -> - f ctxt q i) -let register0 s f = - register0_fullctxt s (fun { context ; _ } -> f context) + RPC_directory.opt_register !rpc_services s (fun ctxt q i -> + rpc_init ctxt >>=? fun ctxt -> f ctxt q i) + +let register0 s f = register0_fullctxt s (fun {context; _} -> f context) + let register0_noctxt s f = - rpc_services := - RPC_directory.register !rpc_services s - (fun _ q i -> f q i) + rpc_services := RPC_directory.register !rpc_services s (fun _ q i -> f q i) let register1_fullctxt s f = rpc_services := - RPC_directory.register !rpc_services s - (fun (ctxt, arg) q i -> - rpc_init ctxt >>=? fun ctxt -> - f ctxt arg q i) -let register1 s f = register1_fullctxt s (fun { context ; _ } x -> f context x) + RPC_directory.register !rpc_services s (fun (ctxt, arg) q i -> + rpc_init ctxt >>=? fun ctxt -> f ctxt arg q i) + +let register1 s f = register1_fullctxt s (fun {context; _} x -> f context x) + let register1_noctxt s f = rpc_services := - RPC_directory.register !rpc_services s - (fun (_, arg) q i -> f arg q i) + RPC_directory.register !rpc_services s (fun (_, arg) q i -> f arg q i) let register2_fullctxt s f = rpc_services := - RPC_directory.register !rpc_services s - (fun ((ctxt, arg1), arg2) q i -> - rpc_init ctxt >>=? fun ctxt -> - f ctxt arg1 arg2 q i) + RPC_directory.register !rpc_services s (fun ((ctxt, arg1), arg2) q i -> + rpc_init ctxt >>=? fun ctxt -> f ctxt arg1 arg2 q i) + let register2 s f = - register2_fullctxt s (fun { context ; _ } a1 a2 q i -> f context a1 a2 q i) + register2_fullctxt s (fun {context; _} a1 a2 q i -> f context a1 a2 q i) let get_rpc_services () = let p = RPC_directory.map (fun c -> - rpc_init c >>= function - | Error _ -> assert false - | Ok c -> Lwt.return c.context) - (Storage_description.build_directory Alpha_context.description) in + rpc_init c + >>= function Error _ -> assert false | Ok c -> Lwt.return c.context) + (Storage_description.build_directory Alpha_context.description) + in RPC_directory.register_dynamic_directory !rpc_services RPC_path.(open_root / "context" / "raw" / "json") diff --git a/vendors/ligo-utils/tezos-protocol-alpha/state_hash.ml b/vendors/ligo-utils/tezos-protocol-alpha/state_hash.ml index ac240a4ad..f72c0d5c5 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/state_hash.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/state_hash.ml @@ -25,13 +25,16 @@ let random_state_hash = "\076\064\204" (* rng(53): never used... *) -include Blake2B.Make(Base58)(struct - let name = "random" - let title = "A random generation state" - let b58check_prefix = random_state_hash - let size = None - end) +include Blake2B.Make + (Base58) + (struct + let name = "random" -let () = - Base58.check_encoded_prefix b58check_encoding "rng" 53 + let title = "A random generation state" + let b58check_prefix = random_state_hash + + let size = None + end) + +let () = Base58.check_encoded_prefix b58check_encoding "rng" 53 diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage.ml index 5d2ec65c9..86f11b8bb 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage.ml @@ -27,269 +27,301 @@ open Storage_functors module Int = struct type t = int + let encoding = Data_encoding.uint16 end module Int32 = struct type t = Int32.t + let encoding = Data_encoding.int32 end module Z = struct include Z + let encoding = Data_encoding.z end module Int_index = struct type t = int + let path_length = 1 + let to_path c l = string_of_int c :: l + let of_path = function - | [] | _ :: _ :: _ -> None - | [ c ] -> int_of_string_opt c + | [] | _ :: _ :: _ -> + None + | [c] -> + int_of_string_opt c + type 'a ipath = 'a * t - let args = Storage_description.One { - rpc_arg = RPC_arg.int ; - encoding = Data_encoding.int31 ; - compare = Compare.Int.compare ; - } + + let args = + Storage_description.One + { + rpc_arg = RPC_arg.int; + encoding = Data_encoding.int31; + compare = Compare.Int.compare; + } end -module Make_index(H : Storage_description.INDEX) - : INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct +module Make_index (H : Storage_description.INDEX) : + INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct include H + type 'a ipath = 'a * t - let args = Storage_description.One { - rpc_arg ; - encoding ; - compare ; - } + + let args = Storage_description.One {rpc_arg; encoding; compare} end module Block_priority = - Make_single_data_storage(Registered) - (Raw_context) - (struct let name = ["block_priority"] end) - (Int) - -(* Only for migration from 004 *) -module Last_block_priority = - Make_single_data_storage(Ghost) - (Raw_context) - (struct let name = ["last_block_priority"] end) + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["block_priority"] + end) (Int) (** Contracts handling *) module Contract = struct - module Raw_context = - Make_subcontext(Registered)(Raw_context)(struct let name = ["contracts"] end) + Make_subcontext (Registered) (Raw_context) + (struct + let name = ["contracts"] + end) module Global_counter = - Make_single_data_storage(Registered) - (Raw_context) - (struct let name = ["global_counter"] end) + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["global_counter"] + end) (Z) module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end)) - (Make_index(Contract_repr.Index)) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["index"] + end)) + (Make_index (Contract_repr.Index)) let fold = Indexed_context.fold_keys + let list = Indexed_context.keys module Balance = Indexed_context.Make_map - (struct let name = ["balance"] end) + (struct + let name = ["balance"] + end) (Tez_repr) module Frozen_balance_index = Make_indexed_subcontext - (Make_subcontext(Registered) - (Indexed_context.Raw_context) - (struct let name = ["frozen_balance"] end)) - (Make_index(Cycle_repr.Index)) + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["frozen_balance"] + end)) + (Make_index (Cycle_repr.Index)) module Frozen_deposits = Frozen_balance_index.Make_map - (struct let name = ["deposits"] end) + (struct + let name = ["deposits"] + end) (Tez_repr) module Frozen_fees = Frozen_balance_index.Make_map - (struct let name = ["fees"] end) + (struct + let name = ["fees"] + end) (Tez_repr) module Frozen_rewards = Frozen_balance_index.Make_map - (struct let name = ["rewards"] end) + (struct + let name = ["rewards"] + end) (Tez_repr) module Manager = Indexed_context.Make_map - (struct let name = ["manager"] end) + (struct + let name = ["manager"] + end) (Manager_repr) - module Spendable_004 = - Indexed_context.Make_set(Ghost) - (struct let name = ["spendable"] end) - - module Delegatable_004 = - Indexed_context.Make_set(Ghost) - (struct let name = ["delegatable"] end) - module Delegate = Indexed_context.Make_map - (struct let name = ["delegate"] end) + (struct + let name = ["delegate"] + end) (Signature.Public_key_hash) module Inactive_delegate = - Indexed_context.Make_set(Registered) - (struct let name = ["inactive_delegate"] end) + Indexed_context.Make_set + (Registered) + (struct + let name = ["inactive_delegate"] + end) module Delegate_desactivation = Indexed_context.Make_map - (struct let name = ["delegate_desactivation"] end) + (struct + let name = ["delegate_desactivation"] + end) (Cycle_repr) module Delegated = Make_data_set_storage - (Make_subcontext(Registered) - (Indexed_context.Raw_context) - (struct let name = ["delegated"] end)) - (Make_index(Contract_repr.Index)) - - (** Only for migration from proto_004 *) - module Delegated_004 = - Make_data_set_storage - (Make_subcontext(Ghost) - (Indexed_context.Raw_context) - (struct let name = ["delegated_004"] end)) - (Make_index(Contract_hash)) + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["delegated"] + end)) + (Make_index (Contract_repr.Index)) module Counter = Indexed_context.Make_map - (struct let name = ["counter"] end) + (struct + let name = ["counter"] + end) (Z) (* Consume gas for serilization and deserialization of expr in this module *) module Make_carbonated_map_expr (N : Storage_sigs.NAME) = struct - module I = Indexed_context.Make_carbonated_map + module I = + Indexed_context.Make_carbonated_map (N) (struct type t = Script_repr.lazy_expr + let encoding = Script_repr.lazy_expr_encoding end) type context = I.context + type key = I.key + type value = I.value let mem = I.mem + let delete = I.delete + let remove = I.remove let consume_deserialize_gas ctxt value = - Lwt.return @@ - (Raw_context.check_enough_gas ctxt (Script_repr.minimal_deserialize_cost value) >>? fun () -> - Script_repr.force_decode value >>? fun (_value, value_cost) -> - Raw_context.consume_gas ctxt value_cost) + Lwt.return + @@ ( Raw_context.check_enough_gas + ctxt + (Script_repr.minimal_deserialize_cost value) + >>? fun () -> + Script_repr.force_decode value + >>? fun (_value, value_cost) -> + Raw_context.consume_gas ctxt value_cost ) let consume_serialize_gas ctxt value = - Lwt.return @@ - (Script_repr.force_bytes value >>? fun (_value, value_cost) -> - Raw_context.consume_gas ctxt value_cost) + Lwt.return + @@ ( Script_repr.force_bytes value + >>? fun (_value, value_cost) -> + Raw_context.consume_gas ctxt value_cost ) let get ctxt contract = - I.get ctxt contract >>=? fun (ctxt, value) -> - consume_deserialize_gas ctxt value >>|? fun ctxt -> - (ctxt, value) + I.get ctxt contract + >>=? fun (ctxt, value) -> + consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value) let get_option ctxt contract = - I.get_option ctxt contract >>=? fun (ctxt, value_opt) -> + I.get_option ctxt contract + >>=? fun (ctxt, value_opt) -> match value_opt with - | None -> return (ctxt, None) + | None -> + return (ctxt, None) | Some value -> - consume_deserialize_gas ctxt value >>|? fun ctxt -> - (ctxt, value_opt) + consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt) let set ctxt contract value = - consume_serialize_gas ctxt value >>=? fun ctxt -> - I.set ctxt contract value + consume_serialize_gas ctxt value + >>=? fun ctxt -> I.set ctxt contract value let set_option ctxt contract value_opt = match value_opt with - | None -> I.set_option ctxt contract None + | None -> + I.set_option ctxt contract None | Some value -> - consume_serialize_gas ctxt value >>=? fun ctxt -> - I.set_option ctxt contract value_opt + consume_serialize_gas ctxt value + >>=? fun ctxt -> I.set_option ctxt contract value_opt let init ctxt contract value = - consume_serialize_gas ctxt value >>=? fun ctxt -> - I.init ctxt contract value + consume_serialize_gas ctxt value + >>=? fun ctxt -> I.init ctxt contract value let init_set ctxt contract value = - consume_serialize_gas ctxt value >>=? fun ctxt -> - I.init_set ctxt contract value - - (** Only for used for 005 migration to avoid gas cost. *) - let init_free ctxt contract value = - I.init_free ctxt contract value - - (** Only for used for 005 migration to avoid gas cost. *) - let set_free ctxt contract value = - I.set_free ctxt contract value + consume_serialize_gas ctxt value + >>=? fun ctxt -> I.init_set ctxt contract value end - module Code = - Make_carbonated_map_expr - (struct let name = ["code"] end) + module Code = Make_carbonated_map_expr (struct + let name = ["code"] + end) - module Storage = - Make_carbonated_map_expr - (struct let name = ["storage"] end) + module Storage = Make_carbonated_map_expr (struct + let name = ["storage"] + end) module Paid_storage_space = Indexed_context.Make_map - (struct let name = ["paid_bytes"] end) + (struct + let name = ["paid_bytes"] + end) (Z) module Used_storage_space = Indexed_context.Make_map - (struct let name = ["used_bytes"] end) + (struct + let name = ["used_bytes"] + end) (Z) module Roll_list = Indexed_context.Make_map - (struct let name = ["roll_list"] end) + (struct + let name = ["roll_list"] + end) (Roll_repr) module Change = Indexed_context.Make_map - (struct let name = ["change"] end) + (struct + let name = ["change"] + end) (Tez_repr) - end (** Big maps handling *) module Big_map = struct module Raw_context = - Make_subcontext(Registered)(Raw_context)(struct let name = ["big_maps"] end) + Make_subcontext (Registered) (Raw_context) + (struct + let name = ["big_maps"] + end) module Next = struct - include - Make_single_data_storage(Registered) - (Raw_context) - (struct let name = ["next"] end) - (Z) + include Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["next"] + end) + (Z) + let incr ctxt = - get ctxt >>=? fun i -> - set ctxt (Z.succ i) >>=? fun ctxt -> - return (ctxt, i) + get ctxt + >>=? fun i -> set ctxt (Z.succ i) >>=? fun ctxt -> return (ctxt, i) + let init ctxt = init ctxt Z.zero end @@ -300,184 +332,224 @@ module Big_map = struct let construct = Z.to_string in let destruct hash = match Z.of_string hash with - | exception _ -> Error "Cannot parse big map id" - | id -> Ok id in + | exception _ -> + Error "Cannot parse big map id" + | id -> + Ok id + in RPC_arg.make - ~descr: "A big map identifier" - ~name: "big_map_id" + ~descr:"A big map identifier" + ~name:"big_map_id" ~construct ~destruct () let encoding = - Data_encoding.def "big_map_id" + Data_encoding.def + "big_map_id" ~title:"Big map identifier" - ~description: "A big map identifier" + ~description:"A big map identifier" Z.encoding + let compare = Compare.Z.compare let path_length = 7 let to_path c l = let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in - let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in - String.sub index_key 0 2 :: - String.sub index_key 2 2 :: - String.sub index_key 4 2 :: - String.sub index_key 6 2 :: - String.sub index_key 8 2 :: - String.sub index_key 10 2 :: - Z.to_string c :: - l + let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + String.sub index_key 0 2 :: String.sub index_key 2 2 + :: String.sub index_key 4 2 :: String.sub index_key 6 2 + :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: Z.to_string c + :: l let of_path = function - | [] | [_] | [_;_] | [_;_;_] | [_;_;_;_] | [_;_;_;_;_] | [_;_;_;_;_;_] - | _::_::_::_::_::_::_::_::_ -> + | [] + | [_] + | [_; _] + | [_; _; _] + | [_; _; _; _] + | [_; _; _; _; _] + | [_; _; _; _; _; _] + | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ -> None - | [ index1 ; index2 ; index3 ; index4 ; index5 ; index6 ; key ] -> + | [index1; index2; index3; index4; index5; index6; key] -> let c = Z.of_string key in let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in - let `Hex index_key = MBytes.to_hex (Raw_hashes.blake2b raw_key) in - assert Compare.String.(String.sub index_key 0 2 = index1) ; - assert Compare.String.(String.sub index_key 2 2 = index2) ; - assert Compare.String.(String.sub index_key 4 2 = index3) ; - assert Compare.String.(String.sub index_key 6 2 = index4) ; - assert Compare.String.(String.sub index_key 8 2 = index5) ; - assert Compare.String.(String.sub index_key 10 2 = index6) ; + let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in + assert (Compare.String.(String.sub index_key 0 2 = index1)) ; + assert (Compare.String.(String.sub index_key 2 2 = index2)) ; + assert (Compare.String.(String.sub index_key 4 2 = index3)) ; + assert (Compare.String.(String.sub index_key 6 2 = index4)) ; + assert (Compare.String.(String.sub index_key 8 2 = index5)) ; + assert (Compare.String.(String.sub index_key 10 2 = index6)) ; Some c end module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end)) - (Make_index(Index)) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["index"] + end)) + (Make_index (Index)) let rpc_arg = Index.rpc_arg let fold = Indexed_context.fold_keys + let list = Indexed_context.keys - let remove_rec ctxt n = - Indexed_context.remove_rec ctxt n + let remove_rec ctxt n = Indexed_context.remove_rec ctxt n - let copy ctxt ~from ~to_ = - Indexed_context.copy ctxt ~from ~to_ + let copy ctxt ~from ~to_ = Indexed_context.copy ctxt ~from ~to_ type key = Raw_context.t * Z.t module Total_bytes = Indexed_context.Make_map - (struct let name = ["total_bytes"] end) + (struct + let name = ["total_bytes"] + end) (Z) module Key_type = Indexed_context.Make_map - (struct let name = ["key_type"] end) - (struct - type t = Script_repr.expr - let encoding = Script_repr.expr_encoding - end) + (struct + let name = ["key_type"] + end) + (struct + type t = Script_repr.expr + + let encoding = Script_repr.expr_encoding + end) module Value_type = Indexed_context.Make_map - (struct let name = ["value_type"] end) - (struct - type t = Script_repr.expr - let encoding = Script_repr.expr_encoding - end) + (struct + let name = ["value_type"] + end) + (struct + type t = Script_repr.expr + + let encoding = Script_repr.expr_encoding + end) module Contents = struct + module I = + Storage_functors.Make_indexed_carbonated_data_storage + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["contents"] + end)) + (Make_index (Script_expr_hash)) + (struct + type t = Script_repr.expr - module I = Storage_functors.Make_indexed_carbonated_data_storage - (Make_subcontext(Registered) - (Indexed_context.Raw_context) - (struct let name = ["contents"] end)) - (Make_index(Script_expr_hash)) - (struct - type t = Script_repr.expr - let encoding = Script_repr.expr_encoding - end) + let encoding = Script_repr.expr_encoding + end) type context = I.context + type key = I.key + type value = I.value let mem = I.mem + let delete = I.delete + let remove = I.remove + let set = I.set + let set_option = I.set_option + let init = I.init + let init_set = I.init_set let consume_deserialize_gas ctxt value = - Lwt.return @@ - Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value) + Lwt.return + @@ Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value) let get ctxt contract = - I.get ctxt contract >>=? fun (ctxt, value) -> - consume_deserialize_gas ctxt value >>|? fun ctxt -> - (ctxt, value) + I.get ctxt contract + >>=? fun (ctxt, value) -> + consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value) let get_option ctxt contract = - I.get_option ctxt contract >>=? fun (ctxt, value_opt) -> + I.get_option ctxt contract + >>=? fun (ctxt, value_opt) -> match value_opt with - | None -> return (ctxt, None) + | None -> + return (ctxt, None) | Some value -> - consume_deserialize_gas ctxt value >>|? fun ctxt -> - (ctxt, value_opt) + consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt) end - end module Delegates = Make_data_set_storage - (Make_subcontext(Registered)(Raw_context)(struct let name = ["delegates"] end)) - (Make_index(Signature.Public_key_hash)) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["delegates"] + end)) + (Make_index (Signature.Public_key_hash)) module Active_delegates_with_rolls = Make_data_set_storage - (Make_subcontext(Registered)(Raw_context)(struct let name = ["active_delegates_with_rolls"] end)) - (Make_index(Signature.Public_key_hash)) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["active_delegates_with_rolls"] + end)) + (Make_index (Signature.Public_key_hash)) module Delegates_with_frozen_balance_index = Make_indexed_subcontext - (Make_subcontext(Registered)(Raw_context) - (struct let name = ["delegates_with_frozen_balance"] end)) - (Make_index(Cycle_repr.Index)) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["delegates_with_frozen_balance"] + end)) + (Make_index (Cycle_repr.Index)) module Delegates_with_frozen_balance = Make_data_set_storage (Delegates_with_frozen_balance_index.Raw_context) - (Make_index(Signature.Public_key_hash)) + (Make_index (Signature.Public_key_hash)) (** Rolls *) module Cycle = struct - module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Registered)(Raw_context)(struct let name = ["cycle"] end)) - (Make_index(Cycle_repr.Index)) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["cycle"] + end)) + (Make_index (Cycle_repr.Index)) module Last_roll = Make_indexed_data_storage - (Make_subcontext(Registered) - (Indexed_context.Raw_context) - (struct let name = ["last_roll"] end)) - (Int_index) + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["last_roll"] + end)) + (Int_index) (Roll_repr) module Roll_snapshot = Indexed_context.Make_map - (struct let name = ["roll_snapshot"] end) + (struct + let name = ["roll_snapshot"] + end) (Int) type unrevealed_nonce = { - nonce_hash: Nonce_hash.t ; - delegate: Signature.Public_key_hash.t ; - rewards: Tez_repr.t ; - fees: Tez_repr.t ; + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; } type nonce_status = @@ -486,213 +558,259 @@ module Cycle = struct let nonce_status_encoding = let open Data_encoding in - union [ - case (Tag 0) - ~title:"Unrevealed" - (tup4 - Nonce_hash.encoding - Signature.Public_key_hash.encoding - Tez_repr.encoding - Tez_repr.encoding) - (function - | Unrevealed { nonce_hash ; delegate ; rewards ; fees } -> - Some (nonce_hash, delegate, rewards, fees) - | _ -> None) - (fun (nonce_hash, delegate, rewards, fees) -> - Unrevealed { nonce_hash ; delegate ; rewards ; fees }) ; - case (Tag 1) - ~title:"Revealed" - Seed_repr.nonce_encoding - (function - | Revealed nonce -> Some nonce - | _ -> None) - (fun nonce -> Revealed nonce) - ] + union + [ case + (Tag 0) + ~title:"Unrevealed" + (tup4 + Nonce_hash.encoding + Signature.Public_key_hash.encoding + Tez_repr.encoding + Tez_repr.encoding) + (function + | Unrevealed {nonce_hash; delegate; rewards; fees} -> + Some (nonce_hash, delegate, rewards, fees) + | _ -> + None) + (fun (nonce_hash, delegate, rewards, fees) -> + Unrevealed {nonce_hash; delegate; rewards; fees}); + case + (Tag 1) + ~title:"Revealed" + Seed_repr.nonce_encoding + (function Revealed nonce -> Some nonce | _ -> None) + (fun nonce -> Revealed nonce) ] module Nonce = Make_indexed_data_storage - (Make_subcontext(Registered) - (Indexed_context.Raw_context) - (struct let name = ["nonces"] end)) - (Make_index(Raw_level_repr.Index)) - (struct - type t = nonce_status - let encoding = nonce_status_encoding - end) + (Make_subcontext (Registered) (Indexed_context.Raw_context) + (struct + let name = ["nonces"] + end)) + (Make_index (Raw_level_repr.Index)) + (struct + type t = nonce_status + + let encoding = nonce_status_encoding + end) module Seed = Indexed_context.Make_map - (struct let name = ["random_seed"] end) + (struct + let name = ["random_seed"] + end) (struct type t = Seed_repr.seed + let encoding = Seed_repr.seed_encoding end) - end module Roll = struct - module Raw_context = - Make_subcontext(Registered)(Raw_context)(struct let name = ["rolls"] end) + Make_subcontext (Registered) (Raw_context) + (struct + let name = ["rolls"] + end) module Indexed_context = Make_indexed_subcontext - (Make_subcontext(Registered)(Raw_context)(struct let name = ["index"] end)) - (Make_index(Roll_repr.Index)) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["index"] + end)) + (Make_index (Roll_repr.Index)) module Next = - Make_single_data_storage(Registered) - (Raw_context) - (struct let name = ["next"] end) + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["next"] + end) (Roll_repr) module Limbo = - Make_single_data_storage(Registered) - (Raw_context) - (struct let name = ["limbo"] end) + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["limbo"] + end) (Roll_repr) module Delegate_roll_list = - Wrap_indexed_data_storage(Contract.Roll_list)(struct - type t = Signature.Public_key_hash.t - let wrap = Contract_repr.implicit_contract - let unwrap = Contract_repr.is_implicit - end) + Wrap_indexed_data_storage + (Contract.Roll_list) + (struct + type t = Signature.Public_key_hash.t + + let wrap = Contract_repr.implicit_contract + + let unwrap = Contract_repr.is_implicit + end) module Successor = Indexed_context.Make_map - (struct let name = ["successor"] end) + (struct + let name = ["successor"] + end) (Roll_repr) module Delegate_change = - Wrap_indexed_data_storage(Contract.Change)(struct - type t = Signature.Public_key_hash.t - let wrap = Contract_repr.implicit_contract - let unwrap = Contract_repr.is_implicit - end) + Wrap_indexed_data_storage + (Contract.Change) + (struct + type t = Signature.Public_key_hash.t + + let wrap = Contract_repr.implicit_contract + + let unwrap = Contract_repr.is_implicit + end) module Snapshoted_owner_index = struct type t = Cycle_repr.t * int + let path_length = Cycle_repr.Index.path_length + 1 - let to_path (c, n) s = - Cycle_repr.Index.to_path c (string_of_int n :: s) + + let to_path (c, n) s = Cycle_repr.Index.to_path c (string_of_int n :: s) + let of_path l = match Misc.take Cycle_repr.Index.path_length l with - | None | Some (_, ([] | _ :: _ :: _ ))-> None - | Some (l1, [l2]) -> - match Cycle_repr.Index.of_path l1, int_of_string_opt l2 with - | None, _ | _, None -> None - | Some c, Some i -> Some (c, i) + | None | Some (_, ([] | _ :: _ :: _)) -> + None + | Some (l1, [l2]) -> ( + match (Cycle_repr.Index.of_path l1, int_of_string_opt l2) with + | (None, _) | (_, None) -> + None + | (Some c, Some i) -> + Some (c, i) ) type 'a ipath = ('a * Cycle_repr.t) * int + let left_args = - Storage_description.One { - rpc_arg = Cycle_repr.rpc_arg ; - encoding = Cycle_repr.encoding ; - compare = Cycle_repr.compare - } + Storage_description.One + { + rpc_arg = Cycle_repr.rpc_arg; + encoding = Cycle_repr.encoding; + compare = Cycle_repr.compare; + } + let right_args = - Storage_description.One { - rpc_arg = RPC_arg.int ; - encoding = Data_encoding.int31 ; - compare = Compare.Int.compare ; - } - let args = - Storage_description.(Pair (left_args, right_args)) + Storage_description.One + { + rpc_arg = RPC_arg.int; + encoding = Data_encoding.int31; + compare = Compare.Int.compare; + } + + let args = Storage_description.(Pair (left_args, right_args)) end module Owner = Make_indexed_data_snapshotable_storage - (Make_subcontext(Registered)(Raw_context)(struct let name = ["owner"] end)) - (Snapshoted_owner_index) - (Make_index(Roll_repr.Index)) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["owner"] + end)) + (Snapshoted_owner_index) + (Make_index (Roll_repr.Index)) (Signature.Public_key) module Snapshot_for_cycle = Cycle.Roll_snapshot module Last_for_snapshot = Cycle.Last_roll let clear = Indexed_context.clear - end -(** Votes **) +(** Votes *) module Vote = struct - module Raw_context = - Make_subcontext(Registered)(Raw_context)(struct let name = ["votes"] end) + Make_subcontext (Registered) (Raw_context) + (struct + let name = ["votes"] + end) module Current_period_kind = - Make_single_data_storage(Registered) - (Raw_context) - (struct let name = ["current_period_kind"] end) + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["current_period_kind"] + end) (struct type t = Voting_period_repr.kind + let encoding = Voting_period_repr.kind_encoding end) - module Current_quorum_004 = - Make_single_data_storage(Ghost) - (Raw_context) - (struct let name = ["current_quorum"] end) - (Int32) - module Participation_ema = - Make_single_data_storage(Registered) - (Raw_context) - (struct let name = ["participation_ema"] end) + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["participation_ema"] + end) (Int32) module Current_proposal = - Make_single_data_storage(Registered) - (Raw_context) - (struct let name = ["current_proposal"] end) + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["current_proposal"] + end) (Protocol_hash) module Listings_size = - Make_single_data_storage(Registered) - (Raw_context) - (struct let name = ["listings_size"] end) + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["listings_size"] + end) (Int32) module Listings = Make_indexed_data_storage - (Make_subcontext(Registered)(Raw_context)(struct let name = ["listings"] end)) - (Make_index(Signature.Public_key_hash)) - (Int32) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["listings"] + end)) + (Make_index (Signature.Public_key_hash)) + (Int32) module Proposals = Make_data_set_storage - (Make_subcontext(Registered)(Raw_context)(struct let name = ["proposals"] end)) - (Pair(Make_index(Protocol_hash))(Make_index(Signature.Public_key_hash))) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["proposals"] + end)) + (Pair + (Make_index + (Protocol_hash)) + (Make_index (Signature.Public_key_hash))) module Proposals_count = Make_indexed_data_storage - (Make_subcontext(Registered)(Raw_context) - (struct let name = ["proposals_count"] end)) - (Make_index(Signature.Public_key_hash)) - (Int) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["proposals_count"] + end)) + (Make_index (Signature.Public_key_hash)) + (Int) module Ballots = Make_indexed_data_storage - (Make_subcontext(Registered)(Raw_context)(struct let name = ["ballots"] end)) - (Make_index(Signature.Public_key_hash)) - (struct - type t = Vote_repr.ballot - let encoding = Vote_repr.ballot_encoding - end) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["ballots"] + end)) + (Make_index (Signature.Public_key_hash)) + (struct + type t = Vote_repr.ballot + let encoding = Vote_repr.ballot_encoding + end) end (** Seed *) module Seed = struct - type unrevealed_nonce = Cycle.unrevealed_nonce = { - nonce_hash: Nonce_hash.t ; - delegate: Signature.Public_key_hash.t ; - rewards: Tez_repr.t ; - fees: Tez_repr.t ; + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; } type nonce_status = Cycle.nonce_status = @@ -701,49 +819,73 @@ module Seed = struct module Nonce = struct open Level_repr + type context = Raw_context.t + let mem ctxt l = Cycle.Nonce.mem (ctxt, l.cycle) l.level + let get ctxt l = Cycle.Nonce.get (ctxt, l.cycle) l.level + let get_option ctxt l = Cycle.Nonce.get_option (ctxt, l.cycle) l.level + let set ctxt l v = Cycle.Nonce.set (ctxt, l.cycle) l.level v + let init ctxt l v = Cycle.Nonce.init (ctxt, l.cycle) l.level v + let init_set ctxt l v = Cycle.Nonce.init_set (ctxt, l.cycle) l.level v + let set_option ctxt l v = Cycle.Nonce.set_option (ctxt, l.cycle) l.level v + let delete ctxt l = Cycle.Nonce.delete (ctxt, l.cycle) l.level + let remove ctxt l = Cycle.Nonce.remove (ctxt, l.cycle) l.level end - module For_cycle = Cycle.Seed + module For_cycle = Cycle.Seed end (** Commitments *) module Commitments = Make_indexed_data_storage - (Make_subcontext(Registered)(Raw_context)(struct let name = ["commitments"] end)) - (Make_index(Blinded_public_key_hash.Index)) - (Tez_repr) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["commitments"] + end)) + (Make_index (Blinded_public_key_hash.Index)) + (Tez_repr) (** Ramp up security deposits... *) module Ramp_up = struct - module Rewards = Make_indexed_data_storage - (Make_subcontext(Registered)(Raw_context)(struct let name = ["ramp_up"; "rewards"] end)) - (Make_index(Cycle_repr.Index)) - (struct - type t = Tez_repr.t * Tez_repr.t - let encoding = Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding - end) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["ramp_up"; "rewards"] + end)) + (Make_index (Cycle_repr.Index)) + (struct + type t = Tez_repr.t list * Tez_repr.t list + + let encoding = + Data_encoding.( + obj2 + (req "baking_reward_per_endorsement" (list Tez_repr.encoding)) + (req "endorsement_reward" (list Tez_repr.encoding))) + end) module Security_deposits = Make_indexed_data_storage - (Make_subcontext(Registered)(Raw_context)(struct let name = ["ramp_up"; "deposits"] end)) - (Make_index(Cycle_repr.Index)) - (struct - type t = Tez_repr.t * Tez_repr.t - let encoding = Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding - end) + (Make_subcontext (Registered) (Raw_context) + (struct + let name = ["ramp_up"; "deposits"] + end)) + (Make_index (Cycle_repr.Index)) + (struct + type t = Tez_repr.t * Tez_repr.t + let encoding = + Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding + end) end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/storage.mli index 1d7c887d5..669b3048f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage.mli @@ -38,372 +38,359 @@ open Storage_sigs module Block_priority : sig val get : Raw_context.t -> int tzresult Lwt.t + val set : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t + val init : Raw_context.t -> int -> Raw_context.t tzresult Lwt.t end -(* Only for migration from 004 *) -module Last_block_priority : sig - val delete : Raw_context.t -> Raw_context.t tzresult Lwt.t -end - module Roll : sig - (** Storage from this submodule must only be accessed through the module `Roll`. *) - module Owner : Indexed_data_snapshotable_storage - with type key = Roll_repr.t - and type snapshot = (Cycle_repr.t * int) - and type value = Signature.Public_key.t - and type t := Raw_context.t + module Owner : + Indexed_data_snapshotable_storage + with type key = Roll_repr.t + and type snapshot = Cycle_repr.t * int + and type value = Signature.Public_key.t + and type t := Raw_context.t - val clear: Raw_context.t -> Raw_context.t Lwt.t + val clear : Raw_context.t -> Raw_context.t Lwt.t (** The next roll to be allocated. *) - module Next : Single_data_storage - with type value = Roll_repr.t - and type t := Raw_context.t + module Next : + Single_data_storage + with type value = Roll_repr.t + and type t := Raw_context.t (** Rolls linked lists represent both account owned and free rolls. All rolls belongs either to the limbo list or to an owned list. *) (** Head of the linked list of rolls in limbo *) - module Limbo : Single_data_storage - with type value = Roll_repr.t - and type t := Raw_context.t + module Limbo : + Single_data_storage + with type value = Roll_repr.t + and type t := Raw_context.t (** Rolls associated to contracts, a linked list per contract *) - module Delegate_roll_list : Indexed_data_storage - with type key = Signature.Public_key_hash.t - and type value = Roll_repr.t - and type t := Raw_context.t + module Delegate_roll_list : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = Roll_repr.t + and type t := Raw_context.t (** Use this to iter on a linked list of rolls *) - module Successor : Indexed_data_storage - with type key = Roll_repr.t - and type value = Roll_repr.t - and type t := Raw_context.t + module Successor : + Indexed_data_storage + with type key = Roll_repr.t + and type value = Roll_repr.t + and type t := Raw_context.t (** The tez of a contract that are not assigned to rolls *) - module Delegate_change : Indexed_data_storage - with type key = Signature.Public_key_hash.t - and type value = Tez_repr.t - and type t := Raw_context.t + module Delegate_change : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = Tez_repr.t + and type t := Raw_context.t (** Index of the randomly selected roll snapshot of a given cycle. *) - module Snapshot_for_cycle : Indexed_data_storage - with type key = Cycle_repr.t - and type value = int - and type t := Raw_context.t + module Snapshot_for_cycle : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = int + and type t := Raw_context.t (** Last roll in the snapshoted roll allocation of a given cycle. *) - module Last_for_snapshot : Indexed_data_storage - with type key = int - and type value = Roll_repr.t - and type t = Raw_context.t * Cycle_repr.t - + module Last_for_snapshot : + Indexed_data_storage + with type key = int + and type value = Roll_repr.t + and type t = Raw_context.t * Cycle_repr.t end module Contract : sig - (** Storage from this submodule must only be accessed through the module `Contract`. *) module Global_counter : sig val get : Raw_context.t -> Z.t tzresult Lwt.t + val set : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t + val init : Raw_context.t -> Z.t -> Raw_context.t tzresult Lwt.t end (** The domain of alive contracts *) val fold : Raw_context.t -> - init:'a -> f:(Contract_repr.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t + init:'a -> + f:(Contract_repr.t -> 'a -> 'a Lwt.t) -> + 'a Lwt.t + val list : Raw_context.t -> Contract_repr.t list Lwt.t (** All the tez possesed by a contract, including rolls and change *) - module Balance : Indexed_data_storage - with type key = Contract_repr.t - and type value = Tez_repr.t - and type t := Raw_context.t + module Balance : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Tez_repr.t + and type t := Raw_context.t (** Frozen balance, see 'delegate_storage.mli' for more explanation. Always update `Delegates_with_frozen_balance` accordingly. *) - module Frozen_deposits : Indexed_data_storage - with type key = Cycle_repr.t - and type value = Tez_repr.t - and type t = Raw_context.t * Contract_repr.t + module Frozen_deposits : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t = Raw_context.t * Contract_repr.t - module Frozen_fees : Indexed_data_storage - with type key = Cycle_repr.t - and type value = Tez_repr.t - and type t = Raw_context.t * Contract_repr.t + module Frozen_fees : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t = Raw_context.t * Contract_repr.t - module Frozen_rewards : Indexed_data_storage - with type key = Cycle_repr.t - and type value = Tez_repr.t - and type t = Raw_context.t * Contract_repr.t + module Frozen_rewards : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t = Raw_context.t * Contract_repr.t (** The manager of a contract *) - module Manager : Indexed_data_storage - with type key = Contract_repr.t - and type value = Manager_repr.t - and type t := Raw_context.t + module Manager : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Manager_repr.t + and type t := Raw_context.t (** The delegate of a contract, if any. *) - module Delegate : Indexed_data_storage - with type key = Contract_repr.t - and type value = Signature.Public_key_hash.t - and type t := Raw_context.t + module Delegate : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Signature.Public_key_hash.t + and type t := Raw_context.t (** All contracts (implicit and originated) that are delegated, if any *) - module Delegated : Data_set_storage - with type elt = Contract_repr.t - and type t = Raw_context.t * Contract_repr.t + module Delegated : + Data_set_storage + with type elt = Contract_repr.t + and type t = Raw_context.t * Contract_repr.t - (** Only for migration from proto_004 *) - module Delegated_004 : Data_set_storage - with type elt = Contract_hash.t - and type t = Raw_context.t * Contract_repr.t - - module Inactive_delegate : Data_set_storage - with type elt = Contract_repr.t - and type t = Raw_context.t + module Inactive_delegate : + Data_set_storage with type elt = Contract_repr.t and type t = Raw_context.t (** The cycle where the delegate should be desactivated. *) - module Delegate_desactivation : Indexed_data_storage - with type key = Contract_repr.t - and type value = Cycle_repr.t - and type t := Raw_context.t + module Delegate_desactivation : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Cycle_repr.t + and type t := Raw_context.t - module Spendable_004 : Data_set_storage - with type elt = Contract_repr.t - and type t := Raw_context.t + module Counter : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t - module Delegatable_004 : Data_set_storage - with type elt = Contract_repr.t - and type t := Raw_context.t - - module Counter : Indexed_data_storage - with type key = Contract_repr.t - and type value = Z.t - and type t := Raw_context.t - - module Code : sig - include Non_iterable_indexed_carbonated_data_storage + module Code : + Non_iterable_indexed_carbonated_data_storage with type key = Contract_repr.t and type value = Script_repr.lazy_expr and type t := Raw_context.t - (** Only used for 005 migration to avoid gas cost. - Allocates a storage bucket at the given key and initializes it ; - returns a {!Storage_error Existing_key} if the bucket exists. *) - val init_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t - - (** Only used for 005 migration to avoid gas cost. - Updates the content of a bucket ; returns A {!Storage_Error - Missing_key} if the value does not exists. *) - val set_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t - end - - module Storage : sig - include Non_iterable_indexed_carbonated_data_storage + module Storage : + Non_iterable_indexed_carbonated_data_storage with type key = Contract_repr.t and type value = Script_repr.lazy_expr and type t := Raw_context.t - (** Only used for 005 migration to avoid gas cost. - Allocates a storage bucket at the given key and initializes it ; - returns a {!Storage_error Existing_key} if the bucket exists. *) - val init_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t - - (** Only used for 005 migration to avoid gas cost. - Updates the content of a bucket ; returns A {!Storage_Error - Missing_key} if the value does not exists. *) - val set_free: Raw_context.t -> Contract_repr.t -> Script_repr.lazy_expr -> (Raw_context.t * int) tzresult Lwt.t - end - (** Current storage space in bytes. Includes code, global storage and big map elements. *) - module Used_storage_space : Indexed_data_storage - with type key = Contract_repr.t - and type value = Z.t - and type t := Raw_context.t + module Used_storage_space : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t (** Maximal space available without needing to burn new fees. *) - module Paid_storage_space : Indexed_data_storage - with type key = Contract_repr.t - and type value = Z.t - and type t := Raw_context.t - + module Paid_storage_space : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t end module Big_map : sig - module Next : sig val incr : Raw_context.t -> (Raw_context.t * Z.t) tzresult Lwt.t + val init : Raw_context.t -> Raw_context.t tzresult Lwt.t end (** The domain of alive big maps *) - val fold : - Raw_context.t -> - init:'a -> f:(Z.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val fold : Raw_context.t -> init:'a -> f:(Z.t -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val list : Raw_context.t -> Z.t list Lwt.t val remove_rec : Raw_context.t -> Z.t -> Raw_context.t Lwt.t - val copy : Raw_context.t -> from:Z.t -> to_:Z.t -> Raw_context.t tzresult Lwt.t + val copy : + Raw_context.t -> from:Z.t -> to_:Z.t -> Raw_context.t tzresult Lwt.t type key = Raw_context.t * Z.t val rpc_arg : Z.t RPC_arg.t - module Index : Storage_description.INDEX with type t = Z.t + module Contents : + Non_iterable_indexed_carbonated_data_storage + with type key = Script_expr_hash.t + and type value = Script_repr.expr + and type t := key - module Contents : Non_iterable_indexed_carbonated_data_storage - with type key = Script_expr_hash.t - and type value = Script_repr.expr - and type t := key + module Total_bytes : + Indexed_data_storage + with type key = Z.t + and type value = Z.t + and type t := Raw_context.t - module Total_bytes : Indexed_data_storage - with type key = Z.t - and type value = Z.t - and type t := Raw_context.t - - module Key_type : Indexed_data_storage - with type key = Z.t - and type value = Script_repr.expr - and type t := Raw_context.t - - module Value_type : Indexed_data_storage - with type key = Z.t - and type value = Script_repr.expr - and type t := Raw_context.t + module Key_type : + Indexed_data_storage + with type key = Z.t + and type value = Script_repr.expr + and type t := Raw_context.t + module Value_type : + Indexed_data_storage + with type key = Z.t + and type value = Script_repr.expr + and type t := Raw_context.t end (** Set of all registered delegates. *) -module Delegates : Data_set_storage - with type t := Raw_context.t - and type elt = Signature.Public_key_hash.t +module Delegates : + Data_set_storage + with type t := Raw_context.t + and type elt = Signature.Public_key_hash.t (** Set of all active delegates with rolls. *) -module Active_delegates_with_rolls : Data_set_storage - with type t := Raw_context.t - and type elt = Signature.Public_key_hash.t +module Active_delegates_with_rolls : + Data_set_storage + with type t := Raw_context.t + and type elt = Signature.Public_key_hash.t (** Set of all the delegates with frozen rewards/bonds/fees for a given cycle. *) -module Delegates_with_frozen_balance : Data_set_storage - with type t = Raw_context.t * Cycle_repr.t - and type elt = Signature.Public_key_hash.t +module Delegates_with_frozen_balance : + Data_set_storage + with type t = Raw_context.t * Cycle_repr.t + and type elt = Signature.Public_key_hash.t (** Votes *) module Vote : sig - - module Current_period_kind : Single_data_storage - with type value = Voting_period_repr.kind - and type t := Raw_context.t - - (** Only for migration from 004. - Expected quorum, in centile of percentage *) - module Current_quorum_004 : Single_data_storage - with type value = int32 - and type t := Raw_context.t + module Current_period_kind : + Single_data_storage + with type value = Voting_period_repr.kind + and type t := Raw_context.t (** Participation exponential moving average, in centile of percentage *) - module Participation_ema : Single_data_storage - with type value = int32 - and type t := Raw_context.t + module Participation_ema : + Single_data_storage with type value = int32 and type t := Raw_context.t - module Current_proposal : Single_data_storage - with type value = Protocol_hash.t - and type t := Raw_context.t + module Current_proposal : + Single_data_storage + with type value = Protocol_hash.t + and type t := Raw_context.t (** Sum of all rolls of all delegates. *) - module Listings_size : Single_data_storage - with type value = int32 - and type t := Raw_context.t + module Listings_size : + Single_data_storage with type value = int32 and type t := Raw_context.t (** Contains all delegates with their assigned number of rolls. *) - module Listings : Indexed_data_storage - with type key = Signature.Public_key_hash.t - and type value = int32 - and type t := Raw_context.t + module Listings : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = int32 + and type t := Raw_context.t (** Set of protocol proposal with corresponding proposer delegate *) - module Proposals : Data_set_storage - with type elt = Protocol_hash.t * Signature.Public_key_hash.t - and type t := Raw_context.t + module Proposals : + Data_set_storage + with type elt = Protocol_hash.t * Signature.Public_key_hash.t + and type t := Raw_context.t (** Keeps for each delegate the number of proposed protocols *) - module Proposals_count : Indexed_data_storage - with type key = Signature.Public_key_hash.t - and type value = int - and type t := Raw_context.t + module Proposals_count : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = int + and type t := Raw_context.t (** Contains for each delegate its ballot *) - module Ballots : Indexed_data_storage - with type key = Signature.Public_key_hash.t - and type value = Vote_repr.ballot - and type t := Raw_context.t - + module Ballots : + Indexed_data_storage + with type key = Signature.Public_key_hash.t + and type value = Vote_repr.ballot + and type t := Raw_context.t end (** Seed *) module Seed : sig - (** Storage from this submodule must only be accessed through the module `Seed`. *) type unrevealed_nonce = { - nonce_hash: Nonce_hash.t ; - delegate: Signature.Public_key_hash.t ; - rewards: Tez_repr.t ; - fees: Tez_repr.t ; + nonce_hash : Nonce_hash.t; + delegate : Signature.Public_key_hash.t; + rewards : Tez_repr.t; + fees : Tez_repr.t; } type nonce_status = | Unrevealed of unrevealed_nonce | Revealed of Seed_repr.nonce - module Nonce : Non_iterable_indexed_data_storage - with type key := Level_repr.t - and type value := nonce_status - and type t := Raw_context.t + module Nonce : + Non_iterable_indexed_data_storage + with type key := Level_repr.t + and type value := nonce_status + and type t := Raw_context.t module For_cycle : sig - val init : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed -> Raw_context.t tzresult Lwt.t + val init : + Raw_context.t -> + Cycle_repr.t -> + Seed_repr.seed -> + Raw_context.t tzresult Lwt.t + val get : Raw_context.t -> Cycle_repr.t -> Seed_repr.seed tzresult Lwt.t + val delete : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t end - end (** Commitments *) -module Commitments : Indexed_data_storage - with type key = Blinded_public_key_hash.t - and type value = Tez_repr.t - and type t := Raw_context.t +module Commitments : + Indexed_data_storage + with type key = Blinded_public_key_hash.t + and type value = Tez_repr.t + and type t := Raw_context.t (** Ramp up security deposits... *) module Ramp_up : sig - module Rewards : Indexed_data_storage - with type key = Cycle_repr.t - and type value = Tez_repr.t * Tez_repr.t (* baking * endorsement *) - and type t := Raw_context.t + with type key = Cycle_repr.t + and type value := Tez_repr.t list * Tez_repr.t list + (* baking rewards per endorsement * endorsement rewards *) + and type t := Raw_context.t module Security_deposits : Indexed_data_storage - with type key = Cycle_repr.t - and type value = Tez_repr.t * Tez_repr.t (* baking * endorsement *) - and type t := Raw_context.t - + with type key = Cycle_repr.t + and type value = Tez_repr.t * Tez_repr.t + (* baking * endorsement *) + and type t := Raw_context.t end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml index 7fa1c1dbb..e9cfb34ce 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.ml @@ -23,59 +23,76 @@ (* *) (*****************************************************************************) -module StringMap = Map.Make(String) +module StringMap = Map.Make (String) type 'key t = 'key description ref and 'key description = | Empty : 'key description - | Value : { get: 'key -> 'a option tzresult Lwt.t ; - encoding: 'a Data_encoding.t } -> 'key description - | NamedDir: 'key t StringMap.t -> 'key description - | IndexedDir: { arg: 'a RPC_arg.t ; - arg_encoding: 'a Data_encoding.t ; - list: 'key -> 'a list tzresult Lwt.t ; - subdir: ('key * 'a) t }-> 'key description + | Value : { + get : 'key -> 'a option tzresult Lwt.t; + encoding : 'a Data_encoding.t; + } + -> 'key description + | NamedDir : 'key t StringMap.t -> 'key description + | IndexedDir : { + arg : 'a RPC_arg.t; + arg_encoding : 'a Data_encoding.t; + list : 'key -> 'a list tzresult Lwt.t; + subdir : ('key * 'a) t; + } + -> 'key description let rec register_named_subcontext : type r. r t -> string list -> r t = - fun dir names -> - match !dir, names with - | _, [] -> dir - | Value _, _ -> invalid_arg "" - | IndexedDir _, _ -> invalid_arg "" - | Empty, name :: names -> - let subdir = ref Empty in - dir := NamedDir (StringMap.singleton name subdir) ; - register_named_subcontext subdir names - | NamedDir map, name :: names -> - let subdir = - match StringMap.find_opt name map with - | Some subdir -> subdir - | None -> - let subdir = ref Empty in - dir := NamedDir (StringMap.add name subdir map) ; - subdir in - register_named_subcontext subdir names + fun dir names -> + match (!dir, names) with + | (_, []) -> + dir + | (Value _, _) -> + invalid_arg "" + | (IndexedDir _, _) -> + invalid_arg "" + | (Empty, name :: names) -> + let subdir = ref Empty in + dir := NamedDir (StringMap.singleton name subdir) ; + register_named_subcontext subdir names + | (NamedDir map, name :: names) -> + let subdir = + match StringMap.find_opt name map with + | Some subdir -> + subdir + | None -> + let subdir = ref Empty in + dir := NamedDir (StringMap.add name subdir map) ; + subdir + in + register_named_subcontext subdir names type (_, _, _) args = - | One : { rpc_arg: 'a RPC_arg.t ; - encoding: 'a Data_encoding.t ; - compare: 'a -> 'a -> int } -> ('key, 'a, 'key * 'a) args - | Pair : ('key, 'a, 'inter_key) args * - ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args + | One : { + rpc_arg : 'a RPC_arg.t; + encoding : 'a Data_encoding.t; + compare : 'a -> 'a -> int; + } + -> ('key, 'a, 'key * 'a) args + | Pair : + ('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 - | One _ -> (fun x -> x) + | One _ -> + fun x -> x | Pair (l, r) -> let unpack_l = unpack l in let unpack_r = unpack r in fun x -> - let c, d = unpack_r x in - let b, a = unpack_l c in + let (c, d) = unpack_r x in + let (b, a) = unpack_l c in (b, (a, d)) let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function - | One _ -> (fun b a -> (b, a)) + | One _ -> + fun b a -> (b, a) | Pair (l, r) -> let pack_l = pack l in let pack_r = pack r in @@ -84,223 +101,239 @@ let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function pack_r c d let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function - | One { compare ; _ } -> compare - | Pair (l, r) -> + | One {compare; _} -> + compare + | Pair (l, r) -> ( let compare_l = compare l in let compare_r = compare r in fun (a1, b1) (a2, b2) -> - match compare_l a1 a2 with - | 0 -> compare_r b1 b2 - | x -> x + match compare_l a1 a2 with 0 -> compare_r b1 b2 | x -> x ) let destutter equal l = match l with - | [] -> [] + | [] -> + [] | (i, _) :: l -> let rec loop acc i = function - | [] -> acc + | [] -> + acc | (j, _) :: l -> - if equal i j then loop acc i l - else loop (j :: acc) j l in + if equal i j then loop acc i l else loop (j :: acc) j l + in loop [i] i l -let rec register_indexed_subcontext - : type r a b. r t -> list:(r -> a list tzresult Lwt.t) -> - (r, a, b) args -> b t = - fun dir ~list path -> - match path with - | Pair (left, right) -> - let compare_left = compare left in - let equal_left x y = Compare.Int.(compare_left x y = 0) in - let list_left r = - list r >>=? fun l -> - return (destutter equal_left l) in - let list_right r = - let a, k = unpack left r in - list a >>=? fun l -> - return - (List.map snd - (List.filter (fun (x, _) -> equal_left x k) l)) in - register_indexed_subcontext - (register_indexed_subcontext dir ~list:list_left left) - ~list:list_right right - | One { rpc_arg = arg ; encoding = arg_encoding ; _ } -> - match !dir with - | Value _ -> invalid_arg "" - | NamedDir _ -> invalid_arg "" - | Empty -> - let subdir = ref Empty in - dir := IndexedDir { arg ; arg_encoding ; list ; subdir }; - subdir - | IndexedDir { arg = inner_arg ; subdir ; _ } -> - match RPC_arg.eq arg inner_arg with - | None -> invalid_arg "" - | Some RPC_arg.Eq -> subdir +let rec register_indexed_subcontext : + type r a b. + r t -> list:(r -> a list tzresult Lwt.t) -> (r, a, b) args -> b t = + fun dir ~list path -> + match path with + | Pair (left, right) -> + let compare_left = compare left in + let equal_left x y = Compare.Int.(compare_left x y = 0) in + let list_left r = list r >>=? fun l -> return (destutter equal_left l) in + let list_right r = + let (a, k) = unpack left r in + list a + >>=? fun l -> + return (List.map snd (List.filter (fun (x, _) -> equal_left x k) l)) + in + register_indexed_subcontext + (register_indexed_subcontext dir ~list:list_left left) + ~list:list_right + right + | One {rpc_arg = arg; encoding = arg_encoding; _} -> ( + match !dir with + | Value _ -> + invalid_arg "" + | NamedDir _ -> + invalid_arg "" + | Empty -> + let subdir = ref Empty in + dir := IndexedDir {arg; arg_encoding; list; subdir} ; + subdir + | IndexedDir {arg = inner_arg; subdir; _} -> ( + match RPC_arg.eq arg inner_arg with + | None -> + invalid_arg "" + | Some RPC_arg.Eq -> + subdir ) ) let register_value : - type a b. a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit = - fun dir ~get encoding -> - match !dir with - | Empty -> dir := Value { get ; encoding } - | _ -> invalid_arg "" + type a b. + a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit = + fun dir ~get encoding -> + match !dir with Empty -> dir := Value {get; encoding} | _ -> invalid_arg "" let create () = ref Empty -let rec pp : type a. Format.formatter -> a t -> unit = fun ppf dir -> +let rec pp : type a. Format.formatter -> a t -> unit = + fun ppf dir -> match !dir with | Empty -> Format.fprintf ppf "EMPTY" | Value _e -> Format.fprintf ppf "Value" | NamedDir map -> - Format.fprintf ppf "@[%a@]" + Format.fprintf + ppf + "@[%a@]" (Format.pp_print_list pp_item) (StringMap.bindings map) - | IndexedDir { arg ; subdir ; _ } -> + | IndexedDir {arg; subdir; _} -> let name = Format.asprintf "<%s>" (RPC_arg.descr arg).name in pp_item ppf (name, subdir) -and pp_item : type a. Format.formatter -> (string * a t) -> unit = - fun ppf (name, dir) -> - Format.fprintf ppf "@[%s@ %a@]" - name - pp dir - +and pp_item : type a. Format.formatter -> string * a t -> unit = + fun ppf (name, dir) -> Format.fprintf ppf "@[%s@ %a@]" name pp dir module type INDEX = sig type t - val path_length: int - val to_path: t -> string list -> string list - val of_path: string list -> t option - val rpc_arg: t RPC_arg.t - val encoding: t Data_encoding.t - val compare: t -> t -> int + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + + val rpc_arg : t RPC_arg.t + + val encoding : t Data_encoding.t + + val compare : t -> t -> int end type _ handler = - Handler : - { encoding: 'a Data_encoding.t ; - get: 'key -> int -> 'a tzresult Lwt.t } -> 'key handler + | Handler : { + encoding : 'a Data_encoding.t; + get : 'key -> int -> 'a tzresult Lwt.t; + } + -> 'key handler type _ opt_handler = - Opt_handler : - { encoding: 'a Data_encoding.t ; - get: 'key -> int -> 'a option tzresult Lwt.t } -> 'key opt_handler + | Opt_handler : { + encoding : 'a Data_encoding.t; + get : 'key -> int -> 'a option tzresult Lwt.t; + } + -> 'key opt_handler let rec combine_object = function - | [] -> Handler { encoding = Data_encoding.unit ; - get = fun _ _ -> return_unit } + | [] -> + Handler {encoding = Data_encoding.unit; get = (fun _ _ -> return_unit)} | (name, Opt_handler handler) :: fields -> - let Handler handlers = combine_object fields in - Handler { encoding = - Data_encoding.merge_objs - Data_encoding.(obj1 (opt name (dynamic_size handler.encoding))) - handlers.encoding ; - get = fun k i -> - handler.get k i >>=? fun v1 -> - handlers.get k i >>=? fun v2 -> - return (v1, v2) } + let (Handler handlers) = combine_object fields in + Handler + { + encoding = + Data_encoding.merge_objs + Data_encoding.(obj1 (opt name (dynamic_size handler.encoding))) + handlers.encoding; + get = + (fun k i -> + handler.get k i + >>=? fun v1 -> handlers.get k i >>=? fun v2 -> return (v1, v2)); + } -type query = { - depth: int ; -} +type query = {depth : int} let depth_query = let open RPC_query in - query (fun depth -> { depth }) + query (fun depth -> {depth}) |+ field "depth" RPC_arg.int 0 (fun t -> t.depth) |> seal let build_directory : type key. key t -> key RPC_directory.t = - fun dir -> - let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in - let register : type ikey. (key, ikey) RPC_path.t -> ikey opt_handler -> unit = - fun path (Opt_handler { encoding ; get }) -> - let service = - RPC_service.get_service - ~query: depth_query - ~output: encoding - path in - rpc_dir := - RPC_directory.register !rpc_dir service begin - fun k q () -> - get k (q.depth + 1) >>=? function - | None -> raise Not_found - | Some x -> return x - end in - let rec build_handler : type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler = - fun dir path -> - match !dir with - | Empty -> Opt_handler { encoding = Data_encoding.unit ; - get = fun _ _ -> return_none } - | Value { get ; encoding } -> - let handler = - Opt_handler { - encoding ; - get = - fun k i -> if Compare.Int.(i < 0) then return_none else get k - } in - register path handler ; - handler - | NamedDir map -> - let fields = StringMap.bindings map in - let fields = - List.map - (fun (name, dir) -> - (name, build_handler dir RPC_path.(path / name))) - fields in - let Handler handler = combine_object fields in - let handler = - Opt_handler - { encoding = handler.encoding ; - get = fun k i -> - if Compare.Int.(i < 0) then - return_none - else - handler.get k (i-1) >>=? fun v -> - return_some v } in - register path handler ; - handler - | IndexedDir { arg ; arg_encoding ; list ; subdir } -> - let Opt_handler handler = - build_handler subdir RPC_path.(path /: arg) in - let encoding = - let open Data_encoding in - union [ - case (Tag 0) - ~title:"Leaf" - (dynamic_size arg_encoding) - (function (key, None) -> Some key | _ -> None) - (fun key -> (key, None)) ; - case (Tag 1) - ~title:"Dir" - (tup2 - (dynamic_size arg_encoding) - (dynamic_size handler.encoding)) - (function (key, Some value) -> Some (key, value) | _ -> None) - (fun (key, value) -> (key, Some value)) ; - ] in - let get k i = - if Compare.Int.(i < 0) then return_none - else if Compare.Int.(i = 0) then return_some [] - else - list k >>=? fun keys -> - map_s - (fun key -> - if Compare.Int.(i = 1) then - return (key, None) - else - handler.get (k, key) (i-1) >>=? fun value -> - return (key, value)) - keys >>=? fun values -> - return_some values in - let handler = - Opt_handler { - encoding = Data_encoding.(list (dynamic_size encoding)) ; - get ; - } in - register path handler ; - handler in - ignore (build_handler dir RPC_path.open_root : key opt_handler) ; - !rpc_dir - + fun dir -> + let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in + let register : type ikey. (key, ikey) RPC_path.t -> ikey opt_handler -> unit + = + fun path (Opt_handler {encoding; get}) -> + let service = + RPC_service.get_service ~query:depth_query ~output:encoding path + in + rpc_dir := + RPC_directory.register !rpc_dir service (fun k q () -> + get k (q.depth + 1) + >>=? function None -> raise Not_found | Some x -> return x) + in + let rec build_handler : + type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler = + fun dir path -> + match !dir with + | Empty -> + Opt_handler + {encoding = Data_encoding.unit; get = (fun _ _ -> return_none)} + | Value {get; encoding} -> + let handler = + Opt_handler + { + encoding; + get = + (fun k i -> if Compare.Int.(i < 0) then return_none else get k); + } + in + register path handler ; handler + | NamedDir map -> + let fields = StringMap.bindings map in + let fields = + List.map + (fun (name, dir) -> + (name, build_handler dir RPC_path.(path / name))) + fields + in + let (Handler handler) = combine_object fields in + let handler = + Opt_handler + { + encoding = handler.encoding; + get = + (fun k i -> + if Compare.Int.(i < 0) then return_none + else handler.get k (i - 1) >>=? fun v -> return_some v); + } + in + register path handler ; handler + | IndexedDir {arg; arg_encoding; list; subdir} -> + let (Opt_handler handler) = + build_handler subdir RPC_path.(path /: arg) + in + let encoding = + let open Data_encoding in + union + [ case + (Tag 0) + ~title:"Leaf" + (dynamic_size arg_encoding) + (function (key, None) -> Some key | _ -> None) + (fun key -> (key, None)); + case + (Tag 1) + ~title:"Dir" + (tup2 + (dynamic_size arg_encoding) + (dynamic_size handler.encoding)) + (function (key, Some value) -> Some (key, value) | _ -> None) + (fun (key, value) -> (key, Some value)) ] + in + let get k i = + if Compare.Int.(i < 0) then return_none + else if Compare.Int.(i = 0) then return_some [] + else + list k + >>=? fun keys -> + map_s + (fun key -> + if Compare.Int.(i = 1) then return (key, None) + else + handler.get (k, key) (i - 1) + >>=? fun value -> return (key, value)) + keys + >>=? fun values -> return_some values + in + let handler = + Opt_handler + {encoding = Data_encoding.(list (dynamic_size encoding)); get} + in + register path handler ; handler + in + ignore (build_handler dir RPC_path.open_root : key opt_handler) ; + !rpc_dir diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_description.mli b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.mli index 2f6a59fd0..1c900c982 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage_description.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_description.mli @@ -27,56 +27,69 @@ type 'key t (** Trivial display of the key-value context layout. *) -val pp: Format.formatter -> 'key t -> unit +val pp : Format.formatter -> 'key t -> unit (** Export an RPC hierarchy for querying the context. There is one service by possible path in the context. Services for "directory" are able to aggregate in one JSON object the whole subtree. *) -val build_directory: 'key t -> 'key RPC_directory.t +val build_directory : 'key t -> 'key RPC_directory.t (** Create a empty context description, keys will be registred by side effects. *) -val create: unit -> 'key t +val create : unit -> 'key t (** Register a single key accessor at a given path. *) -val register_value: +val register_value : 'key t -> get:('key -> 'a option tzresult Lwt.t) -> - 'a Data_encoding.t -> unit + 'a Data_encoding.t -> + unit (** Return a description for a prefixed fragment of the given context. All keys registred in the subcontext will be shared by the external context *) -val register_named_subcontext: 'key t -> string list -> 'key t +val register_named_subcontext : 'key t -> string list -> 'key t (** Description of an index as a sequence of `RPC_arg.t`. *) type (_, _, _) args = - | One : { rpc_arg: 'a RPC_arg.t ; - encoding: 'a Data_encoding.t ; - compare: 'a -> 'a -> int } -> ('key, 'a, 'key * 'a) args - | Pair : ('key, 'a, 'inter_key) args * - ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args + | One : { + rpc_arg : 'a RPC_arg.t; + encoding : 'a Data_encoding.t; + compare : 'a -> 'a -> int; + } + -> ('key, 'a, 'key * 'a) args + | Pair : + ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args + -> ('key, 'a * 'b, 'sub_key) args (** Return a description for a indexed sub-context. All keys registred in the subcontext will be shared by the external context. One should provide a function to list all the registred index in the context. *) -val register_indexed_subcontext: +val register_indexed_subcontext : 'key t -> list:('key -> 'arg list tzresult Lwt.t) -> - ('key, 'arg, 'sub_key) args -> 'sub_key t + ('key, 'arg, 'sub_key) args -> + 'sub_key t (** Helpers for manipulating and defining indexes. *) -val pack: ('key, 'a, 'sub_key) args -> 'key -> 'a -> 'sub_key -val unpack: ('key, 'a, 'sub_key) args -> 'sub_key -> 'key * 'a +val pack : ('key, 'a, 'sub_key) args -> 'key -> 'a -> 'sub_key + +val unpack : ('key, 'a, 'sub_key) args -> 'sub_key -> 'key * 'a module type INDEX = sig type t - val path_length: int - val to_path: t -> string list -> string list - val of_path: string list -> t option - val rpc_arg: t RPC_arg.t - val encoding: t Data_encoding.t - val compare: t -> t -> int + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + + val rpc_arg : t RPC_arg.t + + val encoding : t Data_encoding.t + + val compare : t -> t -> int end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml index 54c3dbbdb..76ed40d4e 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.ml @@ -25,21 +25,32 @@ open Storage_sigs -module Registered = struct let ghost = false end -module Ghost = struct let ghost = true end +module Registered = struct + let ghost = false +end + +module Ghost = struct + let ghost = true +end module Make_encoder (V : VALUE) = struct let of_bytes ~key b = match Data_encoding.Binary.of_bytes V.encoding b with - | None -> error (Raw_context.Storage_error (Corrupted_data key)) - | Some v -> Ok v + | None -> + error (Raw_context.Storage_error (Corrupted_data key)) + | Some v -> + Ok v + let to_bytes v = match Data_encoding.Binary.to_bytes V.encoding v with - | Some b -> b - | None -> MBytes.create 0 + | Some b -> + b + | None -> + MBytes.create 0 end let len_name = "len" + let data_name = "data" let encode_len_value bytes = @@ -53,389 +64,491 @@ let decode_len_value key len = | Some len -> return len -let map_key f = function - | `Key k -> `Key (f k) - | `Dir k -> `Dir (f k) +let map_key f = function `Key k -> `Key (f k) | `Dir k -> `Dir (f k) -module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) - : Raw_context.T with type t = C.t = struct +module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : + Raw_context.T with type t = C.t = struct type t = C.t + type context = t + let name_length = List.length N.name + let to_key k = N.name @ k + let of_key k = Misc.remove_elem_from_list name_length k + let mem t k = C.mem t (to_key k) + let dir_mem t k = C.dir_mem t (to_key k) + let get t k = C.get t (to_key k) + let get_option t k = C.get_option t (to_key k) + let init t k v = C.init t (to_key k) v + let set t k v = C.set t (to_key k) v + let init_set t k v = C.init_set t (to_key k) v + let set_option t k v = C.set_option t (to_key k) v + let delete t k = C.delete t (to_key k) + let remove t k = C.remove t (to_key k) + let remove_rec t k = C.remove_rec t (to_key k) + let copy t ~from ~to_ = C.copy t ~from:(to_key from) ~to_:(to_key to_) + let fold t k ~init ~f = - C.fold t (to_key k) ~init - ~f:(fun k acc -> f (map_key of_key k) acc) + C.fold t (to_key k) ~init ~f:(fun k acc -> f (map_key of_key k) acc) + let keys t k = C.keys t (to_key k) >|= fun keys -> List.map of_key keys + let fold_keys t k ~init ~f = C.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc) + let project = C.project + let absolute_key c k = C.absolute_key c (to_key k) + let consume_gas = C.consume_gas + let check_enough_gas = C.check_enough_gas + let description = - let description = if R.ghost then Storage_description.create () - else C.description in + let description = + if R.ghost then Storage_description.create () else C.description + in Storage_description.register_named_subcontext description N.name end -module Make_single_data_storage (R : REGISTER) (C : Raw_context.T) (N : NAME) (V : VALUE) - : Single_data_storage with type t = C.t - and type value = V.t = struct +module Make_single_data_storage + (R : REGISTER) + (C : Raw_context.T) + (N : NAME) + (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t = +struct type t = C.t + type context = t + type value = V.t - let mem t = - C.mem t N.name - include Make_encoder(V) + + let mem t = C.mem t N.name + + include Make_encoder (V) + let get t = - C.get t N.name >>=? fun b -> + C.get t N.name + >>=? fun b -> let key = C.absolute_key t N.name in Lwt.return (of_bytes ~key b) + let get_option t = - C.get_option t N.name >>= function - | None -> return_none - | Some b -> + C.get_option t N.name + >>= function + | None -> + return_none + | Some b -> ( let key = C.absolute_key t N.name in match of_bytes ~key b with - | Ok v -> return_some v - | Error _ as err -> Lwt.return err + | Ok v -> + return_some v + | Error _ as err -> + Lwt.return err ) + let init t v = - C.init t N.name (to_bytes v) >>=? fun t -> - return (C.project t) - let set t v = - C.set t N.name (to_bytes v) >>=? fun t -> - return (C.project t) + C.init t N.name (to_bytes v) >>=? fun t -> return (C.project t) + + let set t v = C.set t N.name (to_bytes v) >>=? fun t -> return (C.project t) + let init_set t v = - C.init_set t N.name (to_bytes v) >>= fun t -> - Lwt.return (C.project t) + C.init_set t N.name (to_bytes v) >>= fun t -> Lwt.return (C.project t) + let set_option t v = - C.set_option t N.name (Option.map ~f:to_bytes v) >>= fun t -> - Lwt.return (C.project t) - let remove t = - C.remove t N.name >>= fun t -> - Lwt.return (C.project t) - let delete t = - C.delete t N.name >>=? fun t -> - return (C.project t) + C.set_option t N.name (Option.map ~f:to_bytes v) + >>= fun t -> Lwt.return (C.project t) + + let remove t = C.remove t N.name >>= fun t -> Lwt.return (C.project t) + + let delete t = C.delete t N.name >>=? fun t -> return (C.project t) let () = let open Storage_description in - let description = if R.ghost then Storage_description.create () - else C.description in + let description = + if R.ghost then Storage_description.create () else C.description + in register_value ~get:get_option (register_named_subcontext description N.name) V.encoding - end module type INDEX = sig type t - val path_length: int - val to_path: t -> string list -> string list - val of_path: string list -> t option + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + type 'a ipath - val args: ('a, t, 'a ipath) Storage_description.args + + val args : ('a, t, 'a ipath) Storage_description.args end -module Pair(I1 : INDEX)(I2 : INDEX) - : INDEX with type t = I1.t * I2.t = struct +module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t = +struct type t = I1.t * I2.t + let path_length = I1.path_length + I2.path_length + let to_path (x, y) l = I1.to_path x (I2.to_path y l) + let of_path l = match Misc.take I1.path_length l with - | None -> None - | Some (l1, l2) -> - match I1.of_path l1, I2.of_path l2 with - | Some x, Some y -> Some (x, y) - | _ -> None + | None -> + None + | Some (l1, l2) -> ( + match (I1.of_path l1, I2.of_path l2) with + | (Some x, Some y) -> + Some (x, y) + | _ -> + None ) + type 'a ipath = 'a I1.ipath I2.ipath + let args = Storage_description.Pair (I1.args, I2.args) end -module Make_data_set_storage (C : Raw_context.T) (I : INDEX) - : Data_set_storage with type t = C.t and type elt = I.t = struct - +module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : + Data_set_storage with type t = C.t and type elt = I.t = struct type t = C.t + type context = t + type elt = I.t let inited = MBytes.of_string "inited" - let mem s i = - C.mem s (I.to_path i []) + let mem s i = C.mem s (I.to_path i []) + let add s i = - C.init_set s (I.to_path i []) inited >>= fun t -> - Lwt.return (C.project t) + C.init_set s (I.to_path i []) inited >>= fun t -> Lwt.return (C.project t) + let del s i = - C.remove s (I.to_path i []) >>= fun t -> - Lwt.return (C.project t) - let set s i = function - | true -> add s i - | false -> del s i - let clear s = - C.remove_rec s [] >>= fun t -> - Lwt.return (C.project t) + C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t) + + let set s i = function true -> add s i | false -> del s i + + let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t) let fold s ~init ~f = let rec dig i path acc = if Compare.Int.(i <= 1) then - C.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir _ -> Lwt.return acc - | `Key file -> + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir _ -> + Lwt.return acc + | `Key file -> ( match I.of_path file with - | None -> assert false - | Some p -> f p acc - end + | None -> + assert false + | Some p -> + f p acc )) else - C.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir k -> - dig (i-1) k acc - | `Key _ -> - Lwt.return acc - end in + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir k -> + dig (i - 1) k acc + | `Key _ -> + Lwt.return acc) + in dig I.path_length [] init - let elements s = - fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) let () = let open Storage_description in let unpack = unpack I.args in - register_value - (* TODO fixme 'elements...' *) + register_value (* TODO fixme 'elements...' *) ~get:(fun c -> - let (c, k) = unpack c in - mem c k >>= function - | true -> return_some true - | false -> return_none) + let (c, k) = unpack c in + mem c k >>= function true -> return_some true | false -> return_none) (register_indexed_subcontext ~list:(fun c -> elements c >>= return) - C.description I.args) + C.description + I.args) Data_encoding.bool - end -module Make_indexed_data_storage - (C : Raw_context.T) (I : INDEX) (V : VALUE) - : Indexed_data_storage with type t = C.t - and type key = I.t - and type value = V.t = struct +module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) : + Indexed_data_storage + with type t = C.t + and type key = I.t + and type value = V.t = struct type t = C.t + type context = t + type key = I.t + type value = V.t - include Make_encoder(V) - let mem s i = - C.mem s (I.to_path i []) + + include Make_encoder (V) + + let mem s i = C.mem s (I.to_path i []) + let get s i = - C.get s (I.to_path i []) >>=? fun b -> + C.get s (I.to_path i []) + >>=? fun b -> let key = C.absolute_key s (I.to_path i []) in Lwt.return (of_bytes ~key b) + let get_option s i = - C.get_option s (I.to_path i []) >>= function - | None -> return_none - | Some b -> + C.get_option s (I.to_path i []) + >>= function + | None -> + return_none + | Some b -> ( let key = C.absolute_key s (I.to_path i []) in match of_bytes ~key b with - | Ok v -> return_some v - | Error _ as err -> Lwt.return err + | Ok v -> + return_some v + | Error _ as err -> + Lwt.return err ) + let set s i v = - C.set s (I.to_path i []) (to_bytes v) >>=? fun t -> - return (C.project t) + C.set s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t) + let init s i v = - C.init s (I.to_path i []) (to_bytes v) >>=? fun t -> - return (C.project t) + C.init s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t) + let init_set s i v = - C.init_set s (I.to_path i []) (to_bytes v) >>= fun t -> - Lwt.return (C.project t) + C.init_set s (I.to_path i []) (to_bytes v) + >>= fun t -> Lwt.return (C.project t) + let set_option s i v = - C.set_option s (I.to_path i []) (Option.map ~f:to_bytes v) >>= fun t -> - Lwt.return (C.project t) + C.set_option s (I.to_path i []) (Option.map ~f:to_bytes v) + >>= fun t -> Lwt.return (C.project t) + let remove s i = - C.remove s (I.to_path i []) >>= fun t -> - Lwt.return (C.project t) + C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t) + let delete s i = - C.delete s (I.to_path i []) >>=? fun t -> - return (C.project t) - let clear s = - C.remove_rec s [] >>= fun t -> - Lwt.return (C.project t) + C.delete s (I.to_path i []) >>=? fun t -> return (C.project t) + + let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t) let fold_keys s ~init ~f = let rec dig i path acc = if Compare.Int.(i <= 1) then - C.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir _ -> Lwt.return acc - | `Key file -> + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir _ -> + Lwt.return acc + | `Key file -> ( match I.of_path file with - | None -> assert false - | Some path -> f path acc - end + | None -> + assert false + | Some path -> + f path acc )) else - C.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir k -> dig (i-1) k acc - | `Key _ -> Lwt.return acc - end in + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir k -> + dig (i - 1) k acc + | `Key _ -> + Lwt.return acc) + in dig I.path_length [] init let fold s ~init ~f = let f path acc = - get s path >>= function + get s path + >>= function | Error _ -> (* FIXME: silently ignore unparsable data *) Lwt.return acc | Ok v -> - f path v acc in + f path v acc + in fold_keys s ~init ~f + let bindings s = - fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc)) - let keys s = - fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc)) + + let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) let () = let open Storage_description in let unpack = unpack I.args in register_value ~get:(fun c -> - let (c, k) = unpack c in - get_option c k) + let (c, k) = unpack c in + get_option c k) (register_indexed_subcontext ~list:(fun c -> keys c >>= return) - C.description I.args) + C.description + I.args) V.encoding - end module Make_indexed_carbonated_data_storage - (C : Raw_context.T) (I : INDEX) (V : VALUE) - : Non_iterable_indexed_carbonated_data_storage with type t = C.t - and type key = I.t - and type value = V.t = struct + (C : Raw_context.T) + (I : INDEX) + (V : VALUE) : + Non_iterable_indexed_carbonated_data_storage + with type t = C.t + and type key = I.t + and type value = V.t = struct type t = C.t + type context = t + type key = I.t + type value = V.t - include Make_encoder(V) - let data_key i = - I.to_path i [data_name] - let len_key i = - I.to_path i [len_name] + + include Make_encoder (V) + + let data_key i = I.to_path i [data_name] + + let len_key i = I.to_path i [len_name] + let consume_mem_gas c = Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) + let existing_size c i = - C.get_option c (len_key i) >>= function - | None -> return (0, false) - | Some len -> decode_len_value (len_key i) len >>=? fun len -> return (len, true) + C.get_option c (len_key i) + >>= function + | None -> + return (0, false) + | Some len -> + decode_len_value (len_key i) len >>=? fun len -> return (len, true) + let consume_read_gas get c i = - get c (len_key i) >>=? fun len -> - decode_len_value (len_key i) len >>=? fun len -> - Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len))) + get c (len_key i) + >>=? fun len -> + decode_len_value (len_key i) len + >>=? fun len -> + Lwt.return + (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len))) + let consume_serialize_write_gas set c i v = let bytes = to_bytes v in let len = MBytes.length bytes in - Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len)) >>=? fun c -> - Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len))) >>=? fun c -> - set c (len_key i) (encode_len_value bytes) >>=? fun c -> - return (c, bytes) + Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len)) + >>=? fun c -> + Lwt.return + (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len))) + >>=? fun c -> + set c (len_key i) (encode_len_value bytes) >>=? fun c -> return (c, bytes) + let consume_remove_gas del c i = - Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) >>=? fun c -> - del c (len_key i) + Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) + >>=? fun c -> del c (len_key i) + let mem s i = - consume_mem_gas s >>=? fun s -> - C.mem s (data_key i) >>= fun exists -> - return (C.project s, exists) + consume_mem_gas s + >>=? fun s -> + C.mem s (data_key i) >>= fun exists -> return (C.project s, exists) + let get s i = - consume_read_gas C.get s i >>=? fun s -> - C.get s (data_key i) >>=? fun b -> + consume_read_gas C.get s i + >>=? fun s -> + C.get s (data_key i) + >>=? fun b -> let key = C.absolute_key s (data_key i) in - Lwt.return (of_bytes ~key b) >>=? fun v -> - return (C.project s, v) + Lwt.return (of_bytes ~key b) >>=? fun v -> return (C.project s, v) + let get_option s i = - consume_mem_gas s >>=? fun s -> - C.mem s (data_key i) >>= fun exists -> - if exists then - get s i >>=? fun (s, v) -> - return (s, Some v) - else - return (C.project s, None) + consume_mem_gas s + >>=? fun s -> + C.mem s (data_key i) + >>= fun exists -> + if exists then get s i >>=? fun (s, v) -> return (s, Some v) + else return (C.project s, None) + let set s i v = - existing_size s i >>=? fun (prev_size, _) -> - consume_serialize_write_gas C.set s i v >>=? fun (s, bytes) -> - C.set s (data_key i) bytes >>=? fun t -> + existing_size s i + >>=? fun (prev_size, _) -> + consume_serialize_write_gas C.set s i v + >>=? fun (s, bytes) -> + C.set s (data_key i) bytes + >>=? fun t -> let size_diff = MBytes.length bytes - prev_size in return (C.project t, size_diff) + let init s i v = - consume_serialize_write_gas C.init s i v >>=? fun (s, bytes) -> - C.init s (data_key i) bytes >>=? fun t -> + consume_serialize_write_gas C.init s i v + >>=? fun (s, bytes) -> + C.init s (data_key i) bytes + >>=? fun t -> let size = MBytes.length bytes in return (C.project t, size) + let init_set s i v = let init_set s i v = C.init_set s i v >>= return in - existing_size s i >>=? fun (prev_size, existed) -> - consume_serialize_write_gas init_set s i v >>=? fun (s, bytes) -> - init_set s (data_key i) bytes >>=? fun t -> + existing_size s i + >>=? fun (prev_size, existed) -> + consume_serialize_write_gas init_set s i v + >>=? fun (s, bytes) -> + init_set s (data_key i) bytes + >>=? fun t -> let size_diff = MBytes.length bytes - prev_size in return (C.project t, size_diff, existed) + let remove s i = let remove s i = C.remove s i >>= return in - existing_size s i >>=? fun (prev_size, existed) -> - consume_remove_gas remove s i >>=? fun s -> - remove s (data_key i) >>=? fun t -> - return (C.project t, prev_size, existed) + existing_size s i + >>=? fun (prev_size, existed) -> + consume_remove_gas remove s i + >>=? fun s -> + remove s (data_key i) >>=? fun t -> return (C.project t, prev_size, existed) + let delete s i = - existing_size s i >>=? fun (prev_size, _) -> - consume_remove_gas C.delete s i >>=? fun s -> - C.delete s (data_key i) >>=? fun t -> - return (C.project t, prev_size) + existing_size s i + >>=? fun (prev_size, _) -> + consume_remove_gas C.delete s i + >>=? fun s -> + C.delete s (data_key i) >>=? fun t -> return (C.project t, prev_size) + let set_option s i v = - match v with - | None -> remove s i - | Some v -> init_set s i v + match v with None -> remove s i | Some v -> init_set s i v let fold_keys_unaccounted s ~init ~f = let rec dig i path acc = if Compare.Int.(i <= 0) then - C.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir _ -> Lwt.return acc - | `Key file -> + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir _ -> + Lwt.return acc + | `Key file -> ( match List.rev file with | last :: _ when Compare.String.(last = len_name) -> Lwt.return acc - | last :: rest when Compare.String.(last = data_name) -> + | last :: rest when Compare.String.(last = data_name) -> ( let file = List.rev rest in - begin match I.of_path file with - | None -> assert false - | Some path -> f path acc - end - | _ -> assert false - end + match I.of_path file with + | None -> + assert false + | Some path -> + f path acc ) + | _ -> + assert false )) else - C.fold s path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir k -> dig (i-1) k acc - | `Key _ -> Lwt.return acc - end in + C.fold s path ~init:acc ~f:(fun k acc -> + match k with + | `Dir k -> + dig (i - 1) k acc + | `Key _ -> + Lwt.return acc) + in dig I.path_length [] init let keys_unaccounted s = @@ -444,88 +557,99 @@ module Make_indexed_carbonated_data_storage let () = let open Storage_description in let unpack = unpack I.args in - register_value - (* TODO export consumed gas ?? *) + register_value (* TODO export consumed gas ?? *) ~get:(fun c -> - let (c, k) = unpack c in - get_option c k >>=? fun (_, v) -> - return v) + let (c, k) = unpack c in + get_option c k >>=? fun (_, v) -> return v) (register_indexed_subcontext ~list:(fun c -> keys_unaccounted c >>= return) - C.description I.args) + C.description + I.args) V.encoding - end - -module Make_indexed_data_snapshotable_storage (C : Raw_context.T) - (Snapshot_index : INDEX) (I : INDEX) (V : VALUE) - : Indexed_data_snapshotable_storage with type t = C.t - and type snapshot = Snapshot_index.t - and type key = I.t - and type value = V.t = struct +module Make_indexed_data_snapshotable_storage + (C : Raw_context.T) + (Snapshot_index : INDEX) + (I : INDEX) + (V : VALUE) : + Indexed_data_snapshotable_storage + with type t = C.t + and type snapshot = Snapshot_index.t + and type key = I.t + and type value = V.t = struct type snapshot = Snapshot_index.t let data_name = ["current"] + let snapshot_name = ["snapshot"] - module C_data = Make_subcontext(Registered)(C)(struct let name = data_name end) - module C_snapshot = Make_subcontext(Registered)(C)(struct let name = snapshot_name end) + module C_data = + Make_subcontext (Registered) (C) + (struct + let name = data_name + end) - include Make_indexed_data_storage(C_data)(I) (V) - module Snapshot = Make_indexed_data_storage(C_snapshot)(Pair(Snapshot_index)(I))(V) + module C_snapshot = + Make_subcontext (Registered) (C) + (struct + let name = snapshot_name + end) + + include Make_indexed_data_storage (C_data) (I) (V) + module Snapshot = + Make_indexed_data_storage (C_snapshot) (Pair (Snapshot_index) (I)) (V) let snapshot_path id = snapshot_name @ Snapshot_index.to_path id [] - let snapshot_exists s id = - C.dir_mem s (snapshot_path id) + let snapshot_exists s id = C.dir_mem s (snapshot_path id) let snapshot s id = - C.copy s ~from:data_name ~to_:(snapshot_path id) >>=? fun t -> - return (C.project t) + C.copy s ~from:data_name ~to_:(snapshot_path id) + >>=? fun t -> return (C.project t) let delete_snapshot s id = - C.remove_rec s (snapshot_path id) >>= fun t -> - Lwt.return (C.project t) - + C.remove_rec s (snapshot_path id) >>= fun t -> Lwt.return (C.project t) end - -module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) - : Indexed_raw_context with type t = C.t - and type key = I.t - and type 'a ipath = 'a I.ipath = struct - +module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : + Indexed_raw_context + with type t = C.t + and type key = I.t + and type 'a ipath = 'a I.ipath = struct type t = C.t + type context = t + type key = I.t + type 'a ipath = 'a I.ipath - let clear t = - C.remove_rec t [] >>= fun t -> - Lwt.return (C.project t) + let clear t = C.remove_rec t [] >>= fun t -> Lwt.return (C.project t) let fold_keys t ~init ~f = let rec dig i path acc = if Compare.Int.(i <= 0) then match I.of_path path with - | None -> assert false - | Some path -> f path acc + | None -> + assert false + | Some path -> + f path acc else - C.fold t path ~init:acc ~f:begin fun k acc -> - match k with - | `Dir k -> dig (i-1) k acc - | `Key _ -> Lwt.return acc - end in + C.fold t path ~init:acc ~f:(fun k acc -> + match k with + | `Dir k -> + dig (i - 1) k acc + | `Key _ -> + Lwt.return acc) + in dig I.path_length [] init - let keys t = - fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc)) + let keys t = fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc)) let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc)) - let remove_rec t k = - C.remove_rec t (I.to_path k []) + let remove_rec t k = C.remove_rec t (I.to_path k []) let copy t ~from ~to_ = C.copy t ~from:(I.to_path from []) ~to_:(I.to_path to_ []) @@ -537,379 +661,483 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) I.args let unpack = Storage_description.unpack I.args + let pack = Storage_description.pack I.args module Raw_context = struct type t = C.t I.ipath + type context = t + let to_key i k = I.to_path i k + let of_key k = Misc.remove_elem_from_list I.path_length k - let mem c k = let (t, i) = unpack c in C.mem t (to_key i k) - let dir_mem c k = let (t, i) = unpack c in C.dir_mem t (to_key i k) - let get c k = let (t, i) = unpack c in C.get t (to_key i k) - let get_option c k = let (t, i) = unpack c in C.get_option t (to_key i k) + + let mem c k = + let (t, i) = unpack c in + C.mem t (to_key i k) + + let dir_mem c k = + let (t, i) = unpack c in + C.dir_mem t (to_key i k) + + let get c k = + let (t, i) = unpack c in + C.get t (to_key i k) + + let get_option c k = + let (t, i) = unpack c in + C.get_option t (to_key i k) + let init c k v = let (t, i) = unpack c in C.init t (to_key i k) v >>=? fun t -> return (pack t i) + let set c k v = let (t, i) = unpack c in C.set t (to_key i k) v >>=? fun t -> return (pack t i) + let init_set c k v = let (t, i) = unpack c in C.init_set t (to_key i k) v >>= fun t -> Lwt.return (pack t i) + let set_option c k v = let (t, i) = unpack c in C.set_option t (to_key i k) v >>= fun t -> Lwt.return (pack t i) + let delete c k = let (t, i) = unpack c in C.delete t (to_key i k) >>=? fun t -> return (pack t i) + let remove c k = let (t, i) = unpack c in C.remove t (to_key i k) >>= fun t -> Lwt.return (pack t i) + let remove_rec c k = let (t, i) = unpack c in C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (pack t i) + let copy c ~from ~to_ = let (t, i) = unpack c in - C.copy t ~from:(to_key i from) ~to_:(to_key i to_) >>=? fun t -> - return (pack t i) + C.copy t ~from:(to_key i from) ~to_:(to_key i to_) + >>=? fun t -> return (pack t i) + let fold c k ~init ~f = let (t, i) = unpack c in - C.fold t (to_key i k) ~init - ~f:(fun k acc -> f (map_key of_key k) acc) + C.fold t (to_key i k) ~init ~f:(fun k acc -> f (map_key of_key k) acc) + let keys c k = let (t, i) = unpack c in C.keys t (to_key i k) >|= fun keys -> List.map of_key keys + let fold_keys c k ~init ~f = let (t, i) = unpack c in C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc) + let project c = let (t, _) = unpack c in C.project t + let absolute_key c k = let (t, i) = unpack c in C.absolute_key t (to_key i k) + let consume_gas c g = let (t, i) = unpack c in C.consume_gas t g >>? fun t -> ok (pack t i) + let check_enough_gas c g = let (t, _i) = unpack c in C.check_enough_gas t g + let description = description end let resolve t prefix = let rec loop i prefix = function - | [] when Compare.Int.(i = I.path_length) -> begin - match I.of_path prefix with - | None -> assert false - | Some path -> Lwt.return [path] - end + | [] when Compare.Int.(i = I.path_length) -> ( + match I.of_path prefix with + | None -> + assert false + | Some path -> + Lwt.return [path] ) | [] -> - list t prefix >>= fun prefixes -> - Lwt_list.map_s (function - | `Key prefix | `Dir prefix -> loop (i+1) prefix []) prefixes + list t prefix + >>= fun prefixes -> + Lwt_list.map_s + (function `Key prefix | `Dir prefix -> loop (i + 1) prefix []) + prefixes >|= List.flatten | [d] when Compare.Int.(i = I.path_length - 1) -> if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; - list t prefix >>= fun prefixes -> - Lwt_list.map_s (function - | `Key prefix | `Dir prefix -> - match Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) with - | None -> Lwt.return_nil - | Some _ -> loop (i+1) prefix []) + list t prefix + >>= fun prefixes -> + Lwt_list.map_s + (function + | `Key prefix | `Dir prefix -> ( + match + Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix)) + with + | None -> + Lwt.return_nil + | Some _ -> + loop (i + 1) prefix [] )) prefixes >|= List.flatten | "" :: ds -> - list t prefix >>= fun prefixes -> - Lwt_list.map_s (function - | `Key prefix | `Dir prefix -> loop (i+1) prefix ds) prefixes + list t prefix + >>= fun prefixes -> + Lwt_list.map_s + (function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds) + prefixes >|= List.flatten - | d :: ds -> + | d :: ds -> ( if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ; - C.dir_mem t (prefix @ [d]) >>= function - | true -> loop (i+1) (prefix @ [d]) ds - | false -> Lwt.return_nil in + C.dir_mem t (prefix @ [d]) + >>= function + | true -> loop (i + 1) (prefix @ [d]) ds | false -> Lwt.return_nil ) + in loop 0 [] prefix module Make_set (R : REGISTER) (N : NAME) = struct type t = C.t + type context = t + type elt = I.t + let inited = MBytes.of_string "inited" + let mem s i = Raw_context.mem (pack s i) N.name + let add s i = - Raw_context.init_set (pack s i) N.name inited >>= fun c -> + Raw_context.init_set (pack s i) N.name inited + >>= fun c -> let (s, _) = unpack c in Lwt.return (C.project s) + let del s i = - Raw_context.remove (pack s i) N.name >>= fun c -> + Raw_context.remove (pack s i) N.name + >>= fun c -> let (s, _) = unpack c in Lwt.return (C.project s) - let set s i = function - | true -> add s i - | false -> del s i + + let set s i = function true -> add s i | false -> del s i + let clear s = - fold_keys s - ~init:s - ~f:begin fun i s -> - Raw_context.remove (pack s i) N.name >>= fun c -> + fold_keys s ~init:s ~f:(fun i s -> + Raw_context.remove (pack s i) N.name + >>= fun c -> let (s, _) = unpack c in - Lwt.return s - end >>= fun t -> - Lwt.return (C.project t) + Lwt.return s) + >>= fun t -> Lwt.return (C.project t) + let fold s ~init ~f = - fold_keys s ~init - ~f:(fun i acc -> - mem s i >>= function - | true -> f i acc - | false -> Lwt.return acc) - let elements s = - fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + fold_keys s ~init ~f:(fun i acc -> + mem s i >>= function true -> f i acc | false -> Lwt.return acc) + + let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) let () = let open Storage_description in let unpack = unpack I.args in - let description = if R.ghost then Storage_description.create () - else Raw_context.description in + let description = + if R.ghost then Storage_description.create () + else Raw_context.description + in register_value ~get:(fun c -> - let (c, k) = unpack c in - mem c k >>= function - | true -> return_some true - | false -> return_none) + let (c, k) = unpack c in + mem c k + >>= function true -> return_some true | false -> return_none) (register_named_subcontext description N.name) Data_encoding.bool - end module Make_map (N : NAME) (V : VALUE) = struct type t = C.t + type context = t + type key = I.t + type value = V.t - include Make_encoder(V) - let mem s i = - Raw_context.mem (pack s i) N.name + + include Make_encoder (V) + + let mem s i = Raw_context.mem (pack s i) N.name + let get s i = - Raw_context.get (pack s i) N.name >>=? fun b -> + Raw_context.get (pack s i) N.name + >>=? fun b -> let key = Raw_context.absolute_key (pack s i) N.name in Lwt.return (of_bytes ~key b) + let get_option s i = - Raw_context.get_option (pack s i) N.name >>= function - | None -> return_none - | Some b -> + Raw_context.get_option (pack s i) N.name + >>= function + | None -> + return_none + | Some b -> ( let key = Raw_context.absolute_key (pack s i) N.name in match of_bytes ~key b with - | Ok v -> return_some v - | Error _ as err -> Lwt.return err + | Ok v -> + return_some v + | Error _ as err -> + Lwt.return err ) + let set s i v = - Raw_context.set (pack s i) N.name (to_bytes v) >>=? fun c -> + Raw_context.set (pack s i) N.name (to_bytes v) + >>=? fun c -> let (s, _) = unpack c in return (C.project s) + let init s i v = - Raw_context.init (pack s i) N.name (to_bytes v) >>=? fun c -> + Raw_context.init (pack s i) N.name (to_bytes v) + >>=? fun c -> let (s, _) = unpack c in return (C.project s) + let init_set s i v = - Raw_context.init_set (pack s i) N.name (to_bytes v) >>= fun c -> + Raw_context.init_set (pack s i) N.name (to_bytes v) + >>= fun c -> let (s, _) = unpack c in Lwt.return (C.project s) + let set_option s i v = - Raw_context.set_option (pack s i) - N.name (Option.map ~f:to_bytes v) >>= fun c -> + Raw_context.set_option (pack s i) N.name (Option.map ~f:to_bytes v) + >>= fun c -> let (s, _) = unpack c in Lwt.return (C.project s) + let remove s i = - Raw_context.remove (pack s i) N.name >>= fun c -> + Raw_context.remove (pack s i) N.name + >>= fun c -> let (s, _) = unpack c in Lwt.return (C.project s) + let delete s i = - Raw_context.delete (pack s i) N.name >>=? fun c -> + Raw_context.delete (pack s i) N.name + >>=? fun c -> let (s, _) = unpack c in return (C.project s) + let clear s = - fold_keys s ~init:s - ~f:begin fun i s -> - Raw_context.remove (pack s i) N.name >>= fun c -> + fold_keys s ~init:s ~f:(fun i s -> + Raw_context.remove (pack s i) N.name + >>= fun c -> let (s, _) = unpack c in - Lwt.return s - end >>= fun t -> - Lwt.return (C.project t) + Lwt.return s) + >>= fun t -> Lwt.return (C.project t) + let fold s ~init ~f = - fold_keys s ~init - ~f:(fun i acc -> - get s i >>= function - | Error _ -> Lwt.return acc - | Ok v -> f i v acc) + fold_keys s ~init ~f:(fun i acc -> + get s i >>= function Error _ -> Lwt.return acc | Ok v -> f i v acc) + let bindings s = - fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc)) + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc)) + let fold_keys s ~init ~f = - fold_keys s ~init - ~f:(fun i acc -> - mem s i >>= function - | false -> Lwt.return acc - | true -> f i acc) - let keys s = - fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + fold_keys s ~init ~f:(fun i acc -> + mem s i >>= function false -> Lwt.return acc | true -> f i acc) + + let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) let () = let open Storage_description in let unpack = unpack I.args in register_value ~get:(fun c -> - let (c, k) = unpack c in - get_option c k) + let (c, k) = unpack c in + get_option c k) (register_named_subcontext Raw_context.description N.name) V.encoding - end module Make_carbonated_map (N : NAME) (V : VALUE) = struct type t = C.t + type context = t + type key = I.t + type value = V.t - include Make_encoder(V) + + include Make_encoder (V) + let len_name = len_name :: N.name + let data_name = data_name :: N.name + let consume_mem_gas c = - Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) + Lwt.return + (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)) + let existing_size c = - Raw_context.get_option c len_name >>= function - | None -> return (0, false) - | Some len -> decode_len_value len_name len >>=? fun len -> return (len, true) + Raw_context.get_option c len_name + >>= function + | None -> + return (0, false) + | Some len -> + decode_len_value len_name len >>=? fun len -> return (len, true) + let consume_read_gas get c = - get c (len_name) >>=? fun len -> - decode_len_value len_name len >>=? fun len -> - Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len))) + get c len_name + >>=? fun len -> + decode_len_value len_name len + >>=? fun len -> + Lwt.return + (Raw_context.consume_gas + c + (Gas_limit_repr.read_bytes_cost (Z.of_int len))) + let consume_write_gas set c v = let bytes = to_bytes v in let len = MBytes.length bytes in - Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len))) >>=? fun c -> - set c len_name (encode_len_value bytes) >>=? fun c -> - return (c, bytes) + Lwt.return + (Raw_context.consume_gas + c + (Gas_limit_repr.write_bytes_cost (Z.of_int len))) + >>=? fun c -> + set c len_name (encode_len_value bytes) >>=? fun c -> return (c, bytes) + let consume_remove_gas del c = - Lwt.return (Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) >>=? fun c -> - del c len_name + Lwt.return + (Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero)) + >>=? fun c -> del c len_name + let mem s i = - consume_mem_gas (pack s i) >>=? fun c -> - Raw_context.mem c data_name >>= fun res -> - return (Raw_context.project c, res) + consume_mem_gas (pack s i) + >>=? fun c -> + Raw_context.mem c data_name + >>= fun res -> return (Raw_context.project c, res) + let get s i = - consume_read_gas Raw_context.get (pack s i) >>=? fun c -> - Raw_context.get c data_name >>=? fun b -> + consume_read_gas Raw_context.get (pack s i) + >>=? fun c -> + Raw_context.get c data_name + >>=? fun b -> let key = Raw_context.absolute_key c data_name in - Lwt.return (of_bytes ~key b) >>=? fun v -> - return (Raw_context.project c, v) + Lwt.return (of_bytes ~key b) + >>=? fun v -> return (Raw_context.project c, v) + let get_option s i = - consume_mem_gas (pack s i) >>=? fun c -> + consume_mem_gas (pack s i) + >>=? fun c -> let (s, _) = unpack c in - Raw_context.mem (pack s i) data_name >>= fun exists -> - if exists then - get s i >>=? fun (s, v) -> - return (s, Some v) - else - return (C.project s, None) + Raw_context.mem (pack s i) data_name + >>= fun exists -> + if exists then get s i >>=? fun (s, v) -> return (s, Some v) + else return (C.project s, None) + let set s i v = - existing_size (pack s i) >>=? fun (prev_size, _) -> - consume_write_gas Raw_context.set (pack s i) v >>=? fun (c, bytes) -> - Raw_context.set c data_name bytes >>=? fun c -> - let size_diff = MBytes.length bytes - prev_size in - return (Raw_context.project c, size_diff) - let set_free s i v = - let c = pack s i in - let bytes = to_bytes v in - existing_size c >>=? fun (prev_size, _) -> - Raw_context.set c len_name (encode_len_value bytes) >>=? fun c -> - Raw_context.set c data_name bytes >>=? fun c -> + existing_size (pack s i) + >>=? fun (prev_size, _) -> + consume_write_gas Raw_context.set (pack s i) v + >>=? fun (c, bytes) -> + Raw_context.set c data_name bytes + >>=? fun c -> let size_diff = MBytes.length bytes - prev_size in return (Raw_context.project c, size_diff) + let init s i v = - consume_write_gas Raw_context.init (pack s i) v >>=? fun (c, bytes) -> - Raw_context.init c data_name bytes >>=? fun c -> + consume_write_gas Raw_context.init (pack s i) v + >>=? fun (c, bytes) -> + Raw_context.init c data_name bytes + >>=? fun c -> let size = MBytes.length bytes in return (Raw_context.project c, size) - let init_free s i v = - let c = pack s i in - let bytes = to_bytes v in - let size = MBytes.length bytes in - Raw_context.init c len_name (encode_len_value bytes) >>=? fun c -> - Raw_context.init c data_name bytes >>=? fun c -> - return (Raw_context.project c, size) + let init_set s i v = let init_set c k v = Raw_context.init_set c k v >>= return in - existing_size (pack s i) >>=? fun (prev_size, existed) -> - consume_write_gas init_set (pack s i) v >>=? fun (c, bytes) -> - init_set c data_name bytes >>=? fun c -> + existing_size (pack s i) + >>=? fun (prev_size, existed) -> + consume_write_gas init_set (pack s i) v + >>=? fun (c, bytes) -> + init_set c data_name bytes + >>=? fun c -> let size_diff = MBytes.length bytes - prev_size in return (Raw_context.project c, size_diff, existed) + let remove s i = let remove c k = Raw_context.remove c k >>= return in - existing_size (pack s i) >>=? fun (prev_size, existed) -> - consume_remove_gas remove (pack s i) >>=? fun c -> - remove c data_name >>=? fun c -> - return (Raw_context.project c, prev_size, existed) + existing_size (pack s i) + >>=? fun (prev_size, existed) -> + consume_remove_gas remove (pack s i) + >>=? fun c -> + remove c data_name + >>=? fun c -> return (Raw_context.project c, prev_size, existed) + let delete s i = - existing_size (pack s i) >>=? fun (prev_size, _) -> - consume_remove_gas Raw_context.delete (pack s i) >>=? fun c -> - Raw_context.delete c data_name >>=? fun c -> - return (Raw_context.project c, prev_size) + existing_size (pack s i) + >>=? fun (prev_size, _) -> + consume_remove_gas Raw_context.delete (pack s i) + >>=? fun c -> + Raw_context.delete c data_name + >>=? fun c -> return (Raw_context.project c, prev_size) + let set_option s i v = - match v with - | None -> remove s i - | Some v -> init_set s i v + match v with None -> remove s i | Some v -> init_set s i v let () = let open Storage_description in let unpack = unpack I.args in register_value ~get:(fun c -> - let (c, k) = unpack c in - get_option c k >>=? fun (_, v) -> - return v) + let (c, k) = unpack c in + get_option c k >>=? fun (_, v) -> return v) (register_named_subcontext Raw_context.description N.name) V.encoding - end - end module Wrap_indexed_data_storage - (C : Indexed_data_storage) - (K : sig - type t - val wrap: t -> C.key - val unwrap: C.key -> t option - end) = struct + (C : Indexed_data_storage) (K : sig + type t + + val wrap : t -> C.key + + val unwrap : C.key -> t option + end) = +struct type t = C.t + type context = C.t + type key = K.t + type value = C.value + let mem ctxt k = C.mem ctxt (K.wrap k) + let get ctxt k = C.get ctxt (K.wrap k) + let get_option ctxt k = C.get_option ctxt (K.wrap k) + let set ctxt k v = C.set ctxt (K.wrap k) v + let init ctxt k v = C.init ctxt (K.wrap k) v + let init_set ctxt k v = C.init_set ctxt (K.wrap k) v + let set_option ctxt k v = C.set_option ctxt (K.wrap k) v + let delete ctxt k = C.delete ctxt (K.wrap k) + let remove ctxt k = C.remove ctxt (K.wrap k) + let clear ctxt = C.clear ctxt + let fold ctxt ~init ~f = C.fold ctxt ~init ~f:(fun k v acc -> - match K.unwrap k with - | None -> Lwt.return acc - | Some k -> f k v acc) - let bindings s = - fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p,v) :: acc)) - let fold_keys s ~init ~f = - C.fold_keys s ~init - ~f:(fun k acc -> - match K.unwrap k with - | None -> Lwt.return acc - | Some k -> f k acc) - let keys s = - fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + match K.unwrap k with None -> Lwt.return acc | Some k -> f k v acc) + let bindings s = + fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc)) + + let fold_keys s ~init ~f = + C.fold_keys s ~init ~f:(fun k acc -> + match K.unwrap k with None -> Lwt.return acc | Some k -> f k acc) + + let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli index 6217cb9c0..8a4563741 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_functors.mli @@ -28,61 +28,78 @@ open Storage_sigs module Registered : REGISTER + module Ghost : REGISTER -module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) - : Raw_context.T with type t = C.t +module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : + Raw_context.T with type t = C.t module Make_single_data_storage - (R : REGISTER) (C : Raw_context.T) (N : NAME) (V : VALUE) - : Single_data_storage with type t = C.t - and type value = V.t + (R : REGISTER) + (C : Raw_context.T) + (N : NAME) + (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t module type INDEX = sig type t - val path_length: int - val to_path: t -> string list -> string list - val of_path: string list -> t option + + val path_length : int + + val to_path : t -> string list -> string list + + val of_path : string list -> t option + type 'a ipath - val args: ('a, t, 'a ipath) Storage_description.args + + val args : ('a, t, 'a ipath) Storage_description.args end -module Pair(I1 : INDEX)(I2 : INDEX) : INDEX with type t = I1.t * I2.t +module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t -module Make_data_set_storage (C : Raw_context.T) (I : INDEX) - : Data_set_storage with type t = C.t and type elt = I.t +module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : + Data_set_storage with type t = C.t and type elt = I.t -module Make_indexed_data_storage - (C : Raw_context.T) (I : INDEX) (V : VALUE) - : Indexed_data_storage with type t = C.t - and type key = I.t - and type value = V.t +module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) : + Indexed_data_storage + with type t = C.t + and type key = I.t + and type value = V.t module Make_indexed_carbonated_data_storage - (C : Raw_context.T) (I : INDEX) (V : VALUE) - : Non_iterable_indexed_carbonated_data_storage with type t = C.t - and type key = I.t - and type value = V.t + (C : Raw_context.T) + (I : INDEX) + (V : VALUE) : + Non_iterable_indexed_carbonated_data_storage + with type t = C.t + and type key = I.t + and type value = V.t -module Make_indexed_data_snapshotable_storage (C : Raw_context.T) - (Snapshot : INDEX) (I : INDEX) (V : VALUE) - : Indexed_data_snapshotable_storage with type t = C.t - and type snapshot = Snapshot.t - and type key = I.t - and type value = V.t +module Make_indexed_data_snapshotable_storage + (C : Raw_context.T) + (Snapshot : INDEX) + (I : INDEX) + (V : VALUE) : + Indexed_data_snapshotable_storage + with type t = C.t + and type snapshot = Snapshot.t + and type key = I.t + and type value = V.t -module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) - : Indexed_raw_context with type t = C.t - and type key = I.t - and type 'a ipath = 'a I.ipath +module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : + Indexed_raw_context + with type t = C.t + and type key = I.t + and type 'a ipath = 'a I.ipath module Wrap_indexed_data_storage - (C : Indexed_data_storage) - (K : sig - type t - val wrap: t -> C.key - val unwrap: C.key -> t option - end) - : Indexed_data_storage with type t = C.t - and type key = K.t - and type value = C.value + (C : Indexed_data_storage) (K : sig + type t + + val wrap : t -> C.key + + val unwrap : C.key -> t option + end) : + Indexed_data_storage + with type t = C.t + and type key = K.t + and type value = C.value diff --git a/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml b/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml index a637af706..0279d6e99 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/storage_sigs.ml @@ -29,58 +29,57 @@ bound to a specific key in the hierarchical (key x value) database). *) module type Single_data_storage = sig - type t + type context = t (** The type of the value *) type value (** Tells if the data is already defined *) - val mem: context -> bool Lwt.t + val mem : context -> bool Lwt.t (** Retrieve the value from the storage bucket ; returns a {!Storage_error} if the key is not set or if the deserialisation fails *) - val get: context -> value tzresult Lwt.t + val get : context -> value tzresult Lwt.t (** Retrieves the value from the storage bucket ; returns [None] if the data is not initialized, or {!Storage_helpers.Storage_error} if the deserialisation fails *) - val get_option: context -> value option tzresult Lwt.t + val get_option : context -> value option tzresult Lwt.t (** Allocates the storage bucket and initializes it ; returns a {!Storage_error Existing_key} if the bucket exists *) - val init: context -> value -> Raw_context.t tzresult Lwt.t + val init : context -> value -> Raw_context.t tzresult Lwt.t (** Updates the content of the bucket ; returns a {!Storage_Error Missing_key} if the value does not exists *) - val set: context -> value -> Raw_context.t tzresult Lwt.t + val set : context -> value -> Raw_context.t tzresult Lwt.t (** Allocates the data and initializes it with a value ; just updates it if the bucket exists *) - val init_set: context -> value -> Raw_context.t Lwt.t + val init_set : context -> value -> Raw_context.t Lwt.t (** When the value is [Some v], allocates the data and initializes it with [v] ; just updates it if the bucket exists. When the valus is [None], delete the storage bucket when the value ; does nothing if the bucket does not exists. *) - val set_option: context -> value option -> Raw_context.t Lwt.t + val set_option : context -> value option -> Raw_context.t Lwt.t (** Delete the storage bucket ; returns a {!Storage_error Missing_key} if the bucket does not exists *) - val delete: context -> Raw_context.t tzresult Lwt.t + val delete : context -> Raw_context.t tzresult Lwt.t (** Removes the storage bucket and its contents ; does nothing if the bucket does not exists *) - val remove: context -> Raw_context.t Lwt.t - + val remove : context -> Raw_context.t Lwt.t end (** Variant of {!Single_data_storage} with gas accounting. *) module type Single_carbonated_data_storage = sig - type t + type context = t (** The type of the value *) @@ -88,39 +87,40 @@ module type Single_carbonated_data_storage = sig (** Tells if the data is already defined. Consumes [Gas_repr.read_bytes_cost Z.zero]. *) - val mem: context -> (Raw_context.t * bool) tzresult Lwt.t + val mem : context -> (Raw_context.t * bool) tzresult Lwt.t (** Retrieve the value from the storage bucket ; returns a {!Storage_error} if the key is not set or if the deserialisation fails. Consumes [Gas_repr.read_bytes_cost ]. *) - val get: context -> (Raw_context.t * value) tzresult Lwt.t + val get : context -> (Raw_context.t * value) tzresult Lwt.t (** Retrieves the value from the storage bucket ; returns [None] if the data is not initialized, or {!Storage_helpers.Storage_error} if the deserialisation fails. Consumes [Gas_repr.read_bytes_cost ] if present or [Gas_repr.read_bytes_cost Z.zero]. *) - val get_option: context -> (Raw_context.t * value option) tzresult Lwt.t + val get_option : context -> (Raw_context.t * value option) tzresult Lwt.t (** Allocates the storage bucket and initializes it ; returns a {!Storage_error Missing_key} if the bucket exists. Consumes [Gas_repr.write_bytes_cost ]. Returns the size. *) - val init: context -> value -> (Raw_context.t * int) tzresult Lwt.t + val init : context -> value -> (Raw_context.t * int) tzresult Lwt.t (** Updates the content of the bucket ; returns a {!Storage_Error Existing_key} if the value does not exists. Consumes [Gas_repr.write_bytes_cost ]. Returns the difference from the old to the new size. *) - val set: context -> value -> (Raw_context.t * int) tzresult Lwt.t + val set : context -> value -> (Raw_context.t * int) tzresult Lwt.t (** Allocates the data and initializes it with a value ; just updates it if the bucket exists. Consumes [Gas_repr.write_bytes_cost ]. Returns the difference from the old (maybe 0) to the new size, and a boolean indicating if a value was already associated to this key. *) - val init_set: context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t + val init_set : + context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t (** When the value is [Some v], allocates the data and initializes it with [v] ; just updates it if the bucket exists. When the @@ -129,27 +129,27 @@ module type Single_carbonated_data_storage = sig Consumes the same gas cost as either {!remove} or {!init_set}. Returns the difference from the old (maybe 0) to the new size, and a boolean indicating if a value was already associated to this key. *) - val set_option: context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t + val set_option : + context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t (** Delete the storage bucket ; returns a {!Storage_error Missing_key} if the bucket does not exists. Consumes [Gas_repr.write_bytes_cost Z.zero]. Returns the freed size. *) - val delete: context -> (Raw_context.t * int) tzresult Lwt.t + val delete : context -> (Raw_context.t * int) tzresult Lwt.t (** Removes the storage bucket and its contents ; does nothing if the bucket does not exists. Consumes [Gas_repr.write_bytes_cost Z.zero]. Returns the freed size, and a boolean indicating if a value was already associated to this key. *) - val remove: context -> (Raw_context.t * int * bool) tzresult Lwt.t - + val remove : context -> (Raw_context.t * int * bool) tzresult Lwt.t end (** Restricted version of {!Indexed_data_storage} w/o iterators. *) module type Non_iterable_indexed_data_storage = sig - type t + type context = t (** An abstract type for keys *) @@ -159,51 +159,50 @@ module type Non_iterable_indexed_data_storage = sig type value (** Tells if a given key is already bound to a storage bucket *) - val mem: context -> key -> bool Lwt.t + val mem : context -> key -> bool Lwt.t (** Retrieve a value from the storage bucket at a given key ; returns {!Storage_error Missing_key} if the key is not set ; returns {!Storage_error Corrupted_data} if the deserialisation fails. *) - val get: context -> key -> value tzresult Lwt.t + val get : context -> key -> value tzresult Lwt.t (** Retrieve a value from the storage bucket at a given key ; returns [None] if the value is not set ; returns {!Storage_error Corrupted_data} if the deserialisation fails. *) - val get_option: context -> key -> value option tzresult Lwt.t + val get_option : context -> key -> value option tzresult Lwt.t (** Updates the content of a bucket ; returns A {!Storage_Error Missing_key} if the value does not exists. *) - val set: context -> key -> value -> Raw_context.t tzresult Lwt.t + val set : context -> key -> value -> Raw_context.t tzresult Lwt.t (** Allocates a storage bucket at the given key and initializes it ; returns a {!Storage_error Existing_key} if the bucket exists. *) - val init: context -> key -> value -> Raw_context.t tzresult Lwt.t + val init : context -> key -> value -> Raw_context.t tzresult Lwt.t (** Allocates a storage bucket at the given key and initializes it with a value ; just updates it if the bucket exists. *) - val init_set: context -> key -> value -> Raw_context.t Lwt.t + val init_set : context -> key -> value -> Raw_context.t Lwt.t (** When the value is [Some v], allocates the data and initializes it with [v] ; just updates it if the bucket exists. When the valus is [None], delete the storage bucket when the value ; does nothing if the bucket does not exists. *) - val set_option: context -> key -> value option -> Raw_context.t Lwt.t + val set_option : context -> key -> value option -> Raw_context.t Lwt.t (** Delete a storage bucket and its contents ; returns a {!Storage_error Missing_key} if the bucket does not exists. *) - val delete: context -> key -> Raw_context.t tzresult Lwt.t + val delete : context -> key -> Raw_context.t tzresult Lwt.t (** Removes a storage bucket and its contents ; does nothing if the bucket does not exists. *) - val remove: context -> key -> Raw_context.t Lwt.t - + val remove : context -> key -> Raw_context.t Lwt.t end (** Variant of {!Non_iterable_indexed_data_storage} with gas accounting. *) module type Non_iterable_indexed_carbonated_data_storage = sig - type t + type context = t (** An abstract type for keys *) @@ -214,35 +213,36 @@ module type Non_iterable_indexed_carbonated_data_storage = sig (** Tells if a given key is already bound to a storage bucket. Consumes [Gas_repr.read_bytes_cost Z.zero]. *) - val mem: context -> key -> (Raw_context.t * bool) tzresult Lwt.t + val mem : context -> key -> (Raw_context.t * bool) tzresult Lwt.t (** Retrieve a value from the storage bucket at a given key ; returns {!Storage_error Missing_key} if the key is not set ; returns {!Storage_error Corrupted_data} if the deserialisation fails. Consumes [Gas_repr.read_bytes_cost ]. *) - val get: context -> key -> (Raw_context.t * value) tzresult Lwt.t + val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t (** Retrieve a value from the storage bucket at a given key ; returns [None] if the value is not set ; returns {!Storage_error Corrupted_data} if the deserialisation fails. Consumes [Gas_repr.read_bytes_cost ] if present or [Gas_repr.read_bytes_cost Z.zero]. *) - val get_option: context -> key -> (Raw_context.t * value option) tzresult Lwt.t + val get_option : + context -> key -> (Raw_context.t * value option) tzresult Lwt.t (** Updates the content of a bucket ; returns A {!Storage_Error Missing_key} if the value does not exists. Consumes serialization cost. Consumes [Gas_repr.write_bytes_cost ]. Returns the difference from the old to the new size. *) - val set: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + val set : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t (** Allocates a storage bucket at the given key and initializes it ; returns a {!Storage_error Existing_key} if the bucket exists. Consumes serialization cost. Consumes [Gas_repr.write_bytes_cost ]. Returns the size. *) - val init: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + val init : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t (** Allocates a storage bucket at the given key and initializes it with a value ; just updates it if the bucket exists. @@ -250,7 +250,8 @@ module type Non_iterable_indexed_carbonated_data_storage = sig Consumes [Gas_repr.write_bytes_cost ]. Returns the difference from the old (maybe 0) to the new size, and a boolean indicating if a value was already associated to this key. *) - val init_set: context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t + val init_set : + context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t (** When the value is [Some v], allocates the data and initializes it with [v] ; just updates it if the bucket exists. When the @@ -260,160 +261,152 @@ module type Non_iterable_indexed_carbonated_data_storage = sig Consumes the same gas cost as either {!remove} or {!init_set}. Returns the difference from the old (maybe 0) to the new size, and a boolean indicating if a value was already associated to this key. *) - val set_option: context -> key -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t + val set_option : + context -> + key -> + value option -> + (Raw_context.t * int * bool) tzresult Lwt.t (** Delete a storage bucket and its contents ; returns a {!Storage_error Missing_key} if the bucket does not exists. Consumes [Gas_repr.write_bytes_cost Z.zero]. Returns the freed size. *) - val delete: context -> key -> (Raw_context.t * int) tzresult Lwt.t + val delete : context -> key -> (Raw_context.t * int) tzresult Lwt.t (** Removes a storage bucket and its contents ; does nothing if the bucket does not exists. Consumes [Gas_repr.write_bytes_cost Z.zero]. Returns the freed size, and a boolean indicating if a value was already associated to this key. *) - val remove: context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t - + val remove : context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t end (** The generic signature of indexed data accessors (a set of values of the same type indexed by keys of the same form in the hierarchical (key x value) database). *) module type Indexed_data_storage = sig - include Non_iterable_indexed_data_storage (** Empties all the keys and associated data. *) - val clear: context -> Raw_context.t Lwt.t + val clear : context -> Raw_context.t Lwt.t (** Lists all the keys. *) - val keys: context -> key list Lwt.t + val keys : context -> key list Lwt.t (** Lists all the keys and associated data. *) - val bindings: context -> (key * value) list Lwt.t + val bindings : context -> (key * value) list Lwt.t (** Iterates over all the keys and associated data. *) - val fold: + val fold : context -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t (** Iterate over all the keys. *) - val fold_keys: - context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t - + val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t end module type Indexed_data_snapshotable_storage = sig type snapshot + type key include Indexed_data_storage with type key := key - module Snapshot : Indexed_data_storage - with type key = (snapshot * key) - and type value = value - and type t = t + module Snapshot : + Indexed_data_storage + with type key = snapshot * key + and type value = value + and type t = t val snapshot_exists : context -> snapshot -> bool Lwt.t - val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t - val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t + val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t + + val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t end (** The generic signature of a data set accessor (a set of values bound to a specific key prefix in the hierarchical (key x value) database). *) module type Data_set_storage = sig - type t + type context = t (** The type of elements. *) type elt (** Tells if a elt is a member of the set *) - val mem: context -> elt -> bool Lwt.t + val mem : context -> elt -> bool Lwt.t (** Adds a elt is a member of the set *) - val add: context -> elt -> Raw_context.t Lwt.t + val add : context -> elt -> Raw_context.t Lwt.t (** Removes a elt of the set ; does nothing if not a member *) - val del: context -> elt -> Raw_context.t Lwt.t + val del : context -> elt -> Raw_context.t Lwt.t (** Adds/Removes a elt of the set *) - val set: context -> elt -> bool -> Raw_context.t Lwt.t + val set : context -> elt -> bool -> Raw_context.t Lwt.t (** Returns the elements of the set, deserialized in a list in no particular order. *) - val elements: context -> elt list Lwt.t + val elements : context -> elt list Lwt.t (** Iterates over the elements of the set. *) - val fold: context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t + val fold : context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t (** Removes all elements in the set *) - val clear: context -> Raw_context.t Lwt.t - + val clear : context -> Raw_context.t Lwt.t end module type NAME = sig - val name: Raw_context.key + val name : Raw_context.key end module type VALUE = sig type t - val encoding: t Data_encoding.t + + val encoding : t Data_encoding.t end -module type REGISTER = sig val ghost : bool end - -module type Non_iterable_indexed_carbonated_data_storage_with_free = sig - include Non_iterable_indexed_carbonated_data_storage - - (** Only used for 005 migration to avoid gas cost. - Allocates a storage bucket at the given key and initializes it ; - returns a {!Storage_error Existing_key} if the bucket exists. *) - val init_free: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t - - (** Only used for 005 migration to avoid gas cost. - Updates the content of a bucket ; returns A {!Storage_Error - Missing_key} if the value does not exists. *) - val set_free: context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t +module type REGISTER = sig + val ghost : bool end module type Indexed_raw_context = sig - type t + type context = t + type key + type 'a ipath - val clear: context -> Raw_context.t Lwt.t + val clear : context -> Raw_context.t Lwt.t - val fold_keys: - context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t - val keys: context -> key list Lwt.t + val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t - val resolve: context -> string list -> key list Lwt.t + val keys : context -> key list Lwt.t - val remove_rec: context -> key -> context Lwt.t + val resolve : context -> string list -> key list Lwt.t - val copy: context -> from:key -> to_:key -> context tzresult Lwt.t + val remove_rec : context -> key -> context Lwt.t - module Make_set (R : REGISTER) (N : NAME) + val copy : context -> from:key -> to_:key -> context tzresult Lwt.t - : Data_set_storage with type t = t - and type elt = key + module Make_set (R : REGISTER) (N : NAME) : + Data_set_storage with type t = t and type elt = key - module Make_map (N : NAME) (V : VALUE) - : Indexed_data_storage with type t = t - and type key = key - and type value = V.t + module Make_map (N : NAME) (V : VALUE) : + Indexed_data_storage + with type t = t + and type key = key + and type value = V.t - module Make_carbonated_map (N : NAME) (V : VALUE) - : Non_iterable_indexed_carbonated_data_storage_with_free with type t = t - and type key = key - and type value = V.t + module Make_carbonated_map (N : NAME) (V : VALUE) : + Non_iterable_indexed_carbonated_data_storage + with type t = t + and type key = key + and type value = V.t module Raw_context : Raw_context.T with type t = t ipath - end diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.ml index aa8da3282..364d9347f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.ml @@ -23,11 +23,12 @@ (* *) (*****************************************************************************) -include Qty_repr.Make (struct let id = "tez" end) +include Qty_repr.Make (struct + let id = "tez" +end) type t = qty + type tez = qty -let encoding = - Data_encoding.def "mutez" @@ - encoding +let encoding = Data_encoding.def "mutez" @@ encoding diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.mli index 80eb6dbed..8b923658f 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/tez_repr.mli @@ -24,6 +24,7 @@ (*****************************************************************************) type t + type tez = t -include (Qty_repr.S with type qty := t) +include Qty_repr.S with type qty := t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml index 1709ca358..8a79c9973 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.ml @@ -24,9 +24,11 @@ (*****************************************************************************) include Time + type time = t type error += Timestamp_add (* `Permanent *) + type error += Timestamp_sub (* `Permanent *) let () = @@ -35,34 +37,30 @@ let () = ~id:"timestamp_add" ~title:"Timestamp add" ~description:"Overflow when adding timestamps." - ~pp:(fun ppf () -> - Format.fprintf ppf "Overflow when adding timestamps.") + ~pp:(fun ppf () -> Format.fprintf ppf "Overflow when adding timestamps.") Data_encoding.empty (function Timestamp_add -> Some () | _ -> None) - (fun () -> Timestamp_add); + (fun () -> Timestamp_add) ; register_error_kind `Permanent ~id:"timestamp_sub" ~title:"Timestamp sub" ~description:"Substracting timestamps resulted in negative period." ~pp:(fun ppf () -> - Format.fprintf ppf "Substracting timestamps resulted in negative period.") + Format.fprintf ppf "Substracting timestamps resulted in negative period.") Data_encoding.empty (function Timestamp_sub -> Some () | _ -> None) (fun () -> Timestamp_sub) -let of_seconds s = - try Some (of_seconds (Int64.of_string s)) - with _ -> None +let of_seconds s = try Some (of_seconds (Int64.of_string s)) with _ -> None + let to_seconds = to_seconds + let to_seconds_string s = Int64.to_string (to_seconds s) let pp = pp_hum -let (+?) x y = - try ok (add x (Period_repr.to_seconds y)) - with _exn -> error Timestamp_add +let ( +? ) x y = + try ok (add x (Period_repr.to_seconds y)) with _exn -> error Timestamp_add -let (-?) x y = - record_trace Timestamp_sub - (Period_repr.of_seconds (diff x y)) +let ( -? ) x y = record_trace Timestamp_sub (Period_repr.of_seconds (diff x y)) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli index 3cb96922f..e1ef22521 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/time_repr.mli @@ -23,13 +23,18 @@ (* *) (*****************************************************************************) -include module type of (struct include Time end) +include module type of struct + include Time +end + type time = t -val pp: Format.formatter -> t -> unit -val of_seconds: string -> time option -val to_seconds_string: time -> string +val pp : Format.formatter -> t -> unit -val (+?) : time -> Period_repr.t -> time tzresult -val (-?) : time -> time -> Period_repr.t tzresult +val of_seconds : string -> time option +val to_seconds_string : time -> string + +val ( +? ) : time -> Period_repr.t -> time tzresult + +val ( -? ) : time -> time -> Period_repr.t tzresult diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.ml index 64e01f7ca..4fb0b82d9 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.ml @@ -29,22 +29,18 @@ type ballot = Yay | Nay | Pass let ballot_encoding = let of_int8 = function - | 0 -> Yay - | 1 -> Nay - | 2 -> Pass - | _ -> invalid_arg "ballot_of_int8" - in - let to_int8 = function - | Yay -> 0 - | Nay -> 1 - | Pass -> 2 + | 0 -> + Yay + | 1 -> + Nay + | 2 -> + Pass + | _ -> + invalid_arg "ballot_of_int8" in + let to_int8 = function Yay -> 0 | Nay -> 1 | Pass -> 2 in let open Data_encoding in (* union *) splitted - ~binary: (conv to_int8 of_int8 int8) - ~json: (string_enum [ - "yay", Yay ; - "nay", Nay ; - "pass", Pass ; - ]) + ~binary:(conv to_int8 of_int8 int8) + ~json:(string_enum [("yay", Yay); ("nay", Nay); ("pass", Pass)]) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.mli index ad83b08f0..8a7d4a59b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_repr.mli @@ -29,4 +29,5 @@ type proposal = Protocol_hash.t (** votes can be for, against or neutral. Neutral serves to count towards a quorum *) type ballot = Yay | Nay | Pass -val ballot_encoding: ballot Data_encoding.t + +val ballot_encoding : ballot Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml index d5e901321..14aef58cd 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.ml @@ -24,124 +24,133 @@ (*****************************************************************************) let recorded_proposal_count_for_delegate ctxt proposer = - Storage.Vote.Proposals_count.get_option ctxt proposer >>=? function - | None -> return 0 - | Some count -> return count + Storage.Vote.Proposals_count.get_option ctxt proposer + >>=? function None -> return 0 | Some count -> return count let record_proposal ctxt proposal proposer = - recorded_proposal_count_for_delegate ctxt proposer >>=? fun count -> - Storage.Vote.Proposals_count.init_set ctxt proposer (count + 1) >>= fun ctxt -> - Storage.Vote.Proposals.add ctxt (proposal, proposer) >>= fun ctxt -> - return ctxt + recorded_proposal_count_for_delegate ctxt proposer + >>=? fun count -> + Storage.Vote.Proposals_count.init_set ctxt proposer (count + 1) + >>= fun ctxt -> + Storage.Vote.Proposals.add ctxt (proposal, proposer) + >>= fun ctxt -> return ctxt let get_proposals ctxt = - Storage.Vote.Proposals.fold ctxt + Storage.Vote.Proposals.fold + ctxt ~init:(ok Protocol_hash.Map.empty) ~f:(fun (proposal, delegate) acc -> - (* Assuming the same listings is used at votings *) - Storage.Vote.Listings.get ctxt delegate >>=? fun weight -> - Lwt.return begin acc >>? fun acc -> - let previous = - match Protocol_hash.Map.find_opt proposal acc with - | None -> 0l - | Some x -> x - in - ok (Protocol_hash.Map.add proposal (Int32.add weight previous) acc) - end) + (* Assuming the same listings is used at votings *) + Storage.Vote.Listings.get ctxt delegate + >>=? fun weight -> + Lwt.return + ( acc + >>? fun acc -> + let previous = + match Protocol_hash.Map.find_opt proposal acc with + | None -> + 0l + | Some x -> + x + in + ok (Protocol_hash.Map.add proposal (Int32.add weight previous) acc) )) let clear_proposals ctxt = - Storage.Vote.Proposals_count.clear ctxt >>= fun ctxt -> - Storage.Vote.Proposals.clear ctxt + Storage.Vote.Proposals_count.clear ctxt + >>= fun ctxt -> Storage.Vote.Proposals.clear ctxt -type ballots = { - yay: int32 ; - nay: int32 ; - pass: int32 ; -} +type ballots = {yay : int32; nay : int32; pass : int32} let ballots_encoding = let open Data_encoding in conv - (fun { yay ; nay ; pass } -> ( yay , nay , pass )) - (fun ( yay , nay , pass ) -> { yay ; nay ; pass }) - @@ obj3 - (req "yay" int32) - (req "nay" int32) - (req "pass" int32) + (fun {yay; nay; pass} -> (yay, nay, pass)) + (fun (yay, nay, pass) -> {yay; nay; pass}) + @@ obj3 (req "yay" int32) (req "nay" int32) (req "pass" int32) let has_recorded_ballot = Storage.Vote.Ballots.mem + let record_ballot = Storage.Vote.Ballots.init let get_ballots ctxt = - Storage.Vote.Ballots.fold ctxt - ~f:(fun delegate ballot (ballots: ballots tzresult) -> - (* Assuming the same listings is used at votings *) - Storage.Vote.Listings.get ctxt delegate >>=? fun weight -> - let count = Int32.add weight in - Lwt.return begin - ballots >>? fun ballots -> - match ballot with - | Yay -> ok { ballots with yay = count ballots.yay } - | Nay -> ok { ballots with nay = count ballots.nay } - | Pass -> ok { ballots with pass = count ballots.pass } - end) - ~init:(ok { yay = 0l ; nay = 0l; pass = 0l }) + Storage.Vote.Ballots.fold + ctxt + ~f:(fun delegate ballot (ballots : ballots tzresult) -> + (* Assuming the same listings is used at votings *) + Storage.Vote.Listings.get ctxt delegate + >>=? fun weight -> + let count = Int32.add weight in + Lwt.return + ( ballots + >>? fun ballots -> + match ballot with + | Yay -> + ok {ballots with yay = count ballots.yay} + | Nay -> + ok {ballots with nay = count ballots.nay} + | Pass -> + ok {ballots with pass = count ballots.pass} )) + ~init:(ok {yay = 0l; nay = 0l; pass = 0l}) let get_ballot_list = Storage.Vote.Ballots.bindings let clear_ballots = Storage.Vote.Ballots.clear let listings_encoding = - Data_encoding.(list (obj2 - (req "pkh" Signature.Public_key_hash.encoding) - (req "rolls" int32))) + Data_encoding.( + list + (obj2 (req "pkh" Signature.Public_key_hash.encoding) (req "rolls" int32))) let freeze_listings ctxt = - Roll_storage.fold ctxt (ctxt, 0l) - ~f:(fun _roll delegate (ctxt, total) -> - (* TODO use snapshots *) - let delegate = Signature.Public_key.hash delegate in - begin - Storage.Vote.Listings.get_option ctxt delegate >>=? function - | None -> return 0l - | Some count -> return count - end >>=? fun count -> - Storage.Vote.Listings.init_set - ctxt delegate (Int32.succ count) >>= fun ctxt -> - return (ctxt, Int32.succ total)) >>=? fun (ctxt, total) -> - Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt -> - return ctxt + Roll_storage.fold ctxt (ctxt, 0l) ~f:(fun _roll delegate (ctxt, total) -> + (* TODO use snapshots *) + let delegate = Signature.Public_key.hash delegate in + Storage.Vote.Listings.get_option ctxt delegate + >>=? (function None -> return 0l | Some count -> return count) + >>=? fun count -> + Storage.Vote.Listings.init_set ctxt delegate (Int32.succ count) + >>= fun ctxt -> return (ctxt, Int32.succ total)) + >>=? fun (ctxt, total) -> + Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt -> return ctxt let listing_size = Storage.Vote.Listings_size.get + let in_listings = Storage.Vote.Listings.mem + let get_listings = Storage.Vote.Listings.bindings let clear_listings ctxt = - Storage.Vote.Listings.clear ctxt >>= fun ctxt -> - Storage.Vote.Listings_size.remove ctxt >>= fun ctxt -> - return ctxt + Storage.Vote.Listings.clear ctxt + >>= fun ctxt -> + Storage.Vote.Listings_size.remove ctxt >>= fun ctxt -> return ctxt let get_current_period_kind = Storage.Vote.Current_period_kind.get + let set_current_period_kind = Storage.Vote.Current_period_kind.set let get_current_quorum ctxt = - Storage.Vote.Participation_ema.get ctxt >>=? fun participation_ema -> + Storage.Vote.Participation_ema.get ctxt + >>=? fun participation_ema -> let quorum_min = Constants_storage.quorum_min ctxt in let quorum_max = Constants_storage.quorum_max ctxt in let quorum_diff = Int32.sub quorum_max quorum_min in - return Int32.(add quorum_min - (div (mul participation_ema quorum_diff) 100_00l)) + return + Int32.(add quorum_min (div (mul participation_ema quorum_diff) 100_00l)) let get_participation_ema = Storage.Vote.Participation_ema.get + let set_participation_ema = Storage.Vote.Participation_ema.set let get_current_proposal = Storage.Vote.Current_proposal.get + let init_current_proposal = Storage.Vote.Current_proposal.init + let clear_current_proposal = Storage.Vote.Current_proposal.delete let init ctxt = (* participation EMA is in centile of a percentage *) let participation_ema = Constants_storage.quorum_max ctxt in - Storage.Vote.Participation_ema.init ctxt participation_ema >>=? fun ctxt -> - Storage.Vote.Current_period_kind.init ctxt Proposal >>=? fun ctxt -> - return ctxt + Storage.Vote.Participation_ema.init ctxt participation_ema + >>=? fun ctxt -> + Storage.Vote.Current_period_kind.init ctxt Proposal + >>=? fun ctxt -> return ctxt diff --git a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli index 6606bbb83..51dd59f2e 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/vote_storage.mli @@ -26,73 +26,81 @@ (** Manages all the voting related storage in Storage.Vote. *) (** Records a protocol proposal with the delegate that proposed it. *) -val record_proposal: - Raw_context.t -> Protocol_hash.t -> Signature.Public_key_hash.t -> +val record_proposal : + Raw_context.t -> + Protocol_hash.t -> + Signature.Public_key_hash.t -> Raw_context.t tzresult Lwt.t -val recorded_proposal_count_for_delegate: - Raw_context.t -> Signature.Public_key_hash.t -> - int tzresult Lwt.t +val recorded_proposal_count_for_delegate : + Raw_context.t -> Signature.Public_key_hash.t -> int tzresult Lwt.t (** Computes for each proposal how many delegates proposed it. *) -val get_proposals: - Raw_context.t -> int32 Protocol_hash.Map.t tzresult Lwt.t +val get_proposals : Raw_context.t -> int32 Protocol_hash.Map.t tzresult Lwt.t -val clear_proposals: Raw_context.t -> Raw_context.t Lwt.t +val clear_proposals : Raw_context.t -> Raw_context.t Lwt.t (** Counts of the votes *) -type ballots = { - yay: int32 ; - nay: int32 ; - pass: int32 ; -} +type ballots = {yay : int32; nay : int32; pass : int32} val ballots_encoding : ballots Data_encoding.t -val has_recorded_ballot : Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t +val has_recorded_ballot : + Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t (** Records a vote for a delegate, returns a {!Storage_error Existing_key} if the vote was already registered *) -val record_ballot: - Raw_context.t -> Signature.Public_key_hash.t -> Vote_repr.ballot -> +val record_ballot : + Raw_context.t -> + Signature.Public_key_hash.t -> + Vote_repr.ballot -> Raw_context.t tzresult Lwt.t (** Computes the sum of the current ballots weighted by stake. *) -val get_ballots: Raw_context.t -> ballots tzresult Lwt.t +val get_ballots : Raw_context.t -> ballots tzresult Lwt.t + val get_ballot_list : Raw_context.t -> (Signature.Public_key_hash.t * Vote_repr.ballot) list Lwt.t -val clear_ballots: Raw_context.t -> Raw_context.t Lwt.t -val listings_encoding : (Signature.Public_key_hash.t * int32) list Data_encoding.t +val clear_ballots : Raw_context.t -> Raw_context.t Lwt.t + +val listings_encoding : + (Signature.Public_key_hash.t * int32) list Data_encoding.t (** Populates [!Storage.Vote.Listings] using the currently existing rolls and sets Listings_size. Delegates without rolls are not included in the listing. *) -val freeze_listings: Raw_context.t -> Raw_context.t tzresult Lwt.t -val clear_listings: Raw_context.t -> Raw_context.t tzresult Lwt.t +val freeze_listings : Raw_context.t -> Raw_context.t tzresult Lwt.t + +val clear_listings : Raw_context.t -> Raw_context.t tzresult Lwt.t (** Returns the sum of all rolls of all delegates. *) -val listing_size: Raw_context.t -> int32 tzresult Lwt.t +val listing_size : Raw_context.t -> int32 tzresult Lwt.t (** Verifies the presence of a delegate in the listing. *) -val in_listings: - Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t -val get_listings : Raw_context.t -> (Signature.Public_key_hash.t * int32) list Lwt.t +val in_listings : Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t -val get_current_quorum: Raw_context.t -> int32 tzresult Lwt.t +val get_listings : + Raw_context.t -> (Signature.Public_key_hash.t * int32) list Lwt.t -val get_participation_ema: Raw_context.t -> int32 tzresult Lwt.t -val set_participation_ema: Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t +val get_current_quorum : Raw_context.t -> int32 tzresult Lwt.t -val get_current_period_kind: +val get_participation_ema : Raw_context.t -> int32 tzresult Lwt.t + +val set_participation_ema : + Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t + +val get_current_period_kind : Raw_context.t -> Voting_period_repr.kind tzresult Lwt.t -val set_current_period_kind: + +val set_current_period_kind : Raw_context.t -> Voting_period_repr.kind -> Raw_context.t tzresult Lwt.t -val get_current_proposal: - Raw_context.t -> Protocol_hash.t tzresult Lwt.t -val init_current_proposal: +val get_current_proposal : Raw_context.t -> Protocol_hash.t tzresult Lwt.t + +val init_current_proposal : Raw_context.t -> Protocol_hash.t -> Raw_context.t tzresult Lwt.t -val clear_current_proposal: Raw_context.t -> Raw_context.t tzresult Lwt.t + +val clear_current_proposal : Raw_context.t -> Raw_context.t tzresult Lwt.t (** Sets the initial quorum to 80% and period kind to proposal. *) -val init: Raw_context.t -> Raw_context.t tzresult Lwt.t +val init : Raw_context.t -> Raw_context.t tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.ml b/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.ml index 8124e10a0..42a91a530 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.ml @@ -24,59 +24,68 @@ (*****************************************************************************) type t = int32 + type voting_period = t + include (Compare.Int32 : Compare.S with type t := t) + let encoding = Data_encoding.int32 + let pp ppf level = Format.fprintf ppf "%ld" level + let rpc_arg = let construct voting_period = Int32.to_string voting_period in let destruct str = match Int32.of_string str with - | exception _ -> Error "Cannot parse voting period" - | voting_period -> Ok voting_period in + | exception _ -> + Error "Cannot parse voting period" + | voting_period -> + Ok voting_period + in RPC_arg.make ~descr:"A voting period" - ~name: "voting_period" + ~name:"voting_period" ~construct ~destruct () let root = 0l + let succ = Int32.succ let to_int32 l = l + let of_int32_exn l = - if Compare.Int32.(l >= 0l) - then l + if Compare.Int32.(l >= 0l) then l else invalid_arg "Voting_period_repr.of_int32" -type kind = - | Proposal - | Testing_vote - | Testing - | Promotion_vote +type kind = Proposal | Testing_vote | Testing | Promotion_vote let kind_encoding = let open Data_encoding in - union ~tag_size:`Uint8 [ - case (Tag 0) - ~title:"Proposal" - (constant "proposal") - (function Proposal -> Some () | _ -> None) - (fun () -> Proposal) ; - case (Tag 1) - ~title:"Testing_vote" - (constant "testing_vote") - (function Testing_vote -> Some () | _ -> None) - (fun () -> Testing_vote) ; - case (Tag 2) - ~title:"Testing" - (constant "testing") - (function Testing -> Some () | _ -> None) - (fun () -> Testing) ; - case (Tag 3) - ~title:"Promotion_vote" - (constant "promotion_vote") - (function Promotion_vote -> Some () | _ -> None) - (fun () -> Promotion_vote) ; - ] + union + ~tag_size:`Uint8 + [ case + (Tag 0) + ~title:"Proposal" + (constant "proposal") + (function Proposal -> Some () | _ -> None) + (fun () -> Proposal); + case + (Tag 1) + ~title:"Testing_vote" + (constant "testing_vote") + (function Testing_vote -> Some () | _ -> None) + (fun () -> Testing_vote); + case + (Tag 2) + ~title:"Testing" + (constant "testing") + (function Testing -> Some () | _ -> None) + (fun () -> Testing); + case + (Tag 3) + ~title:"Promotion_vote" + (constant "promotion_vote") + (function Promotion_vote -> Some () | _ -> None) + (fun () -> Promotion_vote) ] diff --git a/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.mli b/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.mli index cabe40c99..e22ecd804 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/voting_period_repr.mli @@ -27,22 +27,29 @@ since the root. *) type t + type voting_period = t -val encoding: voting_period Data_encoding.t -val rpc_arg: voting_period RPC_arg.arg -val pp: Format.formatter -> voting_period -> unit + +val encoding : voting_period Data_encoding.t + +val rpc_arg : voting_period RPC_arg.arg + +val pp : Format.formatter -> voting_period -> unit + include Compare.S with type t := voting_period -val to_int32: voting_period -> int32 -val of_int32_exn: int32 -> voting_period +val to_int32 : voting_period -> int32 -val root: voting_period -val succ: voting_period -> voting_period +val of_int32_exn : int32 -> voting_period + +val root : voting_period + +val succ : voting_period -> voting_period type kind = - | Proposal (** protocols can be proposed *) - | Testing_vote (** a proposal can be voted *) - | Testing (** winning proposal is forked on a testnet *) - | Promotion_vote (** activation can be voted *) + | Proposal (** protocols can be proposed *) + | Testing_vote (** a proposal can be voted *) + | Testing (** winning proposal is forked on a testnet *) + | Promotion_vote (** activation can be voted *) -val kind_encoding: kind Data_encoding.t +val kind_encoding : kind Data_encoding.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml index 37220bdc8..5d7ea1635 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml +++ b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.ml @@ -26,98 +26,85 @@ open Alpha_context module S = struct - let path = RPC_path.(open_root / "votes") let ballots = RPC_service.get_service ~description:"Sum of ballots casted so far during a voting period." - ~query: RPC_query.empty - ~output: Vote.ballots_encoding + ~query:RPC_query.empty + ~output:Vote.ballots_encoding RPC_path.(path / "ballots") let ballot_list = RPC_service.get_service ~description:"Ballots casted so far during a voting period." - ~query: RPC_query.empty - ~output: Data_encoding.(list (obj2 - (req "pkh" Signature.Public_key_hash.encoding) - (req "ballot" Vote.ballot_encoding))) + ~query:RPC_query.empty + ~output: + Data_encoding.( + list + (obj2 + (req "pkh" Signature.Public_key_hash.encoding) + (req "ballot" Vote.ballot_encoding))) RPC_path.(path / "ballot_list") let current_period_kind = RPC_service.get_service ~description:"Current period kind." - ~query: RPC_query.empty - ~output: Voting_period.kind_encoding + ~query:RPC_query.empty + ~output:Voting_period.kind_encoding RPC_path.(path / "current_period_kind") let current_quorum = RPC_service.get_service ~description:"Current expected quorum." - ~query: RPC_query.empty - ~output: Data_encoding.int32 + ~query:RPC_query.empty + ~output:Data_encoding.int32 RPC_path.(path / "current_quorum") let listings = RPC_service.get_service - ~description:"List of delegates with their voting weight, in number of rolls." - ~query: RPC_query.empty - ~output: Vote.listings_encoding + ~description: + "List of delegates with their voting weight, in number of rolls." + ~query:RPC_query.empty + ~output:Vote.listings_encoding RPC_path.(path / "listings") let proposals = RPC_service.get_service ~description:"List of proposals with number of supporters." - ~query: RPC_query.empty - ~output: (Protocol_hash.Map.encoding Data_encoding.int32) + ~query:RPC_query.empty + ~output:(Protocol_hash.Map.encoding Data_encoding.int32) RPC_path.(path / "proposals") let current_proposal = RPC_service.get_service ~description:"Current proposal under evaluation." - ~query: RPC_query.empty - ~output: (Data_encoding.option Protocol_hash.encoding) + ~query:RPC_query.empty + ~output:(Data_encoding.option Protocol_hash.encoding) RPC_path.(path / "current_proposal") end let register () = let open Services_registration in + register0 S.ballots (fun ctxt () () -> Vote.get_ballots ctxt) ; + register0 S.ballot_list (fun ctxt () () -> Vote.get_ballot_list ctxt >|= ok) ; + register0 S.current_period_kind (fun ctxt () () -> + Vote.get_current_period_kind ctxt) ; + register0 S.current_quorum (fun ctxt () () -> Vote.get_current_quorum ctxt) ; + register0 S.proposals (fun ctxt () () -> Vote.get_proposals ctxt) ; + register0 S.listings (fun ctxt () () -> Vote.get_listings ctxt >|= ok) ; + register0 S.current_proposal (fun ctxt () () -> + (* this would be better implemented using get_option in get_current_proposal *) + Vote.get_current_proposal ctxt + >>= function + | Ok p -> + return_some p + | Error (Raw_context.Storage_error (Missing_key _) :: _) -> + return_none + | Error _ as e -> + Lwt.return e) - register0 S.ballots begin fun ctxt () () -> - Vote.get_ballots ctxt - end; - - register0 S.ballot_list begin fun ctxt () () -> - Vote.get_ballot_list ctxt >|= ok - end; - - register0 S.current_period_kind begin fun ctxt () () -> - Vote.get_current_period_kind ctxt - end; - - register0 S.current_quorum begin fun ctxt () () -> - Vote.get_current_quorum ctxt - end; - - register0 S.proposals begin fun ctxt () () -> - Vote.get_proposals ctxt - end; - - register0 S.listings begin fun ctxt () () -> - Vote.get_listings ctxt >|= ok - end; - - register0 S.current_proposal begin fun ctxt () () -> - (* this would be better implemented using get_option in get_current_proposal *) - Vote.get_current_proposal ctxt >>= function - | Ok p -> return_some p - | Error (Raw_context.Storage_error (Missing_key _) :: _) -> return_none - | Error _ as e -> Lwt.return e - end - -let ballots ctxt block = - RPC_context.make_call0 S.ballots ctxt block () () +let ballots ctxt block = RPC_context.make_call0 S.ballots ctxt block () () let ballot_list ctxt block = RPC_context.make_call0 S.ballot_list ctxt block () () @@ -128,11 +115,9 @@ let current_period_kind ctxt block = let current_quorum ctxt block = RPC_context.make_call0 S.current_quorum ctxt block () () -let listings ctxt block = - RPC_context.make_call0 S.listings ctxt block () () +let listings ctxt block = RPC_context.make_call0 S.listings ctxt block () () -let proposals ctxt block = - RPC_context.make_call0 S.proposals ctxt block () () +let proposals ctxt block = RPC_context.make_call0 S.proposals ctxt block () () let current_proposal ctxt block = RPC_context.make_call0 S.current_proposal ctxt block () () diff --git a/vendors/ligo-utils/tezos-protocol-alpha/voting_services.mli b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.mli index 0cb4599d7..4c5742e31 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/voting_services.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/voting_services.mli @@ -25,11 +25,12 @@ open Alpha_context -val ballots : - 'a #RPC_context.simple -> 'a -> Vote.ballots shell_tzresult Lwt.t +val ballots : 'a #RPC_context.simple -> 'a -> Vote.ballots shell_tzresult Lwt.t val ballot_list : - 'a #RPC_context.simple -> 'a -> (Signature.Public_key_hash.t * Vote.ballot) list shell_tzresult Lwt.t + 'a #RPC_context.simple -> + 'a -> + (Signature.Public_key_hash.t * Vote.ballot) list shell_tzresult Lwt.t val current_period_kind : 'a #RPC_context.simple -> 'a -> Voting_period.kind shell_tzresult Lwt.t @@ -38,10 +39,14 @@ val current_quorum : 'a #RPC_context.simple -> 'a -> Int32.t shell_tzresult Lwt.t val listings : - 'a #RPC_context.simple -> 'a -> (Signature.Public_key_hash.t * int32) list shell_tzresult Lwt.t + 'a #RPC_context.simple -> + 'a -> + (Signature.Public_key_hash.t * int32) list shell_tzresult Lwt.t val proposals : - 'a #RPC_context.simple -> 'a -> Int32.t Protocol_hash.Map.t shell_tzresult Lwt.t + 'a #RPC_context.simple -> + 'a -> + Int32.t Protocol_hash.Map.t shell_tzresult Lwt.t val current_proposal : 'a #RPC_context.simple -> 'a -> Protocol_hash.t option shell_tzresult Lwt.t diff --git a/vendors/ligo-utils/tezos-utils/michelson-parser/michelson_v1_macros.ml b/vendors/ligo-utils/tezos-utils/michelson-parser/michelson_v1_macros.ml index 1fc947f5b..fb007acc3 100644 --- a/vendors/ligo-utils/tezos-utils/michelson-parser/michelson_v1_macros.ml +++ b/vendors/ligo-utils/tezos-utils/michelson-parser/michelson_v1_macros.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2019 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -23,228 +24,303 @@ (* *) (*****************************************************************************) +(* open Protocol_client_context *) open Tezos_micheline open Micheline - module IntMap = Map.Make (Compare.Int) type 'l node = ('l, string) Micheline.node type error += Unexpected_macro_annotation of string + type error += Sequence_expected of string + type error += Invalid_arity of string * int * int let rec check_letters str i j f = - i > j || f (String.get str i) && check_letters str (i + 1) j f + i > j || (f str.[i] && check_letters str (i + 1) j f) let expand_caddadr original = match original with | Prim (loc, str, args, annot) -> let len = String.length str in - if len > 3 - && String.get str 0 = 'C' - && String.get str (len - 1) = 'R' - && check_letters str 1 (len - 2) - (function 'A' | 'D' -> true | _ -> false) then - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> - let rec parse i annot acc = - if i = 0 then - Seq (loc, acc) + if + len > 3 + && str.[0] = 'C' + && str.[len - 1] = 'R' + && check_letters str 1 (len - 2) (function + | 'A' | 'D' -> + true + | _ -> + false) + then + ( match args with + | [] -> + ok () + | _ :: _ -> + error (Invalid_arity (str, List.length args, 0)) ) + >>? fun () -> + let path_annot = + List.filter (function "@%" | "@%%" -> true | _ -> false) annot + in + let rec parse i acc = + if i = 0 then Seq (loc, acc) else - let annot = if i = len - 2 then annot else [] in - match String.get str i with - | 'A' -> parse (i - 1) [] (Prim (loc, "CAR", [], annot) :: acc) - | 'D' -> parse (i - 1) [] (Prim (loc, "CDR", [], annot) :: acc) - | _ -> assert false in - ok (Some (parse (len - 2) annot [])) - else - ok None - | _ -> ok None - -let extract_first_annot annot char = - let rec extract_first_annot others = function - | [] -> None, List.rev others - | a :: rest -> - try - if a.[0] = char - then Some a, List.rev_append others rest - else extract_first_annot (a :: others) rest - with Invalid_argument _ -> extract_first_annot (a :: others) rest - in - extract_first_annot [] annot - -let extract_first_field_annot annot = extract_first_annot annot '%' -let extract_first_var_annot annot = extract_first_annot annot '@' + let annot = if i = len - 2 then annot else path_annot in + match str.[i] with + | 'A' -> + parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc) + | 'D' -> + parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc) + | _ -> + assert false + in + ok (Some (parse (len - 2) [])) + else ok None + | _ -> + ok None let extract_field_annots annot = - List.partition (fun a -> + List.partition + (fun a -> match a.[0] with - | '%' -> true - | _ -> false - | exception Invalid_argument _ -> false - ) annot + | '%' -> + true + | _ -> + false + | exception Invalid_argument _ -> + false) + annot let expand_set_caddadr original = match original with | Prim (loc, str, args, annot) -> let len = String.length str in - if len >= 7 - && String.sub str 0 5 = "SET_C" - && String.get str (len - 1) = 'R' - && check_letters str 5 (len - 2) - (function 'A' | 'D' -> true | _ -> false) then - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> - begin match extract_field_annots annot with - | [], annot -> ok (None, annot) - | [f], annot -> ok (Some f, annot) - | _, _ -> error (Unexpected_macro_annotation str) - end >>? fun (field_annot, annot) -> + if + len >= 7 + && String.sub str 0 5 = "SET_C" + && str.[len - 1] = 'R' + && check_letters str 5 (len - 2) (function + | 'A' | 'D' -> + true + | _ -> + false) + then + ( match args with + | [] -> + ok () + | _ :: _ -> + error (Invalid_arity (str, List.length args, 0)) ) + >>? fun () -> + ( match extract_field_annots annot with + | ([], annot) -> + ok (None, annot) + | ([f], annot) -> + ok (Some f, annot) + | (_, _) -> + error (Unexpected_macro_annotation str) ) + >>? fun (field_annot, annot) -> let rec parse i acc = - if i = 4 then - acc + if i = 4 then acc else let annot = if i = 5 then annot else [] in - match String.get str i with + match str.[i] with | 'A' -> let acc = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "DIP", - [ Seq (loc, - [ Prim (loc, "CAR", [], [ "@%%" ]) ; - acc ]) ], []) ; - Prim (loc, "CDR", [], [ "@%%" ]) ; - Prim (loc, "SWAP", [], []) ; - Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in + Seq + ( loc, + [ Prim (loc, "DUP", [], []); + Prim + ( loc, + "DIP", + [Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])], + [] ); + Prim (loc, "CDR", [], ["@%%"]); + Prim (loc, "SWAP", [], []); + Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] ) + in parse (i - 1) acc | 'D' -> let acc = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "DIP", - [ Seq (loc, - [ Prim (loc, "CDR", [], [ "@%%" ]) ; - acc ]) ], []) ; - Prim (loc, "CAR", [], [ "@%%" ]) ; - Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in + Seq + ( loc, + [ Prim (loc, "DUP", [], []); + Prim + ( loc, + "DIP", + [Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])], + [] ); + Prim (loc, "CAR", [], ["@%%"]); + Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] ) + in parse (i - 1) acc - | _ -> assert false in - match String.get str (len - 2) with + | _ -> + assert false + in + match str.[len - 2] with | 'A' -> - let access_check = match field_annot with - | None -> [] - | Some f -> [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CAR", [], [ f ]) ; - Prim (loc, "DROP", [], []) ; - ] in - let encoding = [ Prim (loc, "CDR", [], [ "@%%" ]) ; - Prim (loc, "SWAP", [], []) ] in - let pair = [ Prim (loc, "PAIR", [], - [ Option.unopt field_annot ~default:"%" ; "%@" ]) ] in + let access_check = + match field_annot with + | None -> + [] + | Some f -> + [ Prim (loc, "DUP", [], []); + Prim (loc, "CAR", [], [f]); + Prim (loc, "DROP", [], []) ] + in + let encoding = + [Prim (loc, "CDR", [], ["@%%"]); Prim (loc, "SWAP", [], [])] + in + let pair = + [ Prim + ( loc, + "PAIR", + [], + [Option.unopt field_annot ~default:"%"; "%@"] ) ] + in let init = Seq (loc, access_check @ encoding @ pair) in ok (Some (parse (len - 3) init)) | 'D' -> - let access_check = match field_annot with - | None -> [] - | Some f -> [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CDR", [], [ f ]) ; - Prim (loc, "DROP", [], []) ; - ] in - let encoding = [ Prim (loc, "CAR", [], [ "@%%" ]) ] in - let pair = [ Prim (loc, "PAIR", [], - [ "%@" ; Option.unopt field_annot ~default:"%" ]) ] in + let access_check = + match field_annot with + | None -> + [] + | Some f -> + [ Prim (loc, "DUP", [], []); + Prim (loc, "CDR", [], [f]); + Prim (loc, "DROP", [], []) ] + in + let encoding = [Prim (loc, "CAR", [], ["@%%"])] in + let pair = + [ Prim + ( loc, + "PAIR", + [], + ["%@"; Option.unopt field_annot ~default:"%"] ) ] + in let init = Seq (loc, access_check @ encoding @ pair) in ok (Some (parse (len - 3) init)) - | _ -> assert false - else - ok None - | _ -> ok None + | _ -> + assert false + else ok None + | _ -> + ok None let expand_map_caddadr original = match original with | Prim (loc, str, args, annot) -> let len = String.length str in - if len >= 7 - && String.sub str 0 5 = "MAP_C" - && String.get str (len - 1) = 'R' - && check_letters str 5 (len - 2) - (function 'A' | 'D' -> true | _ -> false) then - begin match args with - | [ Seq _ as code ] -> ok code - | [ _ ] -> error (Sequence_expected str) - | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1)) - end >>? fun code -> - begin match extract_field_annots annot with - | [], annot -> ok (None, annot) - | [f], annot -> ok (Some f, annot) - | _, _ -> error (Unexpected_macro_annotation str) - end >>? fun (field_annot, annot) -> + if + len >= 7 + && String.sub str 0 5 = "MAP_C" + && str.[len - 1] = 'R' + && check_letters str 5 (len - 2) (function + | 'A' | 'D' -> + true + | _ -> + false) + then + ( match args with + | [(Seq _ as code)] -> + ok code + | [_] -> + error (Sequence_expected str) + | [] | _ :: _ :: _ -> + error (Invalid_arity (str, List.length args, 1)) ) + >>? fun code -> + ( match extract_field_annots annot with + | ([], annot) -> + ok (None, annot) + | ([f], annot) -> + ok (Some f, annot) + | (_, _) -> + error (Unexpected_macro_annotation str) ) + >>? fun (field_annot, annot) -> let rec parse i acc = - if i = 4 then - acc + if i = 4 then acc else let annot = if i = 5 then annot else [] in - match String.get str i with + match str.[i] with | 'A' -> let acc = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "DIP", - [ Seq (loc, - [ Prim (loc, "CAR", [], [ "@%%" ]) ; - acc ]) ], []) ; - Prim (loc, "CDR", [], [ "@%%" ]) ; - Prim (loc, "SWAP", [], []) ; - Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in + Seq + ( loc, + [ Prim (loc, "DUP", [], []); + Prim + ( loc, + "DIP", + [Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])], + [] ); + Prim (loc, "CDR", [], ["@%%"]); + Prim (loc, "SWAP", [], []); + Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] ) + in parse (i - 1) acc | 'D' -> let acc = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "DIP", - [ Seq (loc, - [ Prim (loc, "CDR", [], [ "@%%" ]) ; - acc ]) ], []) ; - Prim (loc, "CAR", [], [ "@%%" ]) ; - Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in + Seq + ( loc, + [ Prim (loc, "DUP", [], []); + Prim + ( loc, + "DIP", + [Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])], + [] ); + Prim (loc, "CAR", [], ["@%%"]); + Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] ) + in parse (i - 1) acc - | _ -> assert false in - let cr_annot = match field_annot with - | None -> [] - | Some f -> [ "@" ^ String.sub f 1 (String.length f - 1) ] in - match String.get str (len - 2) with + | _ -> + assert false + in + let cr_annot = + match field_annot with + | None -> + [] + | Some f -> + ["@" ^ String.sub f 1 (String.length f - 1)] + in + match str.[len - 2] with | 'A' -> let init = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CDR", [], [ "@%%" ]) ; - Prim (loc, "DIP", - [ Seq (loc, [ Prim (loc, "CAR", [], cr_annot) ; code ]) ], []) ; - Prim (loc, "SWAP", [], []) ; - Prim (loc, "PAIR", [], - [ Option.unopt field_annot ~default:"%" ; "%@"]) ]) in + Seq + ( loc, + [ Prim (loc, "DUP", [], []); + Prim (loc, "CDR", [], ["@%%"]); + Prim + ( loc, + "DIP", + [Seq (loc, [Prim (loc, "CAR", [], cr_annot); code])], + [] ); + Prim (loc, "SWAP", [], []); + Prim + ( loc, + "PAIR", + [], + [Option.unopt field_annot ~default:"%"; "%@"] ) ] ) + in ok (Some (parse (len - 3) init)) | 'D' -> let init = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CDR", [], cr_annot) ; - code ; - Prim (loc, "SWAP", [], []) ; - Prim (loc, "CAR", [], [ "@%%" ]) ; - Prim (loc, "PAIR", [], - [ "%@" ; Option.unopt field_annot ~default:"%" ]) ]) in + Seq + ( loc, + [ Prim (loc, "DUP", [], []); + Prim (loc, "CDR", [], cr_annot); + code; + Prim (loc, "SWAP", [], []); + Prim (loc, "CAR", [], ["@%%"]); + Prim + ( loc, + "PAIR", + [], + ["%@"; Option.unopt field_annot ~default:"%"] ) ] ) + in ok (Some (parse (len - 3) init)) - | _ -> assert false - else - ok None - | _ -> ok None + | _ -> + assert false + else ok None + | _ -> + ok None exception Not_a_roman @@ -252,881 +328,1178 @@ let decimal_of_roman roman = (* http://rosettacode.org/wiki/Roman_numerals/Decode#OCaml *) let arabic = ref 0 in let lastval = ref 0 in - for i = (String.length roman) - 1 downto 0 do + for i = String.length roman - 1 downto 0 do let n = match roman.[i] with - | 'M' -> 1000 - | 'D' -> 500 - | 'C' -> 100 - | 'L' -> 50 - | 'X' -> 10 - | 'V' -> 5 - | 'I' -> 1 - | _ -> raise_notrace Not_a_roman + | 'M' -> + 1000 + | 'D' -> + 500 + | 'C' -> + 100 + | 'L' -> + 50 + | 'X' -> + 10 + | 'V' -> + 5 + | 'I' -> + 1 + | _ -> + raise_notrace Not_a_roman in - if Compare.Int.(n < !lastval) - then arabic := !arabic - n - else arabic := !arabic + n; + if Compare.Int.(n < !lastval) then arabic := !arabic - n + else arabic := !arabic + n ; lastval := n - done; + done ; !arabic -let expand_dxiiivp original = +let dip ~loc ?(annot = []) depth instr = + assert (depth >= 0) ; + if depth = 1 then Prim (loc, "DIP", [instr], annot) + else Prim (loc, "DIP", [Int (loc, Z.of_int depth); instr], annot) + +let expand_deprecated_dxiiivp original = + (* transparently expands deprecated macro [DI...IP] to instruction [DIP n] *) match original with | Prim (loc, str, args, annot) -> let len = String.length str in - if len > 3 - && String.get str 0 = 'D' - && String.get str (len - 1) = 'P' then + if len > 3 && str.[0] = 'D' && str.[len - 1] = 'P' then try let depth = decimal_of_roman (String.sub str 1 (len - 2)) in - let rec make i acc = - if i = 0 then - acc - else - make (i - 1) - (Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ])) in match args with - | [ Seq (_, _) as arg ] -> ok @@ Some (make depth arg) - | [ _ ] -> error (Sequence_expected str) - | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1)) + | [(Seq (_, _) as arg)] -> + ok @@ Some (dip ~loc ~annot depth arg) + | [_] -> + error (Sequence_expected str) + | [] | _ :: _ :: _ -> + error (Invalid_arity (str, List.length args, 1)) with Not_a_roman -> ok None else ok None - | _ -> ok None + | _ -> + ok None exception Not_a_pair -let rec dip ~loc depth instr = - if depth <= 0 - then instr - else dip ~loc (depth - 1) (Prim (loc, "DIP", [ Seq (loc, [ instr ]) ], [])) - -type pair_item = - | A - | I - | P of int * pair_item * pair_item +type pair_item = A | I | P of int * pair_item * pair_item let parse_pair_substr str ~len start = let rec parse ?left i = - if i = len - 1 then - raise_notrace Not_a_pair - else if String.get str i = 'P' then - let next_i, l = parse ~left:true (i + 1) in - let next_i, r = parse ~left:false next_i in - next_i, P (i, l, r) - else if String.get str i = 'A' && left = Some true then - i + 1, A - else if String.get str i = 'I' && left <> Some true then - i + 1, I - else - raise_notrace Not_a_pair in - let last, ast = parse start in - if last <> len - 1 then - raise_notrace Not_a_pair - else - ast + if i = len - 1 then raise_notrace Not_a_pair + else if str.[i] = 'P' then + let (next_i, l) = parse ~left:true (i + 1) in + let (next_i, r) = parse ~left:false next_i in + (next_i, P (i, l, r)) + else if str.[i] = 'A' && left = Some true then (i + 1, A) + else if str.[i] = 'I' && left <> Some true then (i + 1, I) + else raise_notrace Not_a_pair + in + let (last, ast) = parse start in + if last <> len - 1 then raise_notrace Not_a_pair else ast let unparse_pair_item ast = - let rec unparse ast acc = match ast with - | P (_, l, r) -> unparse r (unparse l ("P" :: acc)) - | A -> "A" :: acc - | I -> "I" :: acc in + let rec unparse ast acc = + match ast with + | P (_, l, r) -> + unparse r (unparse l ("P" :: acc)) + | A -> + "A" :: acc + | I -> + "I" :: acc + in List.rev ("R" :: unparse ast []) |> String.concat "" let pappaiir_annots_pos ast annot = let rec find_annots_pos p_pos ast annots acc = - match ast, annots with - | _, [] -> annots, acc - | P (i, left, right), _ -> - let annots, acc = find_annots_pos i left annots acc in + match (ast, annots) with + | (_, []) -> + (annots, acc) + | (P (i, left, right), _) -> + let (annots, acc) = find_annots_pos i left annots acc in find_annots_pos i right annots acc - | A, a :: annots -> - let pos = match IntMap.find_opt p_pos acc with - | None -> [ a ], [] - | Some (_, cdr) -> [ a ], cdr in - annots, IntMap.add p_pos pos acc - | I, a :: annots -> - let pos = match IntMap.find_opt p_pos acc with - | None -> [], [ a ] - | Some (car, _) -> car, [ a ] in - annots, IntMap.add p_pos pos acc in + | (A, a :: annots) -> + let pos = + match IntMap.find_opt p_pos acc with + | None -> + ([a], []) + | Some (_, cdr) -> + ([a], cdr) + in + (annots, IntMap.add p_pos pos acc) + | (I, a :: annots) -> + let pos = + match IntMap.find_opt p_pos acc with + | None -> + ([], [a]) + | Some (car, _) -> + (car, [a]) + in + (annots, IntMap.add p_pos pos acc) + in snd (find_annots_pos 0 ast annot IntMap.empty) let expand_pappaiir original = match original with | Prim (loc, str, args, annot) -> let len = String.length str in - if len > 4 - && String.get str 0 = 'P' - && String.get str (len - 1) = 'R' - && check_letters str 1 (len - 2) - (function 'P' | 'A' | 'I' -> true | _ -> false) then + if + len > 4 + && str.[0] = 'P' + && str.[len - 1] = 'R' + && check_letters str 1 (len - 2) (function + | 'P' | 'A' | 'I' -> + true + | _ -> + false) + then try - let field_annots, annot = extract_field_annots annot in + let (field_annots, annot) = extract_field_annots annot in let ast = parse_pair_substr str ~len 0 in let field_annots_pos = pappaiir_annots_pos ast field_annots in let rec parse p (depth, acc) = match p with | P (i, left, right) -> let annot = - match i, IntMap.find_opt i field_annots_pos with - | 0, None -> annot - | _, None -> [] - | 0, Some ([], cdr_annot) -> "%" :: cdr_annot @ annot - | _, Some ([], cdr_annot) -> "%" :: cdr_annot - | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot + match (i, IntMap.find_opt i field_annots_pos) with + | (0, None) -> + annot + | (_, None) -> + [] + | (0, Some ([], cdr_annot)) -> + ("%" :: cdr_annot) @ annot + | (_, Some ([], cdr_annot)) -> + "%" :: cdr_annot + | (0, Some (car_annot, cdr_annot)) -> + car_annot @ cdr_annot @ annot + | (_, Some (car_annot, cdr_annot)) -> + car_annot @ cdr_annot in - let acc = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc in - (depth, acc) - |> parse left - |> parse right - | A | I -> (depth + 1, acc) + let acc = + if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc + else + dip ~loc depth (Seq (loc, [Prim (loc, "PAIR", [], annot)])) + :: acc + in + (depth, acc) |> parse left |> parse right + | A | I -> + (depth + 1, acc) in - let _, expanded = parse ast (0, []) in - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> - ok (Some (Seq (loc, expanded))) + let (_, expanded) = parse ast (0, []) in + ( match args with + | [] -> + ok () + | _ :: _ -> + error (Invalid_arity (str, List.length args, 0)) ) + >>? fun () -> ok (Some (Seq (loc, expanded))) with Not_a_pair -> ok None - else - ok None - | _ -> ok None + else ok None + | _ -> + ok None let expand_unpappaiir original = match original with | Prim (loc, str, args, annot) -> let len = String.length str in - if len >= 6 - && String.sub str 0 3 = "UNP" - && String.get str (len - 1) = 'R' - && check_letters str 3 (len - 2) - (function 'P' | 'A' | 'I' -> true | _ -> false) then + if + len >= 6 + && String.sub str 0 3 = "UNP" + && str.[len - 1] = 'R' + && check_letters str 3 (len - 2) (function + | 'P' | 'A' | 'I' -> + true + | _ -> + false) + then try let unpair car_annot cdr_annot = - Seq (loc, [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CAR", [], car_annot) ; - dip ~loc 1 (Prim (loc, "CDR", [], cdr_annot)) ; - ]) in + Seq + ( loc, + [ Prim (loc, "DUP", [], []); + Prim (loc, "CAR", [], car_annot); + dip ~loc 1 (Seq (loc, [Prim (loc, "CDR", [], cdr_annot)])) ] + ) + in let ast = parse_pair_substr str ~len 2 in let annots_pos = pappaiir_annots_pos ast annot in let rec parse p (depth, acc) = match p with | P (i, left, right) -> - let car_annot, cdr_annot = + let (car_annot, cdr_annot) = match IntMap.find_opt i annots_pos with - | None -> [], [] - | Some (car_annot, cdr_annot) -> car_annot, cdr_annot in - let acc = dip ~loc depth (unpair car_annot cdr_annot) :: acc in - (depth, acc) - |> parse left - |> parse right - | A | I -> (depth + 1, acc) in - let _, rev_expanded = parse ast (0, []) in + | None -> + ([], []) + | Some (car_annot, cdr_annot) -> + (car_annot, cdr_annot) + in + let acc = + if depth = 0 then unpair car_annot cdr_annot :: acc + else + dip ~loc depth (Seq (loc, [unpair car_annot cdr_annot])) + :: acc + in + (depth, acc) |> parse left |> parse right + | A | I -> + (depth + 1, acc) + in + let (_, rev_expanded) = parse ast (0, []) in let expanded = Seq (loc, List.rev rev_expanded) in - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> - ok (Some expanded) + ( match args with + | [] -> + ok () + | _ :: _ -> + error (Invalid_arity (str, List.length args, 0)) ) + >>? fun () -> ok (Some expanded) with Not_a_pair -> ok None - else - ok None - | _ -> ok None + else ok None + | _ -> + ok None exception Not_a_dup -let expand_duuuuup original = +let dupn loc nloc n annot = + assert (n > 1) ; + if n = 2 then + (* keep the old expansion, shorter for [DUP 2] *) + Seq + ( loc, + [ Prim (loc, "DIP", [Seq (loc, [Prim (nloc, "DUP", [], annot)])], []); + Prim (loc, "SWAP", [], []) ] ) + else + Seq + ( loc, + [ Prim + ( loc, + "DIP", + [ Int (loc, Z.of_int (n - 1)); + Seq (loc, [Prim (loc, "DUP", [], annot)]) ], + [] ); + Prim (loc, "DIG", [Int (nloc, Z.of_int n)], []) ] ) + +let expand_dupn original = + match original with + | Prim (loc, "DUP", [Int (nloc, n)], annot) -> + ok (Some (dupn loc nloc (Z.to_int n) annot)) + | _ -> + ok None + +let expand_deprecated_duuuuup original = + (* transparently expands deprecated macro [DU...UP] to [{ DIP n { DUP } ; DIG n }] *) match original with | Prim (loc, str, args, annot) -> let len = String.length str in - if len > 3 - && String.get str 0 = 'D' - && String.get str (len - 1) = 'P' - && check_letters str 1 (len - 2) ((=) 'U') then - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> + if + len > 3 + && str.[0] = 'D' + && str.[len - 1] = 'P' + && check_letters str 1 (len - 2) (( = ) 'U') + then + ( match args with + | [] -> + ok () + | _ :: _ -> + error (Invalid_arity (str, List.length args, 0)) ) + >>? fun () -> try - let rec parse i acc = - if i = 1 then acc - else if String.get str i = 'U' then - parse (i - 1) - (Seq (loc, [ Prim (loc, "DIP", [ acc ], []) ; - Prim (loc, "SWAP", [], []) ])) - else - raise_notrace Not_a_dup in - ok (Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ])))) + let rec parse i = + if i = 1 then dupn loc loc (len - 2) annot + else if str.[i] = 'U' then parse (i - 1) + else raise_notrace Not_a_dup + in + ok (Some (parse (len - 2))) with Not_a_dup -> ok None - else - ok None - | _ -> ok None + else ok None + | _ -> + ok None let expand_compare original = let cmp loc is annot = let is = match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) - | is -> List.rev is + | Prim (loc, i, args, _) :: r -> + List.rev (Prim (loc, i, args, annot) :: r) + | is -> + List.rev is in - ok (Some (Seq (loc, is))) in + ok (Some (Seq (loc, is))) + in let ifcmp loc is l r annot = let is = - List.map (fun i -> Prim (loc, i, [], [])) is @ - [ Prim (loc, "IF", [ l ; r ], annot) ] in - ok (Some (Seq (loc, is))) in + List.map (fun i -> Prim (loc, i, [], [])) is + @ [Prim (loc, "IF", [l; r], annot)] + in + ok (Some (Seq (loc, is))) + in match original with | Prim (loc, "CMPEQ", [], annot) -> - cmp loc [ "COMPARE" ; "EQ" ] annot + cmp loc ["COMPARE"; "EQ"] annot | Prim (loc, "CMPNEQ", [], annot) -> - cmp loc [ "COMPARE" ; "NEQ" ] annot + cmp loc ["COMPARE"; "NEQ"] annot | Prim (loc, "CMPLT", [], annot) -> - cmp loc [ "COMPARE" ; "LT" ] annot + cmp loc ["COMPARE"; "LT"] annot | Prim (loc, "CMPGT", [], annot) -> - cmp loc [ "COMPARE" ; "GT" ] annot + cmp loc ["COMPARE"; "GT"] annot | Prim (loc, "CMPLE", [], annot) -> - cmp loc [ "COMPARE" ; "LE" ] annot + cmp loc ["COMPARE"; "LE"] annot | Prim (loc, "CMPGE", [], annot) -> - cmp loc [ "COMPARE" ; "GE" ] annot - | Prim (_, ("CMPEQ" | "CMPNEQ" | "CMPLT" - | "CMPGT" | "CMPLE" | "CMPGE" as str), args, []) -> + cmp loc ["COMPARE"; "GE"] annot + | Prim + ( _, + (("CMPEQ" | "CMPNEQ" | "CMPLT" | "CMPGT" | "CMPLE" | "CMPGE") as str), + args, + [] ) -> error (Invalid_arity (str, List.length args, 0)) - | Prim (loc, "IFCMPEQ", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "EQ" ] l r annot - | Prim (loc, "IFCMPNEQ", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "NEQ" ] l r annot - | Prim (loc, "IFCMPLT", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "LT" ] l r annot - | Prim (loc, "IFCMPGT", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "GT" ] l r annot - | Prim (loc, "IFCMPLE", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "LE" ] l r annot - | Prim (loc, "IFCMPGE", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "GE" ] l r annot - | Prim (loc, "IFEQ", [ l ; r ], annot) -> - ifcmp loc [ "EQ" ] l r annot - | Prim (loc, "IFNEQ", [ l ; r ], annot) -> - ifcmp loc [ "NEQ" ] l r annot - | Prim (loc, "IFLT", [ l ; r ], annot) -> - ifcmp loc [ "LT" ] l r annot - | Prim (loc, "IFGT", [ l ; r ], annot) -> - ifcmp loc [ "GT" ] l r annot - | Prim (loc, "IFLE", [ l ; r ], annot) -> - ifcmp loc [ "LE" ] l r annot - | Prim (loc, "IFGE", [ l ; r ], annot) -> - ifcmp loc [ "GE" ] l r annot - | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" - | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" - | "IFEQ" | "IFNEQ" | "IFLT" - | "IFGT" | "IFLE" | "IFGE" as str), args, []) -> + | Prim (loc, "IFCMPEQ", [l; r], annot) -> + ifcmp loc ["COMPARE"; "EQ"] l r annot + | Prim (loc, "IFCMPNEQ", [l; r], annot) -> + ifcmp loc ["COMPARE"; "NEQ"] l r annot + | Prim (loc, "IFCMPLT", [l; r], annot) -> + ifcmp loc ["COMPARE"; "LT"] l r annot + | Prim (loc, "IFCMPGT", [l; r], annot) -> + ifcmp loc ["COMPARE"; "GT"] l r annot + | Prim (loc, "IFCMPLE", [l; r], annot) -> + ifcmp loc ["COMPARE"; "LE"] l r annot + | Prim (loc, "IFCMPGE", [l; r], annot) -> + ifcmp loc ["COMPARE"; "GE"] l r annot + | Prim (loc, "IFEQ", [l; r], annot) -> + ifcmp loc ["EQ"] l r annot + | Prim (loc, "IFNEQ", [l; r], annot) -> + ifcmp loc ["NEQ"] l r annot + | Prim (loc, "IFLT", [l; r], annot) -> + ifcmp loc ["LT"] l r annot + | Prim (loc, "IFGT", [l; r], annot) -> + ifcmp loc ["GT"] l r annot + | Prim (loc, "IFLE", [l; r], annot) -> + ifcmp loc ["LE"] l r annot + | Prim (loc, "IFGE", [l; r], annot) -> + ifcmp loc ["GE"] l r annot + | Prim + ( _, + ( ( "IFCMPEQ" + | "IFCMPNEQ" + | "IFCMPLT" + | "IFCMPGT" + | "IFCMPLE" + | "IFCMPGE" + | "IFEQ" + | "IFNEQ" + | "IFLT" + | "IFGT" + | "IFLE" + | "IFGE" ) as str ), + args, + [] ) -> error (Invalid_arity (str, List.length args, 2)) - | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" - | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" - | "IFEQ" | "IFNEQ" | "IFLT" - | "IFGT" | "IFLE" | "IFGE" as str), [], _ :: _) -> + | Prim + ( _, + ( ( "IFCMPEQ" + | "IFCMPNEQ" + | "IFCMPLT" + | "IFCMPGT" + | "IFCMPLE" + | "IFCMPGE" + | "IFEQ" + | "IFNEQ" + | "IFLT" + | "IFGT" + | "IFLE" + | "IFGE" ) as str ), + [], + _ :: _ ) -> error (Unexpected_macro_annotation str) - | _ -> ok None + | _ -> + ok None let expand_asserts original = let may_rename loc = function - | [] -> Seq (loc, []) - | annot -> Seq (loc, [ Prim (loc, "RENAME", [], annot) ]) + | [] -> + Seq (loc, []) + | annot -> + Seq (loc, [Prim (loc, "RENAME", [], annot)]) in - let fail_false ?(annot=[]) loc = - [may_rename loc annot; Seq (loc, [ Prim (loc, "FAIL", [], []) ])] + let fail_false ?(annot = []) loc = + [may_rename loc annot; Seq (loc, [Prim (loc, "FAIL", [], [])])] in - let fail_true ?(annot=[]) loc = - [Seq (loc, [ Prim (loc, "FAIL", [], []) ]); may_rename loc annot] + let fail_true ?(annot = []) loc = + [Seq (loc, [Prim (loc, "FAIL", [], [])]); may_rename loc annot] in match original with | Prim (loc, "ASSERT", [], []) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, []) ])) + ok @@ Some (Seq (loc, [Prim (loc, "IF", fail_false loc, [])])) | Prim (loc, "ASSERT_NONE", [], []) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, []) ])) + ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_false loc, [])])) | Prim (loc, "ASSERT_SOME", [], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true ~annot loc, []) ])) + ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_true ~annot loc, [])])) | Prim (loc, "ASSERT_LEFT", [], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false ~annot loc, []) ])) + ok + @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_false ~annot loc, [])])) | Prim (loc, "ASSERT_RIGHT", [], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true ~annot loc, []) ])) - | Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME" - | "ASSERT_LEFT" | "ASSERT_RIGHT" as str), args, []) -> + ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_true ~annot loc, [])])) + | Prim + ( _, + ( ( "ASSERT" + | "ASSERT_NONE" + | "ASSERT_SOME" + | "ASSERT_LEFT" + | "ASSERT_RIGHT" ) as str ), + args, + [] ) -> error (Invalid_arity (str, List.length args, 0)) - | Prim (_, ( "ASSERT" | "ASSERT_NONE" as str), [], _ :: _) -> + | Prim (_, (("ASSERT" | "ASSERT_NONE") as str), [], _ :: _) -> error (Unexpected_macro_annotation str) | Prim (loc, s, args, annot) - when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (s, List.length args, 0)) - end >>? fun () -> - begin match annot with - | _ :: _ -> (error (Unexpected_macro_annotation s)) - | [] -> ok () - end >>? fun () -> - begin - let remaining = String.(sub s 7 (length s - 7)) in - let remaining_prim = Prim (loc, remaining, [], []) in - match remaining with - | "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" -> - ok @@ Some (Seq (loc, [ remaining_prim ; - Prim (loc, "IF", fail_false loc, []) ])) - | _ -> - begin - expand_compare remaining_prim >|? function - | None -> None - | Some seq -> - Some (Seq (loc, [ seq ; - Prim (loc, "IF", fail_false loc, []) ])) - end - end - | _ -> ok None - + when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> ( + ( match args with + | [] -> + ok () + | _ :: _ -> + error (Invalid_arity (s, List.length args, 0)) ) + >>? fun () -> + ( match annot with + | _ :: _ -> + error (Unexpected_macro_annotation s) + | [] -> + ok () ) + >>? fun () -> + let remaining = String.(sub s 7 (length s - 7)) in + let remaining_prim = Prim (loc, remaining, [], []) in + match remaining with + | "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" -> + ok + @@ Some + (Seq + (loc, [remaining_prim; Prim (loc, "IF", fail_false loc, [])])) + | _ -> ( + expand_compare remaining_prim + >|? function + | None -> + None + | Some seq -> + Some (Seq (loc, [seq; Prim (loc, "IF", fail_false loc, [])])) ) ) + | _ -> + ok None let expand_if_some = function - | Prim (loc, "IF_SOME", [ right ; left ], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], annot) ])) + | Prim (loc, "IF_SOME", [right; left], annot) -> + ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", [left; right], annot)])) | Prim (_, "IF_SOME", args, _annot) -> error (Invalid_arity ("IF_SOME", List.length args, 2)) - | _ -> ok @@ None + | _ -> + ok @@ None let expand_if_right = function - | Prim (loc, "IF_RIGHT", [ right ; left ], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], annot) ])) + | Prim (loc, "IF_RIGHT", [right; left], annot) -> + ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", [left; right], annot)])) | Prim (_, "IF_RIGHT", args, _annot) -> error (Invalid_arity ("IF_RIGHT", List.length args, 2)) - | _ -> ok @@ None + | _ -> + ok @@ None let expand_fail = function | Prim (loc, "FAIL", [], []) -> - ok @@ Some (Seq (loc, [ - Prim (loc, "UNIT", [], []) ; - Prim (loc, "FAILWITH", [], []) ; - ])) - | _ -> ok @@ None + ok + @@ Some + (Seq + ( loc, + [Prim (loc, "UNIT", [], []); Prim (loc, "FAILWITH", [], [])] )) + | _ -> + ok @@ None let expand original = let rec try_expansions = function - | [] -> ok @@ original - | expander :: expanders -> - expander original >>? function - | None -> try_expansions expanders - | Some rewritten -> ok rewritten in + | [] -> + ok @@ original + | expander :: expanders -> ( + expander original + >>? function + | None -> try_expansions expanders | Some rewritten -> ok rewritten ) + in try_expansions - [ expand_caddadr ; - expand_set_caddadr ; - expand_map_caddadr ; - expand_dxiiivp ; + [ expand_caddadr; + expand_set_caddadr; + expand_map_caddadr; + expand_deprecated_dxiiivp; (* expand_paaiair ; *) - expand_pappaiir ; + expand_pappaiir; (* expand_unpaaiair ; *) - expand_unpappaiir ; - expand_duuuuup ; - expand_compare ; - expand_asserts ; - expand_if_some ; - expand_if_right ; - expand_fail ; - ] + expand_unpappaiir; + expand_deprecated_duuuuup; + expand_dupn; + expand_compare; + expand_asserts; + expand_if_some; + expand_if_right; + expand_fail ] let expand_rec expr = let rec error_map (expanded, errors) f = function - | [] -> (List.rev expanded, List.rev errors) + | [] -> + (List.rev expanded, List.rev errors) | hd :: tl -> let (new_expanded, new_errors) = f hd in error_map (new_expanded :: expanded, List.rev_append new_errors errors) - f tl in + f + tl + in let error_map = error_map ([], []) in let rec expand_rec expr = match expand expr with - | Ok expanded -> - begin - match expanded with - | Seq (loc, items) -> - let items, errors = error_map expand_rec items in - (Seq (loc, items), errors) - | Prim (loc, name, args, annot) -> - let args, errors = error_map expand_rec args in - (Prim (loc, name, args, annot), errors) - | Int _ | String _ | Bytes _ as atom -> (atom, []) end - | Error errors -> (expr, errors) in + | Ok expanded -> ( + match expanded with + | Seq (loc, items) -> + let (items, errors) = error_map expand_rec items in + (Seq (loc, items), errors) + | Prim (loc, name, args, annot) -> + let (args, errors) = error_map expand_rec args in + (Prim (loc, name, args, annot), errors) + | (Int _ | String _ | Bytes _) as atom -> + (atom, []) ) + | Error errors -> + (expr, errors) + in expand_rec expr let unexpand_caddadr expanded = let rec rsteps acc = function - | [] -> Some acc - | Prim (_, "CAR" , [], []) :: rest -> + | [] -> + Some acc + | Prim (_, "CAR", [], []) :: rest -> rsteps ("A" :: acc) rest - | Prim (_, "CDR" , [], []) :: rest -> + | Prim (_, "CDR", [], []) :: rest -> rsteps ("D" :: acc) rest - | _ -> None in + | _ -> + None + in match expanded with - | Seq (loc, (Prim (_, "CAR" , [], []) :: _ as nodes)) - | Seq (loc, (Prim (_, "CDR" , [], []) :: _ as nodes)) -> - begin match rsteps [] nodes with - | Some steps -> - let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in - Some (Prim (loc, name, [], [])) - | None -> None - end - | _ -> None + | Seq (loc, (Prim (_, "CAR", [], []) :: _ as nodes)) + | Seq (loc, (Prim (_, "CDR", [], []) :: _ as nodes)) -> ( + match rsteps [] nodes with + | Some steps -> + let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in + Some (Prim (loc, name, [], [])) + | None -> + None ) + | _ -> + None let unexpand_set_caddadr expanded = let rec steps acc annots = function - | Seq (loc, - [ Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], _) ; - Prim (_, "PAIR", [], _) ]) -> + | Seq + ( loc, + [ Prim (_, "CDR", [], _); + Prim (_, "SWAP", [], _); + Prim (_, "PAIR", [], _) ] ) -> Some (loc, "A" :: acc, annots) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CAR", [], [ field_annot ]) ; - Prim (_, "DROP", [], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "PAIR", [], _) ]) -> + | Seq + ( loc, + [ Prim (_, "DUP", [], []); + Prim (_, "CAR", [], [field_annot]); + Prim (_, "DROP", [], []); + Prim (_, "CDR", [], _); + Prim (_, "SWAP", [], []); + Prim (_, "PAIR", [], _) ] ) -> Some (loc, "A" :: acc, field_annot :: annots) - | Seq (loc, - [ Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], _) ]) -> + | Seq (loc, [Prim (_, "CAR", [], _); Prim (_, "PAIR", [], _)]) -> Some (loc, "D" :: acc, annots) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], [ field_annot ]) ; - Prim (_, "DROP", [], []) ; - Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], _) ]) -> + | Seq + ( loc, + [ Prim (_, "DUP", [], []); + Prim (_, "CDR", [], [field_annot]); + Prim (_, "DROP", [], []); + Prim (_, "CAR", [], _); + Prim (_, "PAIR", [], _) ] ) -> Some (loc, "D" :: acc, field_annot :: annots) - | Seq (_, - [ Prim (_, "DUP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CAR", [], _) ; - sub ]) ], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "PAIR", [], pair_annots) ]) -> - let _, pair_annots = extract_field_annots pair_annots in + | Seq + ( _, + [ Prim (_, "DUP", [], []); + Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []); + Prim (_, "CDR", [], _); + Prim (_, "SWAP", [], []); + Prim (_, "PAIR", [], pair_annots) ] ) -> + let (_, pair_annots) = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub - | Seq (_, - [ Prim (_, "DUP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CDR", [], _) ; - sub ]) ], []) ; - Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], pair_annots) ]) -> - let _, pair_annots = extract_field_annots pair_annots in + | Seq + ( _, + [ Prim (_, "DUP", [], []); + Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], _); sub])], []); + Prim (_, "CAR", [], _); + Prim (_, "PAIR", [], pair_annots) ] ) -> + let (_, pair_annots) = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub - | _ -> None in + | _ -> + None + in match steps [] [] expanded with | Some (loc, steps, annots) -> let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in Some (Prim (loc, name, [], List.rev annots)) - | None -> None + | None -> + None let unexpand_map_caddadr expanded = let rec steps acc annots = function - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CAR", [], []) ; - code ]) ], []) ; - Prim (_, "PAIR", [], _) ]) -> + | Seq + ( loc, + [ Prim (_, "DUP", [], []); + Prim (_, "CDR", [], _); + Prim (_, "SWAP", [], []); + Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], []); code])], []); + Prim (_, "PAIR", [], _) ] ) -> Some (loc, "A" :: acc, annots, code) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CAR", [], [ field_annot ]) ; - code ]) ], []) ; - Prim (_, "PAIR", [], _) ]) -> + | Seq + ( loc, + [ Prim (_, "DUP", [], []); + Prim (_, "CDR", [], _); + Prim (_, "SWAP", [], []); + Prim + ( _, + "DIP", + [Seq (_, [Prim (_, "CAR", [], [field_annot]); code])], + [] ); + Prim (_, "PAIR", [], _) ] ) -> Some (loc, "A" :: acc, field_annot :: annots, code) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], []) ; - code ; - Prim (_, "SWAP", [], []) ; - Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], _) ]) -> + | Seq + ( loc, + [ Prim (_, "DUP", [], []); + Prim (_, "CDR", [], []); + code; + Prim (_, "SWAP", [], []); + Prim (_, "CAR", [], _); + Prim (_, "PAIR", [], _) ] ) -> Some (loc, "D" :: acc, annots, code) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], [ field_annot ]) ; - code ; - Prim (_, "SWAP", [], []) ; - Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], _) ]) -> + | Seq + ( loc, + [ Prim (_, "DUP", [], []); + Prim (_, "CDR", [], [field_annot]); + code; + Prim (_, "SWAP", [], []); + Prim (_, "CAR", [], _); + Prim (_, "PAIR", [], _) ] ) -> Some (loc, "D" :: acc, field_annot :: annots, code) - | Seq (_, - [ Prim (_, "DUP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CAR", [], _) ; - sub ]) ], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "PAIR", [], pair_annots) ]) -> - let _, pair_annots = extract_field_annots pair_annots in + | Seq + ( _, + [ Prim (_, "DUP", [], []); + Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []); + Prim (_, "CDR", [], _); + Prim (_, "SWAP", [], []); + Prim (_, "PAIR", [], pair_annots) ] ) -> + let (_, pair_annots) = extract_field_annots pair_annots in steps ("A" :: acc) (List.rev_append pair_annots annots) sub - | Seq (_, - [ Prim (_, "DUP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CDR", [], []) ; - sub ]) ], []) ; - Prim (_, "CAR", [], []) ; - Prim (_, "PAIR", [], pair_annots) ]) -> - let _, pair_annots = extract_field_annots pair_annots in + | Seq + ( _, + [ Prim (_, "DUP", [], []); + Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], []); sub])], []); + Prim (_, "CAR", [], []); + Prim (_, "PAIR", [], pair_annots) ] ) -> + let (_, pair_annots) = extract_field_annots pair_annots in steps ("D" :: acc) (List.rev_append pair_annots annots) sub - | _ -> None in + | _ -> + None + in match steps [] [] expanded with | Some (loc, steps, annots, code) -> let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in - Some (Prim (loc, name, [ code ], List.rev annots)) - | None -> None + Some (Prim (loc, name, [code], List.rev annots)) + | None -> + None -let roman_of_decimal decimal = - (* http://rosettacode.org/wiki/Roman_numerals/Encode#OCaml *) - let digit x y z = function - | 1 -> [ x ] - | 2 -> [ x ; x ] - | 3 -> [ x ; x ; x ] - | 4 -> [ x ; y ] - | 5 -> [ y ] - | 6 -> [ y ; x ] - | 7 -> [ y ; x ; x ] - | 8 -> [ y ; x ; x ; x ] - | 9 -> [ x ; z ] - | _ -> assert false in - let rec to_roman x = - if x = 0 then [] - else if x < 0 then - invalid_arg "Negative roman numeral" - else if x >= 1000 then - "M" :: to_roman (x - 1000) - else if x >= 100 then - digit "C" "D" "M" (x / 100) @ to_roman (x mod 100) - else if x >= 10 then - digit "X" "L" "C" (x / 10) @ to_roman (x mod 10) - else - digit "I" "V" "X" x in - String.concat "" (to_roman decimal) - -let dxiiivp_roman_of_decimal decimal = - let roman = roman_of_decimal decimal in - if String.length roman = 1 then - (* too short for D*P, fall back to IIIII... *) - String.concat "" (List.init decimal (fun _ -> "I")) - else - roman - -let unexpand_dxiiivp expanded = +let unexpand_deprecated_dxiiivp expanded = + (* transparently turn the old expansion of deprecated [DI...IP] to [DIP n] *) match expanded with - | Seq (loc, - [ Prim (_, "DIP", - [ Seq (_, [ Prim (_, "DIP", [ _ ], []) ]) as sub ], - []) ]) -> + | Seq + ( loc, + [Prim (_, "DIP", [(Seq (_, [Prim (_, "DIP", [_], [])]) as sub)], [])] + ) -> let rec count acc = function - | Seq (_, [ Prim (_, "DIP", [ sub ], []) ]) -> count (acc + 1) sub - | sub -> (acc, sub) in - let depth, sub = count 1 sub in - let name = "D" ^ dxiiivp_roman_of_decimal depth ^ "P" in - Some (Prim (loc, name, [ sub ], [])) - | _ -> None + | Seq (_, [Prim (_, "DIP", [sub], [])]) -> + count (acc + 1) sub + | sub -> + (acc, sub) + in + let (depth, sub) = count 1 sub in + Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], [])) + | _ -> + None -let unexpand_duuuuup expanded = - let rec help expanded = - match expanded with - | Seq (loc, [ Prim (_, "DUP", [], []) ]) -> Some (loc, 1) - | Seq (_, [ Prim (_, "DIP", [expanded'], []); - Prim (_, "SWAP", [], []) ]) -> - begin - match help expanded' with - | None -> None - | Some (loc, n) -> Some (loc, n + 1) - end - | _ -> None - in let rec dupn = function - | 0 -> "P" - | n -> "U" ^ (dupn (n - 1)) in - match help expanded with - | None -> None - | Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], [])) +let unexpand_dupn expanded = + match expanded with + | Seq + ( loc, + [ Prim + (_, "DIP", [Int (_, np); Seq (_, [Prim (_, "DUP", [], annot)])], []); + Prim (_, "DIG", [Int (nloc, ng)], []) ] ) + when Z.equal np (Z.pred ng) -> + Some (Prim (loc, "DUP", [Int (nloc, ng)], annot)) + | _ -> + None -let rec normalize_pair_item ?(right=false) = function - | P (i, a, b) -> P (i, normalize_pair_item a, normalize_pair_item ~right:true b) - | A when right -> I - | A -> A - | I -> I +let unexpand_deprecated_duuuuup expanded = + (* transparently turn the old expansion of deprecated [DU...UP] to [DUP n] *) + let rec expand n = function + | Seq (loc, [Prim (nloc, "DUP", [], annot)]) -> + if n = 1 then None + else Some (Prim (loc, "DUP", [Int (nloc, Z.of_int n)], annot)) + | Seq (_, [Prim (_, "DIP", [expanded'], []); Prim (_, "SWAP", [], [])]) -> + expand (n + 1) expanded' + | _ -> + None + in + expand 1 expanded + +let rec normalize_pair_item ?(right = false) = function + | P (i, a, b) -> + P (i, normalize_pair_item a, normalize_pair_item ~right:true b) + | A when right -> + I + | A -> + A + | I -> + I let unexpand_pappaiir expanded = match expanded with - | Seq (_, [ Prim (_, "PAIR", [], []) ]) -> Some expanded - | Seq (loc, (_ :: _ as nodes)) -> - let rec exec stack nodes = match nodes, stack with - | [], _ -> stack - | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, a :: rstack -> + | Seq (_, [Prim (_, "PAIR", [], [])]) -> + Some expanded + | Seq (loc, (_ :: _ as nodes)) -> ( + let rec exec stack nodes = + match (nodes, stack) with + | ([], _) -> + stack + (* support new expansion using [DIP n] *) + | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, + a :: rstack ) + when Z.to_int n > 1 -> + exec + ( a + :: exec + rstack + [ Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []) + ] ) + rest + | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, [] -> + | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + when Z.to_int n > 1 -> + exec + ( A + :: exec + [] + [ Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []) + ] ) + rest + | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + when Z.to_int n = 1 -> exec (A :: exec [] sub) rest - | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> + (* support old expansion using [DIP] *) + | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + exec (a :: exec rstack sub) rest + | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + exec (A :: exec [] sub) rest + | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) -> exec (P (0, a, b) :: rstack) rest - | Prim (_, "PAIR", [], []) :: rest, [ a ] -> - exec [ P (0, a, I) ] rest - | Prim (_, "PAIR", [], []) :: rest, [] -> - exec [ P (0, A, I) ] rest - | _ -> raise_notrace Not_a_pair in - begin match exec [] nodes with - | [] -> None - | res :: _ -> - let res = normalize_pair_item res in - let name = unparse_pair_item res in - Some (Prim (loc, name, [], [])) - | exception Not_a_pair -> None - end - | _ -> None + | (Prim (_, "PAIR", [], []) :: rest, [a]) -> + exec [P (0, a, I)] rest + | (Prim (_, "PAIR", [], []) :: rest, []) -> + exec [P (0, A, I)] rest + | _ -> + raise_notrace Not_a_pair + in + match exec [] nodes with + | [] -> + None + | res :: _ -> + let res = normalize_pair_item res in + let name = unparse_pair_item res in + Some (Prim (loc, name, [], [])) + | exception Not_a_pair -> + None ) + | _ -> + None let unexpand_unpappaiir expanded = match expanded with - | Seq (loc, (_ :: _ as nodes)) -> - let rec exec stack nodes = match nodes, stack with - | [], _ -> stack - | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, a :: rstack -> + | Seq (loc, (_ :: _ as nodes)) -> ( + let rec exec stack nodes = + match (nodes, stack) with + | ([], _) -> + stack + (* support new expansion using [DIP n] *) + | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, + a :: rstack ) + when Z.to_int n > 1 -> + exec + ( a + :: exec + rstack + [ Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []) + ] ) + rest + | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack) + when Z.to_int n = 1 -> exec (a :: exec rstack sub) rest - | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, [] -> + | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, []) + when Z.to_int n > 1 -> + exec + ( A + :: exec + [] + [ Prim + (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], []) + ] ) + rest + | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, []) + when Z.to_int n = 1 -> exec (A :: exec [] sub) rest - | Seq (_, [ Prim (_, "DUP", [], []) ; - Prim (_, "CAR", [], []) ; - Prim (_, "DIP", - [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], - []) ]) :: rest, - a :: b :: rstack -> + (* support old expansion using [DIP] *) + | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) -> + exec (a :: exec rstack sub) rest + | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) -> + exec (A :: exec [] sub) rest + | ( Seq + ( _, + [ Prim (_, "DUP", [], []); + Prim (_, "CAR", [], []); + Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ] + ) + :: rest, + a :: b :: rstack ) -> exec (P (0, a, b) :: rstack) rest - | Seq (_, [ Prim (_, "DUP", [], []) ; - Prim (_, "CAR", [], []) ; - Prim (_, "DIP", - [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], - []) ]) :: rest, - [ a ] -> - exec [ P (0, a, I) ] rest - | Seq (_, [ Prim (_, "DUP", [], []) ; - Prim (_, "CAR", [], []) ; - Prim (_, "DIP", - [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], - []) ]) :: rest, - [] -> - exec [ P (0, A, I) ] rest - | _ -> raise_notrace Not_a_pair in - begin match exec [] (List.rev nodes) with - | [] -> None - | res :: _ -> - let res = normalize_pair_item res in - let name = "UN" ^ unparse_pair_item res in - Some (Prim (loc, name, [], [])) - | exception Not_a_pair -> None - end - | _ -> None - + | ( Seq + ( _, + [ Prim (_, "DUP", [], []); + Prim (_, "CAR", [], []); + Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ] + ) + :: rest, + [a] ) -> + exec [P (0, a, I)] rest + | ( Seq + ( _, + [ Prim (_, "DUP", [], []); + Prim (_, "CAR", [], []); + Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ] + ) + :: rest, + [] ) -> + exec [P (0, A, I)] rest + | _ -> + raise_notrace Not_a_pair + in + match exec [] (List.rev nodes) with + | [] -> + None + | res :: _ -> + let res = normalize_pair_item res in + let name = "UN" ^ unparse_pair_item res in + Some (Prim (loc, name, [], [])) + | exception Not_a_pair -> + None ) + | _ -> + None let unexpand_compare expanded = match expanded with - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "EQ", [], annot) ]) -> + | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "EQ", [], annot)]) -> Some (Prim (loc, "CMPEQ", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "NEQ", [], annot) ]) -> + | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "NEQ", [], annot)]) -> Some (Prim (loc, "CMPNEQ", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "LT", [], annot) ]) -> + | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LT", [], annot)]) -> Some (Prim (loc, "CMPLT", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "GT", [], annot) ]) -> + | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GT", [], annot)]) -> Some (Prim (loc, "CMPGT", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "LE", [], annot) ]) -> + | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LE", [], annot)]) -> Some (Prim (loc, "CMPLE", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "GE", [], annot) ]) -> + | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GE", [], annot)]) -> Some (Prim (loc, "CMPGE", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "EQ", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq + ( loc, + [ Prim (_, "COMPARE", [], _); + Prim (_, "EQ", [], _); + Prim (_, "IF", args, annot) ] ) -> Some (Prim (loc, "IFCMPEQ", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "NEQ", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq + ( loc, + [ Prim (_, "COMPARE", [], _); + Prim (_, "NEQ", [], _); + Prim (_, "IF", args, annot) ] ) -> Some (Prim (loc, "IFCMPNEQ", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "LT", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq + ( loc, + [ Prim (_, "COMPARE", [], _); + Prim (_, "LT", [], _); + Prim (_, "IF", args, annot) ] ) -> Some (Prim (loc, "IFCMPLT", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "GT", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq + ( loc, + [ Prim (_, "COMPARE", [], _); + Prim (_, "GT", [], _); + Prim (_, "IF", args, annot) ] ) -> Some (Prim (loc, "IFCMPGT", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "LE", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq + ( loc, + [ Prim (_, "COMPARE", [], _); + Prim (_, "LE", [], _); + Prim (_, "IF", args, annot) ] ) -> Some (Prim (loc, "IFCMPLE", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "GE", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq + ( loc, + [ Prim (_, "COMPARE", [], _); + Prim (_, "GE", [], _); + Prim (_, "IF", args, annot) ] ) -> Some (Prim (loc, "IFCMPGE", args, annot)) - | Seq (loc, [ Prim (_, "EQ", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq (loc, [Prim (_, "EQ", [], _); Prim (_, "IF", args, annot)]) -> Some (Prim (loc, "IFEQ", args, annot)) - | Seq (loc, [ Prim (_, "NEQ", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq (loc, [Prim (_, "NEQ", [], _); Prim (_, "IF", args, annot)]) -> Some (Prim (loc, "IFNEQ", args, annot)) - | Seq (loc, [ Prim (_, "LT", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq (loc, [Prim (_, "LT", [], _); Prim (_, "IF", args, annot)]) -> Some (Prim (loc, "IFLT", args, annot)) - | Seq (loc, [ Prim (_, "GT", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq (loc, [Prim (_, "GT", [], _); Prim (_, "IF", args, annot)]) -> Some (Prim (loc, "IFGT", args, annot)) - | Seq (loc, [ Prim (_, "LE", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq (loc, [Prim (_, "LE", [], _); Prim (_, "IF", args, annot)]) -> Some (Prim (loc, "IFLE", args, annot)) - | Seq (loc, [ Prim (_, "GE", [], _) ; - Prim (_, "IF", args, annot) ]) -> + | Seq (loc, [Prim (_, "GE", [], _); Prim (_, "IF", args, annot)]) -> Some (Prim (loc, "IFGE", args, annot)) - | _ -> None + | _ -> + None let unexpand_asserts expanded = match expanded with - | Seq (loc, [ Prim (_, "IF", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> + | Seq + ( loc, + [ Prim + ( _, + "IF", + [ Seq (_, []); + Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT", [], [])) - | Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], []) ; Prim (_, comparison, [], []) ]) ; - Prim (_, "IF", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> + | Seq + ( loc, + [ Seq (_, [Prim (_, "COMPARE", [], []); Prim (_, comparison, [], [])]); + Prim + ( _, + "IF", + [ Seq (_, []); + Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], [])) - | Seq (loc, [ Prim (_, comparison, [], []) ; - Prim (_, "IF", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> + | Seq + ( loc, + [ Prim (_, comparison, [], []); + Prim + ( _, + "IF", + [ Seq (_, []); + Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_" ^ comparison, [], [])) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim (_, "RENAME", [], annot) ]) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> + | Seq + ( loc, + [ Prim + ( _, + "IF_NONE", + [ Seq (_, [Prim (_, "RENAME", [], annot)]); + Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_NONE", [], annot)) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> + | Seq + ( loc, + [ Prim + ( _, + "IF_NONE", + [ Seq (_, []); + Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_NONE", [], [])) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ; - Seq (_, [])], - []) ]) -> + | Seq + ( loc, + [ Prim + ( _, + "IF_NONE", + [ Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ); + Seq (_, []) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_SOME", [], [])) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ; - Seq (_, [ Prim (_, "RENAME", [], annot) ])], - []) ]) -> + | Seq + ( loc, + [ Prim + ( _, + "IF_NONE", + [ Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ); + Seq (_, [Prim (_, "RENAME", [], annot)]) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_SOME", [], annot)) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> + | Seq + ( loc, + [ Prim + ( _, + "IF_LEFT", + [ Seq (_, []); + Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_LEFT", [], [])) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim (_, "RENAME", [], annot) ]) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> + | Seq + ( loc, + [ Prim + ( _, + "IF_LEFT", + [ Seq (_, [Prim (_, "RENAME", [], annot)]); + Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_LEFT", [], annot)) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ; - Seq (_, []) ], - []) ]) -> + | Seq + ( loc, + [ Prim + ( _, + "IF_LEFT", + [ Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ); + Seq (_, []) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_RIGHT", [], [])) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ; - Seq (_, [ Prim (_, "RENAME", [], annot) ]) ], - []) ]) -> + | Seq + ( loc, + [ Prim + ( _, + "IF_LEFT", + [ Seq + ( _, + [ Seq + ( _, + [ Prim (_, "UNIT", [], []); + Prim (_, "FAILWITH", [], []) ] ) ] ); + Seq (_, [Prim (_, "RENAME", [], annot)]) ], + [] ) ] ) -> Some (Prim (loc, "ASSERT_RIGHT", [], annot)) - | _ -> None - + | _ -> + None let unexpand_if_some = function - | Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], annot) ]) -> - Some (Prim (loc, "IF_SOME", [ right ; left ], annot)) - | _ -> None + | Seq (loc, [Prim (_, "IF_NONE", [left; right], annot)]) -> + Some (Prim (loc, "IF_SOME", [right; left], annot)) + | _ -> + None let unexpand_if_right = function - | Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], annot) ]) -> - Some (Prim (loc, "IF_RIGHT", [ right ; left ], annot)) - | _ -> None + | Seq (loc, [Prim (_, "IF_LEFT", [left; right], annot)]) -> + Some (Prim (loc, "IF_RIGHT", [right; left], annot)) + | _ -> + None let unexpand_fail = function - | Seq (loc, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ; - ]) -> + | Seq (loc, [Prim (_, "UNIT", [], []); Prim (_, "FAILWITH", [], [])]) -> Some (Prim (loc, "FAIL", [], [])) - | _ -> None + | _ -> + None let unexpand original = let try_unexpansions unexpanders = match List.fold_left (fun acc f -> - match acc with - | None -> f original - | Some rewritten -> Some rewritten) - None unexpanders with - | None -> original - | Some rewritten -> rewritten in + match acc with + | None -> + f original + | Some rewritten -> + Some rewritten) + None + unexpanders + with + | None -> + original + | Some rewritten -> + rewritten + in try_unexpansions - [ unexpand_asserts ; - unexpand_caddadr ; - unexpand_set_caddadr ; - unexpand_map_caddadr ; - unexpand_dxiiivp ; - unexpand_pappaiir ; - unexpand_unpappaiir ; - unexpand_duuuuup ; - unexpand_compare ; - unexpand_if_some ; - unexpand_if_right ; + [ unexpand_asserts; + unexpand_caddadr; + unexpand_set_caddadr; + unexpand_map_caddadr; + unexpand_deprecated_dxiiivp; + unexpand_pappaiir; + unexpand_unpappaiir; + unexpand_deprecated_duuuuup; + unexpand_dupn; + unexpand_compare; + unexpand_if_some; + unexpand_if_right; unexpand_fail ] -let rec unexpand_rec expr = - match unexpand expr with +(* + If an argument of Prim is a sequence, we do not want to unexpand + its root in case the source already contains an expanded macro. In + which case unexpansion would remove surrounding braces and generate + ill-formed code. + + For example, DIIP { DIP { DUP }; SWAP } is not unexpandable but + DIIP {{ DIP { DUP }; SWAP }} (note the double braces) is unexpanded + to DIIP { DUUP }. + + unexpand_rec_but_root is the same as unexpand_rec but does not try + to unexpand at root *) + +let rec unexpand_rec expr = unexpand_rec_but_root (unexpand expr) + +and unexpand_rec_but_root = function | Seq (loc, items) -> Seq (loc, List.map unexpand_rec items) | Prim (loc, name, args, annot) -> - Prim (loc, name, List.map unexpand_rec args, annot) - | Int _ | String _ | Bytes _ as atom -> atom + Prim (loc, name, List.map unexpand_rec_but_root args, annot) + | (Int _ | String _ | Bytes _) as atom -> + atom let () = let open Data_encoding in @@ -1134,15 +1507,12 @@ let () = `Permanent ~id:"michelson.macros.unexpected_annotation" ~title:"Unexpected annotation" - ~description:"A macro had an annotation, but no annotation was permitted on this macro." - ~pp:(fun ppf -> - Format.fprintf ppf - "Unexpected annotation on macro %s.") - (obj1 - (req "macro_name" string)) - (function - | Unexpected_macro_annotation str -> Some str - | _ -> None) + ~description: + "A macro had an annotation, but no annotation was permitted on this \ + macro." + ~pp:(fun ppf -> Format.fprintf ppf "Unexpected annotation on macro %s.") + (obj1 (req "macro_name" string)) + (function Unexpected_macro_annotation str -> Some str | _ -> None) (fun s -> Unexpected_macro_annotation s) ; register_error_kind `Permanent @@ -1150,13 +1520,12 @@ let () = ~title:"Macro expects a sequence" ~description:"An macro expects a sequence, but a sequence was not provided" ~pp:(fun ppf name -> - Format.fprintf ppf - "Macro %s expects a sequence, but did not receive one." name) - (obj1 - (req "macro_name" string)) - (function - | Sequence_expected name -> Some name - | _ -> None) + Format.fprintf + ppf + "Macro %s expects a sequence, but did not receive one." + name) + (obj1 (req "macro_name" string)) + (function Sequence_expected name -> Some name | _ -> None) (fun name -> Sequence_expected name) ; register_error_kind `Permanent @@ -1164,13 +1533,16 @@ let () = ~title:"Wrong number of arguments to macro" ~description:"A wrong number of arguments was provided to a macro" ~pp:(fun ppf (name, got, exp) -> - Format.fprintf ppf - "Macro %s expects %d arguments, was given %d." name got exp) + Format.fprintf + ppf + "Macro %s expects %d arguments, was given %d." + name + exp + got) (obj3 (req "macro_name" string) (req "given_number_of_arguments" uint16) (req "expected_number_of_arguments" uint16)) (function - | Invalid_arity (name, got, exp) -> Some (name, got, exp) - | _ -> None) + | Invalid_arity (name, got, exp) -> Some (name, got, exp) | _ -> None) (fun (name, got, exp) -> Invalid_arity (name, got, exp)) diff --git a/vendors/ligo-utils/tezos-utils/michelson-parser/michelson_v1_macros.mli b/vendors/ligo-utils/tezos-utils/michelson-parser/michelson_v1_macros.mli index 4a614cbc0..352a59b00 100644 --- a/vendors/ligo-utils/tezos-utils/michelson-parser/michelson_v1_macros.mli +++ b/vendors/ligo-utils/tezos-utils/michelson-parser/michelson_v1_macros.mli @@ -28,35 +28,59 @@ open Tezos_micheline type 'l node = ('l, string) Micheline.node type error += Unexpected_macro_annotation of string + type error += Sequence_expected of string + type error += Invalid_arity of string * int * int val expand : 'l node -> 'l node tzresult + val expand_rec : 'l node -> 'l node * error list val expand_caddadr : 'l node -> 'l node option tzresult + val expand_set_caddadr : 'l node -> 'l node option tzresult + val expand_map_caddadr : 'l node -> 'l node option tzresult -val expand_dxiiivp : 'l node -> 'l node option tzresult + +val expand_deprecated_dxiiivp : 'l node -> 'l node option tzresult + val expand_pappaiir : 'l node -> 'l node option tzresult -val expand_duuuuup : 'l node -> 'l node option tzresult + +val expand_deprecated_duuuuup : 'l node -> 'l node option tzresult + val expand_compare : 'l node -> 'l node option tzresult + val expand_asserts : 'l node -> 'l node option tzresult + val expand_unpappaiir : 'l node -> 'l node option tzresult + val expand_if_some : 'l node -> 'l node option tzresult + val expand_if_right : 'l node -> 'l node option tzresult val unexpand : 'l node -> 'l node + val unexpand_rec : 'l node -> 'l node val unexpand_caddadr : 'l node -> 'l node option + val unexpand_set_caddadr : 'l node -> 'l node option + val unexpand_map_caddadr : 'l node -> 'l node option -val unexpand_dxiiivp : 'l node -> 'l node option + +val unexpand_deprecated_dxiiivp : 'l node -> 'l node option + val unexpand_pappaiir : 'l node -> 'l node option -val unexpand_duuuuup : 'l node -> 'l node option + +val unexpand_deprecated_duuuuup : 'l node -> 'l node option + val unexpand_compare : 'l node -> 'l node option + val unexpand_asserts : 'l node -> 'l node option + val unexpand_unpappaiir : 'l node -> 'l node option + val unexpand_if_some : 'l node -> 'l node option + val unexpand_if_right : 'l node -> 'l node option From 395b4890ebd6c018136748c45fd4576383aeb583 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 12 Feb 2020 19:00:40 +0100 Subject: [PATCH 2/3] update the `dune.inc` magic trick --- .../ligo-utils/tezos-protocol-alpha/dune.inc | 46 +++++++++---------- ...tezos-embedded-protocol-006-PsCARTHA.opam} | 6 +-- ....opam => tezos-protocol-006-PsCARTHA.opam} | 4 +- 3 files changed, 28 insertions(+), 28 deletions(-) rename vendors/ligo-utils/tezos-protocol-alpha/{tezos-embedded-protocol-005-PsBabyM1.opam => tezos-embedded-protocol-006-PsCARTHA.opam} (89%) rename vendors/ligo-utils/tezos-protocol-alpha/{tezos-protocol-005-PsBabyM1.opam => tezos-protocol-006-PsCARTHA.opam} (92%) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/dune.inc b/vendors/ligo-utils/tezos-protocol-alpha/dune.inc index cf411a5e3..1d0ec5fae 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/dune.inc +++ b/vendors/ligo-utils/tezos-protocol-alpha/dune.inc @@ -11,7 +11,7 @@ (targets environment.ml) (action (write-file %{targets} - "module Name = struct let name = \"005-PsBabyM1\" end + "module Name = struct let name = \"006-PsCARTHA\" end include Tezos_protocol_environment.MakeV1(Name)() module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end "))) @@ -22,7 +22,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end (:src_dir TEZOS_PROTOCOL)) (action (with-stdout-to %{targets} - (chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "005_PsBabyM1"))))) + (chdir %{workspace_root} (run %{bin:tezos-embedded-protocol-packer} "%{src_dir}" "006_PsCARTHA"))))) (rule (targets functor.ml) @@ -37,67 +37,67 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end (deps misc.mli misc.ml storage_description.mli storage_description.ml state_hash.ml nonce_hash.ml script_expr_hash.ml contract_hash.ml blinded_public_key_hash.mli blinded_public_key_hash.ml qty_repr.ml tez_repr.mli tez_repr.ml period_repr.mli period_repr.ml time_repr.mli time_repr.ml constants_repr.ml fitness_repr.ml raw_level_repr.mli raw_level_repr.ml voting_period_repr.mli voting_period_repr.ml cycle_repr.mli cycle_repr.ml level_repr.mli level_repr.ml seed_repr.mli seed_repr.ml gas_limit_repr.mli gas_limit_repr.ml script_int_repr.mli script_int_repr.ml script_timestamp_repr.mli script_timestamp_repr.ml michelson_v1_primitives.mli michelson_v1_primitives.ml script_repr.mli script_repr.ml legacy_script_support_repr.mli legacy_script_support_repr.ml contract_repr.mli contract_repr.ml roll_repr.mli roll_repr.ml vote_repr.mli vote_repr.ml block_header_repr.mli block_header_repr.ml operation_repr.mli operation_repr.ml manager_repr.mli manager_repr.ml commitment_repr.mli commitment_repr.ml parameters_repr.mli parameters_repr.ml raw_context.mli raw_context.ml storage_sigs.ml storage_functors.mli storage_functors.ml storage.mli storage.ml constants_storage.ml level_storage.mli level_storage.ml nonce_storage.mli nonce_storage.ml seed_storage.mli seed_storage.ml roll_storage.mli roll_storage.ml delegate_storage.mli delegate_storage.ml contract_storage.mli contract_storage.ml bootstrap_storage.mli bootstrap_storage.ml fitness_storage.ml vote_storage.mli vote_storage.ml commitment_storage.mli commitment_storage.ml init_storage.ml fees_storage.mli fees_storage.ml alpha_context.mli alpha_context.ml script_typed_ir.ml script_tc_errors.ml michelson_v1_gas.mli michelson_v1_gas.ml script_ir_annot.mli script_ir_annot.ml script_ir_translator.mli script_ir_translator.ml script_tc_errors_registration.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml amendment.mli amendment.ml apply_results.mli apply_results.ml apply.ml services_registration.ml constants_services.mli constants_services.ml contract_services.mli contract_services.ml delegate_services.mli delegate_services.ml helpers_services.mli helpers_services.ml voting_services.mli voting_services.ml alpha_services.mli alpha_services.ml main.mli main.ml) (action (write-file %{targets} - "module Environment = Tezos_protocol_environment_005_PsBabyM1.Environment -let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS\" + "module Environment = Tezos_protocol_environment_006_PsCARTHA.Environment +let hash = Tezos_crypto.Protocol_hash.of_b58check_exn \"PsCARTHAGazKbHtnKfLzQg3kms52kSRpgnDY982a9oYsSXRLQEb\" let name = Environment.Name.name -include Tezos_raw_protocol_005_PsBabyM1 -include Tezos_raw_protocol_005_PsBabyM1.Main +include Tezos_raw_protocol_006_PsCARTHA +include Tezos_raw_protocol_006_PsCARTHA.Main "))) (library - (name tezos_protocol_environment_005_PsBabyM1) - (public_name tezos-protocol-005-PsBabyM1.environment) + (name tezos_protocol_environment_006_PsCARTHA) + (public_name tezos-protocol-006-PsCARTHA.environment) (library_flags (:standard -linkall)) (libraries tezos-protocol-environment) (modules Environment)) (library - (name tezos_raw_protocol_005_PsBabyM1) - (public_name tezos-protocol-005-PsBabyM1.raw) - (libraries tezos_protocol_environment_005_PsBabyM1) + (name tezos_raw_protocol_006_PsCARTHA) + (public_name tezos-protocol-006-PsCARTHA.raw) + (libraries tezos_protocol_environment_006_PsCARTHA) (library_flags (:standard -linkall)) (flags (:standard -nopervasives -nostdlib -w +a-4-6-7-9-29-32-40..42-44-45-48 -warn-error -a+8 - -open Tezos_protocol_environment_005_PsBabyM1__Environment + -open Tezos_protocol_environment_006_PsCARTHA__Environment -open Pervasives -open Error_monad)) (modules Misc Storage_description State_hash Nonce_hash Script_expr_hash Contract_hash Blinded_public_key_hash Qty_repr Tez_repr Period_repr Time_repr Constants_repr Fitness_repr Raw_level_repr Voting_period_repr Cycle_repr Level_repr Seed_repr Gas_limit_repr Script_int_repr Script_timestamp_repr Michelson_v1_primitives Script_repr Legacy_script_support_repr Contract_repr Roll_repr Vote_repr Block_header_repr Operation_repr Manager_repr Commitment_repr Parameters_repr Raw_context Storage_sigs Storage_functors Storage Constants_storage Level_storage Nonce_storage Seed_storage Roll_storage Delegate_storage Contract_storage Bootstrap_storage Fitness_storage Vote_storage Commitment_storage Init_storage Fees_storage Alpha_context Script_typed_ir Script_tc_errors Michelson_v1_gas Script_ir_annot Script_ir_translator Script_tc_errors_registration Script_interpreter Baking Amendment Apply_results Apply Services_registration Constants_services Contract_services Delegate_services Helpers_services Voting_services Alpha_services Main)) (install (section lib) - (package tezos-protocol-005-PsBabyM1) + (package tezos-protocol-006-PsCARTHA) (files (TEZOS_PROTOCOL as raw/TEZOS_PROTOCOL))) (library - (name tezos_protocol_005_PsBabyM1) - (public_name tezos-protocol-005-PsBabyM1) + (name tezos_protocol_006_PsCARTHA) + (public_name tezos-protocol-006-PsCARTHA) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_005_PsBabyM1) + tezos_raw_protocol_006_PsCARTHA) (flags -w "+a-4-6-7-9-29-40..42-44-45-48" -warn-error "-a+8" -nopervasives) (modules Protocol)) (library - (name tezos_protocol_005_PsBabyM1_functor) - (public_name tezos-protocol-005-PsBabyM1.functor) + (name tezos_protocol_006_PsCARTHA_functor) + (public_name tezos-protocol-006-PsCARTHA.functor) (libraries tezos-protocol-environment tezos-protocol-environment-sigs - tezos_raw_protocol_005_PsBabyM1) + tezos_raw_protocol_006_PsCARTHA) (flags -w "+a-4-6-7-9-29-40..42-44-45-48" -warn-error "-a+8" -nopervasives) (modules Functor)) (library - (name tezos_embedded_protocol_005_PsBabyM1) - (public_name tezos-embedded-protocol-005-PsBabyM1) + (name tezos_embedded_protocol_006_PsCARTHA) + (public_name tezos-embedded-protocol-006-PsCARTHA) (library_flags (:standard -linkall)) - (libraries tezos-protocol-005-PsBabyM1 + (libraries tezos-protocol-006-PsCARTHA tezos-protocol-updater tezos-protocol-environment) (flags (:standard -w +a-4-6-7-9-29-32-40..42-44-45-48 @@ -106,4 +106,4 @@ include Tezos_raw_protocol_005_PsBabyM1.Main (alias (name runtest_sandbox) - (deps .tezos_protocol_005_PsBabyM1.objs/native/tezos_protocol_005_PsBabyM1.cmx)) + (deps .tezos_protocol_006_PsCARTHA.objs/native/tezos_protocol_006_PsCARTHA.cmx)) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-005-PsBabyM1.opam b/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-006-PsCARTHA.opam similarity index 89% rename from vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-005-PsBabyM1.opam rename to vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-006-PsCARTHA.opam index d1468da55..02c8d046d 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-005-PsBabyM1.opam +++ b/vendors/ligo-utils/tezos-protocol-alpha/tezos-embedded-protocol-006-PsCARTHA.opam @@ -8,9 +8,9 @@ license: "MIT" depends: [ "tezos-tooling" { with-test } "ocamlfind" { build } - "dune" { build & >= "1.7" } + "dune" { >= "1.7" } "tezos-base" - "tezos-protocol-005-PsBabyM1" + "tezos-protocol-006-PsCARTHA" "tezos-protocol-compiler" "tezos-protocol-updater" ] @@ -19,7 +19,7 @@ build: [ "%{tezos-protocol-compiler:lib}%/replace" "%{tezos-protocol-compiler:lib}%/dune_protocol.template" "dune" - "005_PsBabyM1" + "006_PsCARTHA" ] ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} diff --git a/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-005-PsBabyM1.opam b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-006-PsCARTHA.opam similarity index 92% rename from vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-005-PsBabyM1.opam rename to vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-006-PsCARTHA.opam index d1497019b..08f2c0c57 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-005-PsBabyM1.opam +++ b/vendors/ligo-utils/tezos-protocol-alpha/tezos-protocol-006-PsCARTHA.opam @@ -8,7 +8,7 @@ license: "MIT" depends: [ "tezos-tooling" { with-test } "ocamlfind" { build } - "dune" { build & >= "1.7" } + "dune" { >= "1.7" } "tezos-base" "tezos-protocol-compiler" ] @@ -17,7 +17,7 @@ build: [ "%{tezos-protocol-compiler:lib}%/replace" "%{tezos-protocol-compiler:lib}%/dune_protocol.template" "dune" - "005_PsBabyM1" + "006_PsCARTHA" ] ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} From e63f2407c2ff4301ed54f07851f4fd9de6848784 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 13 Feb 2020 14:09:45 +0100 Subject: [PATCH 3/3] carthage update: * update dune & opam files * update modules in source --- src/main/run/of_michelson.ml | 4 ++-- vendors/ligo-utils/memory-proto-alpha/dune | 2 +- .../memory-proto-alpha/memory_proto_alpha.ml | 4 ++-- .../memory-proto-alpha/tezos-memory-proto-alpha.opam | 2 +- vendors/ligo-utils/proto-alpha-utils/dune | 4 ++-- .../ligo-utils/proto-alpha-utils/init_proto_alpha.ml | 2 +- .../proto-alpha-utils/proto-alpha-utils.opam | 2 +- .../ligo-utils/tezos-protocol-alpha-parameters/dune | 12 ++++++------ .../tezos-protocol-alpha-parameters/dune-project | 2 +- ...m => tezos-protocol-006-PsCARTHA-parameters.opam} | 7 ++++--- .../ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL | 2 +- vendors/ligo-utils/tezos-protocol-alpha/dune-project | 2 +- 12 files changed, 23 insertions(+), 22 deletions(-) rename vendors/ligo-utils/tezos-protocol-alpha-parameters/{tezos-protocol-005-PsBabyM1-parameters.opam => tezos-protocol-006-PsCARTHA-parameters.opam} (73%) diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index b8222d44c..4a9b7e1c3 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -97,7 +97,7 @@ let fetch_lambda_types (contract_ty:ex_ty) = | _ -> simple_fail "failed to fetch lambda types" let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) : run_res result = - let open! Tezos_raw_protocol_005_PsBabyM1 in + let open! Tezos_raw_protocol_006_PsCARTHA in let%bind (Ex_ty input_ty, Ex_ty output_ty) = fetch_lambda_types exp_type in let%bind input = Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ @@ -127,7 +127,7 @@ let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Mi | _ -> fail @@ Errors.unknown_failwith_type () ) let run_expression ?options (exp:Michelson.t) (exp_type:ex_ty) : run_res result = - let open! Tezos_raw_protocol_005_PsBabyM1 in + let open! Tezos_raw_protocol_006_PsCARTHA in let (Ex_ty exp_type') = exp_type in let exp = Michelson.strip_annots exp in let top_level = Script_ir_translator.Lambda diff --git a/vendors/ligo-utils/memory-proto-alpha/dune b/vendors/ligo-utils/memory-proto-alpha/dune index 0df6b91ad..207473d50 100644 --- a/vendors/ligo-utils/memory-proto-alpha/dune +++ b/vendors/ligo-utils/memory-proto-alpha/dune @@ -3,6 +3,6 @@ (public_name tezos-memory-proto-alpha) (libraries tezos-protocol-environment - tezos-protocol-005-PsBabyM1 + tezos-protocol-006-PsCARTHA ) ) diff --git a/vendors/ligo-utils/memory-proto-alpha/memory_proto_alpha.ml b/vendors/ligo-utils/memory-proto-alpha/memory_proto_alpha.ml index 2e07e7109..5e2bc88e2 100644 --- a/vendors/ligo-utils/memory-proto-alpha/memory_proto_alpha.ml +++ b/vendors/ligo-utils/memory-proto-alpha/memory_proto_alpha.ml @@ -1,9 +1,9 @@ module Name = struct let name = "alpha" end -module Alpha_environment = Tezos_protocol_005_PsBabyM1.Protocol.Environment +module Alpha_environment = Tezos_protocol_006_PsCARTHA.Protocol.Environment type alpha_error = Alpha_environment.Error_monad.error type 'a alpha_tzresult = 'a Alpha_environment.Error_monad.tzresult module Alpha_error_monad = Alpha_environment.Error_monad -module Proto = Tezos_protocol_005_PsBabyM1 +module Proto = Tezos_protocol_006_PsCARTHA include Proto diff --git a/vendors/ligo-utils/memory-proto-alpha/tezos-memory-proto-alpha.opam b/vendors/ligo-utils/memory-proto-alpha/tezos-memory-proto-alpha.opam index 1ec466604..e6ca037cc 100644 --- a/vendors/ligo-utils/memory-proto-alpha/tezos-memory-proto-alpha.opam +++ b/vendors/ligo-utils/memory-proto-alpha/tezos-memory-proto-alpha.opam @@ -10,7 +10,7 @@ bug-reports: "https://gitlab.com/ligolang/tezos/issues" depends: [ "dune" "tezos-protocol-environment" - "tezos-protocol-005-PsBabyM1" + "tezos-protocol-006-PsCARTHA" ] build: [ ["dune" "build" "-p" name] diff --git a/vendors/ligo-utils/proto-alpha-utils/dune b/vendors/ligo-utils/proto-alpha-utils/dune index 3f8f6b3a1..df6b9a511 100644 --- a/vendors/ligo-utils/proto-alpha-utils/dune +++ b/vendors/ligo-utils/proto-alpha-utils/dune @@ -4,10 +4,10 @@ (libraries tezos-error-monad tezos-stdlib-unix - tezos-protocol-005-PsBabyM1-parameters + tezos-protocol-006-PsCARTHA-parameters tezos-memory-proto-alpha simple-utils tezos-utils ) - (flags (:standard -open Simple_utils )) + (flags (:standard -open Simple_utils)) ) diff --git a/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml index 8239c6c21..1e0a04566 100644 --- a/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml +++ b/vendors/ligo-utils/proto-alpha-utils/init_proto_alpha.ml @@ -105,7 +105,7 @@ module Context_init = struct Pervasives.failwith "Must have one account with a roll to bake"; (* Check there is at least one roll *) - let constants : Constants_repr.parametric = Tezos_protocol_005_PsBabyM1_parameters.Default_parameters.constants_test in + let constants : Constants_repr.parametric = Tezos_protocol_006_PsCARTHA_parameters.Default_parameters.constants_test in check_constants_consistency constants >>=? fun () -> let hash = diff --git a/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam b/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam index e0cf3abfd..d7c1638b6 100644 --- a/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam +++ b/vendors/ligo-utils/proto-alpha-utils/proto-alpha-utils.opam @@ -41,7 +41,7 @@ depends: [ "tezos-data-encoding" "tezos-protocol-environment" "tezos-protocol-alpha" - "tezos-protocol-005-PsBabyM1-parameters" + "tezos-protocol-006-PsCARTHA" "michelson-parser" "simple-utils" "tezos-utils" diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune index efccb5e51..2db13dc83 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune @@ -1,22 +1,22 @@ (library - (name tezos_protocol_005_PsBabyM1_parameters) - (public_name tezos-protocol-005-PsBabyM1-parameters) + (name tezos_protocol_006_PsCARTHA_parameters) + (public_name tezos-protocol-006-PsCARTHA-parameters) (modules :standard \ gen) (libraries tezos-base tezos-protocol-environment - tezos-protocol-005-PsBabyM1) + tezos-protocol-006-PsCARTHA) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_005_PsBabyM1 + -open Tezos_protocol_006_PsCARTHA -linkall)) ) (executable (name gen) (libraries tezos-base - tezos-protocol-005-PsBabyM1-parameters) + tezos-protocol-006-PsCARTHA-parameters) (modules gen) (flags (:standard -open Tezos_base__TzPervasives - -open Tezos_protocol_005_PsBabyM1_parameters + -open Tezos_protocol_006_PsCARTHA_parameters -linkall))) (rule diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project index 6910ef322..6e6688d7b 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project @@ -1,2 +1,2 @@ (lang dune 1.11) -(name tezos-protocol-005-PsBabyM1-parameters) +(name tezos-protocol-006-PsCARTHA-parameters) diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-005-PsBabyM1-parameters.opam b/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-006-PsCARTHA-parameters.opam similarity index 73% rename from vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-005-PsBabyM1-parameters.opam rename to vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-006-PsCARTHA-parameters.opam index 839f7ca54..af4e5f7e0 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-005-PsBabyM1-parameters.opam +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/tezos-protocol-006-PsCARTHA-parameters.opam @@ -8,12 +8,13 @@ license: "MIT" depends: [ "tezos-tooling" { with-test } "ocamlfind" { build } - "dune" { build & >= "1.7" } + "dune" { >= "1.7" } "tezos-base" "tezos-protocol-environment" - "tezos-protocol-005-PsBabyM1" + "tezos-protocol-006-PsCARTHA" ] build: [ - [ "dune" "build" "-p" name "-j" jobs ] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] synopsis: "Tezos/Protocol: parameters" diff --git a/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL b/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL index 92c00fb26..3154380de 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL +++ b/vendors/ligo-utils/tezos-protocol-alpha/TEZOS_PROTOCOL @@ -1,5 +1,5 @@ { - "hash": "PsBabyM1eUXZseaJdmXFApDSBqj8YBfwELoxZHHW77EMcAbbwAS", + "hash": "PsCARTHAGazKbHtnKfLzQg3kms52kSRpgnDY982a9oYsSXRLQEb", "modules": [ "Misc", "Storage_description", diff --git a/vendors/ligo-utils/tezos-protocol-alpha/dune-project b/vendors/ligo-utils/tezos-protocol-alpha/dune-project index d4d600dc7..d011e9a22 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/dune-project +++ b/vendors/ligo-utils/tezos-protocol-alpha/dune-project @@ -1,2 +1,2 @@ (lang dune 1.11) -(name tezos-embedded-protocol-005-PsBabyM1) +(name tezos-embedded-protocol-006-PsCARTHA)