diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index 35a7f995569604e1319642304140a915bd6e4367..d5c14feba74c46e9df9e314bd6beec77305c6f54 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -45,27 +45,29 @@ module type S = sig module Result_syntax : sig include module type of TzLwtreslib.Monad.Result_syntax - (* NOTE: the [tzfail] functions is over-specialised. It could have the more - general type ['e -> ('a, 'e trace) result]. In practice no part of the - code uses that generalisation. In the future, it might be worth - generalising if we start using traces to carry other things than just - [error]. The same remark applies to the other [val] below and to the - [Lwt_result_syntax] [val]s too. *) - (** [tzfail e] is for failing into the [tzresult] type. It wraps the given error in a trace. This is meant as syntactic sugar for a very common pattern that is otherwise written [fail (TzTrace.make e)]. *) - val tzfail : error -> 'a tzresult + val tzfail : 'error -> ('a, 'error trace) result - val ( and* ) : 'a tzresult -> 'b tzresult -> ('a * 'b) tzresult + val ( and* ) : + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result - val ( and+ ) : 'a tzresult -> 'b tzresult -> ('a * 'b) tzresult + val ( and+ ) : + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result - val tzjoin : unit tzresult list -> unit tzresult + val tzjoin : (unit, 'error trace) result list -> (unit, 'error trace) result - val tzall : 'a tzresult list -> 'a list tzresult + val tzall : ('a, 'error trace) result list -> ('a list, 'error trace) result - val tzboth : 'a tzresult -> 'b tzresult -> ('a * 'b) tzresult + val tzboth : + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result end (** You can find a lot of information about the [Lwt_result_syntax] module in the @@ -77,20 +79,30 @@ module type S = sig (** [tzfail e] is for failing into the [tzresult Lwt.t] type. It wraps the given error in a trace. This is meant as syntactic sugar for a very common pattern that is otherwise written [fail (TzTrace.make e)]. *) - val tzfail : error -> 'a tzresult Lwt.t + val tzfail : 'error -> ('a, 'error trace) result Lwt.t val ( and* ) : - 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t val ( and+ ) : - 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t - val tzjoin : unit tzresult Lwt.t list -> unit tzresult Lwt.t + val tzjoin : + (unit, 'error trace) result Lwt.t list -> + (unit, 'error trace) result Lwt.t - val tzall : 'a tzresult Lwt.t list -> 'a list tzresult Lwt.t + val tzall : + ('a, 'error trace) result Lwt.t list -> + ('a list, 'error trace) result Lwt.t val tzboth : - 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t end val classify_trace : tztrace -> Error_classification.t diff --git a/src/lib_error_monad/monad_maker.mli b/src/lib_error_monad/monad_maker.mli index 099ebfe89db9750c6b525875f7eb2fc65ad49951..26c29e9428edb41ae27868d996c1e6c5506962c4 100644 --- a/src/lib_error_monad/monad_maker.mli +++ b/src/lib_error_monad/monad_maker.mli @@ -44,36 +44,55 @@ module type S = sig module Result_syntax : sig include module type of TzLwtreslib.Monad.Result_syntax - val tzfail : error -> 'a tzresult + val tzfail : 'error -> ('a, 'error trace) result - val ( and* ) : 'a tzresult -> 'b tzresult -> ('a * 'b) tzresult + val ( and* ) : + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result - val ( and+ ) : 'a tzresult -> 'b tzresult -> ('a * 'b) tzresult + val ( and+ ) : + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result - val tzjoin : unit tzresult list -> unit tzresult + val tzjoin : (unit, 'error trace) result list -> (unit, 'error trace) result - val tzall : 'a tzresult list -> 'a list tzresult + val tzall : ('a, 'error trace) result list -> ('a list, 'error trace) result - val tzboth : 'a tzresult -> 'b tzresult -> ('a * 'b) tzresult + val tzboth : + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result end module Lwt_result_syntax : sig include module type of TzLwtreslib.Monad.Lwt_result_syntax - val tzfail : error -> 'a tzresult Lwt.t + val tzfail : 'error -> ('a, 'error trace) result Lwt.t val ( and* ) : - 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t val ( and+ ) : - 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t - val tzjoin : unit tzresult Lwt.t list -> unit tzresult Lwt.t + val tzjoin : + (unit, 'error trace) result Lwt.t list -> + (unit, 'error trace) result Lwt.t - val tzall : 'a tzresult Lwt.t list -> 'a list tzresult Lwt.t + val tzall : + ('a, 'error trace) result Lwt.t list -> + ('a list, 'error trace) result Lwt.t val tzboth : - 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t end val classify_trace : tztrace -> Error_classification.t diff --git a/src/lib_protocol_environment/environment_V8.ml b/src/lib_protocol_environment/environment_V8.ml index 608df862270c2cffe5f151f1104037619524b36f..dd193618d4f4d7451439b2582655edbbf1b490e9 100644 --- a/src/lib_protocol_environment/environment_V8.ml +++ b/src/lib_protocol_environment/environment_V8.ml @@ -626,8 +626,6 @@ struct include Error_core include Tezos_error_monad.TzLwtreslib.Monad - module Tzresult_syntax = Traced_result_syntax - module Lwt_tzresult_syntax = Lwt_traced_result_syntax include Tezos_error_monad.Monad_maker.Make (Error_core) (TzTrace) (Tezos_error_monad.TzLwtreslib.Monad) diff --git a/src/lib_protocol_environment/sigs/v8.ml b/src/lib_protocol_environment/sigs/v8.ml index e494e59c5432fcebbbb9a35de1d115e3860621f7..bb973385e1d763c6eea65331cb66eb77dbcf0dcc 100644 --- a/src/lib_protocol_environment/sigs/v8.ml +++ b/src/lib_protocol_environment/sigs/v8.ml @@ -5852,6 +5852,23 @@ module Result_syntax : sig val all : ('a, 'e) result list -> ('a list, 'e list) result val both : ('a, 'e) result -> ('b, 'e) result -> ('a * 'b, 'e list) result + + val tzfail : 'error -> ('a, 'error trace) result + + val ( and* ) : + ('a, 'e trace) result -> ('b, 'e trace) result -> ('a * 'b, 'e trace) result + + val ( and+ ) : + ('a, 'e trace) result -> ('b, 'e trace) result -> ('a * 'b, 'e trace) result + + val tzjoin : (unit, 'error trace) result list -> (unit, 'error trace) result + + val tzall : ('a, 'error trace) result list -> ('a list, 'error trace) result + + val tzboth : + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result end module Lwt_result_syntax : sig @@ -5894,6 +5911,29 @@ module Lwt_result_syntax : sig ('a, 'e) result Lwt.t -> ('b, 'e) result Lwt.t -> ('a * 'b, 'e list) result Lwt.t + + val tzfail : 'error -> ('a, 'error trace) result Lwt.t + + val ( and* ) : + ('a, 'e trace) result Lwt.t -> + ('b, 'e trace) result Lwt.t -> + ('a * 'b, 'e trace) result Lwt.t + + val ( and+ ) : + ('a, 'e trace) result Lwt.t -> + ('b, 'e trace) result Lwt.t -> + ('a * 'b, 'e trace) result Lwt.t + + val tzjoin : + (unit, 'error trace) result Lwt.t list -> (unit, 'error trace) result Lwt.t + + val tzall : + ('a, 'error trace) result Lwt.t list -> ('a list, 'error trace) result Lwt.t + + val tzboth : + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t end module Lwt_option_syntax : sig @@ -5923,94 +5963,6 @@ module Lwt_option_syntax : sig val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t end - -module Tzresult_syntax : sig - val return : 'a -> ('a, 'error) result - - val return_unit : (unit, 'error) result - - val return_none : ('a option, 'error) result - - val return_some : 'a -> ('a option, 'error) result - - val return_nil : ('a list, 'error) result - - val return_true : (bool, 'error) result - - val return_false : (bool, 'error) result - - val fail : 'error -> ('a, 'error trace) result - - val ( let* ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result - - val ( and* ) : - ('a, 'e trace) result -> ('b, 'e trace) result -> ('a * 'b, 'e trace) result - - val ( let+ ) : ('a, 'e) result -> ('a -> 'b) -> ('b, 'e) result - - val ( and+ ) : - ('a, 'e trace) result -> ('b, 'e trace) result -> ('a * 'b, 'e trace) result - - val join : (unit, 'error trace) result list -> (unit, 'error trace) result - - val all : ('a, 'error trace) result list -> ('a list, 'error trace) result - - val both : - ('a, 'error trace) result -> - ('b, 'error trace) result -> - ('a * 'b, 'error trace) result -end - -module Lwt_tzresult_syntax : sig - val return : 'a -> ('a, 'error) result Lwt.t - - val return_unit : (unit, 'error) result Lwt.t - - val return_none : ('a option, 'error) result Lwt.t - - val return_some : 'a -> ('a option, 'error) result Lwt.t - - val return_nil : ('a list, 'error) result Lwt.t - - val return_true : (bool, 'error) result Lwt.t - - val return_false : (bool, 'error) result Lwt.t - - val fail : 'error -> ('a, 'error trace) result Lwt.t - - val ( let* ) : - ('a, 'e) result Lwt.t -> - ('a -> ('b, 'e) result Lwt.t) -> - ('b, 'e) result Lwt.t - - val ( and* ) : - ('a, 'e trace) result Lwt.t -> - ('b, 'e trace) result Lwt.t -> - ('a * 'b, 'e trace) result Lwt.t - - val ( let+ ) : ('a, 'e) result Lwt.t -> ('a -> 'b) -> ('b, 'e) result Lwt.t - - val ( and+ ) : - ('a, 'e trace) result Lwt.t -> - ('b, 'e trace) result Lwt.t -> - ('a * 'b, 'e trace) result Lwt.t - - val ( let*! ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t - - val ( let*? ) : - ('a, 'e) result -> ('a -> ('b, 'e) result Lwt.t) -> ('b, 'e) result Lwt.t - - val join : - (unit, 'error trace) result Lwt.t list -> (unit, 'error trace) result Lwt.t - - val all : - ('a, 'error trace) result Lwt.t list -> ('a list, 'error trace) result Lwt.t - - val both : - ('a, 'error trace) result Lwt.t -> - ('b, 'error trace) result Lwt.t -> - ('a * 'b, 'error trace) result Lwt.t -end end # 50 "v8.in.ml" diff --git a/src/lib_protocol_environment/sigs/v8/error_monad.mli b/src/lib_protocol_environment/sigs/v8/error_monad.mli index 4e6be497c44de466af4d33a3becafa4c846e5ff7..79a35861114ee051106807be18f4fbee49134497 100644 --- a/src/lib_protocol_environment/sigs/v8/error_monad.mli +++ b/src/lib_protocol_environment/sigs/v8/error_monad.mli @@ -315,6 +315,23 @@ module Result_syntax : sig val all : ('a, 'e) result list -> ('a list, 'e list) result val both : ('a, 'e) result -> ('b, 'e) result -> ('a * 'b, 'e list) result + + val tzfail : 'error -> ('a, 'error trace) result + + val ( and* ) : + ('a, 'e trace) result -> ('b, 'e trace) result -> ('a * 'b, 'e trace) result + + val ( and+ ) : + ('a, 'e trace) result -> ('b, 'e trace) result -> ('a * 'b, 'e trace) result + + val tzjoin : (unit, 'error trace) result list -> (unit, 'error trace) result + + val tzall : ('a, 'error trace) result list -> ('a list, 'error trace) result + + val tzboth : + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result end module Lwt_result_syntax : sig @@ -357,6 +374,29 @@ module Lwt_result_syntax : sig ('a, 'e) result Lwt.t -> ('b, 'e) result Lwt.t -> ('a * 'b, 'e list) result Lwt.t + + val tzfail : 'error -> ('a, 'error trace) result Lwt.t + + val ( and* ) : + ('a, 'e trace) result Lwt.t -> + ('b, 'e trace) result Lwt.t -> + ('a * 'b, 'e trace) result Lwt.t + + val ( and+ ) : + ('a, 'e trace) result Lwt.t -> + ('b, 'e trace) result Lwt.t -> + ('a * 'b, 'e trace) result Lwt.t + + val tzjoin : + (unit, 'error trace) result Lwt.t list -> (unit, 'error trace) result Lwt.t + + val tzall : + ('a, 'error trace) result Lwt.t list -> ('a list, 'error trace) result Lwt.t + + val tzboth : + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t end module Lwt_option_syntax : sig @@ -386,91 +426,3 @@ module Lwt_option_syntax : sig val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t end - -module Tzresult_syntax : sig - val return : 'a -> ('a, 'error) result - - val return_unit : (unit, 'error) result - - val return_none : ('a option, 'error) result - - val return_some : 'a -> ('a option, 'error) result - - val return_nil : ('a list, 'error) result - - val return_true : (bool, 'error) result - - val return_false : (bool, 'error) result - - val fail : 'error -> ('a, 'error trace) result - - val ( let* ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result - - val ( and* ) : - ('a, 'e trace) result -> ('b, 'e trace) result -> ('a * 'b, 'e trace) result - - val ( let+ ) : ('a, 'e) result -> ('a -> 'b) -> ('b, 'e) result - - val ( and+ ) : - ('a, 'e trace) result -> ('b, 'e trace) result -> ('a * 'b, 'e trace) result - - val join : (unit, 'error trace) result list -> (unit, 'error trace) result - - val all : ('a, 'error trace) result list -> ('a list, 'error trace) result - - val both : - ('a, 'error trace) result -> - ('b, 'error trace) result -> - ('a * 'b, 'error trace) result -end - -module Lwt_tzresult_syntax : sig - val return : 'a -> ('a, 'error) result Lwt.t - - val return_unit : (unit, 'error) result Lwt.t - - val return_none : ('a option, 'error) result Lwt.t - - val return_some : 'a -> ('a option, 'error) result Lwt.t - - val return_nil : ('a list, 'error) result Lwt.t - - val return_true : (bool, 'error) result Lwt.t - - val return_false : (bool, 'error) result Lwt.t - - val fail : 'error -> ('a, 'error trace) result Lwt.t - - val ( let* ) : - ('a, 'e) result Lwt.t -> - ('a -> ('b, 'e) result Lwt.t) -> - ('b, 'e) result Lwt.t - - val ( and* ) : - ('a, 'e trace) result Lwt.t -> - ('b, 'e trace) result Lwt.t -> - ('a * 'b, 'e trace) result Lwt.t - - val ( let+ ) : ('a, 'e) result Lwt.t -> ('a -> 'b) -> ('b, 'e) result Lwt.t - - val ( and+ ) : - ('a, 'e trace) result Lwt.t -> - ('b, 'e trace) result Lwt.t -> - ('a * 'b, 'e trace) result Lwt.t - - val ( let*! ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t - - val ( let*? ) : - ('a, 'e) result -> ('a -> ('b, 'e) result Lwt.t) -> ('b, 'e) result Lwt.t - - val join : - (unit, 'error trace) result Lwt.t list -> (unit, 'error trace) result Lwt.t - - val all : - ('a, 'error trace) result Lwt.t list -> ('a list, 'error trace) result Lwt.t - - val both : - ('a, 'error trace) result Lwt.t -> - ('b, 'error trace) result Lwt.t -> - ('a * 'b, 'error trace) result Lwt.t -end diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 0c5436e925d8168777340936223dd045b35dbca2..0d0fcc03e8e482e32b7b170552c540ebced2a5b9 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -2157,7 +2157,7 @@ module Sc_rollup = struct let register_boot_sector () = Registration.register1 ~chunked:true S.boot_sector @@ fun ctxt address () () -> - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let+ _ctxt, boot_sector = Alpha_context.Sc_rollup.get_boot_sector ctxt address in @@ -2168,7 +2168,7 @@ module Sc_rollup = struct ~chunked:false S.last_cemented_commitment_hash_with_level @@ fun ctxt address () () -> - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let+ last_cemented_commitment, level, _ctxt = Alpha_context.Sc_rollup.Commitment .last_cemented_commitment_hash_with_level @@ -2180,7 +2180,7 @@ module Sc_rollup = struct let register_staked_on_commitment () = Registration.register2 ~chunked:false S.staked_on_commitment @@ fun ctxt address staker () () -> - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let+ branch, _ctxt = Alpha_context.Sc_rollup.Stake_storage.find_staker ctxt address staker in @@ -2207,7 +2207,7 @@ module Sc_rollup = struct ~chunked:false S.ongoing_refutation_game (fun context rollup staker () -> - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let open Sc_rollup.Game.Index in let open Sc_rollup.Refutation_storage in let* game, _ = get_ongoing_game_for_staker context rollup staker in @@ -2231,7 +2231,7 @@ module Sc_rollup = struct ~chunked:false S.timeout (fun context rollup (staker1, staker2) () -> - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let index = Sc_rollup.Game.Index.make staker1 staker2 in let*! res = Sc_rollup.Refutation_storage.get_timeout context rollup index @@ -2245,7 +2245,7 @@ module Sc_rollup = struct ~chunked:false S.timeout_reached (fun context rollup (staker1, staker2) () -> - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let index = Sc_rollup.Game.Index.make staker1 staker2 in let*! res = Sc_rollup.Refutation_storage.timeout context rollup index in match res with @@ -2257,7 +2257,7 @@ module Sc_rollup = struct ~chunked:false S.can_be_cemented (fun context rollup commitment_hash () -> - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! res = Sc_rollup.Stake_storage.cement_commitment context diff --git a/src/proto_alpha/lib_protocol/amendment.ml b/src/proto_alpha/lib_protocol/amendment.ml index b295020014ee5caf511944104053f45589a02609..6fd95d922bf52916ec11a94220f59a0f8575b415 100644 --- a/src/proto_alpha/lib_protocol/amendment.ml +++ b/src/proto_alpha/lib_protocol/amendment.ml @@ -168,7 +168,7 @@ let is_testnet_dictator ctxt chain_id delegate = applicable. Of course, there must never be such a dictator on mainnet: see {!is_testnet_dictator}. *) let apply_testnet_dictator_proposals ctxt chain_id proposals = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! ctxt = Vote.clear_ballots ctxt in let*! ctxt = Vote.clear_proposals ctxt in let*! ctxt = Vote.clear_current_proposal ctxt in @@ -188,10 +188,10 @@ let apply_testnet_dictator_proposals ctxt chain_id proposals = | _ :: _ :: _ -> (* This case should not be possible if the operation has been previously validated by {!Validate.validate_operation}. *) - fail Validate_errors.Voting.Testnet_dictator_multiple_proposals + tzfail Validate_errors.Voting.Testnet_dictator_multiple_proposals let apply_proposals ctxt chain_id (Proposals {source; period = _; proposals}) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt = if is_testnet_dictator ctxt chain_id source then apply_testnet_dictator_proposals ctxt chain_id proposals @@ -213,7 +213,7 @@ let apply_proposals ctxt chain_id (Proposals {source; period = _; proposals}) = return (ctxt, Apply_results.Single_result Proposals_result) let apply_ballot ctxt (Ballot {source; period = _; proposal = _; ballot}) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt = if dictator_proposal_seen ctxt then (* Noop if dictator voted *) return ctxt else Vote.record_ballot ctxt source ballot diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 4de0c6c9099b5a18b6117f71fb033546dfe69fcb..5c289f7780533cbbfd93583876ab5aa19b054171 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1847,7 +1847,7 @@ let rec mark_skipped : the operation is solvable, i.e. its fees can be taken, i.e. [take_fees] cannot return an error. *) let take_fees ctxt contents_list = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let rec take_fees_rec : type kind. context -> @@ -2012,7 +2012,7 @@ let record_operation (type kind) ctxt hash (operation : kind operation) : let record_preendorsement ctxt (mode : mode) (content : consensus_content) : (context * Kind.preendorsement contents_result_list) tzresult = - let open Tzresult_syntax in + let open Result_syntax in let ctxt = match mode with | Full_construction _ -> ( @@ -2052,7 +2052,7 @@ let is_grandparent_endorsement mode content = let record_endorsement ctxt (mode : mode) (content : consensus_content) : (context * Kind.endorsement contents_result_list) tzresult Lwt.t = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let mk_endorsement_result {Consensus_key.delegate; consensus_pkh} endorsement_power = Single_result @@ -2075,7 +2075,7 @@ let record_endorsement ctxt (mode : mode) (content : consensus_content) : match Slot.Map.find content.slot (Consensus.allowed_endorsements ctxt) with | None -> (* This should not happen: operation validation should have failed. *) - fail Faulty_validation_wrong_slot + tzfail Faulty_validation_wrong_slot | Some (consensus_key, power) -> let*? ctxt = Consensus.record_endorsement ctxt ~initial_slot:content.slot ~power @@ -2098,7 +2098,7 @@ let apply_manager_contents_list ctxt ~payload_producer chain_id let apply_manager_operations ctxt ~payload_producer chain_id ~mempool_mode contents_list = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let ctxt = if mempool_mode then Gas.reset_block_gas ctxt else ctxt in let* ctxt, fees_updated_contents_list = take_fees ctxt contents_list in let*! ctxt, contents_result_list = @@ -2278,7 +2278,7 @@ let apply_contents_list (type kind) ctxt chain_id (mode : mode) contents_list let apply_operation application_state operation_hash operation = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let apply_operation application_state packed_operation ~payload_producer = let {shell; protocol_data = Operation_data unpacked_protocol_data} = packed_operation @@ -2507,7 +2507,7 @@ let record_endorsing_participation ctxt = let begin_application ctxt chain_id ~migration_balance_updates ~migration_operation_results ~(predecessor_fitness : Fitness.raw) (block_header : Block_header.t) : application_state tzresult Lwt.t = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*? fitness = Fitness.from_raw block_header.shell.fitness in let level = block_header.shell.level in let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in @@ -2561,7 +2561,7 @@ let begin_full_construction ctxt chain_id ~migration_balance_updates ~migration_operation_results ~predecessor_timestamp ~predecessor_level ~predecessor_round ~predecessor_hash ~timestamp (block_data_contents : Block_header.contents) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let round_durations = Constants.round_durations ctxt in let*? round = Round.round_of_timestamp @@ -2616,7 +2616,7 @@ let begin_full_construction ctxt chain_id ~migration_balance_updates let begin_partial_construction ctxt chain_id ~migration_balance_updates ~migration_operation_results ~predecessor_level ~(predecessor_fitness : Fitness.raw) : application_state tzresult Lwt.t = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let toggle_vote = Liquidity_baking.LB_pass in let* ctxt, liquidity_baking_operations_results, liquidity_baking_toggle_ema = apply_liquidity_baking_subsidy ctxt ~toggle_vote @@ -2641,7 +2641,7 @@ let finalize_application ctxt block_data_contents ~round ~predecessor_hash ~liquidity_baking_toggle_ema ~implicit_operations_results ~migration_balance_updates ~(block_producer : Consensus_key.t) ~(payload_producer : Consensus_key.t) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let level = Level.current ctxt in let endorsing_power = Consensus.current_endorsement_power ctxt in let* required_endorsements = @@ -2777,7 +2777,7 @@ let finalize_with_commit_message ctxt ~cache_nonce fitness round op_count = return validation_result let finalize_block (application_state : application_state) shell_header_opt = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let { ctxt; liquidity_baking_toggle_ema; diff --git a/src/proto_alpha/lib_protocol/bounded_history_repr.ml b/src/proto_alpha/lib_protocol/bounded_history_repr.ml index 74fbd8fd344b07849453a98290081a8e8cc9028c..d5cf89fea002e022cb33b92f3233792001baa221 100644 --- a/src/proto_alpha/lib_protocol/bounded_history_repr.ml +++ b/src/proto_alpha/lib_protocol/bounded_history_repr.ml @@ -205,7 +205,7 @@ module Make (Name : NAME) (Key : KEY) (Value : VALUE) : Key_bound_to_different_value {key; existing_value; given_value}) let remember key value t = - let open Tzresult_syntax in + let open Result_syntax in if Compare.Int64.(t.capacity <= 0L) then return t else match Map.find key t.events with diff --git a/src/proto_alpha/lib_protocol/contract_storage.ml b/src/proto_alpha/lib_protocol/contract_storage.ml index ee95dfadaf3e38bc8a9e518e7e54d91d0c5a1b1b..ebd98ea2d021b2fc1f56cd6eab7ee1ecaf6c25d2 100644 --- a/src/proto_alpha/lib_protocol/contract_storage.ml +++ b/src/proto_alpha/lib_protocol/contract_storage.ml @@ -572,12 +572,12 @@ let get_balance_carbonated c contract = get_balance c contract >>=? fun balance -> return (c, balance) let check_allocated_and_get_balance c pkh = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* balance_opt = Storage.Contract.Spendable_balance.find c (Contract_repr.Implicit pkh) in match balance_opt with - | None -> fail (Empty_implicit_contract pkh) + | None -> tzfail (Empty_implicit_contract pkh) | Some balance -> return balance let update_script_storage c contract_hash storage lazy_storage_diff = @@ -598,7 +598,7 @@ let spend_from_balance contract balance amount = Tez_repr.(balance -? amount) let check_emptiable c contract = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match contract with | Contract_repr.Originated _ -> return_unit | Implicit pkh -> ( @@ -612,7 +612,7 @@ let check_emptiable c contract = | None -> return_unit) let spend_only_call_from_token c contract amount = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* balance = Storage.Contract.Spendable_balance.find c contract in let balance = Option.value balance ~default:Tez_repr.zero in let*? new_balance = spend_from_balance contract balance amount in @@ -741,7 +741,7 @@ let fold_on_bond_ids ctxt contract = (** Indicate whether the given implicit contract should avoid deletion when it is emptied. *) let should_keep_empty_implicit_contract ctxt contract = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* has_frozen_bonds = has_frozen_bonds ctxt contract in if has_frozen_bonds then return_true else @@ -759,7 +759,7 @@ let should_keep_empty_implicit_contract ctxt contract = return_false let ensure_deallocated_if_empty ctxt contract = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match contract with | Contract_repr.Originated _ -> return ctxt (* Never delete originated contracts *) @@ -780,7 +780,7 @@ let ensure_deallocated_if_empty ctxt contract = if keep_contract then return ctxt else delete ctxt contract) let simulate_spending ctxt ~balance ~amount source = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let contract = Contract_repr.Implicit source in let*? new_balance = spend_from_balance contract balance amount in let* still_allocated = diff --git a/src/proto_alpha/lib_protocol/dal_apply.ml b/src/proto_alpha/lib_protocol/dal_apply.ml index b904b827b03f6c506016e82d6e7e42e7e958cbfc..58b00ce50425f1ca5dfb48ce0fc949b206160d43 100644 --- a/src/proto_alpha/lib_protocol/dal_apply.ml +++ b/src/proto_alpha/lib_protocol/dal_apply.ml @@ -39,14 +39,14 @@ let only_if_dal_feature_enabled ctxt ~default f = if feature_enable then f ctxt else default ctxt let slot_of_int_e n = - let open Tzresult_syntax in + let open Result_syntax in match Dal.Slot_index.of_int n with - | None -> fail Dal_errors.Dal_slot_index_above_hard_limit + | None -> tzfail Dal_errors.Dal_slot_index_above_hard_limit | Some slot_index -> return slot_index let validate_data_availability ctxt op = assert_dal_feature_enabled ctxt >>? fun () -> - let open Tzresult_syntax in + let open Result_syntax in (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4163 check the signature of the endorser as well *) let Dal.Endorsement.{endorser = _; slot_availability; level = given} = op in @@ -84,7 +84,7 @@ let apply_data_availability ctxt op = let validate_publish_slot_header ctxt Dal.Slot.Header.{id = {index; published_level}; _} = assert_dal_feature_enabled ctxt >>? fun () -> - let open Tzresult_syntax in + let open Result_syntax in let open Constants in let Parametric.{dal = {number_of_slots; _}; _} = parametric ctxt in let* number_of_slots = slot_of_int_e (number_of_slots - 1) in @@ -139,7 +139,7 @@ let finalisation ctxt = >|=? fun (ctxt, slot_availability) -> (ctxt, Some slot_availability)) let initialisation ctxt ~level = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in only_if_dal_feature_enabled ctxt ~default:(fun ctxt -> return ctxt) diff --git a/src/proto_alpha/lib_protocol/dal_services.ml b/src/proto_alpha/lib_protocol/dal_services.ml index 65ee5bb1b9b5d432aee104d77dd10e3b465cf564..a914b4e8027f5671e814a88bb90dedc393eb3a6c 100644 --- a/src/proto_alpha/lib_protocol/dal_services.ml +++ b/src/proto_alpha/lib_protocol/dal_services.ml @@ -33,7 +33,7 @@ let assert_dal_feature_enabled ctxt = Dal_errors.Dal_feature_disabled let shards ctxt ~level = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let open Dal.Endorsement in assert_dal_feature_enabled ctxt >>?= fun () -> let level = Level.from_raw ctxt level in diff --git a/src/proto_alpha/lib_protocol/dal_slot_repr.ml b/src/proto_alpha/lib_protocol/dal_slot_repr.ml index 237d0a306183111a8f7d4f3a453e6624a608588b..b3c8609b69afd2ef3439f6a07c1d1de08a9ee114 100644 --- a/src/proto_alpha/lib_protocol/dal_slot_repr.ml +++ b/src/proto_alpha/lib_protocol/dal_slot_repr.ml @@ -320,7 +320,7 @@ module History = struct *) let next ~prev_cell ~prev_cell_ptr elt = - let open Tzresult_syntax in + let open Result_syntax in let* () = error_when (Compare.Int.( <= ) @@ -398,7 +398,7 @@ module History = struct end) let add_confirmed_slot_header (t, cache) slot_header = - let open Tzresult_syntax in + let open Result_syntax in let prev_cell_ptr = hash_skip_list_cell t in let* cache = History_cache.remember prev_cell_ptr t cache in let* new_cell = Skip_list.next ~prev_cell:t ~prev_cell_ptr slot_header in @@ -694,7 +694,7 @@ module History = struct let proof_error reason = error @@ dal_proof_error reason let check_page_proof dal_params proof data pid commitment = - let open Tzresult_syntax in + let open Result_syntax in let* dal = match Dal.make dal_params with | Ok dal -> return dal @@ -712,7 +712,7 @@ module History = struct | Error `Segment_index_out_of_range -> fail_with_error_msg "Segment_index_out_of_range" | Error `Page_length_mismatch -> - fail + tzfail @@ Unexpected_page_size { expected_size = dal_params.page_size; @@ -720,7 +720,7 @@ module History = struct } let produce_proof_repr dal_params page_id ~page_info slots_hist hist_cache = - let open Tzresult_syntax in + let open Result_syntax in let Page.{slot_id; page_index = _} = page_id in let deref ptr = History_cache.find ptr hist_cache in (* We search for a slot whose ID is equal to target_id. *) @@ -796,7 +796,7 @@ module History = struct are provided." let produce_proof dal_params page_id ~page_info slots_hist hist_cache = - let open Tzresult_syntax in + let open Result_syntax in let* proof_repr, page_data = produce_proof_repr dal_params page_id ~page_info slots_hist hist_cache in @@ -826,7 +826,7 @@ module History = struct (dal_proof_error "verify_proof_repr: invalid inclusion Dal proof.") let verify_proof_repr dal_params page_id snapshot proof = - let open Tzresult_syntax in + let open Result_syntax in let Page.{slot_id; page_index = _} = page_id in match proof with | Page_confirmed {target_cell; page_data; page_proof; inc_proof} -> @@ -916,7 +916,7 @@ module History = struct return_none let verify_proof dal_params page_id snapshot serialized_proof = - let open Tzresult_syntax in + let open Result_syntax in let* proof_repr = deserialize_proof serialized_proof in verify_proof_repr dal_params page_id snapshot proof_repr diff --git a/src/proto_alpha/lib_protocol/delegate_consensus_key.ml b/src/proto_alpha/lib_protocol/delegate_consensus_key.ml index 3a96b922d1818fc56ce27fc11cc1efd1ba15dc14..5b0ded930a8b05b39752fc88241b16cde1dbcd01 100644 --- a/src/proto_alpha/lib_protocol/delegate_consensus_key.ml +++ b/src/proto_alpha/lib_protocol/delegate_consensus_key.ml @@ -93,7 +93,7 @@ let pp ppf {delegate; consensus_pkh} = *) let check_unused ctxt pkh = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! is_active = Storage.Consensus_keys.mem ctxt pkh in fail_when is_active Invalid_consensus_key_update_active @@ -102,14 +102,14 @@ let set_unused = Storage.Consensus_keys.remove let set_used = Storage.Consensus_keys.add let init ctxt delegate pk = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let pkh = Signature.Public_key.hash pk in let* () = check_unused ctxt pkh in let*! ctxt = set_used ctxt pkh in Storage.Contract.Consensus_key.init ctxt (Contract_repr.Implicit delegate) pk let active_pubkey ctxt delegate = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* pk = Storage.Contract.Consensus_key.get ctxt (Contract_repr.Implicit delegate) in @@ -117,12 +117,12 @@ let active_pubkey ctxt delegate = return {consensus_pk = pk; consensus_pkh = pkh; delegate} let active_key ctxt delegate = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* pk = active_pubkey ctxt delegate in return (pkh pk) let raw_pending_updates ctxt delegate = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! pendings = Storage.Contract.Pending_consensus_keys.bindings (ctxt, Contract_repr.Implicit delegate) @@ -130,7 +130,7 @@ let raw_pending_updates ctxt delegate = return pendings let pending_updates ctxt delegate = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* updates = raw_pending_updates ctxt delegate in let updates = List.sort (fun (c1, _) (c2, _) -> Cycle_repr.compare c1 c2) updates @@ -138,7 +138,7 @@ let pending_updates ctxt delegate = return (List.map (fun (c, pk) -> (c, Signature.Public_key.hash pk)) updates) let raw_active_pubkey_for_cycle ctxt delegate cycle = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* pendings = raw_pending_updates ctxt delegate in let* active = active_pubkey ctxt delegate in let current_level = Raw_context.current_level ctxt in @@ -152,7 +152,7 @@ let raw_active_pubkey_for_cycle ctxt delegate cycle = return active_for_cycle let active_pubkey_for_cycle ctxt delegate cycle = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* _, consensus_pk = raw_active_pubkey_for_cycle ctxt delegate cycle in return { @@ -162,7 +162,7 @@ let active_pubkey_for_cycle ctxt delegate cycle = } let register_update ctxt delegate pk = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let update_cycle = let current_level = Raw_context.current_level ctxt in let preserved_cycles = Constants_storage.preserved_cycles ctxt in @@ -192,7 +192,7 @@ let register_update ctxt delegate pk = return ctxt let activate ctxt ~new_cycle = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in Storage.Delegates.fold ctxt ~order:`Undefined diff --git a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml index 5215aed04e7a350f7a561d9e8a3e8a7bd0ececca..7479491e0ccfe6bebcd09bc49c4ed609ed88a4aa 100644 --- a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml @@ -38,7 +38,7 @@ let already_slashed_for_double_baking ctxt delegate (level : Level_repr.t) = | Some slashed -> return slashed.for_double_baking let punish_double_endorsing ctxt delegate (level : Level_repr.t) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* slashed = Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate) in @@ -81,7 +81,7 @@ let punish_double_endorsing ctxt delegate (level : Level_repr.t) = return (ctxt, amount_to_burn, balance_updates) let punish_double_baking ctxt delegate (level : Level_repr.t) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* slashed = Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate) in diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml index f0bf60d9cd128e206ecf867d0bdc75f74b8d8be2..9e7f049b724e5cb785ff556d00f873968b9e7943 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_storage.ml @@ -93,7 +93,7 @@ module Contract = struct (fun c -> Empty_delegate_account c) let set_self_delegate c delegate = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! is_registered = registered c delegate in if is_registered then let* () = @@ -159,7 +159,7 @@ module Contract = struct (fun () -> Current_delegate) let set_delegate c contract delegate = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* () = match contract with | Contract_repr.Originated _ -> return_unit @@ -176,7 +176,7 @@ module Contract = struct return_unit | Some delegate, Some current_delegate when Signature.Public_key_hash.equal delegate current_delegate -> - fail Current_delegate + tzfail Current_delegate | _ -> return_unit in let* balance_and_frozen_bonds = @@ -249,7 +249,7 @@ let delegated_balance ctxt delegate = Lwt.return Tez_repr.(staking_balance -? self_staking_balance) let drain ctxt ~delegate ~destination = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let destination_contract = Contract_repr.Implicit destination in let*! is_destination_allocated = Contract_storage.allocated ctxt destination_contract diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index d8fc06e5a01db373561caf6c98a8990033c42484..6828b8e424c87036a9b5f80246bb8cf7da248b9c 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -96,7 +96,7 @@ type application_state = Apply.application_state let init_allowed_consensus_operations ctxt ~endorsement_level ~preendorsement_level = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let open Alpha_context in let* ctxt = Delegate.prepare_stake_distribution ctxt in let* ctxt, allowed_endorsements, allowed_preendorsements = @@ -139,7 +139,7 @@ type mode = } let prepare_ctxt ctxt mode ~(predecessor : Block_header.shell_header) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let open Alpha_context in let level, timestamp = match mode with @@ -180,7 +180,7 @@ let prepare_ctxt ctxt mode ~(predecessor : Block_header.shell_header) = predecessor_raw_level ) let begin_validation ctxt chain_id mode ~predecessor = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let open Alpha_context in let* ( ctxt, _migration_balance_updates, @@ -265,7 +265,7 @@ let () = (fun () -> Cannot_apply_in_partial_validation) let begin_application ctxt chain_id mode ~predecessor = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let open Alpha_context in let* ( ctxt, migration_balance_updates, @@ -285,7 +285,7 @@ let begin_application ctxt chain_id mode ~predecessor = ~migration_operation_results ~predecessor_fitness block_header - | Partial_validation _ -> fail Cannot_apply_in_partial_validation + | Partial_validation _ -> tzfail Cannot_apply_in_partial_validation | Construction {predecessor_hash; timestamp; block_header_data; _} -> let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in Apply.begin_full_construction @@ -388,7 +388,7 @@ module Mempool = struct include Mempool_validation let init ctxt chain_id ~head_hash ~(head : Block_header.shell_header) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let open Alpha_context in let* ( ctxt, _migration_balance_updates, diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 3aa81fec1a77bf05c831ddb53e90c3d8b6c19452..1498820cd30ac5e5ad6521e6990658764fad1a6c 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -1365,20 +1365,20 @@ module Make (Context : P) : type error += Arith_proof_verification_failed let verify_proof input_given proof = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! result = Context.verify_proof proof (step_transition input_given) in match result with - | None -> fail Arith_proof_verification_failed + | None -> tzfail Arith_proof_verification_failed | Some (_state, request) -> return request let produce_proof context input_given state = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! result = Context.produce_proof context state (step_transition input_given) in match result with | Some (tree_proof, _requested) -> return tree_proof - | None -> fail Arith_proof_production_failed + | None -> tzfail Arith_proof_production_failed let verify_origination_proof proof boot_sector = let open Lwt_syntax in @@ -1393,7 +1393,7 @@ module Make (Context : P) : match result with None -> return false | Some (_, ()) -> return true let produce_origination_proof context boot_sector = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! state = initial_state context in let*! result = Context.produce_proof context state (fun state -> @@ -1403,7 +1403,7 @@ module Make (Context : P) : in match result with | Some (proof, ()) -> return proof - | None -> fail Arith_proof_production_failed + | None -> tzfail Arith_proof_production_failed (* TEMPORARY: The following definitions will be extended in a future commit. *) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_commitment_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_commitment_storage.ml index 1d9f8bda6b81044ae7c9b95dc740fcb1514c8364..e027c9525c6fdbac74bab76b28c2f7cbfae2e426 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_commitment_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_commitment_storage.ml @@ -35,27 +35,27 @@ let get_commitment_opt_unsafe ctxt rollup commitment = return (res, ctxt) let get_commitment_unsafe ctxt rollup commitment = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* res, ctxt = get_commitment_opt_unsafe ctxt rollup commitment in match res with - | None -> fail (Sc_rollup_unknown_commitment commitment) + | None -> tzfail (Sc_rollup_unknown_commitment commitment) | Some commitment -> return (commitment, ctxt) let last_cemented_commitment ctxt rollup = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, res = Store.Last_cemented_commitment.find ctxt rollup in match res with - | None -> fail (Sc_rollup_does_not_exist rollup) + | None -> tzfail (Sc_rollup_does_not_exist rollup) | Some lcc -> return (lcc, ctxt) let get_commitment ctxt rollup commitment = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in (* Assert that a last cemented commitment exists. *) let* _lcc, ctxt = last_cemented_commitment ctxt rollup in get_commitment_unsafe ctxt rollup commitment let last_cemented_commitment_hash_with_level ctxt rollup = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* commitment_hash, ctxt = last_cemented_commitment ctxt rollup in let+ {inbox_level; _}, ctxt = get_commitment_unsafe ctxt rollup commitment_hash @@ -63,7 +63,7 @@ let last_cemented_commitment_hash_with_level ctxt rollup = (commitment_hash, inbox_level, ctxt) let set_commitment_added ctxt rollup node new_value = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, res = Store.Commitment_added.find (ctxt, rollup) node in match res with | Some old_value -> @@ -81,12 +81,12 @@ let get_predecessor_opt_unsafe ctxt rollup node = return (Option.map (fun (c : Commitment.t) -> c.predecessor) commitment, ctxt) let get_predecessor_unsafe ctxt rollup node = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* commitment, ctxt = get_commitment_unsafe ctxt rollup node in return (commitment.predecessor, ctxt) let hash ctxt commitment = - let open Tzresult_syntax in + let open Result_syntax in let* ctxt = Raw_context.consume_gas ctxt @@ -110,7 +110,7 @@ let hash ctxt commitment = module Internal_for_tests = struct let get_cemented_commitments_with_levels ctxt rollup = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let rec aux ctxt commitments_with_levels commitment_hash = let* commitment_opt, ctxt = get_commitment_opt_unsafe ctxt rollup commitment_hash diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml index b491d5a689b89ce6b3cdb06c125dc549c1633fc8..eb1ed60db3aa95bb8a163e9845a7cbb9f944eed2 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -865,19 +865,19 @@ let status_encoding = ] let find_choice dissection tick = - let open Tzresult_syntax in + let open Result_syntax in let rec traverse states = match states with | ({state_hash = _; tick = state_tick} as curr) :: next :: others -> if Sc_rollup_tick_repr.(tick = state_tick) then return (curr, next) else traverse (next :: others) - | _ -> fail (Dissection_choice_not_found tick) + | _ -> tzfail (Dissection_choice_not_found tick) in traverse dissection let check_dissection ~default_number_of_sections ~start_chunk ~stop_chunk dissection = - let open Tzresult_syntax in + let open Result_syntax in let len = Z.of_int @@ List.length dissection in let dist = Sc_rollup_tick_repr.distance start_chunk.tick stop_chunk.tick in let should_be_equal_to expected = @@ -889,7 +889,7 @@ let check_dissection ~default_number_of_sections ~start_chunk ~stop_chunk error_unless Z.(equal len num_sections) (should_be_equal_to num_sections) else if Z.(gt dist one) then error_unless Z.(equal len (succ dist)) (should_be_equal_to Z.(succ dist)) - else fail (Dissection_invalid_number_of_sections len) + else tzfail (Dissection_invalid_number_of_sections len) in let* () = match (List.hd dissection, List.last_opt dissection) with @@ -924,19 +924,19 @@ let check_dissection ~default_number_of_sections ~start_chunk ~stop_chunk | _ -> (* This case is probably already handled by the [Dissection_invalid_number_of_sections] returned above *) - fail (Dissection_invalid_number_of_sections len) + tzfail (Dissection_invalid_number_of_sections len) in let half_dist = Z.(div dist (of_int 2) |> succ) in let rec traverse states = match states with | {state_hash = None; _} :: {state_hash = Some _; _} :: _ -> - fail Dissection_invalid_successive_states_shape + tzfail Dissection_invalid_successive_states_shape | {tick; _} :: ({tick = next_tick; state_hash = _} as next) :: others -> if Sc_rollup_tick_repr.(tick < next_tick) then let incr = Sc_rollup_tick_repr.distance tick next_tick in if Z.(leq incr half_dist) then traverse (next :: others) - else fail Dissection_invalid_distribution - else fail Dissection_ticks_not_increasing + else tzfail Dissection_invalid_distribution + else tzfail Dissection_ticks_not_increasing | _ -> return () in traverse dissection @@ -1086,7 +1086,7 @@ let loser_of_results ~alice_result ~bob_result = | true, false -> Some Bob let play dal_parameters ~dal_endorsement_lag ~stakers metadata game refutation = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let mk_loser loser = let loser = Index.staker stakers loser in Either.Left (Loser {loser; reason = Conflict_resolved}) @@ -1117,7 +1117,7 @@ let play dal_parameters ~dal_endorsement_lag ~stakers metadata game refutation = pvm_name = game.pvm_name; game_state = new_game_state; }) - | Dissection _, Final_move _ -> fail Dissecting_during_final_move + | Dissection _, Final_move _ -> tzfail Dissecting_during_final_move | Proof proof, Dissecting {dissection; default_number_of_sections = _} -> let*? start_chunk, stop_chunk = find_choice dissection refutation.choice diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.ml index 05ce21e3eb4dcac3444198d50ec7a32ecea50d74..04310d03af6173ba29944f3bcd5878fe29301cfa 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.ml @@ -128,15 +128,15 @@ let encoding = type serialized = string let serialize msg = - let open Tzresult_syntax in + let open Result_syntax in match Data_encoding.Binary.to_string_opt encoding msg with - | None -> fail Error_encode_inbox_message + | None -> tzfail Error_encode_inbox_message | Some str -> return str let deserialize s = - let open Tzresult_syntax in + let open Result_syntax in match Data_encoding.Binary.of_string_opt encoding s with - | None -> fail Error_decode_inbox_message + | None -> tzfail Error_decode_inbox_message | Some msg -> return msg let unsafe_of_string s = s diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml index 3d6fcc6760372487174ecde345e532994ce9090c..f1084903669303f80f1351da2eea2d774e0b8cae 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -490,7 +490,7 @@ struct set_number_of_messages tree Z.zero let add_message inbox payload level_tree = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let message_index = inbox.message_counter in let message_counter = Z.succ message_index in let*! level_tree = @@ -544,7 +544,7 @@ struct P.commit_tree ctxt key tree let form_history_proof ctxt history inbox level_tree = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! () = let*! tree = match level_tree with @@ -598,7 +598,7 @@ struct return (history, inbox, tree) let add_messages ctxt history inbox level payloads level_tree = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* () = fail_when (match payloads with [] -> true | _ -> false) @@ -626,7 +626,7 @@ struct return (level_tree, history, {inbox with current_level_proof}) let add_messages_no_history ctxt inbox level payloads level_tree = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let+ level_tree, _, inbox = add_messages ctxt no_history inbox level payloads level_tree in @@ -659,7 +659,7 @@ struct aux [] ptr_path let verify_inclusion_proof inclusion_proof snapshot_history_proof = - let open Tzresult_syntax in + let open Result_syntax in let rec aux (hash_map, ptr_list) = function | [] -> error (Inbox_proof_error "inclusion proof is empty") | [target] -> @@ -763,8 +763,8 @@ struct let to_serialized_proof = Data_encoding.Binary.to_bytes_exn proof_encoding let proof_error reason = - let open Lwt_tzresult_syntax in - fail (Inbox_proof_error reason) + let open Lwt_result_syntax in + tzfail (Inbox_proof_error reason) let check p reason = unless p (fun () -> proof_error reason) @@ -791,7 +791,7 @@ struct [P.verify_proof], but also checks the proof has the correct [P.proof_before] hash. *) let check_message_proof message_proof level_hash n label = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* () = check (Hash.equal level_hash (P.proof_before message_proof)) @@ -804,7 +804,7 @@ struct let verify_proof (l, n) snapshot proof = assert (Z.(geq n zero)) ; - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match proof with | Single_level {inc; message_proof} -> ( let*? history_proof = verify_inclusion_proof inc snapshot in @@ -844,14 +844,14 @@ struct | Some _ -> proof_error "more messages to read in current level") (** Utility function; we convert all our calls to be consistent with - [Lwt_tzresult_syntax]. *) + [Lwt_result_syntax]. *) let option_to_result e lwt_opt = let open Lwt_syntax in let* opt = lwt_opt in match opt with None -> proof_error e | Some x -> return (ok x) let produce_proof ctxt history inbox (l, n) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let deref ptr = History.find ptr history in let compare {hash = _; level} = Raw_level_repr.compare level l in let result = Skip_list.search ~deref ~compare ~cell:inbox in @@ -926,7 +926,7 @@ struct let eq_tree = Tree.equal let produce_inclusion_proof history a b = - let open Tzresult_syntax in + let open Result_syntax in let cell_ptr = hash_history_proof b in let target_index = Skip_list.index a in let* history = History.remember cell_ptr b history in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml index 0bfdaaeb119cdb2d6b5739745f948a387da257b3..acd794758972b35b5cd55b7e8269643826c26ccd 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml @@ -34,7 +34,7 @@ let update_num_and_size_of_messages ~num_messages ~total_messages_size message = (message : Sc_rollup_inbox_message_repr.serialized :> string) ) let get_inbox ctxt = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* inbox = Store.Inbox.get ctxt in return (inbox, ctxt) @@ -55,7 +55,7 @@ let _assert_inbox_nb_messages_in_commitment_period ctxt inbox extra_messages = let add_messages ctxt messages = let {Level_repr.level; _} = Raw_context.current_level ctxt in - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let open Raw_context in let* inbox, ctxt = get_inbox ctxt in let* num_messages, total_messages_size, ctxt = @@ -121,7 +121,7 @@ let serialize_external_messages ctxt external_messages = let open Sc_rollup_inbox_message_repr in List.fold_left_map_e (fun ctxt message -> - let open Tzresult_syntax in + let open Result_syntax in (* Pay gas for serializing an external message. *) let* ctxt = let bytes_len = String.length message in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index 7b73c746c28203e1d4dc2d0db30a4dd055fcad06..3ab96e8ee9c5b88940be8a55d013d9335b29f9b4 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -55,7 +55,7 @@ type atomic_transaction_batch = {transactions : transaction list} type outbox_message = Atomic_transaction_batch of atomic_transaction_batch let make_internal_transfer ctxt ty ~payload ~sender ~source ~destination = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let+ payload, ctxt = Script_ir_translator.unparse_data ctxt @@ -68,7 +68,7 @@ let make_internal_transfer ctxt ty ~payload ~sender ~source ~destination = ctxt ) let transactions_batch_of_internal ctxt transactions = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let or_internal_transaction ctxt {Sc_rollup.Outbox.Message.unparsed_parameters; destination; entrypoint} = (* Lookup the contract-hash. *) @@ -78,7 +78,7 @@ let transactions_batch_of_internal ctxt transactions = let* ctxt, _cache_key, cached = Script_cache.find ctxt destination in match cached with | Some (_script, ex_script) -> return (ex_script, ctxt) - | None -> fail Sc_rollup_invalid_destination + | None -> tzfail Sc_rollup_invalid_destination in (* Find the entrypoint type for the given entrypoint. *) let*? res, ctxt = @@ -123,13 +123,13 @@ let transactions_batch_of_internal ctxt transactions = let outbox_message_of_outbox_message_repr ctxt (Sc_rollup.Outbox.Message.Atomic_transaction_batch {transactions}) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let+ ts, ctxt = transactions_batch_of_internal ctxt transactions in (Atomic_transaction_batch ts, ctxt) module Internal_for_tests = struct let make_transaction ctxt parameters_ty ~parameters ~destination ~entrypoint = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* unparsed_parameters, ctxt = Script_ir_translator.unparse_data ctxt Optimized parameters_ty parameters in @@ -147,7 +147,7 @@ module Internal_for_tests = struct let make_atomic_batch transactions = Atomic_transaction_batch {transactions} let serialize_outbox_message (Atomic_transaction_batch {transactions}) = - let open Tzresult_syntax in + let open Result_syntax in let to_internal_transaction (Transaction { diff --git a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml index 0147504b3b9582e1f645819792b855aafa44de0e..342d6c17050a081e80f4b73bcb3ddae0365a97d9 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml @@ -87,7 +87,7 @@ type origination_result = { } let origination_proof_of_string origination_proof kind = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match kind with | Sc_rollup.Kind.Example_arith -> let* proof = @@ -98,7 +98,7 @@ let origination_proof_of_string origination_proof kind = with | Some x -> return x | None -> - fail + tzfail (Sc_rollup_proof_repr.Sc_rollup_proof_check "invalid encoding for Arith origination proof") in @@ -122,7 +122,7 @@ let origination_proof_of_string origination_proof kind = with | Some x -> return x | None -> - fail + tzfail (Sc_rollup_proof_repr.Sc_rollup_proof_check "invalid encoding for Wasm_2_0_0 origination proof") in @@ -198,7 +198,7 @@ and validate_two_tys : (validate_ty [@ocaml.tailcall]) ty2 k) let validate_parameters_ty ctxt parameters_ty = - let open Tzresult_syntax in + let open Result_syntax in let* ctxt = Gas.consume ctxt @@ -209,7 +209,7 @@ let validate_parameters_ty ctxt parameters_ty = ctxt let validate_untyped_parameters_ty ctxt parameters_ty = - let open Tzresult_syntax in + let open Result_syntax in (* Parse the type and check that the entrypoints are well-formed. Using [parse_parameter_ty_and_entrypoints] restricts to [passable] types (everything but operations), which is OK since [validate_ty] constraints @@ -224,7 +224,7 @@ let validate_untyped_parameters_ty ctxt parameters_ty = validate_parameters_ty ctxt arg_type let check_origination_proof kind boot_sector origination_proof = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (module PVM) = Sc_rollup.wrapped_proof_module origination_proof in let kind' = Sc_rollup.wrapped_proof_kind_exn origination_proof in let* () = @@ -242,9 +242,9 @@ let check_origination_proof kind boot_sector origination_proof = return PVM.(proof_stop_state proof) let originate ctxt ~kind ~boot_sector ~origination_proof ~parameters_ty = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*? ctxt = - let open Tzresult_syntax in + let open Result_syntax in let* parameters_ty, ctxt = Script.force_decode_in_context ~consume_deserialization_gas:When_needed @@ -277,7 +277,7 @@ let to_transaction_operation ctxt ~source (Sc_rollup_management_protocol.Transaction {destination; entrypoint; parameters_ty; parameters; unparsed_parameters}) = - let open Tzresult_syntax in + let open Result_syntax in let* ctxt, nonce = fresh_internal_nonce ctxt in (* Validate the type of the parameters. Only types that can be transferred from Layer 1 to Layer 2 are permitted. @@ -309,7 +309,7 @@ let to_transaction_operation ctxt ~source amount. *) let transfer_ticket_token ctxt ~source_destination ~target_destination ~amount ticket_token = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* source_key_hash, ctxt = Ticket_balance_key.of_ex_token ctxt ~owner:source_destination ticket_token in @@ -332,7 +332,7 @@ let transfer_ticket_token ctxt ~source_destination ~target_destination ~amount let transfer_ticket_tokens ctxt ~source_destination ~acc_storage_diff {Ticket_operations_diff.ticket_token; total_amount = _; destinations} = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in List.fold_left_es (fun (acc_storage_diff, ctxt) (target_destination, (amount : Script_typed_ir.ticket_amount)) -> @@ -350,7 +350,7 @@ let transfer_ticket_tokens ctxt ~source_destination ~acc_storage_diff let validate_and_decode_output_proof ctxt ~cemented_commitment rollup ~output_proof = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in (* Lookup the PVM of the rollup. *) let* ctxt, (module PVM : Sc_rollup.PVM.S) = let+ ctxt, kind = Sc_rollup.kind ctxt rollup in @@ -412,7 +412,7 @@ let validate_outbox_level ctxt ~outbox_level ~lcc_level = let execute_outbox_message ctxt ~validate_and_decode_output_proof rollup ~cemented_commitment ~source ~output_proof = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in (* TODO: #3211 Allow older cemented commits as well. This has the benefits of eliminating any race condition where new commits @@ -448,7 +448,7 @@ let execute_outbox_message ctxt ~validate_and_decode_output_proof rollup let*? ctxt, operations = List.fold_left_map_e (fun ctxt transaction -> - let open Tzresult_syntax in + let open Result_syntax in let+ op, ctxt = to_transaction_operation ctxt ~source transaction in (ctxt, op)) ctxt diff --git a/src/proto_alpha/lib_protocol/sc_rollup_outbox_message_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_outbox_message_repr.ml index 839f313cf8fa322dab311d9bf505b55726f272cd..33292d5f51aa52f783e631a3c51e246e4ea0c386 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_outbox_message_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_outbox_message_repr.ml @@ -117,16 +117,16 @@ let pp fmt (Atomic_transaction_batch {transactions}) = type serialized = string let deserialize data = - let open Tzresult_syntax in + let open Result_syntax in match Data_encoding.Binary.of_string_opt encoding data with | Some x -> return x - | None -> fail Error_decode_outbox_message + | None -> tzfail Error_decode_outbox_message let serialize outbox_message = - let open Tzresult_syntax in + let open Result_syntax in match Data_encoding.Binary.to_string_opt encoding outbox_message with | Some str -> return str - | None -> fail Error_encode_outbox_message + | None -> tzfail Error_encode_outbox_message let unsafe_of_string s = s diff --git a/src/proto_alpha/lib_protocol/sc_rollup_outbox_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_outbox_storage.ml index f1c5858cc271b44aa2a0b370eae6317a88fe75e9..6952ff8286884db3b081f34f79147eb404d6e1d6 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_outbox_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_outbox_storage.ml @@ -31,7 +31,7 @@ let level_index ctxt level = Int32.rem (Raw_level_repr.to_int32 level) max_active_levels let record_applied_message ctxt rollup level ~message_index = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in (* Check that the 0 <= message index < maximum number of outbox messages per level. *) let*? () = @@ -48,7 +48,7 @@ let record_applied_message ctxt rollup level ~message_index = Storage.Sc_rollup.Applied_outbox_messages.find (ctxt, rollup) level_index in let*? bitset, ctxt = - let open Tzresult_syntax in + let open Result_syntax in let* bitset, ctxt = match level_and_bitset_opt with | Some (existing_level, bitset) @@ -64,7 +64,7 @@ let record_applied_message ctxt rollup level ~message_index = return (bitset, ctxt) | Some (existing_level, _bitset) when Raw_level_repr.(level < existing_level) -> - fail Sc_rollup_errors.Sc_rollup_outbox_level_expired + tzfail Sc_rollup_errors.Sc_rollup_outbox_level_expired | Some _ | None -> (* The old level is outdated or there is no previous bitset at this index. *) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml index 2c7bc842b01d45a62ac121c23a03090e82ff7ef9..89837840437eeb48887abbccfaaf7d12400858d6 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml @@ -182,11 +182,11 @@ let cut_at_level ~origination_level ~commit_level | Reveal _data -> Some input let proof_error reason = - let open Lwt_tzresult_syntax in - fail (Sc_rollup_proof_check reason) + let open Lwt_result_syntax in + tzfail (Sc_rollup_proof_check reason) let check p reason = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in if p then return () else proof_error reason let check_inbox_proof snapshot serialized_inbox_proof (level, counter) = @@ -226,7 +226,7 @@ module Dal_proofs = struct let verify ~metadata ~dal_endorsement_lag ~commit_level dal_parameters page_id dal_snapshot proof = - let open Tzresult_syntax in + let open Result_syntax in if page_level_is_valid ~origination_level:metadata.Sc_rollup_metadata_repr.origination_level @@ -246,7 +246,7 @@ module Dal_proofs = struct let produce ~metadata ~dal_endorsement_lag ~commit_level dal_parameters page_id ~page_info confirmed_slots_history history_cache = - let open Tzresult_syntax in + let open Result_syntax in if page_level_is_valid ~origination_level:metadata.Sc_rollup_metadata_repr.origination_level @@ -270,7 +270,7 @@ end let valid ~metadata snapshot commit_level dal_snapshot dal_parameters ~dal_endorsement_lag ~pvm_name proof = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in let* () = check (String.equal P.name pvm_name) "Incorrect PVM kind" in let origination_level = metadata.Sc_rollup_metadata_repr.origination_level in @@ -380,7 +380,7 @@ module type PVM_with_context_and_state = sig end let produce ~metadata pvm_and_state commit_level = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (module P : PVM_with_context_and_state) = pvm_and_state in let open P in let*! (request : Sc_rollup_PVM_sig.input_request) = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml index 38f9bbf0230a1371237cfa09881e5d352ae418f7..1fdf65db49c655c93989135a552077c2045db8ee 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml @@ -57,7 +57,7 @@ let initial_timeout ctxt = (current_level - last_turn_level)] where [nb_of_block_left] is her current timeout. *) let update_timeout ctxt rollup (game : Sc_rollup_game_repr.t) idx = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, timeout = Store.Game_timeout.get (ctxt, rollup) idx in let current_level = (Raw_context.current_level ctxt).level in let sub_block_left nb_of_block_left = @@ -77,14 +77,14 @@ let update_timeout ctxt rollup (game : Sc_rollup_game_repr.t) idx = return ctxt let get_ongoing_game ctxt rollup staker1 staker2 = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let stakers = Sc_rollup_game_repr.Index.make staker1 staker2 in let* ctxt, game = Store.Game.find (ctxt, rollup) stakers in let answer = Option.map (fun game -> (game, stakers)) game in return (answer, ctxt) let get_ongoing_game_for_staker ctxt rollup staker = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, opponent = Store.Opponent.find (ctxt, rollup) staker in match opponent with | Some opponent -> get_ongoing_game ctxt rollup staker opponent @@ -93,7 +93,7 @@ let get_ongoing_game_for_staker ctxt rollup staker = (** [goto_inbox_level ctxt rollup inbox_level commit] Follows the predecessors of [commit] until it arrives at the exact [inbox_level]. The result is the commit hash at the given inbox level. *) let goto_inbox_level ctxt rollup inbox_level commit = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let rec go ctxt commit = let* info, ctxt = Commitment_storage.get_commitment_unsafe ctxt rollup commit @@ -108,7 +108,7 @@ let goto_inbox_level ctxt rollup inbox_level commit = go ctxt commit let get_conflict_point ctxt rollup staker1 staker2 = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in (* Ensure the LCC is set. *) let* lcc, ctxt = Commitment_storage.last_cemented_commitment ctxt rollup in (* Find out on which commitments the competitors are staked. *) @@ -190,9 +190,11 @@ let get_conflict_point ctxt rollup staker1 staker2 = traverse_in_parallel ctxt commit1 commit2 let get_game ctxt rollup stakers = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, game = Store.Game.find (ctxt, rollup) stakers in - match game with Some g -> return (g, ctxt) | None -> fail Sc_rollup_no_game + match game with + | Some g -> return (g, ctxt) + | None -> tzfail Sc_rollup_no_game (** [start_game ctxt rollup refuter defender] initialises the game or if it already exists fails with `Sc_rollup_game_already_started`. @@ -227,7 +229,7 @@ let get_game ctxt rollup stakers = is already playing a game} } *) let start_game ctxt rollup ~player:refuter ~opponent:defender = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let stakers = Sc_rollup_game_repr.Index.make refuter defender in let* ctxt, game_exists = Store.Game.mem (ctxt, rollup) stakers in let* () = fail_when game_exists Sc_rollup_game_already_started in @@ -237,11 +239,11 @@ let start_game ctxt rollup ~player:refuter ~opponent:defender = match (opp_1, opp_2) with | None, None -> return () | Some _refuter_opponent, None -> - fail (Sc_rollup_staker_in_game (`Refuter refuter)) + tzfail (Sc_rollup_staker_in_game (`Refuter refuter)) | None, Some _defender_opponent -> - fail (Sc_rollup_staker_in_game (`Defender defender)) + tzfail (Sc_rollup_staker_in_game (`Defender defender)) | Some _refuter_opponent, Some _defender_opponent -> - fail (Sc_rollup_staker_in_game (`Both (refuter, defender))) + tzfail (Sc_rollup_staker_in_game (`Both (refuter, defender))) in let* ( ( {hash = _refuter_commit; commitment = _info}, {hash = _defender_commit; commitment = child_info} ), @@ -281,7 +283,7 @@ let start_game ctxt rollup ~player:refuter ~opponent:defender = return ctxt let game_move ctxt rollup ~player ~opponent refutation = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let stakers = Sc_rollup_game_repr.Index.make player opponent in let* game, ctxt = get_game ctxt rollup stakers in let* () = @@ -310,16 +312,16 @@ let game_move ctxt rollup ~player ~opponent refutation = return (None, ctxt) let get_timeout ctxt rollup stakers = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, timeout_opt = Storage.Sc_rollup.Game_timeout.find (ctxt, rollup) stakers in match timeout_opt with | Some timeout -> return (timeout, ctxt) - | None -> fail Sc_rollup_no_game + | None -> tzfail Sc_rollup_no_game let timeout ctxt rollup stakers = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let level = (Raw_context.current_level ctxt).level in let* game, ctxt = get_game ctxt rollup stakers in let* ctxt, timeout = Store.Game_timeout.get (ctxt, rollup) stakers in @@ -352,7 +354,7 @@ let timeout ctxt rollup stakers = return (game_result, ctxt) let reward ctxt winner = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let winner_contract = Contract_repr.Implicit winner in let stake = Constants_storage.sc_rollup_stake_amount ctxt in let*? reward = Tez_repr.(stake /? 2L) in @@ -364,7 +366,7 @@ let reward ctxt winner = let apply_game_result ctxt rollup (stakers : Sc_rollup_game_repr.Index.t) (game_result : Sc_rollup_game_repr.game_result) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let status = Sc_rollup_game_repr.Ended game_result in let* ctxt, balances_updates = match game_result with @@ -420,7 +422,7 @@ let conflict_encoding = (req "parent_commitment" Sc_rollup_commitment_repr.Hash.encoding))) let conflicting_stakers_uncarbonated ctxt rollup staker = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let make_conflict ctxt rollup other (our_point, their_point) = let our_hash = our_point.hash and their_hash = their_point.hash in let get = Sc_rollup_commitment_storage.get_commitment_unsafe ctxt rollup in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml index af8bb11b7ec42dfcd3d5b2ab5183594136ea4efc..8d28d386a77ac1234c26d715babf4d0deec284ed 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml @@ -31,20 +31,20 @@ module Commitment = Sc_rollup_commitment_repr module Commitment_hash = Commitment.Hash let find_staker_unsafe ctxt rollup staker = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, res = Store.Stakers.find (ctxt, rollup) staker in match res with - | None -> fail Sc_rollup_not_staked + | None -> tzfail Sc_rollup_not_staked | Some branch -> return (branch, ctxt) let find_staker ctxt rollup staker = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, res = Store.Last_cemented_commitment.mem ctxt rollup in - if not res then fail (Sc_rollup_does_not_exist rollup) + if not res then tzfail (Sc_rollup_does_not_exist rollup) else find_staker_unsafe ctxt rollup staker let modify_staker_count ctxt rollup f = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, maybe_count = Store.Staker_count.find ctxt rollup in let count = Option.value ~default:0l maybe_count in let* ctxt, size_diff, _was_bound = @@ -61,7 +61,7 @@ let get_contract_and_stake ctxt staker = (** Warning: must be called only if [rollup] exists and [staker] is not to be found in {!Store.Stakers.} *) let deposit_stake ctxt rollup staker = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* lcc, ctxt = Commitment_storage.last_cemented_commitment ctxt rollup in let staker_contract, stake = get_contract_and_stake ctxt staker in let* ctxt, staker_balance = Token.balance ctxt (`Contract staker_contract) in @@ -89,11 +89,11 @@ let deposit_stake ctxt rollup staker = return (ctxt, balance_updates, lcc) let withdraw_stake ctxt rollup staker = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* lcc, ctxt = Commitment_storage.last_cemented_commitment ctxt rollup in let* ctxt, res = Store.Stakers.find (ctxt, rollup) staker in match res with - | None -> fail Sc_rollup_not_staked + | None -> tzfail Sc_rollup_not_staked | Some staked_on_commitment -> let* () = fail_unless @@ -116,7 +116,7 @@ let withdraw_stake ctxt rollup staker = (ctxt, balance_updates) let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* lcc, ctxt = Commitment_storage.get_commitment_unsafe ctxt rollup lcc in let min_level = Commitment.(lcc.inbox_level) in let max_level = Commitment.(commitment.inbox_level) in @@ -135,7 +135,7 @@ let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment = This property is used in several places - not obeying it causes severe breakage. *) let assert_commitment_period ctxt rollup commitment = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let pred_hash = Commitment.(commitment.predecessor) in let* pred, ctxt = Commitment_storage.get_commitment_unsafe ctxt rollup pred_hash @@ -177,20 +177,20 @@ let assert_commitment_period ctxt rollup commitment = of their deposit. *) let assert_refine_conditions_met ctxt rollup lcc commitment = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt = assert_commitment_not_too_far_ahead ctxt rollup lcc commitment in let* ctxt = assert_commitment_period ctxt rollup commitment in return ctxt let get_commitment_stake_count ctxt rollup node = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, maybe_staked_on_commitment = Store.Commitment_stake_count.find (ctxt, rollup) node in return (Option.value ~default:0l maybe_staked_on_commitment, ctxt) let modify_commitment_stake_count ctxt rollup node f = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* count, ctxt = get_commitment_stake_count ctxt rollup node in let new_count = f count in let* ctxt, size_diff, _was_bound = @@ -199,7 +199,7 @@ let modify_commitment_stake_count ctxt rollup node f = return (new_count, size_diff, ctxt) let deallocate_commitment ctxt rollup node = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in if Commitment_hash.(node = zero) then return ctxt else let* ctxt, _size_freed = @@ -208,7 +208,7 @@ let deallocate_commitment ctxt rollup node = return ctxt let deallocate_commitment_metadata ctxt rollup node = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in if Commitment_hash.(node = zero) then return ctxt else let* ctxt, _size_freed = @@ -220,7 +220,7 @@ let deallocate_commitment_metadata ctxt rollup node = return ctxt let deallocate ctxt rollup node = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt = deallocate_commitment_metadata ctxt rollup node in deallocate_commitment ctxt rollup node @@ -243,7 +243,7 @@ let find_commitment_to_deallocate ctxt rollup commitment_hash aux ctxt commitment_hash num_commitments_to_keep let decrease_commitment_stake_count ctxt rollup node = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* new_count, _size_diff, ctxt = modify_commitment_stake_count ctxt rollup node Int32.pred in @@ -251,7 +251,7 @@ let decrease_commitment_stake_count ctxt rollup node = else return ctxt let increase_commitment_stake_count ctxt rollup node = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* _new_count, size_diff, ctxt = modify_commitment_stake_count ctxt rollup node Int32.succ in @@ -264,7 +264,7 @@ let increase_commitment_stake_count ctxt rollup node = let commitment_storage_size_in_bytes = 85 let refine_stake ctxt rollup staker staked_on commitment = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* lcc, ctxt = Commitment_storage.last_cemented_commitment ctxt rollup in let* ctxt = assert_refine_conditions_met ctxt rollup lcc commitment in let*? ctxt, new_hash = Sc_rollup_commitment_storage.hash ctxt commitment in @@ -320,7 +320,7 @@ let refine_stake ctxt rollup staker staked_on commitment = go Commitment.(commitment.predecessor) ctxt let publish_commitment ctxt rollup staker commitment = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* () = fail_when Sc_rollup_repr.Number_of_ticks.( @@ -339,7 +339,7 @@ let publish_commitment ctxt rollup staker commitment = (commitment_hash, ctxt, level, balance_updates) let cement_commitment ctxt rollup new_lcc = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let refutation_deadline_blocks = Constants_storage.sc_rollup_challenge_window_in_blocks ctxt in @@ -414,11 +414,11 @@ let cement_commitment ctxt rollup new_lcc = (ctxt, new_lcc_commitment) let remove_staker ctxt rollup staker = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* lcc, ctxt = Commitment_storage.last_cemented_commitment ctxt rollup in let* ctxt, res = Store.Stakers.find (ctxt, rollup) staker in match res with - | None -> fail Sc_rollup_not_staked + | None -> tzfail Sc_rollup_not_staked | Some staked_on -> let* () = fail_when Commitment_hash.(staked_on = lcc) Sc_rollup_remove_lcc @@ -452,7 +452,7 @@ module Internal_for_tests = struct let deposit_stake = deposit_stake let refine_stake ctxt rollup staker ?staked_on commitment = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match staked_on with | Some staked_on -> refine_stake ctxt rollup staker staked_on commitment | None -> diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 138940cf0f3f86290769ff087799dc6631aea69e..6d31fd7d9e90ea78a96a59ffb903ee1def1156b3 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -32,7 +32,7 @@ module Commitment_hash = Commitment.Hash (** [address_from_nonce ctxt nonce] produces an address completely determined by an operation hash and an origination counter, and accounts for gas spent. *) let address_from_nonce ctxt nonce = - let open Tzresult_syntax in + let open Result_syntax in let* ctxt = Raw_context.consume_gas ctxt Sc_rollup_costs.Constants.cost_serialize_nonce in @@ -48,7 +48,7 @@ let address_from_nonce ctxt nonce = (ctxt, Sc_rollup_repr.Address.hash_bytes [nonce_bytes]) let originate ctxt ~kind ~boot_sector ~parameters_ty ~genesis_commitment = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*? ctxt, genesis_commitment_hash = Sc_rollup_commitment_storage.hash ctxt genesis_commitment in @@ -115,11 +115,11 @@ let originate ctxt ~kind ~boot_sector ~parameters_ty ~genesis_commitment = return (address, size, genesis_commitment_hash, ctxt) let kind ctxt address = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, kind_opt = Store.PVM_kind.find ctxt address in match kind_opt with | Some k -> return (ctxt, k) - | None -> fail (Sc_rollup_errors.Sc_rollup_does_not_exist address) + | None -> tzfail (Sc_rollup_errors.Sc_rollup_does_not_exist address) let list_unaccounted ctxt = let open Lwt_syntax in @@ -127,14 +127,14 @@ let list_unaccounted ctxt = Result.return res let genesis_info ctxt rollup = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, genesis_info = Store.Genesis_info.find ctxt rollup in match genesis_info with - | None -> fail (Sc_rollup_does_not_exist rollup) + | None -> tzfail (Sc_rollup_does_not_exist rollup) | Some genesis_info -> return (ctxt, genesis_info) let get_metadata ctxt rollup = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, genesis_info = genesis_info ctxt rollup in let metadata : Sc_rollup_metadata_repr.t = {address = rollup; origination_level = genesis_info.level} @@ -142,10 +142,10 @@ let get_metadata ctxt rollup = return (ctxt, metadata) let get_boot_sector ctxt rollup = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* ctxt, boot_sector = Storage.Sc_rollup.Boot_sector.find ctxt rollup in match boot_sector with - | None -> fail (Sc_rollup_does_not_exist rollup) + | None -> tzfail (Sc_rollup_does_not_exist rollup) | Some boot_sector -> return (ctxt, boot_sector) let parameters_type ctxt rollup = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index 27edb05f805b6808f96a82170f05f4707a4dcb56..573c7d4c3054f82cef7b7740db0101d923d89937 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -344,22 +344,22 @@ module V2_0_0 = struct type error += WASM_proof_verification_failed let verify_proof input_given proof = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! result = Context.verify_proof proof (step_transition input_given) in match result with - | None -> fail WASM_proof_verification_failed + | None -> tzfail WASM_proof_verification_failed | Some (_state, request) -> return request type error += WASM_proof_production_failed let produce_proof context input_given state = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! result = Context.produce_proof context state (step_transition input_given) in match result with | Some (tree_proof, _requested) -> return tree_proof - | None -> fail WASM_proof_production_failed + | None -> tzfail WASM_proof_production_failed let verify_origination_proof proof boot_sector = let open Lwt_syntax in @@ -374,7 +374,7 @@ module V2_0_0 = struct match result with None -> return false | Some (_, ()) -> return true let produce_origination_proof context boot_sector = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! state = initial_state context in let*! result = Context.produce_proof context state (fun state -> @@ -384,7 +384,7 @@ module V2_0_0 = struct in match result with | Some (tree_proof, ()) -> return tree_proof - | None -> fail WASM_proof_production_failed + | None -> tzfail WASM_proof_production_failed type output_proof = { output_proof : Context.proof; diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index f4a40dcbead7d53b51f1b5f91edf5fc560133813..aa2ea0c7fad8925249183c0fa52cd70960f3ad96 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1715,12 +1715,12 @@ module Sc_rollup = struct let to_versioned = Sc_rollup_inbox_repr.to_versioned let get ctxt = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* versioned = get ctxt in return (of_versioned versioned) let find ctxt = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* versioned = find ctxt in return (Option.map of_versioned versioned) diff --git a/src/proto_alpha/lib_protocol/test/unit/test_merkle_list.ml b/src/proto_alpha/lib_protocol/test/unit/test_merkle_list.ml index af2b1149f73677eef95e3b373dc4a0bf60844da2..e7aa2cabd3983b0a82a20ff61270fd562ddd539e 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_merkle_list.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_merkle_list.ml @@ -154,7 +154,7 @@ let test_check_path () = let* b = check_path path pos elements_array.(pos) (ML.root t) in assert b ; return_unit) - |> Environment.Error_monad.Tzresult_syntax.join + |> Environment.Error_monad.Result_syntax.tzjoin (* Check that a path is only valid for the position for which it was computed *) @@ -171,7 +171,7 @@ let test_check_path_wrong_pos () = let* b = check_path path pos elements_array.(pos) (ML.root t) in assert (not b) ; return_unit) - |> Environment.Error_monad.Tzresult_syntax.join + |> Environment.Error_monad.Result_syntax.tzjoin (* Check that a computed path is invalidated by a tree update *) let test_check_invalidated_path () = diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.ml b/src/proto_alpha/lib_protocol/ticket_accounting.ml index 2dac9aaa1836a65e26301bab7d48e7682a659be1..329d402c403135dd57d7775887d2905beeb9eaa7 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/ticket_accounting.ml @@ -51,12 +51,12 @@ module Ticket_token_map = struct include Ticket_token_map let balance_diff ctxt token map = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let+ amnt_opt, ctxt = Ticket_token_map.find ctxt token map in (Option.value ~default:Z.zero amnt_opt, ctxt) let merge_overlap ctxt b1 b2 = - let open Tzresult_syntax in + let open Result_syntax in let+ ctxt = Gas.consume ctxt (Ticket_costs.add_z_cost b1 b2) in (Z.add b1 b2, ctxt) @@ -66,7 +66,7 @@ module Ticket_token_map = struct let add ctxt = Ticket_token_map.merge ctxt ~merge_overlap let sub ctxt m1 m2 = - let open Tzresult_syntax in + let open Result_syntax in let* m2, ctxt = map_e ctxt @@ -79,12 +79,12 @@ module Ticket_token_map = struct end let ticket_balances_of_value ctxt ~include_lazy ty value = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* tickets, ctxt = Ticket_scanner.tickets_of_value ~include_lazy ctxt ty value in let accum_ticket_balances (acc, ctxt) ticket = - let open Tzresult_syntax in + let open Result_syntax in let token, amount = Ticket_scanner.ex_token_and_amount_of_ex_ticket ticket in @@ -100,7 +100,7 @@ let ticket_balances_of_value ctxt ~include_lazy ty value = Ticket_token_map.of_list ctxt token_amounts let update_ticket_balances ctxt ~total_storage_diff token destinations = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in List.fold_left_es (fun (tot_storage_diff, ctxt) (owner, delta) -> let* key_hash, ctxt = Ticket_balance_key.of_ex_token ctxt ~owner token in @@ -123,7 +123,7 @@ let invalid_ticket_transfer_error Invalid_ticket_transfer {ticketer = Contract.to_b58check ticketer; amount} let update_ticket_balances_for_self_contract ctxt ~self_contract ticket_diffs = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in List.fold_left_es (fun (total_storage_diff, ctxt) (ticket_token, amount) -> (* Diff is valid iff either: @@ -148,7 +148,7 @@ let update_ticket_balances_for_self_contract ctxt ~self_contract ticket_diffs = let ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets lazy_storage_diff = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in (* Only scan lazy-diffs for tickets in case the storage contains tickets. *) if Ticket_scanner.has_tickets storage_type_has_tickets then let* diffs, ctxt = @@ -190,7 +190,7 @@ let ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets let ticket_diffs ctxt ~self_contract ~arg_type_has_tickets ~storage_type_has_tickets ~arg ~old_storage ~new_storage ~lazy_storage_diff = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in (* Collect ticket-token balances of the incoming parameters. *) let* arg_tickets, ctxt = ticket_balances_of_value ctxt ~include_lazy:true arg_type_has_tickets arg @@ -231,7 +231,7 @@ let ticket_diffs ctxt ~self_contract ~arg_type_has_tickets return (diff, ticket_receipt, ctxt) let update_ticket_balances ctxt ~self_contract ~ticket_diffs operations = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let validate_spending_budget ctxt (Ticket_token.Ex_token {ticketer; _} as ticket_token) amount = if Contract.equal ticketer self_contract then @@ -283,7 +283,7 @@ let update_ticket_balances ctxt ~self_contract ~ticket_diffs operations = List.fold_left_e (fun (acc, ctxt) (token, (amount : Script_typed_ir.ticket_amount)) -> (* Consume some gas for traversing the list. *) - let open Tzresult_syntax in + let open Result_syntax in let+ ctxt = Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step in diff --git a/src/proto_alpha/lib_protocol/validate.ml b/src/proto_alpha/lib_protocol/validate.ml index f9a61d13a973111b41c92a72ff3a1663abbfa323..05c2ca5b3681a5152c7b91bca11f3f8e758a11ad 100644 --- a/src/proto_alpha/lib_protocol/validate.ml +++ b/src/proto_alpha/lib_protocol/validate.ml @@ -631,7 +631,7 @@ module Consensus = struct open Validate_errors.Consensus let check_frozen_deposits_are_positive ctxt delegate_pkh = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* frozen_deposits = Delegate.frozen_deposits ctxt delegate_pkh in fail_unless Tez.(frozen_deposits.current_amount > zero) @@ -718,7 +718,7 @@ module Consensus = struct let check_preendorsement vi ~check_signature (operation : Kind.preendorsement operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Preendorsement consensus_content)) = operation.protocol_data.contents in @@ -824,7 +824,7 @@ module Consensus = struct function will only be called in [Partial_construction] mode. *) let check_grandparent_endorsement vi ~check_signature expected operation (consensus_content : consensus_content) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let kind = Grandparent_endorsement in let level = Level.from_raw vi.ctxt consensus_content.level in let* (_ctxt : t), consensus_key = @@ -905,7 +905,7 @@ module Consensus = struct during block validation or construction. *) let check_normal_endorsement vi ~check_signature (operation : Kind.endorsement operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Endorsement consensus_content)) = operation.protocol_data.contents in @@ -977,7 +977,7 @@ module Consensus = struct let check_endorsement vi ~check_signature (operation : Kind.endorsement operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Endorsement consensus_content)) = operation.protocol_data.contents in @@ -1058,7 +1058,7 @@ module Consensus = struct endorsement encoding. However, once the DAL is ready, this operation should be merged with an endorsement or at least refined. *) - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Dal_slot_availability op)) = operation.protocol_data.contents in @@ -1164,7 +1164,7 @@ module Consensus = struct let validate_preendorsement ~check_signature info operation_state block_state oph (operation : Kind.preendorsement operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Preendorsement consensus_content)) = operation.protocol_data.contents in @@ -1193,7 +1193,7 @@ module Consensus = struct let validate_endorsement ~check_signature info operation_state block_state oph operation = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* kind = check_endorsement info ~check_signature operation in let*? () = check_endorsement_conflict operation_state oph operation @@ -1225,14 +1225,14 @@ module Voting = struct (Wrong_voting_period_index {expected; provided = period_index}) let check_proposals_source_is_registered ctxt source = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! is_registered = Delegate.registered ctxt source in fail_unless is_registered (Proposals_from_unregistered_delegate source) (** Check that the list of proposals is not empty and does not contain duplicates. *) let check_proposal_list_sanity proposals = - let open Tzresult_syntax in + let open Result_syntax in let* () = match proposals with [] -> error Empty_proposals | _ :: _ -> ok_unit in @@ -1257,7 +1257,7 @@ module Voting = struct error (Wrong_voting_period_kind {current; expected = [Proposal]}) let check_in_listings ctxt source = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! in_listings = Vote.in_listings ctxt source in fail_unless in_listings Source_not_in_vote_listings @@ -1272,7 +1272,7 @@ module Voting = struct {previous_count = count_in_ctxt; operation_count = proposals_length}) let check_already_proposed ctxt proposer proposals = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in List.iter_es (fun proposal -> let*! already_proposed = Vote.has_proposed ctxt proposer proposal in @@ -1345,7 +1345,7 @@ module Voting = struct incorrectly signed. *) let check_proposals vi ~check_signature (operation : Kind.proposals operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Proposals {source; period; proposals})) = operation.protocol_data.contents in @@ -1382,7 +1382,7 @@ module Voting = struct (regardless of whether this source is a testnet dictator or an ordinary manager). *) let check_proposals_conflict vs oph (operation : Kind.proposals operation) = - let open Tzresult_syntax in + let open Result_syntax in let (Single (Proposals {source; _})) = operation.protocol_data.contents in match Signature.Public_key_hash.Map.find_opt @@ -1417,7 +1417,7 @@ module Voting = struct {vs with voting_state = {vs.voting_state with proposals_seen}} let check_ballot_source_is_registered ctxt source = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! is_registered = Delegate.registered ctxt source in fail_unless is_registered (Ballot_from_unregistered_delegate source) @@ -1430,7 +1430,7 @@ module Voting = struct {current; expected = [Exploration; Promotion]}) let check_current_proposal ctxt op_proposal = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* current_proposal = Vote.get_current_proposal ctxt in fail_unless (Protocol_hash.equal op_proposal current_proposal) @@ -1438,7 +1438,7 @@ module Voting = struct {current = current_proposal; submitted = op_proposal}) let check_source_has_not_already_voted ctxt source = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*! has_ballot = Vote.has_recorded_ballot ctxt source in fail_when has_ballot Already_submitted_a_ballot @@ -1467,7 +1467,7 @@ module Voting = struct Operation.Invalid_signature] if the operation is unsigned or incorrectly signed. *) let check_ballot vi ~check_signature (operation : Kind.ballot operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Ballot {source; period; proposal; ballot = _})) = operation.protocol_data.contents in @@ -1526,7 +1526,7 @@ module Anonymous = struct let (Single (Activate_account {id = edpkh; activation_code})) = operation.protocol_data.contents in - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let blinded_pkh = Blinded_public_key_hash.of_ed25519_pkh activation_code edpkh in @@ -1602,7 +1602,7 @@ module Anonymous = struct ~consensus_operation:denunciation_kind vi (op1 : kind Kind.consensus Operation.t) (op2 : kind Kind.consensus Operation.t) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match (op1.protocol_data.contents, op2.protocol_data.contents) with | Single (Preendorsement e1), Single (Preendorsement e2) | Single (Endorsement e1), Single (Endorsement e2) -> @@ -1761,7 +1761,7 @@ module Anonymous = struct let check_double_baking_evidence vi (operation : Kind.double_baking_evidence operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Double_baking_evidence {bh1; bh2})) = operation.protocol_data.contents in @@ -1888,7 +1888,7 @@ module Anonymous = struct let check_drain_delegate info ~check_signature (operation : Kind.drain_delegate Operation.t) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Drain_delegate {delegate; destination; consensus_key})) = operation.protocol_data.contents in @@ -2000,7 +2000,7 @@ module Anonymous = struct let check_seed_nonce_revelation vi (operation : Kind.seed_nonce_revelation operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Seed_nonce_revelation {level = commitment_raw_level; nonce})) = operation.protocol_data.contents in @@ -2054,7 +2054,7 @@ module Anonymous = struct {vs with anonymous_state} let check_vdf_revelation vi (operation : Kind.vdf_revelation operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Single (Vdf_revelation {solution})) = operation.protocol_data.contents in @@ -2186,7 +2186,7 @@ module Manager = struct check_batch_tail_sanity source counter rest >>? fun () -> ok (source, None, counter) in - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let*? source, revealed_key, first_counter = check_batch contents_list in let* balance = Contract.check_allocated_and_get_balance vi.ctxt source in let* () = Contract.check_counter_increment vi.ctxt source first_counter in @@ -2358,7 +2358,7 @@ module Manager = struct let check_contents (type kind) vi batch_state (contents : kind Kind.manager contents) remaining_block_gas = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let (Manager_operation {source; fee; counter = _; operation; gas_limit; storage_limit}) = contents @@ -2467,7 +2467,7 @@ module Manager = struct Gas.Arith.fp -> Gas.Arith.fp tzresult Lwt.t = fun vi batch_state contents_list remaining_gas -> - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match contents_list with | Single contents -> let* batch_state = @@ -2482,7 +2482,7 @@ module Manager = struct let check_manager_operation vi ~check_signature (operation : _ Kind.manager operation) remaining_block_gas = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let contents_list = operation.protocol_data.contents in let* batch_state, source_pk = check_sanity_and_find_public_key vi contents_list @@ -2577,7 +2577,7 @@ module Manager = struct let validate_manager_operation ~check_signature info operation_state block_state oph operation = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let* gas_used = check_manager_operation info @@ -2614,7 +2614,7 @@ let init_validation_state ctxt mode chain_id all_expected_consensus_features *) let begin_any_application ctxt chain_id ~predecessor_level ~predecessor_timestamp (block_header : Block_header.t) fitness ~is_partial = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let predecessor_round = Fitness.predecessor_round fitness in let round = Fitness.round fitness in let current_level = Level.current ctxt in @@ -2701,7 +2701,7 @@ let begin_application ctxt chain_id ~predecessor_level ~predecessor_timestamp let begin_full_construction ctxt chain_id ~predecessor_level ~predecessor_round ~predecessor_timestamp ~predecessor_hash round (header_contents : Block_header.contents) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let round_durations = Constants.round_durations ctxt in let timestamp = Timestamp.current ctxt in let*? () = @@ -2797,7 +2797,7 @@ let begin_no_predecessor_info ctxt chain_id = let check_operation ?(check_signature = true) info (type kind) (operation : kind operation) : unit tzresult Lwt.t = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match operation.protocol_data.contents with | Single (Preendorsement _) -> let* (_voting_power : int) = @@ -2851,7 +2851,7 @@ let check_operation ?(check_signature = true) info (type kind) remaining_gas in return_unit - | Single (Failing_noop _) -> fail Validate_errors.Failing_noop_error + | Single (Failing_noop _) -> tzfail Validate_errors.Failing_noop_error let check_operation_conflict (type kind) operation_conflict_state oph (operation : kind operation) = @@ -3013,7 +3013,7 @@ let remove_operation operation_conflict_state (type kind) | Single (Failing_noop _) -> (* Nothing to do *) operation_conflict_state let check_validation_pass_consistency vi vs validation_pass = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match vi.mode with | Mempool | Construction _ -> return vs | Application _ | Partial_validation _ -> ( @@ -3028,7 +3028,7 @@ let check_validation_pass_consistency vi vs validation_pass = {expected = previous_vp; provided = validation_pass}) in return {vs with last_op_validation_pass = Some validation_pass} - | Some _, None -> fail Validate_errors.Failing_noop_error) + | Some _, None -> tzfail Validate_errors.Failing_noop_error) (** Increment [vs.op_count] for all operations, and record non-consensus operation hashes in [vs.recorded_operations_rev]. *) @@ -3047,7 +3047,7 @@ let record_operation vs ophash validation_pass_opt = let validate_operation ?(check_signature = true) {info; operation_state; block_state} oph (packed_operation : packed_operation) = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let {shell; protocol_data = Operation_data protocol_data} = packed_operation in @@ -3207,10 +3207,10 @@ let validate_operation ?(check_signature = true) block_state oph operation - | Single (Failing_noop _) -> fail Validate_errors.Failing_noop_error) + | Single (Failing_noop _) -> tzfail Validate_errors.Failing_noop_error) let are_endorsements_required vi = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let+ first_level = First_level_of_protocol.get vi.ctxt in (* [Comment from Legacy_apply] NB: the first level is the level of the migration block. There are no endorsements for this @@ -3252,7 +3252,7 @@ let compute_payload_hash block_state (List.rev block_state.recorded_operations_rev) let finalize_block {info; block_state; _} = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in match info.mode with | Application {fitness; predecessor_hash; block_data_contents; _} -> let* are_endorsements_required = are_endorsements_required info in