diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs new file mode 100644 index 0000000000000000000000000000000000000000..a74c46cad00cc813e1eb58161c1bb18dd6f722bf --- /dev/null +++ b/.git-blame-ignore-revs @@ -0,0 +1,2 @@ +# Upgrade to OCamlformat 0.26.0 +7390b3e35331aac4f0452559e4f13422dc749fcd diff --git a/.ocamlformat b/.ocamlformat index fb8540e41041d1518b3266f44113d2847281564c..53d8f893264a4cee99c04af63cd4438732105e7b 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.24.1 +version=0.26.0 ocaml-version=4.14 wrap-fun-args=false let-binding-spacing=compact diff --git a/devtools/get_contracts/get_contracts.ml b/devtools/get_contracts/get_contracts.ml index 65ff0fcc147a1d213d55727b8934afebe0c85d19..d1b8b8477af6fad8c5e03a8045080d663be6b53a 100644 --- a/devtools/get_contracts/get_contracts.ml +++ b/devtools/get_contracts/get_contracts.ml @@ -507,9 +507,9 @@ module Make (P : Sigs.PROTOCOL) : Sigs.MAIN = struct else return Contract_size.zero in (if Config.collect_storage then - let dirname = Filename.concat output_dir (hash_string ^ ".storage") in - let storages = ExprMap.map (fun {storage; _} -> storage) ctr.storages in - File_helpers.print_expr_dir ~dirname ~ext:".storage" storages) ; + let dirname = Filename.concat output_dir (hash_string ^ ".storage") in + let storages = ExprMap.map (fun {storage; _} -> storage) ctr.storages in + File_helpers.print_expr_dir ~dirname ~ext:".storage" storages) ; return @@ Contract_size.add contract_size total_size let write_gas_file ~output_dir contract_map = diff --git a/devtools/simdal/bin/dat.ml b/devtools/simdal/bin/dat.ml index cda0f51c861226bd1d173ea5ecae3e80ecf983fb..c89e753be45bc1ef97a9d72321da2b5c228f7049 100644 --- a/devtools/simdal/bin/dat.ml +++ b/devtools/simdal/bin/dat.ml @@ -66,13 +66,13 @@ let append ?(sep = default_sep) ~into src = let* src = load ~sep src in let into_exists = Sys.file_exists into in (if into_exists then - (* Check that header match *) - match load_header ~sep into with - | None -> invalid_arg "append: could not load header" - | Some into_header -> ( - match Array.for_all2 String.equal into_header src.header with - | (exception _) | false -> invalid_arg "append: header mismatch" - | true -> ())) ; + (* Check that header match *) + match load_header ~sep into with + | None -> invalid_arg "append: could not load header" + | Some into_header -> ( + match Array.for_all2 String.equal into_header src.header with + | (exception _) | false -> invalid_arg "append: header mismatch" + | true -> ())) ; Out_channel.with_open_gen [Open_wronly; Open_creat; Open_text; Open_append] 0o666 diff --git a/devtools/simdal/bin/roles.ml b/devtools/simdal/bin/roles.ml index 74c6f951f301b0c563ae52afe302093d26518a88..79dc3b9dc403a1652274c62dd1dbdf5ce969493b 100644 --- a/devtools/simdal/bin/roles.ml +++ b/devtools/simdal/bin/roles.ml @@ -39,7 +39,7 @@ let realistic_cfg ?(flat_stake = false) ?(nproducers = 256) ?(nconsumers = 256) let shards = Array.to_seq (if flat_stake then Stake.uniform_shard_assignment - else Stake.mainnet_shard_assignment) + else Stake.mainnet_shard_assignment) in let shard_assignment = shards diff --git a/devtools/simdal/bin/sim.ml b/devtools/simdal/bin/sim.ml index 0344b59026ab644bf2b5e7ca1a3af68041d61fb0..b1fab83f183b24ab6945e8c68dfae31bcc863845 100644 --- a/devtools/simdal/bin/sim.ml +++ b/devtools/simdal/bin/sim.ml @@ -391,21 +391,21 @@ let () = List.concat [ (if List.mem "bandwidth" parameters.Cmdline.analysis then - [estimate_bandwidth] - else []); + [estimate_bandwidth] + else []); (if List.mem "consumer" parameters.Cmdline.analysis then - [consumer_receives_enough_shards] - else []); + [consumer_receives_enough_shards] + else []); (if List.mem "shards" parameters.Cmdline.analysis then - [ - attester_receives_enough_shards (Roles.largest_attester_index cfg); - attester_receives_enough_shards (Roles.median_attester_index cfg); - attester_receives_enough_shards (Roles.smallest_attester_index cfg); - ] - else []); + [ + attester_receives_enough_shards (Roles.largest_attester_index cfg); + attester_receives_enough_shards (Roles.median_attester_index cfg); + attester_receives_enough_shards (Roles.smallest_attester_index cfg); + ] + else []); (if List.mem "confirmation" parameters.Cmdline.analysis then - [slot_confirmed] - else []); + [slot_confirmed] + else []); ] in diff --git a/devtools/simdal/bin/topic.ml b/devtools/simdal/bin/topic.ml index 916909401f1c3eaff5c3e3bfb2ebb5e91662535c..b962458c562cc932321ccff58db27360a6e6f518 100644 --- a/devtools/simdal/bin/topic.ml +++ b/devtools/simdal/bin/topic.ml @@ -10,7 +10,7 @@ module Topic = struct if c = 0 then Int.compare t1.shard t2.shard else c let pp fmtr {slot; shard} = Format.fprintf fmtr "slot=%d,shard=%d" slot shard - [@@ocaml.warning "-32"] + [@@ocaml.warning "-32"] end include Topic diff --git a/devtools/simdal/lib/sampler.ml b/devtools/simdal/lib/sampler.ml index fd2a33890bb3e2f067cbd2c72637ebc3a6b81e8c..603007562b3cd399642116d669e9304a8e77fda0 100644 --- a/devtools/simdal/lib/sampler.ml +++ b/devtools/simdal/lib/sampler.ml @@ -227,7 +227,7 @@ let float_incr table key dx = match Vertex_table.find_opt table key with | None -> Vertex_table.add table key (ref 0.0) | Some x -> x := !x +. dx - [@@ocaml.inline] +[@@ocaml.inline] let uniform_spanning_trees ~graph ~source ~subgraph_predicate = if not (subgraph_predicate source) then @@ -262,7 +262,7 @@ let estimate_bandwidth ~state ~subgraph_predicate ~counters ~spanning_trees float_incr incoming dst db ; float_incr outgoing src db ; Edge_table.add routing e () - [@@ocaml.inline] + [@@ocaml.inline] in (* Invariant: all spanning trees have the same support, corresponding to the subgraph predicate. Hence, we optimize as follows: diff --git a/manifest/main.ml b/manifest/main.ml index 518f9290ab82b30377845bf22eeb5e904f36f76b..122b6e4dff70a13a1e1fa08c5a5364303c696366 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -4948,18 +4948,18 @@ end = struct "test_delegation"; "test_double_baking"; (if N.(number >= 018) then "test_double_attestation" - else "test_double_endorsement"); + else "test_double_endorsement"); (if N.(number >= 018) then "test_double_preattestation" - else "test_double_preendorsement"); + else "test_double_preendorsement"); (if N.(number >= 018) then "test_attestation" - else "test_endorsement"); + else "test_endorsement"); "test_frozen_deposits"; "test_helpers_rpcs"; "test_participation"; (if N.(number >= 018) then "test_preattestation_functor" - else "test_preendorsement_functor"); + else "test_preendorsement_functor"); (if N.(number >= 018) then "test_preattestation" - else "test_preendorsement"); + else "test_preendorsement"); "test_seed"; ] ~path:(path // "lib_protocol/test/integration/consensus") @@ -5487,11 +5487,11 @@ module Protocol = Protocol S "run"; S "%{bin:octez-protocol-compiler}"; (if - String_set.mem - tezos_protocol.Tezos_protocol.hash - final_protocol_versions - then E - else S "-no-hash-check"); + String_set.mem + tezos_protocol.Tezos_protocol.hash + final_protocol_versions + then E + else S "-no-hash-check"); (match disable_warnings with | [] -> E | l -> @@ -5885,7 +5885,7 @@ let hash = Protocol.hash name ~path: (if active then path // "lib_protocol/test/helpers" - else path // "lib_protocol") + else path // "lib_protocol") ~opam:name ~internal_name:(sf "tezos_%s_test_helpers" name_underscore) ~synopsis:"Tezos/Protocol: protocol testing framework" @@ -6059,8 +6059,8 @@ let hash = Protocol.hash ~path:(path // "lib_delegate") ~synopsis: (if N.(number <= 011) then - "Tezos/Protocol: base library for `tezos-baker/endorser/accuser`" - else "Tezos/Protocol: base library for `tezos-baker/accuser`") + "Tezos/Protocol: base library for `tezos-baker/endorser/accuser`" + else "Tezos/Protocol: base library for `tezos-baker/accuser`") ~deps: [ octez_base |> open_ ~m:"TzPervasives" @@ -6092,8 +6092,8 @@ let hash = Protocol.hash ~linkall:true ~all_modules_except: (if N.(number <= 011) then - ["Delegate_commands"; "Delegate_commands_registration"] - else ["Baking_commands"; "Baking_commands_registration"]) + ["Delegate_commands"; "Delegate_commands_registration"] + else ["Baking_commands"; "Baking_commands_registration"]) in let tenderbrute = only_if (active && N.(number >= 013)) @@ fun () -> @@ -6211,8 +6211,7 @@ let hash = Protocol.hash ~linkall:true ~modules: [ - (if N.(number <= 011) then "Delegate_commands" - else "Baking_commands"); + (if N.(number <= 011) then "Delegate_commands" else "Baking_commands"); ] in let baking_commands_registration = @@ -6237,7 +6236,7 @@ let hash = Protocol.hash ~modules: [ (if N.(number <= 011) then "Delegate_commands_registration" - else "Baking_commands_registration"); + else "Baking_commands_registration"); ] in let daemon daemon = @@ -6334,12 +6333,12 @@ let hash = Protocol.hash tezt (* test [test_dac_pages_encoding] was removed after 016 *) (if N.(number == 016) then - [ - "test_dal_slot_frame_encoding"; - "test_dac_pages_encoding"; - "test_helpers"; - ] - else ["test_dal_slot_frame_encoding"; "test_helpers"]) + [ + "test_dal_slot_frame_encoding"; + "test_dac_pages_encoding"; + "test_helpers"; + ] + else ["test_dal_slot_frame_encoding"; "test_helpers"]) ~path:(path // "lib_dal/test") ~opam:(sf "tezos-dal-%s" name_dash) ~with_macos_security_framework:true @@ -7088,23 +7087,23 @@ let get_contracts_lib = match (Protocol.status proto, Protocol.client proto) with | Active, Some client -> (if not @@ Sys.file_exists get_contracts_ml then - let contents = - file_content @@ get_contracts_module Protocol.alpha - in - let contents = - Str.global_replace - (Str.regexp_string "open Tezos_protocol_alpha") - ("open Tezos_protocol_" ^ Protocol.name_underscore proto) - contents - in - let contents = - Str.global_replace - (Str.regexp_string "open Tezos_client_alpha") - ("open Tezos_client_" ^ Protocol.name_underscore proto) - contents - in - write get_contracts_ml (fun fmt -> - Format.pp_print_string fmt contents)) ; + let contents = + file_content @@ get_contracts_module Protocol.alpha + in + let contents = + Str.global_replace + (Str.regexp_string "open Tezos_protocol_alpha") + ("open Tezos_protocol_" ^ Protocol.name_underscore proto) + contents + in + let contents = + Str.global_replace + (Str.regexp_string "open Tezos_client_alpha") + ("open Tezos_client_" ^ Protocol.name_underscore proto) + contents + in + write get_contracts_ml (fun fmt -> + Format.pp_print_string fmt contents)) ; Some [Protocol.main proto; client] | _ -> remove_if_exists get_contracts_ml ; @@ -7155,17 +7154,17 @@ let yes_wallet_lib = match Protocol.status proto with | Active -> (if not @@ Sys.file_exists get_delegates_ml then - let contents = - file_content @@ get_delegates_module Protocol.alpha - in - let contents = - Str.global_replace - (Str.regexp_string "open Tezos_protocol_alpha") - ("open Tezos_protocol_" ^ Protocol.name_underscore proto) - contents - in - write get_delegates_ml (fun fmt -> - Format.pp_print_string fmt contents)) ; + let contents = + file_content @@ get_delegates_module Protocol.alpha + in + let contents = + Str.global_replace + (Str.regexp_string "open Tezos_protocol_alpha") + ("open Tezos_protocol_" ^ Protocol.name_underscore proto) + contents + in + write get_delegates_ml (fun fmt -> + Format.pp_print_string fmt contents)) ; Some (Protocol.main proto) | _ -> remove_if_exists get_delegates_ml ; diff --git a/manifest/manifest.ml b/manifest/manifest.ml index 6d218e5093ae00baf1e6d09082eb3518a922eb9a..892aa6210247971e6c53d4ef127f315bfd1c5c83 100644 --- a/manifest/manifest.ml +++ b/manifest/manifest.ml @@ -262,23 +262,23 @@ module Dune = struct | [] -> E | _ -> [V (S "libraries" :: libraries)]); (if inline_tests then - let modes : mode list = - match (modes, js_of_ocaml) with - | None, None -> - (* Make the default dune behavior explicit *) - [Native] - | None, Some _ -> [Native; JS] - | Some modes, _ -> - (* always preserve mode if specified *) - modes - in - [ - S "inline_tests"; - [S "flags"; S "-verbose"]; - S "modes" - :: of_list (List.map (fun mode -> S (string_of_mode mode)) modes); - ] - else E); + let modes : mode list = + match (modes, js_of_ocaml) with + | None, None -> + (* Make the default dune behavior explicit *) + [Native] + | None, Some _ -> [Native; JS] + | Some modes, _ -> + (* always preserve mode if specified *) + modes + in + [ + S "inline_tests"; + [S "flags"; S "-verbose"]; + S "modes" + :: of_list (List.map (fun mode -> S (string_of_mode mode)) modes); + ] + else E); (match preprocess with | [] -> E | _ :: _ -> S "preprocess" :: of_list preprocess); diff --git a/src/bin_dal_node/RPC_server.ml b/src/bin_dal_node/RPC_server.ml index c3645bd3e140a2fc137f2458324bb341dbc248a6..d401926cb11425e7e0be539f8efabcd3a1b2ead8 100644 --- a/src/bin_dal_node/RPC_server.ml +++ b/src/bin_dal_node/RPC_server.ml @@ -158,18 +158,18 @@ module Profile_handlers = struct let get_attestable_slots ctxt pkh attested_level () () = call_handler2 ctxt (fun store {proto_parameters; _} -> (let open Lwt_result_syntax in - let* shard_indices = - Node_context.fetch_assigned_shard_indices - ctxt - ~pkh - ~level:attested_level - |> Errors.other_lwt_result - in - Profile_manager.get_attestable_slots - ~shard_indices - store - proto_parameters - ~attested_level) + let* shard_indices = + Node_context.fetch_assigned_shard_indices + ctxt + ~pkh + ~level:attested_level + |> Errors.other_lwt_result + in + Profile_manager.get_attestable_slots + ~shard_indices + store + proto_parameters + ~attested_level) |> Errors.to_tzresult) end diff --git a/src/bin_dal_node/daemon.ml b/src/bin_dal_node/daemon.ml index 277dc8b24cb05a02aee31db557df04692b8086d0..f85835baf8c38d162f1d1c79772836b291d1f57e 100644 --- a/src/bin_dal_node/daemon.ml +++ b/src/bin_dal_node/daemon.ml @@ -468,7 +468,7 @@ let run ~data_dir configuration_override = in let*! () = Event.(emit starting_node) () in let* ({network_name; rpc_addr; peers; endpoint; profiles; listen_addr; _} as - config) = + config) = let*! result = Configuration_file.load ~data_dir in match result with | Ok configuration -> return (configuration_override configuration) diff --git a/src/bin_dal_node/store.ml b/src/bin_dal_node/store.ml index 89df720e0897e6917cbc37d70c115ba3187b226d..8a25c787a24184677fc0cee8a21a0192587b94e2 100644 --- a/src/bin_dal_node/store.ml +++ b/src/bin_dal_node/store.ml @@ -563,7 +563,7 @@ module Legacy = struct @@ { Services.Types.slot_id; commitment; - status = (status :> Services.Types.header_status); + status :> Services.Types.header_status; } :: acc))) accu @@ -576,8 +576,8 @@ module Legacy = struct let skip_commitment read_commitment = Result_syntax.return (if String.equal read_commitment encoded_commitment then - `Keep commitment - else `Skip) + `Keep commitment + else `Skip) in get_accepted_headers ~skip_commitment slot_ids store accu diff --git a/src/bin_evm_proxy/evm_proxy.ml b/src/bin_evm_proxy/evm_proxy.ml index cdcad5462c0981d0aa2fb4c128fd26923e1cec51..ba2cd4d4dda73bb01b81a23e4430d0c50ca6fc77 100644 --- a/src/bin_evm_proxy/evm_proxy.ml +++ b/src/bin_evm_proxy/evm_proxy.ml @@ -167,7 +167,7 @@ let start server ~callback: (if debug then callback_log server - else RPC_server.resto_callback server) + else RPC_server.resto_callback server) node in let*! () = diff --git a/src/bin_node/node_identity_command.ml b/src/bin_node/node_identity_command.ml index ab3feebcc0e0f7f6e490aa28f457f2befe10d2e2..0e3c6c1f35f0d5434582599824412fe0c0229f48 100644 --- a/src/bin_node/node_identity_command.ml +++ b/src/bin_node/node_identity_command.ml @@ -56,50 +56,50 @@ let identity_file data_dir = data_dir // Data_version.default_identity_file_name let show data_dir config_file expected_pow = Shared_arg.process_command (let open Lwt_result_syntax in - let* {Config_file.data_dir; _} = - get_config data_dir config_file expected_pow - in - let* id = Identity_file.read (identity_file data_dir) in - Format.printf "Peer_id: %a.@." P2p_peer.Id.pp id.peer_id ; - return_unit) + let* {Config_file.data_dir; _} = + get_config data_dir config_file expected_pow + in + let* id = Identity_file.read (identity_file data_dir) in + Format.printf "Peer_id: %a.@." P2p_peer.Id.pp id.peer_id ; + return_unit) let check data_dir config_file expected_pow = Shared_arg.process_command (let open Lwt_result_syntax in - let* {Config_file.data_dir; p2p = {expected_pow; _}; _} = - get_config data_dir config_file expected_pow - in - let* id = Identity_file.read ~expected_pow (identity_file data_dir) in - Format.printf - "Peer_id: %a. Proof of work is higher than %.2f.@." - P2p_peer.Id.pp - id.peer_id - expected_pow ; - return_unit) + let* {Config_file.data_dir; p2p = {expected_pow; _}; _} = + get_config data_dir config_file expected_pow + in + let* id = Identity_file.read ~expected_pow (identity_file data_dir) in + Format.printf + "Peer_id: %a. Proof of work is higher than %.2f.@." + P2p_peer.Id.pp + id.peer_id + expected_pow ; + return_unit) let generate data_dir config_file expected_pow = Shared_arg.process_command (let open Lwt_result_syntax in - let* {Config_file.data_dir; p2p = {expected_pow; _}; _} = - get_config data_dir config_file expected_pow - in - let check_data_dir ~data_dir = - let dummy_genesis = - { - Genesis.time = Time.Protocol.epoch; - block = Block_hash.zero; - protocol = Protocol_hash.zero; - } - in - Data_version.ensure_data_dir ~mode:Exists dummy_genesis data_dir - in - let* _id = - Identity_file.generate - ~check_data_dir - (identity_file data_dir) - expected_pow - in - return_unit) + let* {Config_file.data_dir; p2p = {expected_pow; _}; _} = + get_config data_dir config_file expected_pow + in + let check_data_dir ~data_dir = + let dummy_genesis = + { + Genesis.time = Time.Protocol.epoch; + block = Block_hash.zero; + protocol = Protocol_hash.zero; + } + in + Data_version.ensure_data_dir ~mode:Exists dummy_genesis data_dir + in + let* _id = + Identity_file.generate + ~check_data_dir + (identity_file data_dir) + expected_pow + in + return_unit) (** Main *) diff --git a/src/bin_node/node_replay_command.ml b/src/bin_node/node_replay_command.ml index a2deae5b735f5494a0ea5e6aa64524176ee29c5a..a4229ad5c580b823f72fba9a425279c358a4d7e4 100644 --- a/src/bin_node/node_replay_command.ml +++ b/src/bin_node/node_replay_command.ml @@ -34,10 +34,8 @@ module Event = struct ~name:"block_validation_start" ~msg:"replaying block {alias}{hash} ({level})" ~level:Notice - ~pp1: - (fun fmt -> function - | None -> () - | Some alias -> Format.fprintf fmt "%s: " alias) + ~pp1:(fun fmt -> function + | None -> () | Some alias -> Format.fprintf fmt "%s: " alias) ("alias", Data_encoding.(option string)) ~pp2:Block_hash.pp ("hash", Block_hash.encoding) diff --git a/src/bin_node/node_storage_command.ml b/src/bin_node/node_storage_command.ml index ea06bba0dab017afa508069e3bb5443b921a3a9f..0395dd96a570bf9da004860c5b1dd8e46abe73f3 100644 --- a/src/bin_node/node_storage_command.ml +++ b/src/bin_node/node_storage_command.ml @@ -115,31 +115,31 @@ module Term = struct let integrity_check config_file data_dir auto_repair = Shared_arg.process_command (let open Lwt_result_syntax in - let* root = root config_file data_dir in - let*! () = - Tezos_context.Context.Checks.Pack.Integrity_check.run - ~ppf:Format.std_formatter - ~root - ~auto_repair - ~always:false - ~heads:None - () - in - return_unit) + let* root = root config_file data_dir in + let*! () = + Tezos_context.Context.Checks.Pack.Integrity_check.run + ~ppf:Format.std_formatter + ~root + ~auto_repair + ~always:false + ~heads:None + () + in + return_unit) let stat_index config_file data_dir = Shared_arg.process_command (let open Lwt_result_syntax in - let* root = root config_file data_dir in - Tezos_context.Context.Checks.Index.Stat.run ~root ; - return_unit) + let* root = root config_file data_dir in + Tezos_context.Context.Checks.Index.Stat.run ~root ; + return_unit) let stat_pack config_file data_dir = Shared_arg.process_command (let open Lwt_result_syntax in - let* root = root config_file data_dir in - let*! () = Tezos_context.Context.Checks.Pack.Stat.run ~root in - return_unit) + let* root = root config_file data_dir in + let*! () = Tezos_context.Context.Checks.Pack.Stat.run ~root in + return_unit) let index_dir_exists context_dir output = let open Lwt_result_syntax in @@ -150,14 +150,14 @@ module Term = struct let reconstruct_index config_file data_dir output index_log_size = Shared_arg.process_command (let open Lwt_result_syntax in - let* root = root config_file data_dir in - let* () = index_dir_exists root output in - Tezos_context.Context.Checks.Pack.Reconstruct_index.run - ~root - ~output - ~index_log_size - () ; - return_unit) + let* root = root config_file data_dir in + let* () = index_dir_exists root output in + Tezos_context.Context.Checks.Pack.Reconstruct_index.run + ~root + ~output + ~index_log_size + () ; + return_unit) let resolve_block chain_store block = let open Lwt_result_syntax in @@ -173,74 +173,74 @@ module Term = struct let integrity_check_inodes config_file data_dir block = Shared_arg.process_command (let open Lwt_result_syntax in - let*! () = Tezos_base_unix.Internal_event_unix.init () in - let* data_dir, node_config = - Shared_arg.resolve_data_dir_and_config_file ?data_dir ?config_file () - in - let ({genesis; _} : Config_file.blockchain_network) = - node_config.blockchain_network - in - let chain_id = Chain_id.of_block_hash genesis.block in - let* () = Data_version.ensure_data_dir genesis data_dir in - let context_dir = Data_version.context_dir data_dir in - let store_dir = Data_version.store_dir data_dir in - let* store = - Store.init ~store_dir ~context_dir ~allow_testchains:false genesis - in - let* chain_store = Store.get_chain_store store chain_id in - let* block = resolve_block chain_store block in - let*! () = Store.close_store store in - let context_hash = Store.Block.context_hash block in - let context_hash_str = Context_hash.to_b58check context_hash in - let*! () = - Event.( - emit - integrity_info - (Store.Block.hash block, Store.Block.level block, context_hash)) - in - let*! () = - Tezos_context.Context.Checks.Pack.Integrity_check_inodes.run - ~root:context_dir - ~heads:(Some [context_hash_str]) - in - return_unit) + let*! () = Tezos_base_unix.Internal_event_unix.init () in + let* data_dir, node_config = + Shared_arg.resolve_data_dir_and_config_file ?data_dir ?config_file () + in + let ({genesis; _} : Config_file.blockchain_network) = + node_config.blockchain_network + in + let chain_id = Chain_id.of_block_hash genesis.block in + let* () = Data_version.ensure_data_dir genesis data_dir in + let context_dir = Data_version.context_dir data_dir in + let store_dir = Data_version.store_dir data_dir in + let* store = + Store.init ~store_dir ~context_dir ~allow_testchains:false genesis + in + let* chain_store = Store.get_chain_store store chain_id in + let* block = resolve_block chain_store block in + let*! () = Store.close_store store in + let context_hash = Store.Block.context_hash block in + let context_hash_str = Context_hash.to_b58check context_hash in + let*! () = + Event.( + emit + integrity_info + (Store.Block.hash block, Store.Block.level block, context_hash)) + in + let*! () = + Tezos_context.Context.Checks.Pack.Integrity_check_inodes.run + ~root:context_dir + ~heads:(Some [context_hash_str]) + in + return_unit) let check_index config_file data_dir auto_repair = Shared_arg.process_command (let open Lwt_result_syntax in - let* root = root config_file data_dir in - Tezos_context.Context.Checks.Pack.Integrity_check_index.run - ~root - ~auto_repair - () ; - return_unit) + let* root = root config_file data_dir in + Tezos_context.Context.Checks.Pack.Integrity_check_index.run + ~root + ~auto_repair + () ; + return_unit) let find_head config_file data_dir = Shared_arg.process_command (let open Lwt_result_syntax in - let*! () = Tezos_base_unix.Internal_event_unix.init () in - let* data_dir, node_config = - Shared_arg.resolve_data_dir_and_config_file ?data_dir ?config_file () - in - let ({genesis; _} : Config_file.blockchain_network) = - node_config.blockchain_network - in - let chain_id = Chain_id.of_block_hash genesis.block in - let* () = Data_version.ensure_data_dir genesis data_dir in - let context_dir = Data_version.context_dir data_dir in - let store_dir = Data_version.store_dir data_dir in - let* store = - Store.init ~store_dir ~context_dir ~allow_testchains:false genesis - in - let* chain_store = Store.get_chain_store store chain_id in - let*! head = Store.Chain.current_head chain_store in - let*! () = Store.close_store store in - let head_context_hash = Store.Block.context_hash head in - (* This output isn't particularly useful for most users, - it will typically be used to inspect context - directories using Irmin tooling *) - let () = Format.printf "%a@." Context_hash.pp head_context_hash in - return_unit) + let*! () = Tezos_base_unix.Internal_event_unix.init () in + let* data_dir, node_config = + Shared_arg.resolve_data_dir_and_config_file ?data_dir ?config_file () + in + let ({genesis; _} : Config_file.blockchain_network) = + node_config.blockchain_network + in + let chain_id = Chain_id.of_block_hash genesis.block in + let* () = Data_version.ensure_data_dir genesis data_dir in + let context_dir = Data_version.context_dir data_dir in + let store_dir = Data_version.store_dir data_dir in + let* store = + Store.init ~store_dir ~context_dir ~allow_testchains:false genesis + in + let* chain_store = Store.get_chain_store store chain_id in + let*! head = Store.Chain.current_head chain_store in + let*! () = Store.close_store store in + let head_context_hash = Store.Block.context_hash head in + (* This output isn't particularly useful for most users, + it will typically be used to inspect context + directories using Irmin tooling *) + let () = Format.printf "%a@." Context_hash.pp head_context_hash in + return_unit) let auto_repair = let open Cmdliner.Arg in diff --git a/src/bin_proxy_server/main_proxy_server.ml b/src/bin_proxy_server/main_proxy_server.ml index c348da09cc76e25559c4247f9dc42e81cf6967df..40cf4d19039e07689295e0178b03b92bee0d58cd 100644 --- a/src/bin_proxy_server/main_proxy_server.ml +++ b/src/bin_proxy_server/main_proxy_server.ml @@ -261,19 +261,19 @@ let main (config_file : string option) (log_requests : bool) in Lwt_main.run (let open Lwt_syntax in - let* r = - Lwt_exit.wrap_and_error - @@ main_promise config_file config_args log_requests - in - match r with - | Ok (Ok _) -> - let+ _ = Lwt_exit.exit_and_wait 0 in - `Ok () - | Ok (Error err) -> - let+ _ = Lwt_exit.exit_and_wait 2 in - `Error (false, Format.asprintf "%a" pp_print_trace err) - | Error exit_status -> - Lwt.return (`Error (false, Format.asprintf "Exited %d" exit_status))) + let* r = + Lwt_exit.wrap_and_error + @@ main_promise config_file config_args log_requests + in + match r with + | Ok (Ok _) -> + let+ _ = Lwt_exit.exit_and_wait 0 in + `Ok () + | Ok (Error err) -> + let+ _ = Lwt_exit.exit_and_wait 2 in + `Error (false, Format.asprintf "%a" pp_print_trace err) + | Error exit_status -> + Lwt.return (`Error (false, Format.asprintf "Exited %d" exit_status))) let term : unit Term.t = Term.( diff --git a/src/bin_snoop/commands.ml b/src/bin_snoop/commands.ml index 88d9b6621bccb1096b0f2ea44b1d0a5207fced4c..48047a3d6f4af1ee52bd0d00056e1d7bb1012658 100644 --- a/src/bin_snoop/commands.ml +++ b/src/bin_snoop/commands.ml @@ -1845,29 +1845,29 @@ let list_solvers, list_models = let result = Lwt_main.run (let open Lwt_result_syntax in - let* list_flags, args = - Tezos_clic.parse_global_options Global_options.options () original_args - in - match autocomplete with - | Some (prev_arg, cur_arg, script) -> - let* completions = - Tezos_clic.autocompletion - ~script - ~cur_arg - ~prev_arg - ~args:original_args - ~global_options:Global_options.options - commands_with_man - () - in - List.iter print_endline completions ; - return list_flags - | None -> ( - match args with - | [] -> return list_flags - | _ -> - let* () = Tezos_clic.dispatch commands_with_man () args in - return list_flags)) + let* list_flags, args = + Tezos_clic.parse_global_options Global_options.options () original_args + in + match autocomplete with + | Some (prev_arg, cur_arg, script) -> + let* completions = + Tezos_clic.autocompletion + ~script + ~cur_arg + ~prev_arg + ~args:original_args + ~global_options:Global_options.options + commands_with_man + () + in + List.iter print_endline completions ; + return list_flags + | None -> ( + match args with + | [] -> return list_flags + | _ -> + let* () = Tezos_clic.dispatch commands_with_man () args in + return list_flags)) in match result with | Ok global_options -> global_options diff --git a/src/bin_snoop/main_snoop.ml b/src/bin_snoop/main_snoop.ml index b67ee88685fb293fe27c258b4f6e5c63c688f567..b4847fd3648b050fd6d2752e130feaa49bec71fb 100644 --- a/src/bin_snoop/main_snoop.ml +++ b/src/bin_snoop/main_snoop.ml @@ -204,8 +204,8 @@ and infer_cmd_one_shot local_model_name workload_data solver let s = perform_report () in Lwt_main.run (let open Lwt_syntax in - let* _nwritten = Lwt_utils_unix.create_file output_file s in - Lwt.return_unit) ; + let* _nwritten = Lwt_utils_unix.create_file output_file s in + Lwt.return_unit) ; Format.eprintf "Produced report on %s@." output_file in process_output measure local_model_name problem solution infer_opts @@ -492,8 +492,8 @@ and infer_for_measurements ?local_model_name measurements let s = Report.to_latex report in Lwt_main.run (let open Lwt_syntax in - let* _nwritten = Lwt_utils_unix.create_file output_file s in - Lwt.return_unit) ; + let* _nwritten = Lwt_utils_unix.create_file output_file s in + Lwt.return_unit) ; Format.eprintf "Produced report on %s@." output_file | _ -> assert false) ; solution diff --git a/src/bin_tps_evaluation/benchmark_tps_command.ml b/src/bin_tps_evaluation/benchmark_tps_command.ml index 34636cc44fb0055dd314c10f21ef41454d60243f..0241861b324a72ea99b55d1c86f4f8159d81e0ea 100644 --- a/src/bin_tps_evaluation/benchmark_tps_command.ml +++ b/src/bin_tps_evaluation/benchmark_tps_command.ml @@ -130,11 +130,11 @@ let run_benchmark ~lift_protocol_limits ~provided_tps_of_injection ~blocks_total Protocol.write_parameter_file ~base:(Either.right (protocol, Some protocol_constants)) (if lift_protocol_limits then - [ - (["hard_gas_limit_per_block"], `String_of_int 2147483647); - (["hard_gas_limit_per_operation"], `String_of_int 2147483647); - ] - else []) + [ + (["hard_gas_limit_per_block"], `String_of_int 2147483647); + (["hard_gas_limit_per_operation"], `String_of_int 2147483647); + ] + else []) in (* It is important to use a good estimate of max possible TPS that is theoretically achievable. If we send operations with lower TPS than diff --git a/src/bin_wasm_debugger/custom_section.ml b/src/bin_wasm_debugger/custom_section.ml index 71e264728b26673dca41fef07270ce3310e6c4c1..19d42131772440b71c09d7d0ed9d181d907932a7 100644 --- a/src/bin_wasm_debugger/custom_section.ml +++ b/src/bin_wasm_debugger/custom_section.ml @@ -94,8 +94,8 @@ let parse_nameassoc bytes start = else let uchar = String.get_utf_8_uchar string index in (if Uchar.utf_decode_is_valid uchar then - let u = Uchar.utf_decode_uchar uchar in - if Uchar.is_char u then Buffer.add_char buffer (Uchar.to_char u)) ; + let u = Uchar.utf_decode_uchar uchar in + if Uchar.is_char u then Buffer.add_char buffer (Uchar.to_char u)) ; decode string (index + Uchar.utf_decode_length uchar) in let index = decode bytes start_index in diff --git a/src/lib_base/bounded.ml b/src/lib_base/bounded.ml index cb27193c09565ece5ac6cdf95a66a52ec22479ce..3d9a4f9ca39eeb693c5edac43f513d2e1b2dedbc 100644 --- a/src/lib_base/bounded.ml +++ b/src/lib_base/bounded.ml @@ -147,7 +147,7 @@ let checks (type ocaml_type) (ty : ocaml_type ty) ( < ) ( > ) ~min_value (ty_max_value ty) pp max_value) - [@@inline always] +[@@inline always] (* A partial encoding that ensures the decoded value is in the specified bounds. *) let guarded_encoding ty ~to_value ~of_value = @@ -157,11 +157,11 @@ let guarded_encoding ty ~to_value ~of_value = (fun x -> match of_value x with None -> Error "Out of bounds" | Some x -> Ok x) (encoding ty) - [@@inline always] +[@@inline always] let of_value ( < ) ( > ) ~min_value ~max_value x = if x < min_value then None else if x > max_value then None else Some x - [@@inline always] +[@@inline always] (* We introduce one functor by OCaml datatype so that comparison functions are statically known and consequently inlined. Using the @@ -210,10 +210,11 @@ end) (* The parameter [T] of this functor allows to choose the desired encoding without duplicating the interface. *) -module Make31 (T : sig - val ty : int ty -end) -(B : BOUNDS with type ocaml_type := int) = +module Make31 + (T : sig + val ty : int ty + end) + (B : BOUNDS with type ocaml_type := int) = struct include Compare.Int include B diff --git a/src/lib_base/unix/file_event_sink.ml b/src/lib_base/unix/file_event_sink.ml index 789a55f31b7e9affb37da58027177538d81ce814..75546049ef597c4d20116366d71af01577526f6c 100644 --- a/src/lib_base/unix/file_event_sink.ml +++ b/src/lib_base/unix/file_event_sink.ml @@ -119,7 +119,7 @@ module Event_filter = struct ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") (fun fmt s -> fprintf fmt "(Some %a)" Internal_event.Section.pp s)) l - [@@warning "-32"] + [@@warning "-32"] (* -> The "unused value" warning. *) @@ -475,16 +475,15 @@ module Query = struct fold_directory (path // date // time) ~init:(return previous) - ~f: - (fun previous -> function - | `Directory "." | `Directory ".." -> return previous - | `Regular_file file -> - f previous (path // date // time // file) - | `Directory p | `Special (_, p) -> - return_with_warning - previous - (`Expecting_regular_file_at - (path // date // time // p))) + ~f:(fun previous -> function + | `Directory "." | `Directory ".." -> return previous + | `Regular_file file -> + f previous (path // date // time // file) + | `Directory p | `Special (_, p) -> + return_with_warning + previous + (`Expecting_regular_file_at + (path // date // time // p))) | `Directory _ (* filtered out *) -> return previous | `Regular_file p | `Special (_, p) -> return_with_warning @@ -496,7 +495,8 @@ module Query = struct let handle_event_kind_directory (type a) ~time_query ~section_path ~init ~f ev = - let module Event = (val ev : Internal_event.EVENT_DEFINITION with type t = a) + let module Event = + (val ev : Internal_event.EVENT_DEFINITION with type t = a) in let handle_event_file previous path = let open Lwt_result_syntax in @@ -542,54 +542,51 @@ module Query = struct fold_directory sink_path ~init:(return ([], init)) - ~f: - (fun previous -> function - | `Directory ("." | "..") -> return previous - | `Directory dir -> ( - match Section_dir.section_name dir with - | Ok sec when section_matches sec -> - fold_directory - (sink_path // dir) - ~init:(return ([], init)) - ~f: - (fun previous -> function - | `Directory ("." | "..") -> return previous - | `Directory event_name when name_matches event_name - -> ( - let open Internal_event in - match All_definitions.find (( = ) event_name) with - | Some (Generic.Definition (_, _, ev)) -> - handle_event_kind_directory + ~f:(fun previous -> function + | `Directory ("." | "..") -> return previous + | `Directory dir -> ( + match Section_dir.section_name dir with + | Ok sec when section_matches sec -> + fold_directory + (sink_path // dir) + ~init:(return ([], init)) + ~f:(fun previous -> function + | `Directory ("." | "..") -> return previous + | `Directory event_name when name_matches event_name -> ( + let open Internal_event in + match All_definitions.find (( = ) event_name) with + | Some (Generic.Definition (_, _, ev)) -> + handle_event_kind_directory + ~time_query + ev + ~section_path:(sink_path // dir) + ~init:previous + ~f + | None -> ( + match on_unknown with + | None -> + return_with_warning + previous + (`Unknown_event_name_at + (event_name, sink_path // dir)) + | Some f -> + fold_event_kind_directory ~time_query - ev - ~section_path:(sink_path // dir) + (sink_path // dir // event_name) ~init:previous - ~f - | None -> ( - match on_unknown with - | None -> - return_with_warning - previous - (`Unknown_event_name_at - (event_name, sink_path // dir)) - | Some f -> - fold_event_kind_directory - ~time_query - (sink_path // dir // event_name) - ~init:previous - ~f:(fun prev file -> - let* () = f file in - return prev))) - | `Directory _ (* filtered out *) -> return previous - | `Regular_file p | `Special (_, p) -> - return_with_warning - previous - (`Expecting_directory_at (sink_path // p))) - | Ok _ (* section does not match *) -> return previous - | Error _ -> - return_with_error previous (`Cannot_recognize_section dir)) - | `Regular_file p | `Special (_, p) -> - return_with_warning - previous - (`Expecting_directory_at (sink_path // p))) + ~f:(fun prev file -> + let* () = f file in + return prev))) + | `Directory _ (* filtered out *) -> return previous + | `Regular_file p | `Special (_, p) -> + return_with_warning + previous + (`Expecting_directory_at (sink_path // p))) + | Ok _ (* section does not match *) -> return previous + | Error _ -> + return_with_error previous (`Cannot_recognize_section dir)) + | `Regular_file p | `Special (_, p) -> + return_with_warning + previous + (`Expecting_directory_at (sink_path // p))) end diff --git a/src/lib_benchmark/fixed_point_transform.ml b/src/lib_benchmark/fixed_point_transform.ml index c0293bd8f339b5b676dcd1def825bf83dc81b82b..173895413d6236132cd8f70eac2b762d9f1fabc6 100644 --- a/src/lib_benchmark/fixed_point_transform.ml +++ b/src/lib_benchmark/fixed_point_transform.ml @@ -348,10 +348,11 @@ end It is assumed that the term is _closed_, i.e. contains no free variables. *) -module Convert_mult (P : sig - val options : options -end) -(X : Costlang.S) : sig +module Convert_mult + (P : sig + val options : options + end) + (X : Costlang.S) : sig include Costlang.S with type size = X.size val prj : 'a repr -> 'a X.repr diff --git a/src/lib_benchmark/lib_micheline_rewriting/custom_weak.ml b/src/lib_benchmark/lib_micheline_rewriting/custom_weak.ml index 2cefe1dcb9c3879e455fad8ac16bb50e42485b3f..130b63d01102cd8eb4dd89cb1e155aede05c0f67 100644 --- a/src/lib_benchmark/lib_micheline_rewriting/custom_weak.ml +++ b/src/lib_benchmark/lib_micheline_rewriting/custom_weak.ml @@ -122,13 +122,13 @@ module Make_table (H : Hashtbl.HashedType) = struct in loop 0 (Weak.length bucket - 1) ; (if prev_len = 0 then ( - t.table.(t.rover) <- emptybucket ; - t.hashes.(t.rover) <- [||]) - else - let newbucket = weak_create prev_len in - Weak.blit bucket 0 newbucket 0 prev_len ; - t.table.(t.rover) <- newbucket ; - t.hashes.(t.rover) <- Array.sub hbucket 0 prev_len) ; + t.table.(t.rover) <- emptybucket ; + t.hashes.(t.rover) <- [||]) + else + let newbucket = weak_create prev_len in + Weak.blit bucket 0 newbucket 0 prev_len ; + t.table.(t.rover) <- newbucket ; + t.hashes.(t.rover) <- Array.sub hbucket 0 prev_len) ; if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1) ; t.rover <- (t.rover + 1) mod Array.length t.table diff --git a/src/lib_benchmark/lib_micheline_rewriting/micheline_with_hash_consing.ml b/src/lib_benchmark/lib_micheline_rewriting/micheline_with_hash_consing.ml index 918f5360dbf4e240d24378bac2d4a4559f7be0b2..ac920595dd3557bf4d5723a7f7cb97dc33ecb03b 100644 --- a/src/lib_benchmark/lib_micheline_rewriting/micheline_with_hash_consing.ml +++ b/src/lib_benchmark/lib_micheline_rewriting/micheline_with_hash_consing.ml @@ -32,7 +32,8 @@ open Custom_weak type hcons_info = {tag : int; hash : int} module Make - (X : Algebraic_signature.S) (P : sig + (X : Algebraic_signature.S) + (P : sig val initial_size : int option end) : Micheline_sig.S with type label = hcons_info and type head = X.t = struct diff --git a/src/lib_benchmark/lib_micheline_rewriting/micheline_without_hash_consing.ml b/src/lib_benchmark/lib_micheline_rewriting/micheline_without_hash_consing.ml index e1d4cb8689261a995ec81a94e5a6b8c5e0517774..f9b1b97ee8d159e8df24f35005697d93e1e823f3 100644 --- a/src/lib_benchmark/lib_micheline_rewriting/micheline_without_hash_consing.ml +++ b/src/lib_benchmark/lib_micheline_rewriting/micheline_without_hash_consing.ml @@ -24,7 +24,8 @@ (*****************************************************************************) module Make - (X : Algebraic_signature.S) (Label : sig + (X : Algebraic_signature.S) + (Label : sig type t val default : t diff --git a/src/lib_benchmark/measure.ml b/src/lib_benchmark/measure.ml index 2f9fd0ce7b6e470c2a8f84dfec68cd04e4f46ad9..3620f416151584a846cded1370383f48e01f7b46 100644 --- a/src/lib_benchmark/measure.ml +++ b/src/lib_benchmark/measure.ml @@ -358,11 +358,11 @@ let collect_stats : 'a workload_data -> workloads_stats = module Time = struct external get_time_ns : unit -> (int64[@unboxed]) = "caml_clock_gettime_byte" "caml_clock_gettime" - [@@noalloc] + [@@noalloc] external clock_getres : unit -> (int64[@unboxed]) = "caml_clock_getres_byte" "caml_clock_getres" - [@@noalloc] + [@@noalloc] let measure f = let bef = get_time_ns () in @@ -370,7 +370,7 @@ module Time = struct let aft = get_time_ns () in let dt = Int64.(to_float (sub aft bef)) in dt - [@@inline always] + [@@inline always] let measure_and_return f = let bef = get_time_ns () in @@ -378,7 +378,7 @@ module Time = struct let aft = get_time_ns () in let dt = Int64.(to_float (sub aft bef)) in (dt, x) - [@@inline always] + [@@inline always] let check_timer_resolution () = let ns = clock_getres () in @@ -408,7 +408,7 @@ let compute_empirical_timing_distribution : done ; let shape = Linalg.Tensor.Int.rank_one nsamples in Linalg.Vec.Float.make shape (fun i -> buffer.{i + start}) - [@@ocaml.inline] +[@@ocaml.inline] let seed_init_from_options (options : options) = match options.seed with diff --git a/src/lib_benchmark/model.ml b/src/lib_benchmark/model.ml index 2b5f707a6e0eca43a570daf1ed0bd885fe1d20bb..03eb01cfb1469d8341435062717404bb36e94a76 100644 --- a/src/lib_benchmark/model.ml +++ b/src/lib_benchmark/model.ml @@ -104,25 +104,25 @@ let pp ppf = function sub_models let apply_model : 'arg -> 'arg model -> applied = - fun (type e) (elim : e) ((module Impl) : e model) -> - let module Applied (X : Costlang.S) = struct - include Impl.Def (X) - - type t = X.size X.repr - - let rec apply : - type a b c. - (int -> c X.repr) -> (c, a, b) arity -> a X.repr -> b -> c X.repr = - fun conv arity f arg -> - match arity with - | Zero_arity -> f - | Succ_arity ar -> - let arg, rest = arg in - apply conv ar (X.app f (conv arg)) rest - - let applied = apply X.int arity model elim - end in - ((module Applied) : applied) + fun (type e) (elim : e) ((module Impl) : e model) -> + let module Applied (X : Costlang.S) = struct + include Impl.Def (X) + + type t = X.size X.repr + + let rec apply : + type a b c. + (int -> c X.repr) -> (c, a, b) arity -> a X.repr -> b -> c X.repr = + fun conv arity f arg -> + match arity with + | Zero_arity -> f + | Succ_arity ar -> + let arg, rest = arg in + apply conv ar (X.app f (conv arg)) rest + + let applied = apply X.int arity model elim + end in + ((module Applied) : applied) module Instantiate (X : Costlang.S) (M : Model_impl) : Instantiated @@ -802,7 +802,8 @@ end module Synthesize (B : Binary_operation) (X : Model_impl) - (Y : Model_impl with type arg_type = X.arg_type) (Names : sig + (Y : Model_impl with type arg_type = X.arg_type) + (Names : sig val name : Namespace.t val x_label : string diff --git a/src/lib_benchmark/plot.ml b/src/lib_benchmark/plot.ml index 69a91e36e3cca671e60114fc4bd011ef35dec33f..eb95bcade90799806adf815d3f0f6a658dc9f2d7 100644 --- a/src/lib_benchmark/plot.ml +++ b/src/lib_benchmark/plot.ml @@ -852,54 +852,54 @@ end = struct GP_subcommand.t list -> string list -> GP_data.t list * GP_subcommand.t list * string list = - fun (type dim) - (axes : dim axes) - (specs : dim spec list) - data_acc - cmd_acc - name_acc -> - match specs with - | [] -> (List.rev data_acc, List.rev cmd_acc, List.rev name_acc) - | Scatter {data; error_bars} :: tl -> - let `Data data_block, `Command command_chunk, data_name = - scatter axes data error_bars - in - spec_list - axes - tl - (data_block :: data_acc) - (command_chunk :: cmd_acc) - (data_name :: name_acc) - | Histogram {data; options; legend} :: tl -> - let `Data data_block, `Command command_chunk, data_name = - histogram data options legend - in - spec_list - axes - tl - (data_block :: data_acc) - (command_chunk :: cmd_acc) - (data_name :: name_acc) - | Line {data; with_points; error_bars} :: tl -> - let `Data data_block, `Command command_chunk, data_name = - line axes data with_points error_bars - in - spec_list - axes - tl - (data_block :: data_acc) - (command_chunk :: cmd_acc) - (data_name :: name_acc) - | Boxes {data; box_width; fill} :: tl -> - let `Data data_block, `Command command_chunk, data_name = - boxes data box_width fill - in - spec_list - axes - tl - (data_block :: data_acc) - (command_chunk :: cmd_acc) - (data_name :: name_acc) + fun (type dim) + (axes : dim axes) + (specs : dim spec list) + data_acc + cmd_acc + name_acc -> + match specs with + | [] -> (List.rev data_acc, List.rev cmd_acc, List.rev name_acc) + | Scatter {data; error_bars} :: tl -> + let `Data data_block, `Command command_chunk, data_name = + scatter axes data error_bars + in + spec_list + axes + tl + (data_block :: data_acc) + (command_chunk :: cmd_acc) + (data_name :: name_acc) + | Histogram {data; options; legend} :: tl -> + let `Data data_block, `Command command_chunk, data_name = + histogram data options legend + in + spec_list + axes + tl + (data_block :: data_acc) + (command_chunk :: cmd_acc) + (data_name :: name_acc) + | Line {data; with_points; error_bars} :: tl -> + let `Data data_block, `Command command_chunk, data_name = + line axes data with_points error_bars + in + spec_list + axes + tl + (data_block :: data_acc) + (command_chunk :: cmd_acc) + (data_name :: name_acc) + | Boxes {data; box_width; fill} :: tl -> + let `Data data_block, `Command command_chunk, data_name = + boxes data box_width fill + in + spec_list + axes + tl + (data_block :: data_acc) + (command_chunk :: cmd_acc) + (data_name :: name_acc) let render ?save (Plot {axes; plots; title}) = let title_cmd = diff --git a/src/lib_bls12_381/g1.ml b/src/lib_bls12_381/g1.ml index 7fd845f477338cf49163c6a4568312952e08991b..16a719b7c07c8e216c8e76a3a815d56af541e49b 100644 --- a/src/lib_bls12_381/g1.ml +++ b/src/lib_bls12_381/g1.ml @@ -83,7 +83,8 @@ module Stubs = struct Bytes.t -> Unsigned.Size_t.t -> int - = "caml_blst_p1_hash_to_curve_stubs_bytecode" "caml_blst_p1_hash_to_curve_stubs" + = "caml_blst_p1_hash_to_curve_stubs_bytecode" + "caml_blst_p1_hash_to_curve_stubs" external memcpy : jacobian -> jacobian -> int = "caml_blst_p1_memcpy_stubs" @@ -344,18 +345,18 @@ module G1 = struct if start < 0 || len < 1 || start + len > n then raise @@ Invalid_argument (Format.sprintf "start %i len %i" start len) ; (if len = 1 then ( - ignore @@ Stubs.continuous_array_get buffer ps start ; - mul_inplace buffer ss.(start)) - else - let res = - Stubs.pippenger_with_affine_array - buffer - ps - ss - (Unsigned.Size_t.of_int start) - (Unsigned.Size_t.of_int len) - in - assert (res = 0)) ; + ignore @@ Stubs.continuous_array_get buffer ps start ; + mul_inplace buffer ss.(start)) + else + let res = + Stubs.pippenger_with_affine_array + buffer + ps + ss + (Unsigned.Size_t.of_int start) + (Unsigned.Size_t.of_int len) + in + assert (res = 0)) ; buffer end diff --git a/src/lib_bls12_381/g2.ml b/src/lib_bls12_381/g2.ml index 9683eef710d19de214b34191173ff09551d2d464..4fb5452cb1a3067812a6b3d037076c8efa8e3abb 100644 --- a/src/lib_bls12_381/g2.ml +++ b/src/lib_bls12_381/g2.ml @@ -82,7 +82,8 @@ module Stubs = struct Bytes.t -> Unsigned.Size_t.t -> int - = "caml_blst_p2_hash_to_curve_stubs_bytecode" "caml_blst_p2_hash_to_curve_stubs" + = "caml_blst_p2_hash_to_curve_stubs_bytecode" + "caml_blst_p2_hash_to_curve_stubs" external memcpy : jacobian -> jacobian -> int = "caml_blst_p2_memcpy_stubs" @@ -376,18 +377,18 @@ module G2 = struct if start < 0 || len < 1 || start + len > n then raise @@ Invalid_argument (Format.sprintf "start %i len %i" start len) ; (if len = 1 then ( - ignore @@ Stubs.continuous_array_get buffer ps start ; - mul_inplace buffer ss.(start)) - else - let res = - Stubs.pippenger_with_affine_array - buffer - ps - ss - (Unsigned.Size_t.of_int start) - (Unsigned.Size_t.of_int len) - in - assert (res = 0)) ; + ignore @@ Stubs.continuous_array_get buffer ps start ; + mul_inplace buffer ss.(start)) + else + let res = + Stubs.pippenger_with_affine_array + buffer + ps + ss + (Unsigned.Size_t.of_int start) + (Unsigned.Size_t.of_int len) + in + assert (res = 0)) ; buffer end diff --git a/src/lib_bls12_381_hash/anemoi.ml b/src/lib_bls12_381_hash/anemoi.ml index 0d16b6efc4ffcb13048fc6bc94c4796790291e1e..1c1a81a23b74eabfdc3dc3ee8ffb30bb8a1abc21 100644 --- a/src/lib_bls12_381_hash/anemoi.ml +++ b/src/lib_bls12_381_hash/anemoi.ml @@ -33,7 +33,8 @@ module Stubs = struct int -> int -> ctxt - = "caml_bls12_381_hash_anemoi_allocate_ctxt_stubs_bytecode" "caml_bls12_381_hash_anemoi_allocate_ctxt_stubs" + = "caml_bls12_381_hash_anemoi_allocate_ctxt_stubs_bytecode" + "caml_bls12_381_hash_anemoi_allocate_ctxt_stubs" end module Parameters = struct diff --git a/src/lib_bls12_381_hash/bls12_381_hash.mli b/src/lib_bls12_381_hash/bls12_381_hash.mli index 05a8df87455d4d4d7da1a9bd70cf3f1e0628c521..3486f3ad86255cb6ff358e038584e83fe1855627 100644 --- a/src/lib_bls12_381_hash/bls12_381_hash.mli +++ b/src/lib_bls12_381_hash/bls12_381_hash.mli @@ -89,11 +89,11 @@ module Permutation : sig the library. *) val create : int -> int -> Bls12_381.Fr.t array array -> t - [@@deprecated - "It is highly recommended to follow the recommandation in the paper \ - for the choice of security parameters. Please open an issue if you \ - need support for other instances than the default parameters \ - provided by the library."] + [@@deprecated + "It is highly recommended to follow the recommandation in the paper \ + for the choice of security parameters. Please open an issue if you \ + need support for other instances than the default parameters provided \ + by the library."] (** Exponent for the substitution box. For BLS12-381, it is [5] *) val alpha : Bls12_381.Fr.t diff --git a/src/lib_bls12_381_hash/poseidon.ml b/src/lib_bls12_381_hash/poseidon.ml index b17a39cdd7ddb86a583cac926c2ac8d1e572a2d5..740dfd74d4c526ef4cd7b06a9e344b68ba0e390e 100644 --- a/src/lib_bls12_381_hash/poseidon.ml +++ b/src/lib_bls12_381_hash/poseidon.ml @@ -11,7 +11,8 @@ module Stubs = struct ark:Bls12_381.Fr.t array -> mds:Bls12_381.Fr.t array array -> ctxt - = "caml_bls12_381_hash_poseidon_allocate_ctxt_stubs_bytecode" "caml_bls12_381_hash_poseidon_allocate_ctxt_stubs" + = "caml_bls12_381_hash_poseidon_allocate_ctxt_stubs_bytecode" + "caml_bls12_381_hash_poseidon_allocate_ctxt_stubs" external get_state : Bls12_381.Fr.t array -> ctxt -> unit = "caml_bls12_381_hash_poseidon_get_state_stubs" diff --git a/src/lib_bls12_381_polynomial/carray.ml b/src/lib_bls12_381_polynomial/carray.ml index ceb86c4fdf9bd95171075ff395cd4dddc79a435d..0c857794e98f0877d892979df109664a70c1411b 100644 --- a/src/lib_bls12_381_polynomial/carray.ml +++ b/src/lib_bls12_381_polynomial/carray.ml @@ -105,7 +105,7 @@ module Make (Elt : Elt_sig) : Carray_sig with type elt = Elt.t = struct - ensures: [elt = p[i]] *) external get : elt -> t -> int -> int -> unit = "caml_bls12_381_polynomial_polynomial_carray_get_stubs" - [@@noalloc] + [@@noalloc] (** [set p elt i size] copies [elt] in the [i]-th element of [p], assuming elements of [size] bytes. @@ -113,13 +113,13 @@ module Make (Elt : Elt_sig) : Carray_sig with type elt = Elt.t = struct - ensures: [elt = p[i]] *) external set : t -> elt -> int -> int -> unit = "caml_bls12_381_polynomial_polynomial_carray_set_stubs" - [@@noalloc] + [@@noalloc] (** [memset_zero p n] writes [n] bytes of zeros in [p] - requires: [n <= size p] *) external memset_zero : t -> int -> unit = "caml_bls12_381_polynomial_polynomial_memset_zero_stubs" - [@@noalloc] + [@@noalloc] end let t : t Repr.t = diff --git a/src/lib_bls12_381_polynomial/domain.ml b/src/lib_bls12_381_polynomial/domain.ml index 38461b22b14fedabacd8588cfcc6b5206a21ee88..2623ac9b94ecf4bddb144f50257b19d9f3558210 100644 --- a/src/lib_bls12_381_polynomial/domain.ml +++ b/src/lib_bls12_381_polynomial/domain.ml @@ -40,7 +40,7 @@ module Stubs = struct - [res[i] = g^i] for [i = 0..(n-1)] *) external compute_domain : fr_array -> int -> fr -> unit = "caml_bls12_381_polynomial_polynomial_compute_domain_stubs" - [@@noalloc] + [@@noalloc] (** [rescale res a size_res size_a] writes the result of rescaling the evaluation representation of a polynomial [a] from [domain_a] of size [size_a] to @@ -54,7 +54,7 @@ module Stubs = struct - [size_res mod size_a = 0] *) external rescale : fr_array -> fr_array -> int -> int -> unit = "caml_bls12_381_polynomial_polynomial_evaluations_rescale_stubs" - [@@noalloc] + [@@noalloc] end module Domain_impl = struct diff --git a/src/lib_bls12_381_polynomial/evaluations.ml b/src/lib_bls12_381_polynomial/evaluations.ml index c782e6d8f20650502b229f76163bee43569aa9e8..02979b788d5e73386bb9f9dd11de8fb8c7720742 100644 --- a/src/lib_bls12_381_polynomial/evaluations.ml +++ b/src/lib_bls12_381_polynomial/evaluations.ml @@ -43,7 +43,7 @@ module Stubs = struct - [size_b mod size_a = 0] *) external add : fr_array -> fr_array -> fr_array -> int -> int -> unit = "caml_bls12_381_polynomial_polynomial_evaluations_add_stubs" - [@@noalloc] + [@@noalloc] (** [mul_arrays res eval_evallen_comp_power_powlen size_res nb_evals] writes the result of computing [p₁(gᶜ₁·x)ᵐ₁·p₂(gᶜ₂·x)ᵐ₂·…·pₖ(gᶜₖ·x)ᵐₖ] using @@ -69,7 +69,7 @@ module Stubs = struct int -> int -> unit = "caml_bls12_381_polynomial_polynomial_evaluations_mul_arrays_stubs" - [@@noalloc] + [@@noalloc] (** [linear_arrays res eval_evallen_coeff_comp add_constant size_res nb_evals] writes the result of computing @@ -91,7 +91,7 @@ module Stubs = struct external linear_arrays : fr_array -> (fr_array * int * fr * int) array -> fr -> int -> int -> unit = "caml_bls12_381_polynomial_polynomial_evaluations_linear_arrays_stubs" - [@@noalloc] + [@@noalloc] (** [fft_inplace p domain log log_degree] computes Fast Fourier Transform. It converts the coefficient representation of a polynomial [p] to @@ -117,7 +117,7 @@ module Stubs = struct [n]-th root of unity and [n = 2^log] (as done by {!Domain.Stubs.compute_domain}) *) external ifft_inplace : fr_array -> domain:fr_array -> log:int -> unit = "caml_bls12_381_polynomial_ifft_inplace_on_stubs" - [@@noalloc] + [@@noalloc] (** [dft_inplace coefficients domain inverse length] computes the Fourier Transform. @@ -130,7 +130,7 @@ module Stubs = struct [n]-th root of unity (as done by {!Domain.Stubs.compute_domain}) *) external dft_inplace : fr_array -> fr_array -> bool -> int -> unit = "caml_bls12_381_polynomial_dft_stubs" - [@@noalloc] + [@@noalloc] (** [fft_prime_factor_algorithm_inplace coefficient (domain1, domain1_length) (domain2, domain2_length) inverse] computes the Fast Fourier Transform following @@ -149,7 +149,7 @@ module Stubs = struct external fft_prime_factor_algorithm_inplace : fr_array -> fr_array * int -> fr_array * int -> bool -> unit = "caml_bls12_381_polynomial_prime_factor_algorithm_fft_stubs" - [@@noalloc] + [@@noalloc] end module type Evaluations_sig = sig diff --git a/src/lib_bls12_381_polynomial/polynomial.ml b/src/lib_bls12_381_polynomial/polynomial.ml index f89acdd09cc6142ca2e91d3f9289ee4391659d02..29b84b57afe9b5fe34822fdbb853f4a91a4b9d73 100644 --- a/src/lib_bls12_381_polynomial/polynomial.ml +++ b/src/lib_bls12_381_polynomial/polynomial.ml @@ -41,7 +41,7 @@ module Stubs = struct - [size p = n] *) external of_sparse : fr_array -> (fr * int) array -> int -> unit = "caml_bls12_381_polynomial_polynomial_of_sparse_stubs" - [@@noalloc] + [@@noalloc] (** [add res a b size_a size_b] writes the result of polynomial addition of [a] and [b] in [res] @@ -53,7 +53,7 @@ module Stubs = struct - [res], [a] and [b] are either pairwise disjoint or equal *) external add : fr_array -> fr_array -> fr_array -> int -> int -> unit = "caml_bls12_381_polynomial_polynomial_add_stubs" - [@@noalloc] + [@@noalloc] (** [sub res a b size_a size_b] writes the result of polynomial subtraction of [b] from [a] in [res] @@ -65,7 +65,7 @@ module Stubs = struct - [res], [a] and [b] are either pairwise disjoint or equal *) external sub : fr_array -> fr_array -> fr_array -> int -> int -> unit = "caml_bls12_381_polynomial_polynomial_sub_stubs" - [@@noalloc] + [@@noalloc] (** [mul res a b size_a size_b] writes the result of polynomial multiplication of [a] by [b] in [res] @@ -77,7 +77,7 @@ module Stubs = struct - [size res = size_a + size_b - 1] *) external mul : fr_array -> fr_array -> fr_array -> int -> int -> unit = "caml_bls12_381_polynomial_polynomial_mul_stubs" - [@@noalloc] + [@@noalloc] (** [mul_by_scalar res b a size_a] writes the result of multiplying a polynomial [a] by a blst_fr element [b] in [res] @@ -88,7 +88,7 @@ module Stubs = struct - [res] and [a] either disjoint or equal *) external mul_by_scalar : fr_array -> fr -> fr_array -> int -> unit = "caml_bls12_381_polynomial_polynomial_mul_by_scalar_stubs" - [@@noalloc] + [@@noalloc] (** [linear res poly_polylen_coeff nb_polys] writes the result of computing [λ₁·p₁(x) + λ₂·p₂(x) + … + λₖ·pₖ(x)] in [res], where @@ -102,7 +102,7 @@ module Stubs = struct - [size p_i = size_p_i] *) external linear : fr_array -> (fr_array * int * fr) array -> int -> unit = "caml_bls12_381_polynomial_polynomial_linear_stubs" - [@@noalloc] + [@@noalloc] (** [linear_with_powers res c poly_polylen nb_polys] writes the result of computing [c⁰·p₀(x) + c¹·p₁(x) + … + cᵏ·pₖ(x)] in [res], where @@ -117,7 +117,7 @@ module Stubs = struct external linear_with_powers : fr_array -> fr -> (fr_array * int) array -> int -> unit = "caml_bls12_381_polynomial_polynomial_linear_with_powers_stubs" - [@@noalloc] + [@@noalloc] (** [negate res p n] writes the result of negating a polynomial [p] in [res] @@ -127,7 +127,7 @@ module Stubs = struct - [res] and [p] either disjoint or equal *) external negate : fr_array -> fr_array -> int -> unit = "caml_bls12_381_polynomial_polynomial_negate_stubs" - [@@noalloc] + [@@noalloc] (** [evaluate res p n x] writes the result of evaluating a polynomial [p] at [x] in [res] @@ -135,7 +135,7 @@ module Stubs = struct - requires: [size p = n] and [n > 0] *) external evaluate : fr -> fr_array -> int -> fr -> unit = "caml_bls12_381_polynomial_polynomial_evaluate_stubs" - [@@noalloc] + [@@noalloc] (** [division_xn res_q res_r p size_p (n, c)] writes the quotient and remainder of the division of a polynomial [p] by [(X^n + c)] in [res] @@ -147,7 +147,7 @@ module Stubs = struct external division_xn : fr_array -> fr_array -> fr_array -> int -> int * fr -> unit = "caml_bls12_381_polynomial_polynomial_division_xn_stubs" - [@@noalloc] + [@@noalloc] (** [mul_xn res p size_p n c] writes the result of multiplying a polynomial [p] by [(X^n + c)] in [res] @@ -158,11 +158,11 @@ module Stubs = struct - [size res = size_p + n] *) external mul_xn : fr_array -> fr_array -> int -> int -> fr -> unit = "caml_bls12_381_polynomial_polynomial_mul_xn_stubs" - [@@noalloc] + [@@noalloc] external derivative : fr_array -> fr_array -> int -> unit = "caml_bls12_381_polynomial_polynomial_derivative_stubs" - [@@noalloc] + [@@noalloc] end module Polynomial_impl = struct diff --git a/src/lib_bls12_381_polynomial/srs.ml b/src/lib_bls12_381_polynomial/srs.ml index d524a09846f72ea89e83beb0000e9a409ed88b7c..9482cf33a17b1604539479fb179abaab68840404 100644 --- a/src/lib_bls12_381_polynomial/srs.ml +++ b/src/lib_bls12_381_polynomial/srs.ml @@ -205,11 +205,11 @@ module Elt_g1 = struct let eq a b = G.eq (G.jacobian_of_affine a) (G.jacobian_of_affine b) external uncompress : t -> bytes -> int = "caml_blst_p1_uncompress_stubs" - [@@noalloc] + [@@noalloc] external pippenger : G.t -> Bigstringaf.t -> Polynomial.t -> int -> int -> int = "caml_bls12_381_polynomial_srs_g1_pippenger_stubs" - [@@noalloc] + [@@noalloc] end module Elt_g2 = struct @@ -227,11 +227,11 @@ module Elt_g2 = struct external uncompress : G.affine -> bytes -> int = "caml_blst_p2_uncompress_stubs" - [@@noalloc] + [@@noalloc] external pippenger : G.t -> Bigstringaf.t -> Polynomial.t -> int -> int -> int = "caml_bls12_381_polynomial_srs_g2_pippenger_stubs" - [@@noalloc] + [@@noalloc] end module Srs_g1 : diff --git a/src/lib_bls12_381_signature/bls12_381_signature.ml b/src/lib_bls12_381_signature/bls12_381_signature.ml index 80a8d772c3c83ae3a0ca6534e45925cab264c399..72779d7c39bd51d3644538083ef66fecbe5e4e0e 100644 --- a/src/lib_bls12_381_signature/bls12_381_signature.ml +++ b/src/lib_bls12_381_signature/bls12_381_signature.ml @@ -136,7 +136,8 @@ module MinPk = struct Bytes.t -> Unsigned.Size_t.t -> int - = "caml_bls12_381_signature_blst_pairing_chk_n_mul_n_aggr_pk_in_g1_stubs_bytecode" "caml_bls12_381_signature_blst_pairing_chk_n_mul_n_aggr_pk_in_g1_stubs" + = "caml_bls12_381_signature_blst_pairing_chk_n_mul_n_aggr_pk_in_g1_stubs_bytecode" + "caml_bls12_381_signature_blst_pairing_chk_n_mul_n_aggr_pk_in_g1_stubs" end type pk = Bytes.t @@ -442,7 +443,8 @@ module MinSig = struct Bytes.t -> Unsigned.Size_t.t -> int - = "caml_bls12_381_signature_blst_pairing_chk_n_mul_n_aggr_pk_in_g2_stubs_bytecode" "caml_bls12_381_signature_blst_pairing_chk_n_mul_n_aggr_pk_in_g2_stubs" + = "caml_bls12_381_signature_blst_pairing_chk_n_mul_n_aggr_pk_in_g2_stubs_bytecode" + "caml_bls12_381_signature_blst_pairing_chk_n_mul_n_aggr_pk_in_g2_stubs" end type pk = Bytes.t diff --git a/src/lib_bls12_381_signature/test/test_signature.ml b/src/lib_bls12_381_signature/test/test_signature.ml index 1fc70feb7684df7149e0df529fe0819bd05f9268..c3053063db12f98898e96399955b82f110b186ee 100644 --- a/src/lib_bls12_381_signature/test/test_signature.ml +++ b/src/lib_bls12_381_signature/test/test_signature.ml @@ -132,22 +132,23 @@ let test_keygen_raise_invalid_argument_if_ikm_too_small () = (* Both can be used i.e. MinPk or MinSig. They must share the same interface. *) module type SIGNATURE_INSTANTIATION = module type of Bls12_381_signature.MinPk -module MakeTestsForInstantiation (MISC : sig - val sig_basic_filenames : string list +module MakeTestsForInstantiation + (MISC : sig + val sig_basic_filenames : string list - val sig_aug_filenames : string list + val sig_aug_filenames : string list - val sig_pop_filenames : string list + val sig_pop_filenames : string list - val pop_filenames : string list + val pop_filenames : string list - val pk_not_in_subgroup : string list + val pk_not_in_subgroup : string list - val signature_not_in_subgroup : string list -end) -(PkGroup : Bls12_381.CURVE) -(SigGroup : Bls12_381.CURVE) -(SignatureM : SIGNATURE_INSTANTIATION) = + val signature_not_in_subgroup : string list + end) + (PkGroup : Bls12_381.CURVE) + (SigGroup : Bls12_381.CURVE) + (SignatureM : SIGNATURE_INSTANTIATION) = struct let test_pk_size_in_bytes () = let ikm = generate_random_bytes 32 in diff --git a/src/lib_clic/tezos_clic.ml b/src/lib_clic/tezos_clic.ml index 783a273270d30ab9d7d02067490b4da33f073d27..5262ed58774f7f728d10582f3aaea4831d75166e 100644 --- a/src/lib_clic/tezos_clic.ml +++ b/src/lib_clic/tezos_clic.ml @@ -1108,7 +1108,7 @@ let search_command keyword (Command {params; _}) = (* Command execution *) let exec (type ctx) (Command {options = options_spec; params = spec; handler; conv; _} as - command) (ctx : ctx) params args_dict = + command) (ctx : ctx) params args_dict = let open Lwt_result_syntax in let rec exec : type ctx a. diff --git a/src/lib_client_base/client_context.ml b/src/lib_client_base/client_context.ml index a5014b74f4f664ee9b1d833b87c26c00e30d534e..aba83475f91063abb08ff906a78994e9eec11ad8 100644 --- a/src/lib_client_base/client_context.ml +++ b/src/lib_client_base/client_context.ml @@ -26,34 +26,31 @@ type ('a, 'b) lwt_format = ('a, Format.formatter, unit, 'b Lwt.t) format4 -class type printer = - object - method error : ('a, 'b) lwt_format -> 'a +class type printer = object + method error : ('a, 'b) lwt_format -> 'a - method warning : ('a, unit) lwt_format -> 'a + method warning : ('a, unit) lwt_format -> 'a - method message : ('a, unit) lwt_format -> 'a + method message : ('a, unit) lwt_format -> 'a - method answer : ('a, unit) lwt_format -> 'a + method answer : ('a, unit) lwt_format -> 'a - method log : string -> ('a, unit) lwt_format -> 'a - end + method log : string -> ('a, unit) lwt_format -> 'a +end -class type prompter = - object - method prompt : ('a, string tzresult) lwt_format -> 'a +class type prompter = object + method prompt : ('a, string tzresult) lwt_format -> 'a - method prompt_password : ('a, Bytes.t tzresult) lwt_format -> 'a + method prompt_password : ('a, Bytes.t tzresult) lwt_format -> 'a - method multiple_password_retries : bool - end + method multiple_password_retries : bool +end -class type io = - object - inherit printer +class type io = object + inherit printer - inherit prompter - end + inherit prompter +end class simple_printer log = let message x = Format.kasprintf (fun msg -> log "stdout" msg) x in @@ -72,87 +69,79 @@ class simple_printer log = fun name -> Format.kasprintf (fun msg -> log name msg) end -class type wallet = - object - method load_passwords : string Lwt_stream.t option +class type wallet = object + method load_passwords : string Lwt_stream.t option - method read_file : string -> string tzresult Lwt.t + method read_file : string -> string tzresult Lwt.t - method with_lock : (unit -> 'a Lwt.t) -> 'a Lwt.t + method with_lock : (unit -> 'a Lwt.t) -> 'a Lwt.t - method load : - string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t + method load : + string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t - method write : - string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t + method write : + string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t - method last_modification_time : string -> float option tzresult Lwt.t + method last_modification_time : string -> float option tzresult Lwt.t - method get_base_dir : string - end + method get_base_dir : string +end -class type chain = - object - method chain : Shell_services.chain - end +class type chain = object + method chain : Shell_services.chain +end -class type block = - object - method block : Shell_services.block +class type block = object + method block : Shell_services.block - method confirmations : int option - end + method confirmations : int option +end -class type io_wallet = - object - inherit printer +class type io_wallet = object + inherit printer - inherit prompter + inherit prompter - inherit wallet - end + inherit wallet +end -class type io_rpcs = - object - inherit printer +class type io_rpcs = object + inherit printer - inherit prompter + inherit prompter - inherit Tezos_rpc.Context.generic - end + inherit Tezos_rpc.Context.generic +end -class type ui = - object - method sleep : float -> unit Lwt.t +class type ui = object + method sleep : float -> unit Lwt.t - method exit : 'a. int -> 'a + method exit : 'a. int -> 'a - method now : unit -> Ptime.t - end + method now : unit -> Ptime.t +end -class type ux_options = - object - method verbose_rpc_error_diagnostics : bool - end +class type ux_options = object + method verbose_rpc_error_diagnostics : bool +end -class type full = - object - inherit printer +class type full = object + inherit printer - inherit prompter + inherit prompter - inherit wallet + inherit wallet - inherit Tezos_rpc.Context.generic + inherit Tezos_rpc.Context.generic - inherit chain + inherit chain - inherit block + inherit block - inherit ui + inherit ui - inherit ux_options - end + inherit ux_options +end class proxy_context (obj : full) = object diff --git a/src/lib_client_base/client_context.mli b/src/lib_client_base/client_context.mli index 7bbbe910f97f3d6d768240d3ed0463cea715b67e..d63f14017c5d391a8e5fd4034518135b1bf9e4c5 100644 --- a/src/lib_client_base/client_context.mli +++ b/src/lib_client_base/client_context.mli @@ -42,90 +42,84 @@ type ('a, 'b) lwt_format = ('a, Format.formatter, unit, 'b Lwt.t) format4 (** [printer] is a class for objects that provide output functions to display information to the end-user. *) -class type printer = - object - method error : ('a, 'b) lwt_format -> 'a +class type printer = object + method error : ('a, 'b) lwt_format -> 'a - method warning : ('a, unit) lwt_format -> 'a + method warning : ('a, unit) lwt_format -> 'a - method message : ('a, unit) lwt_format -> 'a + method message : ('a, unit) lwt_format -> 'a - method answer : ('a, unit) lwt_format -> 'a + method answer : ('a, unit) lwt_format -> 'a - method log : string -> ('a, unit) lwt_format -> 'a - end + method log : string -> ('a, unit) lwt_format -> 'a +end (** [prompter] is a class of objects that provide input functions to request data from the end-user, whether normal inputs or passwords. *) -class type prompter = - object - method prompt : ('a, string tzresult) lwt_format -> 'a +class type prompter = object + method prompt : ('a, string tzresult) lwt_format -> 'a - method prompt_password : ('a, Bytes.t tzresult) lwt_format -> 'a + method prompt_password : ('a, Bytes.t tzresult) lwt_format -> 'a - (** when [multiple_password_retries] is [true], password + (** when [multiple_password_retries] is [true], password prompt should retries more than once. [true] is the default value. *) - method multiple_password_retries : bool - end + method multiple_password_retries : bool +end -class type io = - object - inherit printer +class type io = object + inherit printer - inherit prompter - end + inherit prompter +end (** Operations on the wallet. *) -class type wallet = - object - method load_passwords : string Lwt_stream.t option +class type wallet = object + method load_passwords : string Lwt_stream.t option - (** [read_file path] reads the content of the file given by + (** [read_file path] reads the content of the file given by [path]. Note that the whole content of the file is loaded into memory: you shouldn't read big files using this method. Errors that may be returned are implementation-dependent. *) - method read_file : string -> string tzresult Lwt.t + method read_file : string -> string tzresult Lwt.t - (** [with_lock f] calls [f ()] exclusively from any other function + (** [with_lock f] calls [f ()] exclusively from any other function that is wrapped within [with_lock]. *) - method with_lock : (unit -> 'a Lwt.t) -> 'a Lwt.t + method with_lock : (unit -> 'a Lwt.t) -> 'a Lwt.t - (** [load alias ~default enc] reads the file corresponding to the + (** [load alias ~default enc] reads the file corresponding to the [alias], and parses using [encoding]. If the file does not exist, then [default] is returned. *) - method load : - string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t + method load : + string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t - (** [write alias x encoding] writes in a file corresponding to the + (** [write alias x encoding] writes in a file corresponding to the [alias] the information given by [x] using the [encoding]. *) - method write : - string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t + method write : + string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t - (** [last_modification_time alias] returns the last modification + (** [last_modification_time alias] returns the last modification time of the file corresponding to the [alias], if the file exists; otherwise [None]. *) - method last_modification_time : string -> float option tzresult Lwt.t + method last_modification_time : string -> float option tzresult Lwt.t - (** Current base directory. Stores the information of keys (public + (** Current base directory. Stores the information of keys (public key hashes, public keys, secret keys) and watermarks. *) - method get_base_dir : string - end + method get_base_dir : string +end (** Accessor on the chain. *) -class type chain = - object - method chain : Shell_services.chain - end +class type chain = object + method chain : Shell_services.chain +end (** Operations on blocks. *) -class type block = - object - method block : Shell_services.block +class type block = object + method block : Shell_services.block - method confirmations : int option - end + method confirmations : int option +end (** Primitives for input, output and wallet. The general organisation of the code in this module is to @@ -134,61 +128,56 @@ class type block = depend on some features, but not all, so that these functions can be used in places that only have access to these features. *) -class type io_wallet = - object - inherit printer +class type io_wallet = object + inherit printer - inherit prompter + inherit prompter - inherit wallet - end + inherit wallet +end (** Primitives for input, output and RPCs. *) -class type io_rpcs = - object - inherit printer +class type io_rpcs = object + inherit printer - inherit prompter + inherit prompter - inherit Tezos_rpc.Context.generic - end + inherit Tezos_rpc.Context.generic +end (** User interface related operations. *) -class type ui = - object - method sleep : float -> unit Lwt.t +class type ui = object + method sleep : float -> unit Lwt.t - method exit : int -> 'a + method exit : int -> 'a - method now : unit -> Ptime.t - end + method now : unit -> Ptime.t +end (** User experience options. *) -class type ux_options = - object - method verbose_rpc_error_diagnostics : bool - end +class type ux_options = object + method verbose_rpc_error_diagnostics : bool +end (** A comprehensive class type gathering the above class types, that is used for #Protocol_client_context.full. *) -class type full = - object - inherit printer +class type full = object + inherit printer - inherit prompter + inherit prompter - inherit wallet + inherit wallet - inherit Tezos_rpc.Context.generic + inherit Tezos_rpc.Context.generic - inherit chain + inherit chain - inherit block + inherit block - inherit ui + inherit ui - inherit ux_options - end + inherit ux_options +end (** A simple printer can be used to implement a printer as it is done in class [Client_context_unix.unix_logger]. *) diff --git a/src/lib_client_base/pbkdf.ml b/src/lib_client_base/pbkdf.ml index 27ebd11e61703c5b28f68ddf91040c3c65b541e5..f9270ad1ada44dd0f13f2f895d33db313c5b59e1 100644 --- a/src/lib_client_base/pbkdf.ml +++ b/src/lib_client_base/pbkdf.ml @@ -18,7 +18,7 @@ let cdiv x y = if y < 1 then raise Division_by_zero else if x > 0 then 1 + ((x - 1) / y) else 0 - [@@inline] +[@@inline] module type S = sig val pbkdf2 : diff --git a/src/lib_client_base_unix/client_config.ml b/src/lib_client_base_unix/client_config.ml index 4ffc6200afd32887607baffd80a52d60fd083e38..1e9fcf4fd3a90c6507721ba11cf2f5f130f789d2 100644 --- a/src/lib_client_base_unix/client_config.ml +++ b/src/lib_client_base_unix/client_config.ml @@ -101,8 +101,8 @@ let () = Format.fprintf ppf (if List.compare_length_with args 1 = 0 then - "Option %s is in conflict with %s" - else "Options %s are in conflict with %s") + "Option %s is in conflict with %s" + else "Options %s are in conflict with %s") (String.concat " and " args) by) Data_encoding.(obj2 (req "suppressed" (list string)) (req "by" string)) diff --git a/src/lib_client_base_unix/client_context_unix.mli b/src/lib_client_base_unix/client_context_unix.mli index 425e10c42189f48ed75a6e8b3dc7f9b8ae7ddb12..d55b9033f27bc9e8f4f952b709cf799b47029580 100644 --- a/src/lib_client_base_unix/client_context_unix.mli +++ b/src/lib_client_base_unix/client_context_unix.mli @@ -24,45 +24,31 @@ (* *) (*****************************************************************************) -class unix_wallet : - base_dir:string -> password_filename:string option -> Client_context.wallet +class unix_wallet : base_dir:string -> password_filename:string option -> + Client_context.wallet class unix_prompter : Client_context.prompter class unix_logger : base_dir:string -> Client_context.printer -class unix_io_wallet : - base_dir:string -> password_filename:string option -> Client_context.io_wallet +class unix_io_wallet : base_dir:string -> password_filename:string option -> + Client_context.io_wallet class unix_ui : Client_context.ui -class unix_full : - base_dir:string - -> chain:Shell_services.chain - -> block:Shell_services.block - -> confirmations:int option - -> password_filename:string option - -> rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config - -> verbose_rpc_error_diagnostics:bool - -> Client_context.full - -class unix_mockup : - base_dir:string - -> mem_only:bool - -> mockup_env:Tezos_mockup_registration.Registration.mockup_environment - -> chain_id:Chain_id.t - -> rpc_context:Tezos_protocol_environment.rpc_context - -> protocol_data:bytes - -> Client_context.full - -class unix_proxy : - base_dir:string - -> ?protocol:Protocol_hash.t - -> chain:Shell_services.chain - -> block:Shell_services.block - -> confirmations:int option - -> password_filename:string option - -> rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config - -> mode:Tezos_proxy.Proxy_services.mode - -> unit - -> Client_context.full +class unix_full : base_dir:string -> chain:Shell_services.chain -> + block:Shell_services.block -> confirmations:int option -> + password_filename:string option -> + rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config -> + verbose_rpc_error_diagnostics:bool -> Client_context.full + +class unix_mockup : base_dir:string -> mem_only:bool -> + mockup_env:Tezos_mockup_registration.Registration.mockup_environment -> + chain_id:Chain_id.t -> rpc_context:Tezos_protocol_environment.rpc_context -> + protocol_data:bytes -> Client_context.full + +class unix_proxy : base_dir:string -> ?protocol:Protocol_hash.t -> + chain:Shell_services.chain -> block:Shell_services.block -> + confirmations:int option -> password_filename:string option -> + rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config -> + mode:Tezos_proxy.Proxy_services.mode -> unit -> Client_context.full diff --git a/src/lib_client_base_unix/client_main_run.ml b/src/lib_client_base_unix/client_main_run.ml index 346a0e2e0683a8f529c980234873b4f7b2377f29..e828732d328fa9340a37e3b83f8e0d4fe3b08c90 100644 --- a/src/lib_client_base_unix/client_main_run.ml +++ b/src/lib_client_base_unix/client_main_run.ml @@ -520,7 +520,7 @@ let main (module C : M) ~select_commands = ~executable_name ~global_options (if Unix.isatty Unix.stdout then Tezos_clic.Ansi - else Tezos_clic.Plain) + else Tezos_clic.Plain) Format.std_formatter (C.clic_commands ~base_dir diff --git a/src/lib_client_commands/client_keys_commands.ml b/src/lib_client_commands/client_keys_commands.ml index d34da200c9bf2197d22ba1c2a352be0086940bc0..a15448ecee3a709f557d2a5362d1fcbd48b193e0 100644 --- a/src/lib_client_commands/client_keys_commands.ml +++ b/src/lib_client_commands/client_keys_commands.ml @@ -702,26 +702,26 @@ let commands network : Client_context.full Tezos_clic.command list = register_key cctxt ~force (pkh, pk_uri, sk_uri) ?public_key name); ] @ (if network <> Some `Mainnet then [] - else - [ - command - ~group - ~desc:"Add a fundraiser secret key to the wallet." - (args1 (Secret_key.force_switch ())) - (prefix "import" - @@ prefixes ["fundraiser"; "secret"; "key"] - @@ Secret_key.fresh_alias_param @@ stop) - (fun force name (cctxt : Client_context.full) -> - let* name = Secret_key.of_fresh cctxt force name in - let* sk = input_fundraiser_params cctxt in - let* sk_uri = - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - in - let* pk_uri = Client_keys.neuterize sk_uri in - let* () = fail_if_already_registered cctxt force pk_uri name in - let* pkh, _public_key = Client_keys.public_key_hash pk_uri in - register_key cctxt ~force (pkh, pk_uri, sk_uri) name); - ]) + else + [ + command + ~group + ~desc:"Add a fundraiser secret key to the wallet." + (args1 (Secret_key.force_switch ())) + (prefix "import" + @@ prefixes ["fundraiser"; "secret"; "key"] + @@ Secret_key.fresh_alias_param @@ stop) + (fun force name (cctxt : Client_context.full) -> + let* name = Secret_key.of_fresh cctxt force name in + let* sk = input_fundraiser_params cctxt in + let* sk_uri = + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + in + let* pk_uri = Client_keys.neuterize sk_uri in + let* () = fail_if_already_registered cctxt force pk_uri name in + let* pkh, _public_key = Client_keys.public_key_hash pk_uri in + register_key cctxt ~force (pkh, pk_uri, sk_uri) name); + ]) @ [ command ~group diff --git a/src/lib_context/dump/context_dump.ml b/src/lib_context/dump/context_dump.ml index 6e5337d5556d3a6f9e1d31005889d84af8fda5a5..558cff9594096a19ad8d1cbcb208cd35466324bb 100644 --- a/src/lib_context/dump/context_dump.ml +++ b/src/lib_context/dump/context_dump.ml @@ -261,8 +261,8 @@ module Make (I : Dump_interface) = struct (nb_context_elements / 1_000) (100 * i / nb_context_elements) (if !read > 1_048_576 then - Format.asprintf "%dMiB" (!read / 1_048_576) - else Format.asprintf "%dKiB" (!read / 1_024))) + Format.asprintf "%dMiB" (!read / 1_048_576) + else Format.asprintf "%dKiB" (!read / 1_024))) (fun notify -> I.batch index (fun batch -> second_pass diff --git a/src/lib_context/helpers/context.mli b/src/lib_context/helpers/context.mli index 5fc7e5951cfb046638a021da71b7e15e5ad87dcc..00e4c953870e65d1a1ea52f9374ca1dc8e51f3d4 100644 --- a/src/lib_context/helpers/context.mli +++ b/src/lib_context/helpers/context.mli @@ -70,7 +70,9 @@ end module Proof_encoding = Tezos_context_merkle_proof_encoding -module Make_proof (DB : DB) (Store_conf : Tezos_context_encoding.Context.Conf) : sig +module Make_proof + (DB : DB) + (Store_conf : Tezos_context_encoding.Context.Conf) : sig module Proof : Tezos_context_sigs.Context.PROOF type kinded_key := [`Value of DB.contents_key | `Node of DB.node_key] diff --git a/src/lib_context/test/test_context.ml b/src/lib_context/test/test_context.ml index e1ef3093c1f0363da0cb58a8251d69ce0a93b319..9591b17eee17ce74e153c1bbf0021771799ea754 100644 --- a/src/lib_context/test/test_context.ml +++ b/src/lib_context/test/test_context.ml @@ -92,14 +92,16 @@ let chain_id = Chain_id.of_block_hash genesis_block (** Test functors *) (* Context-generic tests *) -module Make_generic (Tag : sig - val tag : string -end) (Type_parameters : sig - type memory_context_tree -end) -(Context : Tezos_context_sigs.Context.TEZOS_CONTEXT - with type memory_context_tree := - Type_parameters.memory_context_tree) = +module Make_generic + (Tag : sig + val tag : string + end) + (Type_parameters : sig + type memory_context_tree + end) + (Context : Tezos_context_sigs.Context.TEZOS_CONTEXT + with type memory_context_tree := + Type_parameters.memory_context_tree) = struct open Context diff --git a/src/lib_crawler/layer_1.ml b/src/lib_crawler/layer_1.ml index c508589f1dacba4a61ac1bdcbfa6b2ccbb498531..dc0610f872969b8c9bfcacd52663b26674729004 100644 --- a/src/lib_crawler/layer_1.ml +++ b/src/lib_crawler/layer_1.ml @@ -110,7 +110,7 @@ let start ~name ~reconnection_delay ?protocols (cctxt : #Client_context.full) = in { name; - cctxt = (cctxt :> Client_context.full); + cctxt :> Client_context.full; heads; stopper; reconnection_delay; @@ -347,7 +347,7 @@ module Internal_for_tests = struct name = "dummy_layer_1_for_tests"; reconnection_delay = 5.0; heads; - cctxt = (cctxt :> Client_context.full); + cctxt :> Client_context.full; stopper = Fun.id; protocols = None; running = false; diff --git a/src/lib_crypto/blake2B.ml b/src/lib_crypto/blake2B.ml index 6ae5f3ee0669399306682a770afa5c97259691b7..e3508ecc99594465bd9b1dfa1cd6619965514b31 100644 --- a/src/lib_crypto/blake2B.ml +++ b/src/lib_crypto/blake2B.ml @@ -314,20 +314,22 @@ end let rec log2 x = if x <= 1 then 0 else 1 + log2 ((x + 1) / 2) -module Make_merkle_tree (R : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Base58.data) -> - 'a Base58.encoding -end) -(K : PrefixedName) (Contents : sig - type t - - val to_bytes : t -> Bytes.t -end) = +module Make_merkle_tree + (R : sig + val register_encoding : + prefix:string -> + length:int -> + to_raw:('a -> string) -> + of_raw:(string -> 'a option) -> + wrap:('a -> Base58.data) -> + 'a Base58.encoding + end) + (K : PrefixedName) + (Contents : sig + type t + + val to_bytes : t -> Bytes.t + end) = struct include Make (R) (K) diff --git a/src/lib_crypto/blake2B.mli b/src/lib_crypto/blake2B.mli index 044734007acd633d5e74e63c38f9e07be9b26dc9..83dd2e650d28c87aed97e8372a4c70bc4adede2a 100644 --- a/src/lib_crypto/blake2B.mli +++ b/src/lib_crypto/blake2B.mli @@ -68,20 +68,22 @@ module Make (Register : Register) (Name : PrefixedName) : S.HASH (**/**) -module Make_merkle_tree (R : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Base58.data) -> - 'a Base58.encoding -end) -(K : PrefixedName) (Contents : sig - type t - - val to_bytes : t -> Bytes.t -end) : S.MERKLE_TREE with type elt = Contents.t +module Make_merkle_tree + (R : sig + val register_encoding : + prefix:string -> + length:int -> + to_raw:('a -> string) -> + of_raw:(string -> 'a option) -> + wrap:('a -> Base58.data) -> + 'a Base58.encoding + end) + (K : PrefixedName) + (Contents : sig + type t + + val to_bytes : t -> Bytes.t + end) : S.MERKLE_TREE with type elt = Contents.t module Generic_Merkle_tree (H : sig type t diff --git a/src/lib_crypto/test/test_prop_signature.ml b/src/lib_crypto/test/test_prop_signature.ml index 412f5ad53b8b29f18b5e184a17c4b8deef16aed5..1e709784c83f10089707fde2884b438c57f96e5c 100644 --- a/src/lib_crypto/test/test_prop_signature.ml +++ b/src/lib_crypto/test/test_prop_signature.ml @@ -44,10 +44,11 @@ let gen_watermark = let open Gen in Gen.char >|= Bytes.make 1 -module Signature_Properties (Desc : sig - val name : string -end) -(X : SIGNATURE) = +module Signature_Properties + (Desc : sig + val name : string + end) + (X : SIGNATURE) = struct (** Tests that a signature of [s], with optional [watermark], by a generated key and [X.sign] is accepted by [X.check] with the same key. *) @@ -79,10 +80,11 @@ module type AGGREGATE_SIGNATURE = sig val watermark_of_bytes : bytes -> watermark end -module Aggregate_Signature_Properties (Desc : sig - val name : string -end) -(X : AGGREGATE_SIGNATURE) = +module Aggregate_Signature_Properties + (Desc : sig + val name : string + end) + (X : AGGREGATE_SIGNATURE) = struct (** Tests that signatures of [msg1], [msg2], [msg3], (with optional corresponding watermarks) obtained using [X.sign] are accepted by diff --git a/src/lib_crypto/test/test_signature_encodings.ml b/src/lib_crypto/test/test_signature_encodings.ml index 1348de63f7bf52f45546903369b9460ee401fc7f..8fa39525b79d6c57ab68450b6253d493f65537b0 100644 --- a/src/lib_crypto/test/test_signature_encodings.ml +++ b/src/lib_crypto/test/test_signature_encodings.ml @@ -39,7 +39,8 @@ module type B58CHECK = sig end module Make_tests - (P : Intfs.SIGNATURE) (T : sig + (P : Intfs.SIGNATURE) + (T : sig val name : string val pkh_vectors : (string * string) list diff --git a/src/lib_crypto_dal/cryptobox.ml b/src/lib_crypto_dal/cryptobox.ml index b4dee0a1655ace006a35559e599b8f0d0fb6d9e8..03f38398e7cef9e63b408661333c653f7e398025 100644 --- a/src/lib_crypto_dal/cryptobox.ml +++ b/src/lib_crypto_dal/cryptobox.ml @@ -43,7 +43,7 @@ let () = (function | Failed_to_load_trusted_setup parameter -> Some parameter | _ -> None) (fun parameter -> Failed_to_load_trusted_setup parameter) - [@@coverage off] +[@@coverage off] type initialisation_parameters = {srs_g1 : Srs_g1.t; srs_g2 : Srs_g2.t} @@ -63,7 +63,7 @@ let () = Data_encoding.empty (function Dal_initialisation_twice -> Some () | _ -> None) (function () -> Dal_initialisation_twice) - [@@coverage off] +[@@coverage off] (* This function is expected to be called once. *) let load_parameters parameters = @@ -197,7 +197,7 @@ module Inner = struct (fun {index; share} -> (index, share)) (fun (index, share) -> {index; share}) (tup2 int31 share_encoding) - [@@coverage off] + [@@coverage off] let shards_proofs_precomputation_encoding = tup2 (array fr_encoding) (array (array g1_encoding)) @@ -224,22 +224,22 @@ module Inner = struct let commitment_to_bytes = Bls12_381.G1.to_compressed_bytes let commitment_of_bytes_opt = Bls12_381.G1.of_compressed_bytes_opt - [@@coverage off] + [@@coverage off] let commitment_of_bytes_exn bytes = match Bls12_381.G1.of_compressed_bytes_opt bytes with | None -> Format.kasprintf Stdlib.failwith "Unexpected data (DAL commitment)" | Some commitment -> commitment - [@@coverage off] + [@@coverage off] let commitment_size = Bls12_381.G1.compressed_size_in_bytes [@@coverage off] let to_string commitment = commitment_to_bytes commitment |> Bytes.to_string - [@@coverage off] + [@@coverage off] let of_string_opt str = commitment_of_bytes_opt (String.to_bytes str) - [@@coverage off] + [@@coverage off] let b58check_encoding = Base58.register_encoding @@ -248,7 +248,7 @@ module Inner = struct ~to_raw:to_string ~of_raw:of_string_opt ~wrap:(fun x -> Data x) - [@@coverage off] + [@@coverage off] let raw_encoding = let open Data_encoding in @@ -256,7 +256,7 @@ module Inner = struct commitment_to_bytes commitment_of_bytes_exn (Fixed.bytes commitment_size) - [@@coverage off] + [@@coverage off] (* TODO: https://gitlab.com/tezos/tezos/-/issues/5593 @@ -291,12 +291,12 @@ module Inner = struct function exposed. We only need the Base58 encoding and the rpc_arg. *) assert false - [@@coverage off] + [@@coverage off] let seeded_hash _ _ = (* Same argument. *) assert false - [@@coverage off] + [@@coverage off] end) let of_b58check = of_b58check @@ -314,7 +314,7 @@ module Inner = struct Stdlib.failwith "Unexpected data (DAL commitment proof)" | Some proof -> proof - [@@coverage off] + [@@coverage off] let size = Bls12_381.G1.compressed_size_in_bytes @@ -344,7 +344,7 @@ module Inner = struct Data_encoding.string) (function Invalid_precomputation_hash err -> Some err | _ -> None) (function err -> Invalid_precomputation_hash err) - [@@coverage off] + [@@coverage off] (* Number of bytes fitting in a Scalar.t. Since scalars are integer modulo r~2^255, we restrict ourselves to 248-bit integers (31 bytes). *) @@ -637,8 +637,8 @@ module Inner = struct (* Error cases of this functions are not encapsulated into `tzresult` for modularity reasons. *) let make - ({redundancy_factor; slot_size; page_size; number_of_shards} as - parameters) = + ({redundancy_factor; slot_size; page_size; number_of_shards} as parameters) + = let open Result_syntax in let max_polynomial_length = slot_as_polynomial_length ~slot_size ~page_size @@ -697,7 +697,7 @@ module Inner = struct let parameters ({redundancy_factor; slot_size; page_size; number_of_shards; _} : t) = {redundancy_factor; slot_size; page_size; number_of_shards} - [@@coverage off] + [@@coverage off] let polynomial_degree = Polynomials.degree diff --git a/src/lib_crypto_dal/dal_config/dal_config.ml b/src/lib_crypto_dal/dal_config/dal_config.ml index 5aa96f1addd0ea03deebcc1bd5143c1a18c6010e..3126c2c32a7d3f60883e945b80aae721a86338d0 100644 --- a/src/lib_crypto_dal/dal_config/dal_config.ml +++ b/src/lib_crypto_dal/dal_config/dal_config.ml @@ -43,7 +43,7 @@ let parameters_encoding = (req "page_size" uint16) (req "slot_size" int31) (req "number_of_shards" uint16)) - [@@coverage off] +[@@coverage off] type t = { activated : bool; @@ -62,7 +62,7 @@ let encoding : t Data_encoding.t = (req "activated" bool) (req "use_mock_srs_for_testing" (option parameters_encoding)) (req "bootstrap_peers" (list string))) - [@@coverage off] +[@@coverage off] let default = {activated = false; use_mock_srs_for_testing = None; bootstrap_peers = []} diff --git a/src/lib_crypto_dal/test/test_dal_cryptobox.ml b/src/lib_crypto_dal/test/test_dal_cryptobox.ml index d771c2b5d945cdc35297c18c870bc83702e645ba..fbf541b974baa94cfff552d0e59b3bd148312e58 100644 --- a/src/lib_crypto_dal/test/test_dal_cryptobox.ml +++ b/src/lib_crypto_dal/test/test_dal_cryptobox.ml @@ -536,13 +536,13 @@ module Test = struct let* retrieved_precomputation = Lwt_main.run (let open Error_monad.Lwt_result_syntax in - let* () = - Cryptobox.save_precompute_shards_proofs precomputation ~filename - in - Cryptobox.load_precompute_shards_proofs - ~hash:(Some hash) - ~filename - ()) + let* () = + Cryptobox.save_precompute_shards_proofs precomputation ~filename + in + Cryptobox.load_precompute_shards_proofs + ~hash:(Some hash) + ~filename + ()) in Sys.remove filename ; return @@ -575,15 +575,15 @@ module Test = struct let* _ = Lwt_main.run (let open Error_monad.Lwt_result_syntax in - let* () = - Cryptobox.save_precompute_shards_proofs - precomputation - ~filename:!filename - in - Cryptobox.load_precompute_shards_proofs - ~hash:(Some dummy_hash) - ~filename:!filename - ()) + let* () = + Cryptobox.save_precompute_shards_proofs + precomputation + ~filename:!filename + in + Cryptobox.load_precompute_shards_proofs + ~hash:(Some dummy_hash) + ~filename:!filename + ()) in return filename) |> function diff --git a/src/lib_dac_client/dac_node_client.ml b/src/lib_dac_client/dac_node_client.ml index ad5150243cc4bd2a1423bc23cc2a3bbc108b1dd8..de3cf4af0f6b678dfcf843772b5a99e916c29951 100644 --- a/src/lib_dac_client/dac_node_client.ml +++ b/src/lib_dac_client/dac_node_client.ml @@ -23,10 +23,9 @@ (* *) (*****************************************************************************) -class type cctxt = - object - inherit Tezos_rpc.Context.generic - end +class type cctxt = object + inherit Tezos_rpc.Context.generic +end class unix_cctxt ~rpc_config : cctxt = object diff --git a/src/lib_dac_client/dac_node_client.mli b/src/lib_dac_client/dac_node_client.mli index 8acd4f0b3b74b8713a3ba1ced9729bfbe37caebe..cc2d9057b74b04f29f3d2c13fa4d0a01827f5969 100644 --- a/src/lib_dac_client/dac_node_client.mli +++ b/src/lib_dac_client/dac_node_client.mli @@ -25,10 +25,9 @@ (** Instance of [Tezos_client_base.Client_context] that only handles IOs and RPCs. Can be used for keys and RPCs related commands. *) -class type cctxt = - object - inherit Tezos_rpc.Context.generic - end +class type cctxt = object + inherit Tezos_rpc.Context.generic +end (** Instance of [cctxt] for linux systems. Relies on [Tezos_rpc_http_client_unix]. *) diff --git a/src/lib_dac_node/RPC_server.ml b/src/lib_dac_node/RPC_server.ml index d910274702818209f0dec3fd8a0017ad1dfd2e12..89580a6bb2e4b165dc634c57d6e774e1d19337a3 100644 --- a/src/lib_dac_node/RPC_server.ml +++ b/src/lib_dac_node/RPC_server.ml @@ -250,8 +250,8 @@ let start ~rpc_address ~rpc_port ~allow_v1_api node_ctxt = (Tezos_rpc.Directory.merge (register_v0_dynamic_rpc (module Dac_plugin)) (if allow_v1_api then - register_v1_dynamic_rpc (module Dac_plugin) - else Tezos_rpc.Directory.empty) + register_v1_dynamic_rpc (module Dac_plugin) + else Tezos_rpc.Directory.empty) |> register_health_endpoints) | Starting -> Lwt.return (Tezos_rpc.Directory.empty |> register_health_endpoints)) diff --git a/src/lib_dac_node/page_store.ml b/src/lib_dac_node/page_store.ml index d31910ce5a63f09669781e6c11d65c8397ab8e1b..25ec2ab7442716209ee73fc80680edfbc372fa4f 100644 --- a/src/lib_dac_node/page_store.ml +++ b/src/lib_dac_node/page_store.ml @@ -248,13 +248,17 @@ module Filesystem_with_integrity_check : S with type configuration = string and type t = Filesystem.t = With_data_integrity_check (Filesystem) -module With_remote_fetch (R : sig - type remote_context - - val fetch : - Dac_plugin.t -> remote_context -> Dac_plugin.hash -> bytes tzresult Lwt.t -end) -(P : S) : +module With_remote_fetch + (R : sig + type remote_context + + val fetch : + Dac_plugin.t -> + remote_context -> + Dac_plugin.hash -> + bytes tzresult Lwt.t + end) + (P : S) : S with type configuration = R.remote_context * P.t and type t = R.remote_context * P.t = struct @@ -370,13 +374,17 @@ module Internal_for_tests = struct S with type configuration = P.configuration and type t = P.t = With_data_integrity_check (P) - module With_remote_fetch (R : sig - type remote_context + module With_remote_fetch + (R : sig + type remote_context - val fetch : - Dac_plugin.t -> remote_context -> Dac_plugin.hash -> bytes tzresult Lwt.t - end) - (P : S) : + val fetch : + Dac_plugin.t -> + remote_context -> + Dac_plugin.hash -> + bytes tzresult Lwt.t + end) + (P : S) : S with type configuration = R.remote_context * P.t and type t = R.remote_context * P.t = diff --git a/src/lib_dac_node/page_store.mli b/src/lib_dac_node/page_store.mli index 1d2d67266a9751ed335dac29c78c26f67628e081..5aa8be385fb7a57e624396e6aae0d68703a3596f 100644 --- a/src/lib_dac_node/page_store.mli +++ b/src/lib_dac_node/page_store.mli @@ -133,13 +133,17 @@ module Internal_for_tests : sig so that it will fetch pages using a function [R.fetch] to load pages remotely and saved them in the page store of type [P], when a page is not present in said store. *) - module With_remote_fetch (R : sig - type remote_context - - val fetch : - Dac_plugin.t -> remote_context -> Dac_plugin.hash -> bytes tzresult Lwt.t - end) - (P : S) : + module With_remote_fetch + (R : sig + type remote_context + + val fetch : + Dac_plugin.t -> + remote_context -> + Dac_plugin.hash -> + bytes tzresult Lwt.t + end) + (P : S) : S with type configuration = R.remote_context * P.t and type t = R.remote_context * P.t diff --git a/src/lib_dal_node/dal_node_client.ml b/src/lib_dal_node/dal_node_client.ml index 007753725a3821430ebf3f44b4bd807c9f5b43b2..b565d343ac2a8c945720112487b909ea7d40e25f 100644 --- a/src/lib_dal_node/dal_node_client.ml +++ b/src/lib_dal_node/dal_node_client.ml @@ -25,10 +25,9 @@ open Tezos_dal_node_services -class type cctxt = - object - inherit Tezos_rpc.Context.generic - end +class type cctxt = object + inherit Tezos_rpc.Context.generic +end class unix_cctxt ~rpc_config : cctxt = object diff --git a/src/lib_dal_node/dal_node_client.mli b/src/lib_dal_node/dal_node_client.mli index 6ed119b01ad106c3d96a5b29b350d709136aca22..33e615afe16cf3ccbcdce86c04e13d38bc43a931 100644 --- a/src/lib_dal_node/dal_node_client.mli +++ b/src/lib_dal_node/dal_node_client.mli @@ -27,10 +27,9 @@ open Tezos_crypto_dal (** Instance of [Tezos_client_base.Client_context] that only handles IOs and RPCs. Can be used for keys and RPCs related commands. *) -class type cctxt = - object - inherit Tezos_rpc.Context.generic - end +class type cctxt = object + inherit Tezos_rpc.Context.generic +end (** Instance of [cctxt] for linux systems. Relies on [Tezos_rpc_http_client_unix]. *) diff --git a/src/lib_distributed_plonk/distribution.ml b/src/lib_distributed_plonk/distribution.ml index 0a42447cc035ee28f880058b1de8052b351e9d5e..02970824d07542b19caf8e2f97f374f8f82b20af 100644 --- a/src/lib_distributed_plonk/distribution.ml +++ b/src/lib_distributed_plonk/distribution.ml @@ -24,9 +24,7 @@ (*****************************************************************************) open Distribution_helpers - module DP = DP_Pack () - module Runner = Master_runner.Make (DP.D) module MP = DP.MP diff --git a/src/lib_distributed_plonk/distribution_meta.ml b/src/lib_distributed_plonk/distribution_meta.ml index 4affe2375dfbf9239718293c5c98412c93e873b4..60d8b4229c072c5deea9288426075fdd0d43fe9f 100644 --- a/src/lib_distributed_plonk/distribution_meta.ml +++ b/src/lib_distributed_plonk/distribution_meta.ml @@ -1,7 +1,5 @@ open Distribution_helpers - module DP = DP_Meta () - module Runner = Master_runner.Make (DP.D) open Helpers (DP) diff --git a/src/lib_distributed_plonk/test/test_distribution.ml b/src/lib_distributed_plonk/test/test_distribution.ml index 404c6566f377c2462a7d94a94341833c08f59581..03e16c969fec54565919683f56f1f6a9d693077d 100644 --- a/src/lib_distributed_plonk/test/test_distribution.ml +++ b/src/lib_distributed_plonk/test/test_distribution.ml @@ -118,9 +118,10 @@ let test_distribution ?(circuit_builder = Circuit_Builder.base) dp () = worker1_config) ; Lwt_main.run (let open Master_runner.Make (Master) in - Master.run_node - ~process:(master_proc DP.(distributed_prover_main ~inputs pp_prover) ~ret) - master_config) ; + Master.run_node + ~process: + (master_proc DP.(distributed_prover_main ~inputs pp_prover) ~ret) + master_config) ; let proof = Option.get !ret in let verifier_inputs = DP.MP.to_verifier_inputs pp_prover inputs in assert (DP.MP.verify pp_verifier ~inputs:verifier_inputs proof) diff --git a/src/lib_distributed_plonk/worker.ml b/src/lib_distributed_plonk/worker.ml index 273e854cbdc6cfb8ebee7d1571c23cf98a9b144d..69d9e82614b3aec67895b16bfa5399f5c8326c27 100644 --- a/src/lib_distributed_plonk/worker.ml +++ b/src/lib_distributed_plonk/worker.ml @@ -119,8 +119,7 @@ module Make (Main : Distribution.Main_protocol.S) : S = struct main_pid ~step:Msg.S_ppctt ~handler:(fun - (Msg.PP_commit_to_t {index; content = all_ids_keys, alpha}) - -> + (Msg.PP_commit_to_t {index; content = all_ids_keys, alpha}) -> Some (fun () -> let batched_ids = diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index d5c14feba74c46e9df9e314bd6beec77305c6f54..77cce67c9e7961b30b8c1f8370e5799299d2f7aa 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -191,14 +191,15 @@ module type S = sig unit end -module Make (Error : sig - type error = .. - - include Sig.CORE with type error := error -end) -(Trace : Sig.TRACE) -(Monad : Tezos_lwt_result_stdlib.Lwtreslib.TRACED_MONAD - with type 'error trace := 'error Trace.trace) : +module Make + (Error : sig + type error = .. + + include Sig.CORE with type error := error + end) + (Trace : Sig.TRACE) + (Monad : Tezos_lwt_result_stdlib.Lwtreslib.TRACED_MONAD + with type 'error trace := 'error Trace.trace) : S with type error := Error.error and type 'error trace := 'error Trace.trace = struct module Lwt_syntax = Monad.Lwt_syntax diff --git a/src/lib_error_monad/monad_maker.mli b/src/lib_error_monad/monad_maker.mli index 26c29e9428edb41ae27868d996c1e6c5506962c4..dfa6b171b73097c02c91fe8c24302151c184d4c2 100644 --- a/src/lib_error_monad/monad_maker.mli +++ b/src/lib_error_monad/monad_maker.mli @@ -284,12 +284,13 @@ p >>= function unit end -module Make (Error : sig - type error = .. - - include Sig.CORE with type error := error -end) -(Trace : Sig.TRACE) -(Monad : Tezos_lwt_result_stdlib.Lwtreslib.TRACED_MONAD - with type 'error trace := 'error Trace.trace) : +module Make + (Error : sig + type error = .. + + include Sig.CORE with type error := error + end) + (Trace : Sig.TRACE) + (Monad : Tezos_lwt_result_stdlib.Lwtreslib.TRACED_MONAD + with type 'error trace := 'error Trace.trace) : S with type error := Error.error and type 'error trace := 'error Trace.trace diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index c9e16d7637ebe56ac0383c2586e221e2bfab3d7e..814c89a7897b809107d69f8cdfbc11ad63ec5b46 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -280,12 +280,11 @@ module All_sinks = struct ~id:"internal-event-activation-error" ~title ~description - ~pp: - (fun ppf -> function - | Missing_uri_scheme uri -> - Format.fprintf ppf "%s: Missing URI scheme %S" title uri - | Uri_scheme_not_registered uri -> - Format.fprintf ppf "%s: URI scheme not registered %S" title uri) + ~pp:(fun ppf -> function + | Missing_uri_scheme uri -> + Format.fprintf ppf "%s: Missing URI scheme %S" title uri + | Uri_scheme_not_registered uri -> + Format.fprintf ppf "%s: URI scheme not registered %S" title uri) Data_encoding.( union [ @@ -580,88 +579,87 @@ module Simple = struct This is useful for inline parameters. *) let rec pp_human_readable : 'a. never_empty:bool -> 'a Data_encoding.t -> _ -> 'a -> _ = - fun (type a) ~never_empty (encoding : a Data_encoding.t) fmt (value : a) -> - match encoding.encoding with - | Null -> if never_empty then Format.pp_print_string fmt "N/A" - | Empty -> if never_empty then Format.pp_print_string fmt "N/A" - | Ignore -> if never_empty then Format.pp_print_string fmt "N/A" - | Constant name -> pp_print_shortened_string fmt name - | Bool -> Format.pp_print_bool fmt value - | Int8 -> Format.pp_print_int fmt value - | Uint8 -> Format.pp_print_int fmt value - | Int16 -> Format.pp_print_int fmt value - | Uint16 -> Format.pp_print_int fmt value - | Int31 -> Format.pp_print_int fmt value - | Int32 -> Format.fprintf fmt "%ld" value - | Int64 -> Format.fprintf fmt "%Ld" value - | N -> Format.pp_print_string fmt (Z.to_string value) - | Z -> Format.pp_print_string fmt (Z.to_string value) - | RangedInt _ -> Format.pp_print_int fmt value - | RangedFloat _ -> pp_print_compact_float fmt value - | Float -> pp_print_compact_float fmt value - | Bytes _ -> pp_print_shortened_string fmt (Bytes.to_string value) - | String _ -> pp_print_shortened_string fmt value - | Padded (encoding, _) -> pp_human_readable ~never_empty encoding fmt value - | String_enum (table, _) -> ( - match Stdlib.Hashtbl.find_opt table value with - | None -> if never_empty then Format.pp_print_string fmt "N/A" - | Some (name, _) -> pp_print_shortened_string fmt name) - | Array _ -> if never_empty then Format.pp_print_string fmt "" - | List _ -> if never_empty then Format.pp_print_string fmt "" - | Obj (Req {encoding; _} | Dft {encoding; _}) -> - pp_human_readable ~never_empty encoding fmt value - | Obj (Opt {encoding; _}) -> - Option.iter (pp_human_readable ~never_empty encoding fmt) value - | Objs _ -> if never_empty then Format.pp_print_string fmt "" - | Tup encoding -> pp_human_readable ~never_empty encoding fmt value - | Tups _ -> if never_empty then Format.pp_print_string fmt "" - | Union - { - cases = - [ - Case {encoding; proj; _}; - Case {encoding = {encoding = Null; _}; _}; - ]; - _; - } -> ( - (* Probably an [option] type or similar. - We only print the value if it is not null, - unless [never_empty] is [true]. *) - match proj value with - | None -> if never_empty then Format.pp_print_string fmt "null" - | Some value -> pp_human_readable ~never_empty encoding fmt value) - | Union _ -> if never_empty then Format.pp_print_string fmt "" - | Mu _ -> if never_empty then Format.pp_print_string fmt "" - | Conv {proj; encoding; _} -> - (* TODO: it may be worth it to take a look at [encoding] - before calling [proj], to try and predict whether the value - will actually be printed. *) - pp_human_readable ~never_empty encoding fmt (proj value) - | Describe {encoding; _} -> - pp_human_readable ~never_empty encoding fmt value - | Splitted {json_encoding; _} -> ( - (* Generally, [Splitted] nodes imply that the JSON encoding - is more human-friendly, as JSON is a human-friendly - format. A typical example is Blake2B hashes. - So for log outputs we use the JSON encoding. - Unfortunately, [Json_encoding.t] is abstract so we have - to [construct] the JSON value and continue from here. *) - (* TODO: it may be worth it to take a look at [encoding] - before constructing the JSON value, to try and predict - whether the value will actually be printed (same as [Conv]). *) - match Json_encoding.construct json_encoding value with - | `Null -> if never_empty then Format.pp_print_string fmt "N/A" - | `Bool value -> Format.pp_print_bool fmt value - | `Float value -> pp_print_compact_float fmt value - | `String value -> pp_print_shortened_string fmt value - | `A _ -> if never_empty then Format.pp_print_string fmt "" - | `O _ -> if never_empty then Format.pp_print_string fmt "") - | Dynamic_size {encoding; _} -> - pp_human_readable ~never_empty encoding fmt value - | Check_size {encoding; _} -> - pp_human_readable ~never_empty encoding fmt value - | Delayed make_encoding -> - pp_human_readable ~never_empty (make_encoding ()) fmt value + fun (type a) ~never_empty (encoding : a Data_encoding.t) fmt (value : a) -> + match encoding.encoding with + | Null -> if never_empty then Format.pp_print_string fmt "N/A" + | Empty -> if never_empty then Format.pp_print_string fmt "N/A" + | Ignore -> if never_empty then Format.pp_print_string fmt "N/A" + | Constant name -> pp_print_shortened_string fmt name + | Bool -> Format.pp_print_bool fmt value + | Int8 -> Format.pp_print_int fmt value + | Uint8 -> Format.pp_print_int fmt value + | Int16 -> Format.pp_print_int fmt value + | Uint16 -> Format.pp_print_int fmt value + | Int31 -> Format.pp_print_int fmt value + | Int32 -> Format.fprintf fmt "%ld" value + | Int64 -> Format.fprintf fmt "%Ld" value + | N -> Format.pp_print_string fmt (Z.to_string value) + | Z -> Format.pp_print_string fmt (Z.to_string value) + | RangedInt _ -> Format.pp_print_int fmt value + | RangedFloat _ -> pp_print_compact_float fmt value + | Float -> pp_print_compact_float fmt value + | Bytes _ -> pp_print_shortened_string fmt (Bytes.to_string value) + | String _ -> pp_print_shortened_string fmt value + | Padded (encoding, _) -> pp_human_readable ~never_empty encoding fmt value + | String_enum (table, _) -> ( + match Stdlib.Hashtbl.find_opt table value with + | None -> if never_empty then Format.pp_print_string fmt "N/A" + | Some (name, _) -> pp_print_shortened_string fmt name) + | Array _ -> if never_empty then Format.pp_print_string fmt "" + | List _ -> if never_empty then Format.pp_print_string fmt "" + | Obj (Req {encoding; _} | Dft {encoding; _}) -> + pp_human_readable ~never_empty encoding fmt value + | Obj (Opt {encoding; _}) -> + Option.iter (pp_human_readable ~never_empty encoding fmt) value + | Objs _ -> if never_empty then Format.pp_print_string fmt "" + | Tup encoding -> pp_human_readable ~never_empty encoding fmt value + | Tups _ -> if never_empty then Format.pp_print_string fmt "" + | Union + { + cases = + [ + Case {encoding; proj; _}; Case {encoding = {encoding = Null; _}; _}; + ]; + _; + } -> ( + (* Probably an [option] type or similar. + We only print the value if it is not null, + unless [never_empty] is [true]. *) + match proj value with + | None -> if never_empty then Format.pp_print_string fmt "null" + | Some value -> pp_human_readable ~never_empty encoding fmt value) + | Union _ -> if never_empty then Format.pp_print_string fmt "" + | Mu _ -> if never_empty then Format.pp_print_string fmt "" + | Conv {proj; encoding; _} -> + (* TODO: it may be worth it to take a look at [encoding] + before calling [proj], to try and predict whether the value + will actually be printed. *) + pp_human_readable ~never_empty encoding fmt (proj value) + | Describe {encoding; _} -> + pp_human_readable ~never_empty encoding fmt value + | Splitted {json_encoding; _} -> ( + (* Generally, [Splitted] nodes imply that the JSON encoding + is more human-friendly, as JSON is a human-friendly + format. A typical example is Blake2B hashes. + So for log outputs we use the JSON encoding. + Unfortunately, [Json_encoding.t] is abstract so we have + to [construct] the JSON value and continue from here. *) + (* TODO: it may be worth it to take a look at [encoding] + before constructing the JSON value, to try and predict + whether the value will actually be printed (same as [Conv]). *) + match Json_encoding.construct json_encoding value with + | `Null -> if never_empty then Format.pp_print_string fmt "N/A" + | `Bool value -> Format.pp_print_bool fmt value + | `Float value -> pp_print_compact_float fmt value + | `String value -> pp_print_shortened_string fmt value + | `A _ -> if never_empty then Format.pp_print_string fmt "" + | `O _ -> if never_empty then Format.pp_print_string fmt "") + | Dynamic_size {encoding; _} -> + pp_human_readable ~never_empty encoding fmt value + | Check_size {encoding; _} -> + pp_human_readable ~never_empty encoding fmt value + | Delayed make_encoding -> + pp_human_readable ~never_empty (make_encoding ()) fmt value type parameter = | Parameter : diff --git a/src/lib_gossipsub/tezos_gossipsub.ml b/src/lib_gossipsub/tezos_gossipsub.ml index e88e970baf13e43dfff83f6ea7b3f3b7aa2cebaa..f22dd9f7e866edd99188ad53b2fe91ce0b0406ae 100644 --- a/src/lib_gossipsub/tezos_gossipsub.ml +++ b/src/lib_gossipsub/tezos_gossipsub.ml @@ -2542,7 +2542,7 @@ module Make (C : AUTOMATON_CONFIG) : List.concat [ (if Topic.Set.is_empty c.topics then [] - else [Fmt.field "topics" (fun c -> c.topics) pp_topic_set]); + else [Fmt.field "topics" (fun c -> c.topics) pp_topic_set]); [Fmt.field "direct" (fun c -> c.direct) Fmt.bool]; [Fmt.field "outbound" (fun c -> c.outbound) Fmt.bool]; ] diff --git a/src/lib_hacl/gen/gen.ml b/src/lib_hacl/gen/gen.ml index cc349cfeb360beed22082b1982862a7a79440c70..699d362beea95406c16fc77b9c5cbbc1855fdbbc 100644 --- a/src/lib_hacl/gen/gen.ml +++ b/src/lib_hacl/gen/gen.ml @@ -208,10 +208,10 @@ end = struct end let rec compute_arity : 'a. 'a Ctypes_static.fn -> int = - fun (type a) (t : a Ctypes_static.fn) -> - match t with - | Ctypes_static.Returns _ -> 0 - | Function (_, x) -> 1 + compute_arity x + fun (type a) (t : a Ctypes_static.fn) -> + match t with + | Ctypes_static.Returns _ -> 0 + | Function (_, x) -> 1 + compute_arity x let unify_type (type a) (typ : a Ctypes_static.typ) (api : Api_json.typ) : Api_json.typ = @@ -271,14 +271,14 @@ let rec unify_types : Api_json.arg list -> Api_json.typ -> Api_json.arg list * Api_json.typ = - fun (type a) acc (t : a Ctypes_static.fn) args return -> - match (t, args) with - | Ctypes_static.Returns t, [] -> (List.rev acc, unify_type t return) - | Ctypes_static.Returns _, _ -> assert false - | Function (t, x), a :: args -> - let typ = unify_type t a.Api_json.typ in - unify_types ({a with typ} :: acc) x args return - | Function _, [] -> assert false + fun (type a) acc (t : a Ctypes_static.fn) args return -> + match (t, args) with + | Ctypes_static.Returns t, [] -> (List.rev acc, unify_type t return) + | Ctypes_static.Returns _, _ -> assert false + | Function (t, x), a :: args -> + let typ = unify_type t a.Api_json.typ in + unify_types ({a with typ} :: acc) x args return + | Function _, [] -> assert false let gen_fn ~api ~manually_implemented ~required ~name ~ctypes_name add fn : unit = diff --git a/src/lib_hacl/test/test_prop_hacl_hash.ml b/src/lib_hacl/test/test_prop_hacl_hash.ml index c57894b4f1c24b8d24fe565210e7cb25261e0cb3..48408626505aa080f357bcba6019e96ca19d3172 100644 --- a/src/lib_hacl/test/test_prop_hacl_hash.ml +++ b/src/lib_hacl/test/test_prop_hacl_hash.ml @@ -35,10 +35,11 @@ open Qcheck2_helpers open QCheck2 -module Hash_Properties (Desc : sig - val name : string -end) -(X : Hacl.Hash.S) = +module Hash_Properties + (Desc : sig + val name : string + end) + (X : Hacl.Hash.S) = struct let pp_bytes fmt d = Format.fprintf fmt "%S" (Bytes.to_string d) diff --git a/src/lib_hacl/test/test_prop_signature_pk.ml b/src/lib_hacl/test/test_prop_signature_pk.ml index 363a8b788d0af0bd1517a3ee58f0b2114729eeb0..83b90fdaf770d4d179e9ce0af06d6ec8b7c0d889 100644 --- a/src/lib_hacl/test/test_prop_signature_pk.ml +++ b/src/lib_hacl/test/test_prop_signature_pk.ml @@ -37,10 +37,11 @@ open Qcheck2_helpers open QCheck2 -module Pk_Properties (Desc : sig - val name : string -end) -(X : Hacl.SIGNATURE) = +module Pk_Properties + (Desc : sig + val name : string + end) + (X : Hacl.SIGNATURE) = struct (** Checks that [pk_of_bytes_without_validation] and [pk_of_bytes] have the same output on valid public keys and always return a Some. *) diff --git a/src/lib_injector/disk_persistence.ml b/src/lib_injector/disk_persistence.ml index e5f8089697b1fd922a700ee511d87a0af46bfdcd..b3ad87fc6ded528646759207c00f97339a213360 100644 --- a/src/lib_injector/disk_persistence.ml +++ b/src/lib_injector/disk_persistence.ml @@ -276,14 +276,16 @@ module Make_table (H : H) = struct t end -module Make_queue (N : sig - val name : string -end) -(K : Tezos_crypto.Intfs.HASH) (V : sig - type t - - val encoding : t Data_encoding.t -end) = +module Make_queue + (N : sig + val name : string + end) + (K : Tezos_crypto.Intfs.HASH) + (V : sig + type t + + val encoding : t Data_encoding.t + end) = struct module Q = Hash_queue.Make (K) (V) diff --git a/src/lib_injector/disk_persistence.mli b/src/lib_injector/disk_persistence.mli index abb72db045fde4c6784dac42cb75e14df806a0c3..e8b066a02a5a785b938837a1b288278c7fdf6185 100644 --- a/src/lib_injector/disk_persistence.mli +++ b/src/lib_injector/disk_persistence.mli @@ -119,16 +119,18 @@ module Make_table (H : H) : sig end (** Create an on-disk persistent version of the {!Hash_queue} data structure. *) -module Make_queue (N : sig - (** Name used to derive a path (relative to [data_dir] in [load_from_disk]) of where +module Make_queue + (N : sig + (** Name used to derive a path (relative to [data_dir] in [load_from_disk]) of where to store the persistent information for this queue. *) - val name : string -end) -(K : Tezos_crypto.Intfs.HASH) (V : sig - type t - - val encoding : t Data_encoding.t -end) : sig + val name : string + end) + (K : Tezos_crypto.Intfs.HASH) + (V : sig + type t + + val encoding : t Data_encoding.t + end) : sig type t (** [remove q k] removes the binding from [k] in [q]. If [k] is not bound in diff --git a/src/lib_injector/injector_events.ml b/src/lib_injector/injector_events.ml index 5f062dd89eece7e609975b47c086c9a223dcc8f6..e81383798d47d1162ac375a57c8fec1f96161f9d 100644 --- a/src/lib_injector/injector_events.ml +++ b/src/lib_injector/injector_events.ml @@ -29,265 +29,258 @@ open Injector_sigs module Make (Parameters : PARAMETERS) (Tags : module type of Injector_tags.Make (Parameters.Tag)) - (Operation : PARAM_OPERATION) - (Inj_operation : INJECTOR_OPERATION with type operation = Operation.t) - (Request : module type of Request (Inj_operation)) = + (Operation : PARAM_OPERATION) + (Inj_operation : INJECTOR_OPERATION with type operation = Operation.t) + (Request : module type of Request (Inj_operation)) = struct - include Internal_event.Simple + include Internal_event.Simple - let section = Parameters.events_section @ ["injector"] + let section = Parameters.events_section @ ["injector"] - let monitoring_error = - declare_1 - ~section - ~name:"monitoring_error" - ~msg:"error (ignored) in monitoring: {error}" - ~level:Warning - ("error", trace_encoding) + let monitoring_error = + declare_1 + ~section + ~name:"monitoring_error" + ~msg:"error (ignored) in monitoring: {error}" + ~level:Warning + ("error", trace_encoding) - let declare_1 ~name ~msg ~level ?pp1 enc1 = - declare_3 - ~section - ~name - ~msg:("[{signer}: {tags}] " ^ msg) - ~level - ("signer", Signature.Public_key_hash.encoding) - ("tags", Tags.encoding) - enc1 - ~pp1:Signature.Public_key_hash.pp_short - ~pp2:Tags.pp - ?pp3:pp1 + let declare_1 ~name ~msg ~level ?pp1 enc1 = + declare_3 + ~section + ~name + ~msg:("[{signer}: {tags}] " ^ msg) + ~level + ("signer", Signature.Public_key_hash.encoding) + ("tags", Tags.encoding) + enc1 + ~pp1:Signature.Public_key_hash.pp_short + ~pp2:Tags.pp + ?pp3:pp1 - let declare_2 ~name ~msg ~level ?pp1 ?pp2 enc1 enc2 = - declare_4 - ~section - ~name - ~msg:("[{signer}: {tags}] " ^ msg) - ~level - ("signer", Signature.Public_key_hash.encoding) - ("tags", Tags.encoding) - enc1 - enc2 - ~pp1:Signature.Public_key_hash.pp_short - ~pp2:Tags.pp - ?pp3:pp1 - ?pp4:pp2 + let declare_2 ~name ~msg ~level ?pp1 ?pp2 enc1 enc2 = + declare_4 + ~section + ~name + ~msg:("[{signer}: {tags}] " ^ msg) + ~level + ("signer", Signature.Public_key_hash.encoding) + ("tags", Tags.encoding) + enc1 + enc2 + ~pp1:Signature.Public_key_hash.pp_short + ~pp2:Tags.pp + ?pp3:pp1 + ?pp4:pp2 - let declare_3 ~name ~msg ~level ?pp1 ?pp2 ?pp3 enc1 enc2 enc3 = - declare_5 - ~section - ~name - ~msg:("[{signer}: {tags}] " ^ msg) - ~level - ("signer", Signature.Public_key_hash.encoding) - ("tags", Tags.encoding) - enc1 - enc2 - enc3 - ~pp1:Signature.Public_key_hash.pp_short - ~pp2:Tags.pp - ?pp3:pp1 - ?pp4:pp2 - ?pp5:pp3 + let declare_3 ~name ~msg ~level ?pp1 ?pp2 ?pp3 enc1 enc2 enc3 = + declare_5 + ~section + ~name + ~msg:("[{signer}: {tags}] " ^ msg) + ~level + ("signer", Signature.Public_key_hash.encoding) + ("tags", Tags.encoding) + enc1 + enc2 + enc3 + ~pp1:Signature.Public_key_hash.pp_short + ~pp2:Tags.pp + ?pp3:pp1 + ?pp4:pp2 + ?pp5:pp3 - let request_failed = - declare_3 - ~name:"request_failed" - ~msg:"request {view} failed ({worker_status}): {errors}" - ~level:Warning - ("view", Request.encoding) - ~pp1:Request.pp - ("worker_status", Worker_types.request_status_encoding) - ~pp2:Worker_types.pp_status - ("errors", Error_monad.trace_encoding) - ~pp3:Error_monad.pp_print_trace + let request_failed = + declare_3 + ~name:"request_failed" + ~msg:"request {view} failed ({worker_status}): {errors}" + ~level:Warning + ("view", Request.encoding) + ~pp1:Request.pp + ("worker_status", Worker_types.request_status_encoding) + ~pp2:Worker_types.pp_status + ("errors", Error_monad.trace_encoding) + ~pp3:Error_monad.pp_print_trace - let request_completed_notice = - declare_2 - ~name:"request_completed_notice" - ~msg:"{view} {worker_status}" - ~level:Notice - ("view", Request.encoding) - ("worker_status", Worker_types.request_status_encoding) - ~pp1:Request.pp - ~pp2:Worker_types.pp_status + let request_completed_notice = + declare_2 + ~name:"request_completed_notice" + ~msg:"{view} {worker_status}" + ~level:Notice + ("view", Request.encoding) + ("worker_status", Worker_types.request_status_encoding) + ~pp1:Request.pp + ~pp2:Worker_types.pp_status - let request_completed_debug = - declare_2 - ~name:"request_completed_debug" - ~msg:"{view} {worker_status}" - ~level:Debug - ("view", Request.encoding) - ("worker_status", Worker_types.request_status_encoding) - ~pp1:Request.pp - ~pp2:Worker_types.pp_status + let request_completed_debug = + declare_2 + ~name:"request_completed_debug" + ~msg:"{view} {worker_status}" + ~level:Debug + ("view", Request.encoding) + ("worker_status", Worker_types.request_status_encoding) + ~pp1:Request.pp + ~pp2:Worker_types.pp_status - let new_tezos_head = - declare_1 - ~name:"new_tezos_head" - ~msg:"processing new Tezos head {head}" - ~level:Debug - ("head", Block_hash.encoding) + let new_tezos_head = + declare_1 + ~name:"new_tezos_head" + ~msg:"processing new Tezos head {head}" + ~level:Debug + ("head", Block_hash.encoding) - let cannot_compute_reorg = - declare_1 - ~name:"cannot_compute_reorg" - ~msg:"Cannot compute reorg for new block {head}" - ~level:Warning - ("head", Block_hash.encoding) + let cannot_compute_reorg = + declare_1 + ~name:"cannot_compute_reorg" + ~msg:"Cannot compute reorg for new block {head}" + ~level:Warning + ("head", Block_hash.encoding) - let injecting_pending = - declare_1 - ~name:"injecting_pending" - ~msg:"injecting {count} pending operations" - ~level:Notice - ("count", Data_encoding.int31) + let injecting_pending = + declare_1 + ~name:"injecting_pending" + ~msg:"injecting {count} pending operations" + ~level:Notice + ("count", Data_encoding.int31) - let pp_operations_list ppf operations = - Format.fprintf - ppf - "@[%a@]" - (Format.pp_print_list Operation.pp) - operations + let pp_operations_list ppf operations = + Format.fprintf ppf "@[%a@]" (Format.pp_print_list Operation.pp) operations - let pp_operations_hash_list ppf operations = - Format.fprintf - ppf - "@[%a@]" - (Format.pp_print_list Inj_operation.Hash.pp) - operations + let pp_operations_hash_list ppf operations = + Format.fprintf + ppf + "@[%a@]" + (Format.pp_print_list Inj_operation.Hash.pp) + operations - let number_of_operations_in_queue = - declare_1 - ~name:"number_of_operations_in_queue" - ~msg: - "injector's queue: there is currently {number_of_operations} \ - operations waiting to be injected" - ~level:Info - ("number_of_operations", Data_encoding.int31) + let number_of_operations_in_queue = + declare_1 + ~name:"number_of_operations_in_queue" + ~msg: + "injector's queue: there is currently {number_of_operations} \ + operations waiting to be injected" + ~level:Info + ("number_of_operations", Data_encoding.int31) - let considered_operations_info = - declare_1 - ~name:"considered_operations_info" - ~msg: - "injector's queue: the following operations are being considered \ - for injection {operations}" - ~level:Debug - ("operations", Data_encoding.list Operation.encoding) - ~pp1:pp_operations_list + let considered_operations_info = + declare_1 + ~name:"considered_operations_info" + ~msg: + "injector's queue: the following operations are being considered for \ + injection {operations}" + ~level:Debug + ("operations", Data_encoding.list Operation.encoding) + ~pp1:pp_operations_list - let dropped_operations = - declare_1 - ~name:"dropped_operations" - ~msg: - "dropping operations: the following operations are dropped \ - {operations}" - ~level:Debug - ("operations", Data_encoding.list Operation.encoding) - ~pp1:pp_operations_list + let dropped_operations = + declare_1 + ~name:"dropped_operations" + ~msg: + "dropping operations: the following operations are dropped {operations}" + ~level:Debug + ("operations", Data_encoding.list Operation.encoding) + ~pp1:pp_operations_list - let simulating_operations = - declare_2 - ~name:"simulating_operations" - ~msg:"simulating operations (force = {force}): {operations}" - ~level:Debug - ("operations", Data_encoding.list Operation.encoding) - ("force", Data_encoding.bool) - ~pp1:pp_operations_list + let simulating_operations = + declare_2 + ~name:"simulating_operations" + ~msg:"simulating operations (force = {force}): {operations}" + ~level:Debug + ("operations", Data_encoding.list Operation.encoding) + ("force", Data_encoding.bool) + ~pp1:pp_operations_list - let discard_error_operation = - declare_3 - ~name:"discard_error_operation" - ~msg: - "discarding operation {operation} failing {count} times with \ - {error}" - ~level:Notice - ("operation", Operation.encoding) - ~pp1:Operation.pp - ("count", Data_encoding.int31) - ("error", Data_encoding.option Error_monad.trace_encoding) - ~pp3:(fun ppf -> Option.iter (Error_monad.pp_print_trace ppf)) + let discard_error_operation = + declare_3 + ~name:"discard_error_operation" + ~msg:"discarding operation {operation} failing {count} times with {error}" + ~level:Notice + ("operation", Operation.encoding) + ~pp1:Operation.pp + ("count", Data_encoding.int31) + ("error", Data_encoding.option Error_monad.trace_encoding) + ~pp3:(fun ppf -> Option.iter (Error_monad.pp_print_trace ppf)) - let injected = - declare_2 - ~name:"injected" - ~msg:"injected {nb} operations in {oph}" - ~level:Notice - ("nb", Data_encoding.int31) - ("oph", Operation_hash.encoding) + let injected = + declare_2 + ~name:"injected" + ~msg:"injected {nb} operations in {oph}" + ~level:Notice + ("nb", Data_encoding.int31) + ("oph", Operation_hash.encoding) - let add_pending = - declare_1 - ~name:"add_pending" - ~msg:"add {operation} to pending" - ~level:Notice - ("operation", Operation.encoding) - ~pp1:Operation.pp + let add_pending = + declare_1 + ~name:"add_pending" + ~msg:"add {operation} to pending" + ~level:Notice + ("operation", Operation.encoding) + ~pp1:Operation.pp - let retry_operation = - declare_1 - ~name:"retry_operation" - ~msg:"retry {operation}" - ~level:Notice - ("operation", Operation.encoding) - ~pp1:Operation.pp + let retry_operation = + declare_1 + ~name:"retry_operation" + ~msg:"retry {operation}" + ~level:Notice + ("operation", Operation.encoding) + ~pp1:Operation.pp - let included = - declare_3 - ~name:"included" - ~msg:"included operations of {block} at level {level}: {operations}" - ~level:Notice - ("block", Block_hash.encoding) - ("level", Data_encoding.int32) - ("operations", Data_encoding.list Inj_operation.Hash.encoding) - ~pp3:pp_operations_hash_list + let included = + declare_3 + ~name:"included" + ~msg:"included operations of {block} at level {level}: {operations}" + ~level:Notice + ("block", Block_hash.encoding) + ("level", Data_encoding.int32) + ("operations", Data_encoding.list Inj_operation.Hash.encoding) + ~pp3:pp_operations_hash_list - let revert_operations = - declare_1 - ~name:"revert_operations" - ~msg:"reverting operations: {operations}" - ~level:Notice - ("operations", Data_encoding.list Inj_operation.Hash.encoding) - ~pp1:pp_operations_hash_list + let revert_operations = + declare_1 + ~name:"revert_operations" + ~msg:"reverting operations: {operations}" + ~level:Notice + ("operations", Data_encoding.list Inj_operation.Hash.encoding) + ~pp1:pp_operations_hash_list - let confirmed_level = - declare_1 - ~name:"confirmed_level" - ~msg:"confirmed Tezos level {level}" - ~level:Notice - ("level", Data_encoding.int32) + let confirmed_level = + declare_1 + ~name:"confirmed_level" + ~msg:"confirmed Tezos level {level}" + ~level:Notice + ("level", Data_encoding.int32) - let loaded_from_disk = - declare_2 - ~name:"loaded_from_disk" - ~msg:"loaded {nb} elements in {kind} from disk" - ~level:Notice - ("nb", Data_encoding.int31) - ("kind", Data_encoding.string) + let loaded_from_disk = + declare_2 + ~name:"loaded_from_disk" + ~msg:"loaded {nb} elements in {kind} from disk" + ~level:Notice + ("nb", Data_encoding.int31) + ("kind", Data_encoding.string) - let corrupted_operation_on_disk = - declare_2 - ~name:"corrupted_operation_on_disk" - ~msg:"ignoring unreadable file {file} on disk: {error}" - ~level:Warning - ("file", Data_encoding.string) - ("error", Error_monad.trace_encoding) - ~pp1:Format.pp_print_string - ~pp2:Error_monad.pp_print_trace + let corrupted_operation_on_disk = + declare_2 + ~name:"corrupted_operation_on_disk" + ~msg:"ignoring unreadable file {file} on disk: {error}" + ~level:Warning + ("file", Data_encoding.string) + ("error", Error_monad.trace_encoding) + ~pp1:Format.pp_print_string + ~pp2:Error_monad.pp_print_trace - let inject_wait = - declare_1 - ~name:"inject_wait" - ~msg:"waiting {delay} seconds to trigger injection" - ~level:Notice - ("delay", Data_encoding.float) + let inject_wait = + declare_1 + ~name:"inject_wait" + ~msg:"waiting {delay} seconds to trigger injection" + ~level:Notice + ("delay", Data_encoding.float) - let never_included = - declare_2 - ~name:"never_included" - ~msg:"{operation} was never included in a block after {ttl} blocks" - ~level:Warning - ("operation", Operation.encoding) - ("ttl", Data_encoding.int31) - ~pp1:Operation.pp - end + let never_included = + declare_2 + ~name:"never_included" + ~msg:"{operation} was never included in a block after {ttl} blocks" + ~level:Warning + ("operation", Operation.encoding) + ("ttl", Data_encoding.int31) + ~pp1:Operation.pp +end diff --git a/src/lib_injector/injector_functor.ml b/src/lib_injector/injector_functor.ml index 542e29ce67758f12670aab3c193c156d8e43ac4d..c64997f9d1b7f67a7b236846dcfbfc698221bdae 100644 --- a/src/lib_injector/injector_functor.ml +++ b/src/lib_injector/injector_functor.ml @@ -1454,7 +1454,7 @@ module Make (Parameters : PARAMETERS) = struct table signer { - cctxt = (cctxt :> Client_context.full); + cctxt :> Client_context.full; l1_ctxt; head_protocols; data_dir; diff --git a/src/lib_layer2_store/indexed_store.ml b/src/lib_layer2_store/indexed_store.ml index 83da818ce78d781313ead132fe0612d12796fea7..89b440327c6d4474853a21439c271306e276e445 100644 --- a/src/lib_layer2_store/indexed_store.ml +++ b/src/lib_layer2_store/indexed_store.ml @@ -595,7 +595,8 @@ end module Make_simple_indexed_file (N : NAME) - (K : Index.Key.S) (V : sig + (K : Index.Key.S) + (V : sig include ENCODABLE_VALUE_HEADER val header : t -> Header.t diff --git a/src/lib_layer2_store/indexed_store.mli b/src/lib_layer2_store/indexed_store.mli index c22e4536fce393777a7ec0643352a0c38f256de2..7a8186a30a567049bd10efe58540065db4ba7468 100644 --- a/src/lib_layer2_store/indexed_store.mli +++ b/src/lib_layer2_store/indexed_store.mli @@ -206,7 +206,10 @@ module Make_singleton (S : ENCODABLE_VALUE) : module Make_indexable (_ : NAME) (K : Index.Key.S) (V : Index.Value.S) : INDEXABLE_STORE with type key := K.t and type value := V.t -module Make_indexable_removable (_ : NAME) (K : Index.Key.S) (V : Index.Value.S) : +module Make_indexable_removable + (_ : NAME) + (K : Index.Key.S) + (V : Index.Value.S) : INDEXABLE_REMOVABLE_STORE with type key := K.t and type value := V.t module Make_indexed_file @@ -220,7 +223,8 @@ module Make_indexed_file module Make_simple_indexed_file (_ : NAME) - (K : Index.Key.S) (V : sig + (K : Index.Key.S) + (V : sig include ENCODABLE_VALUE_HEADER val header : t -> Header.t diff --git a/src/lib_layer2_store/test/test_indexed_store.ml b/src/lib_layer2_store/test/test_indexed_store.ml index 3430155da9b27ca1e842ed80efa21c78d46da3f1..b6513f01955843d87757f03612f2dc2329b4bfc0 100644 --- a/src/lib_layer2_store/test/test_indexed_store.ml +++ b/src/lib_layer2_store/test/test_indexed_store.ml @@ -232,7 +232,8 @@ let uid = ref 0 checks on it. *) module Runner (Key : GENERATABLE) - (Value : GENERATABLE) (Store : sig + (Value : GENERATABLE) + (Store : sig type t val load : path:string -> t tzresult Lwt.t diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_lib.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_lib.ml index 4dca72c5d798fdfcda51af5862cb7db3891d9b68..6aa965df6a0e2e8ba085e1ccc6b4328b4dafb03f 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_lib.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_lib.ml @@ -1108,8 +1108,8 @@ let gen_test_of_ty : let dg = gen_of_ty tyd in QCheck2.Test.make ~name - ~print: - (fun ((va, _, _, _), (vb, _, _, _), (vc, _, _, _), (vd, _, _, _)) -> + ~print:(fun + ((va, _, _, _), (vb, _, _, _), (vc, _, _, _), (vd, _, _, _)) -> Format.asprintf "(%a, %a, %a, %a)" (pp_of_ty tya) diff --git a/src/lib_mec/ec.ml b/src/lib_mec/ec.ml index cca415fde543129a4db512f04c4d31c4669c3a67..b595c62c6bfe42fb28ca19d8f5e157dd6d309c0d 100644 --- a/src/lib_mec/ec.ml +++ b/src/lib_mec/ec.ml @@ -45,7 +45,8 @@ open Bls12_381 module MakeJacobianWeierstrass (Fq : Ff_sig.PRIME) - (Fp : Ff_sig.PRIME) (Params : sig + (Fp : Ff_sig.PRIME) + (Params : sig val a : Fq.t val b : Fq.t @@ -258,7 +259,8 @@ end module MakeAffineWeierstrass (Fq : Ff_sig.PRIME) - (Fp : Ff_sig.PRIME) (Params : sig + (Fp : Ff_sig.PRIME) + (Params : sig val a : Fq.t val b : Fq.t @@ -549,7 +551,8 @@ end module MakeProjectiveWeierstrass (Fq : Ff_sig.PRIME) - (Fp : Ff_sig.PRIME) (Params : sig + (Fp : Ff_sig.PRIME) + (Params : sig val a : Fq.t val b : Fq.t @@ -752,7 +755,8 @@ end module MakeAffineMontgomery (Fq : Ff_sig.PRIME) - (Fp : Ff_sig.PRIME) (Params : sig + (Fp : Ff_sig.PRIME) + (Params : sig val a : Fq.t val b : Fq.t @@ -1114,7 +1118,8 @@ end module MakeAffineEdwards (Base : Ff_sig.PRIME) - (Scalar : Ff_sig.PRIME) (Params : sig + (Scalar : Ff_sig.PRIME) + (Params : sig val a : Base.t val d : Base.t diff --git a/src/lib_mec/ff.ml b/src/lib_mec/ff.ml index bacaf422ae297a92f93be6158cb133052a17b81c..0e529a646e586611b917448ba2ea068545acc757 100644 --- a/src/lib_mec/ff.ml +++ b/src/lib_mec/ff.ml @@ -186,7 +186,8 @@ end) : PRIME_WITH_ROOT_OF_UNITY = struct end module MakeFp2 - (Fp : BASE) (Intf : sig + (Fp : BASE) + (Intf : sig (* Non square residue. Arithmetic is over Fp[X] / X^2 - r *) val nsr : Fp.t end) : sig diff --git a/src/lib_mec/pedersen_hash.ml b/src/lib_mec/pedersen_hash.ml index f483ac40d2d2132ade945b5e32b66ed01e5ef6e3..7fcdad37c798b91227b45ad8b4d6fc6be82e960d 100644 --- a/src/lib_mec/pedersen_hash.ml +++ b/src/lib_mec/pedersen_hash.ml @@ -1,5 +1,6 @@ module MakePedersenHash - (Ec : Ec_sig.BASE) (Params : sig + (Ec : Ec_sig.BASE) + (Params : sig val generators : Ec.t list val chunks_per_generator : int diff --git a/src/lib_mec/reddsa.ml b/src/lib_mec/reddsa.ml index 3c016bfc39a97bd1881c7c03fd19b28b5ef4b96a..44f2cf936e50aaac9d0daec36bc110ec366eb925 100644 --- a/src/lib_mec/reddsa.ml +++ b/src/lib_mec/reddsa.ml @@ -39,7 +39,8 @@ module type SIGNATURE_SCHEME = sig end module MakeRedDSA - (Ec : Ec_sig.AffineEdwardsT) (Param : sig + (Ec : Ec_sig.AffineEdwardsT) + (Param : sig val length : int val hash : Bytes.t -> Bytes.t diff --git a/src/lib_mec/reddsa.mli b/src/lib_mec/reddsa.mli index 389358b93a4e0b0cf71fbfeafd13de2a6b873e7b..337fc4e5aabe0834311840edb96ae519163c0803 100644 --- a/src/lib_mec/reddsa.mli +++ b/src/lib_mec/reddsa.mli @@ -39,7 +39,8 @@ module type SIGNATURE_SCHEME = sig end module MakeRedDSA - (Ec : Ec_sig.AffineEdwardsT) (Param : sig + (Ec : Ec_sig.AffineEdwardsT) + (Param : sig val length : int val hash : Bytes.t -> Bytes.t diff --git a/src/lib_micheline/micheline_parser.ml b/src/lib_micheline/micheline_parser.ml index 51c99d0221f05a7e5d0a6c027d8cc181b00896ab..3f63368a6ab82eb2e62bc52dcd407fc58fb95022 100644 --- a/src/lib_micheline/micheline_parser.ml +++ b/src/lib_micheline/micheline_parser.ml @@ -548,7 +548,7 @@ let rec parse ?(check = true) errors tokens stack = | ( (Wrapped _ | Unwrapped _) :: _, {token = Open_paren; _} :: ({token = Int _ | String _ | Bytes _ | Annot _ | Close_paren; _} as - token) + token) :: rem ) | ( (Expression None | Sequence _ | Toplevel _) :: _, {token = Int _ | String _ | Bytes _; _} diff --git a/src/lib_micheline/test/test_parser.ml b/src/lib_micheline/test/test_parser.ml index dd7c6bb112baf915ca8828cf9ce780f25e8c09e5..3635cf0fefeab9df7611f0ae107a22fd3d53c6f3 100644 --- a/src/lib_micheline/test/test_parser.ml +++ b/src/lib_micheline/test/test_parser.ml @@ -42,19 +42,19 @@ let pp_tokens fmt tokens = fmt "@[%s@]" (let open Micheline_parser in - match token_value with - | String s -> Format.sprintf "String %S" s - | Bytes s -> Format.sprintf "Bytes %S" s - | Int s -> Format.sprintf "Int %S" s - | Ident s -> Format.sprintf "Ident %S" s - | Annot s -> Format.sprintf "Annot %S" s - | Comment s -> Format.sprintf "Comment %S" s - | Eol_comment s -> Format.sprintf "Eol_comment %S" s - | Semi -> Format.sprintf "Semi" - | Open_paren -> Format.sprintf "Open_paren" - | Close_paren -> Format.sprintf "Close_paren" - | Open_brace -> Format.sprintf "Open_brace" - | Close_brace -> Format.sprintf "Close_brace") + match token_value with + | String s -> Format.sprintf "String %S" s + | Bytes s -> Format.sprintf "Bytes %S" s + | Int s -> Format.sprintf "Int %S" s + | Ident s -> Format.sprintf "Ident %S" s + | Annot s -> Format.sprintf "Annot %S" s + | Comment s -> Format.sprintf "Comment %S" s + | Eol_comment s -> Format.sprintf "Eol_comment %S" s + | Semi -> Format.sprintf "Semi" + | Open_paren -> Format.sprintf "Open_paren" + | Close_paren -> Format.sprintf "Close_paren" + | Open_brace -> Format.sprintf "Open_brace" + | Close_brace -> Format.sprintf "Close_brace") in Format.fprintf fmt diff --git a/src/lib_node_config/config_file.ml b/src/lib_node_config/config_file.ml index 52371cf1582e90e32df682645caafe2d84b15413..f032c4c3184946652f3f99839620ba2773159ff7 100644 --- a/src/lib_node_config/config_file.ml +++ b/src/lib_node_config/config_file.ml @@ -529,13 +529,13 @@ let p2p = bool default_p2p.enable_testchain) (let open Tezos_p2p_services.Point_reconnection_config in - dft - "greylisting_config" - ~description: - "The reconnection policy regulates the frequency with which the \ - node tries to reconnect to an old known peer." - encoding - default) + dft + "greylisting_config" + ~description: + "The reconnection policy regulates the frequency with which the \ + node tries to reconnect to an old known peer." + encoding + default) (dft "disable_peer_discovery" ~description: @@ -858,7 +858,7 @@ let update ?(disable_config_validation = false) ?data_dir ?min_connections binary_chunks_size = Option.map (fun x -> x lsl 10) binary_chunks_size; maintenance_idle_time = (if disable_p2p_maintenance then None - else cfg.p2p.limits.maintenance_idle_time); + else cfg.p2p.limits.maintenance_idle_time); swap_linger = (if disable_p2p_swap then None else cfg.p2p.limits.swap_linger); } diff --git a/src/lib_node_config/data_version.ml b/src/lib_node_config/data_version.ml index e92bf36212ce58ed8707ea0cf263c1b6a33f2c17..f9f8ac5d874d32cf61dca76d24fea3645f488cf3 100644 --- a/src/lib_node_config/data_version.ml +++ b/src/lib_node_config/data_version.ml @@ -193,8 +193,8 @@ let () = Version.pp exp (if Version.compare got exp < 0 then - "incompatible and cannot be automatically upgraded." - else "too recent for this node version.")) + "incompatible and cannot be automatically upgraded." + else "too recent for this node version.")) Data_encoding.( obj2 (req "expected_version" Version.encoding) diff --git a/src/lib_octogram/agent.ml b/src/lib_octogram/agent.ml index db4440beb99d3feb7ee6dcbb1f2f16299b76b10e..fd742ab234c97900192c642b2bf9157e47934a8a 100644 --- a/src/lib_octogram/agent.ml +++ b/src/lib_octogram/agent.ml @@ -64,7 +64,7 @@ let run ~input ~output state = let* _ = Lwt.both (if Agent_builtins.agent_should_continue state then run () - else return ()) + else return ()) @@ match Helpers.of_json_string request_encoding req_str with | {proc_id; procedure = Packed proc} -> diff --git a/src/lib_p2p/p2p.ml b/src/lib_p2p/p2p.ml index eff2f2a2e62636add7d2c93f19289a67c3951b57..2004ac3b0e583110c10cf3572963babea2ba1a9e 100644 --- a/src/lib_p2p/p2p.ml +++ b/src/lib_p2p/p2p.ml @@ -190,21 +190,21 @@ module Real = struct let rec answerer = lazy (if config.private_mode then P2p_protocol.create_private () - else - let connect = - P2p_connect_handler.connect (Lazy.force connect_handler) - in - let proto_conf = - { - P2p_protocol.swap_linger = limits.P2p_limits.swap_linger; - pool; - log; - connect; - latest_accepted_swap = Ptime.epoch; - latest_successful_swap = Ptime.epoch; - } - in - P2p_protocol.create_default proto_conf) + else + let connect = + P2p_connect_handler.connect (Lazy.force connect_handler) + in + let proto_conf = + { + P2p_protocol.swap_linger = limits.P2p_limits.swap_linger; + pool; + log; + connect; + latest_accepted_swap = Ptime.epoch; + latest_successful_swap = Ptime.epoch; + } + in + P2p_protocol.create_default proto_conf) and connect_handler = lazy (create_connect_handler diff --git a/src/lib_p2p/p2p_connect_handler.ml b/src/lib_p2p/p2p_connect_handler.ml index 067147c7e9f0d27e4e5ed372cbb1f5b07a234a1c..66fad0c97c98e3a5d845c1a0374db7a390d9846d 100644 --- a/src/lib_p2p/p2p_connect_handler.ml +++ b/src/lib_p2p/p2p_connect_handler.ml @@ -359,12 +359,12 @@ let raw_authenticate t ?point_info canceler scheduled_conn point = may_register_my_id_point t.pool err ; t.log (Authentication_failed point) ; (if not incoming then - let timestamp = Time.System.now () in - Option.iter - (P2p_point_state.set_disconnected - ~timestamp - t.config.reconnection_config) - point_info) ; + let timestamp = Time.System.now () in + Option.iter + (P2p_point_state.set_disconnected + ~timestamp + t.config.reconnection_config) + point_info) ; Lwt.return_error err) in (* Authentication correct! *) diff --git a/src/lib_p2p/p2p_directory.ml b/src/lib_p2p/p2p_directory.ml index f7317d3715cdc04d6c55c6b72986d0fe831b908d..72422b711b5daa6771e3aa92a0997d3219bf1723 100644 --- a/src/lib_p2p/p2p_directory.ml +++ b/src/lib_p2p/p2p_directory.ml @@ -139,9 +139,9 @@ let build_rpc_directory net = (fun peer_id () () -> return (let open Option_syntax in - let* pool = P2p.pool net in - let+ conn = P2p_pool.Connection.find_by_peer_id pool peer_id in - P2p_conn.info conn)) + let* pool = P2p.pool net in + let+ conn = P2p_pool.Connection.find_by_peer_id pool peer_id in + P2p_conn.info conn)) in let dir = Tezos_rpc.Directory.lwt_register1 diff --git a/src/lib_p2p/p2p_io_scheduler.ml b/src/lib_p2p/p2p_io_scheduler.ml index 10d1581d2be319e9039af305ea0dd2556714438b..5e1abeb44d545c3ae58b7f39ac655b848e65b819 100644 --- a/src/lib_p2p/p2p_io_scheduler.ml +++ b/src/lib_p2p/p2p_io_scheduler.ml @@ -486,13 +486,13 @@ let reset_quota st = in let nb_conn = P2p_fd.Table.length st.connected in (if nb_conn > 0 then - let fair_read_quota = current_inflow / nb_conn - and fair_write_quota = current_outflow / nb_conn in - P2p_fd.Table.iter - (fun _id conn -> - conn.read_conn.quota <- min conn.read_conn.quota 0 + fair_read_quota ; - conn.write_conn.quota <- min conn.write_conn.quota 0 + fair_write_quota) - st.connected) ; + let fair_read_quota = current_inflow / nb_conn + and fair_write_quota = current_outflow / nb_conn in + P2p_fd.Table.iter + (fun _id conn -> + conn.read_conn.quota <- min conn.read_conn.quota 0 + fair_read_quota ; + conn.write_conn.quota <- min conn.write_conn.quota 0 + fair_write_quota) + st.connected) ; ReadScheduler.update_quota st.read_scheduler ; WriteScheduler.update_quota st.write_scheduler diff --git a/src/lib_p2p/p2p_maintenance.ml b/src/lib_p2p/p2p_maintenance.ml index 7a326c6cd25776b27cc0f61afaf8b63563f73a1e..6a7c58f36402e16ad6898824403459dbf21e414d 100644 --- a/src/lib_p2p/p2p_maintenance.ml +++ b/src/lib_p2p/p2p_maintenance.ml @@ -297,9 +297,9 @@ let rec worker_loop ~rng ~motive t = return Events.Last_maintenance) else ( (if not t.config.private_mode then - match t.debug_config with - | Some {trigger_swap = false; _} -> () - | _ -> send_swap_request t) ; + match t.debug_config with + | Some {trigger_swap = false; _} -> () + | _ -> send_swap_request t) ; protect ~canceler:t.canceler (fun () -> let timer_promise = let idle_time = t.config.maintenance_idle_time in diff --git a/src/lib_plompiler/circuit.ml b/src/lib_plompiler/circuit.ml index c71e97f4cb0da6666c0cdd8c6e8003e659fed685..05b48bae12b85aceb484e1cd784b9342210d87dd 100644 --- a/src/lib_plompiler/circuit.ml +++ b/src/lib_plompiler/circuit.ml @@ -1329,7 +1329,8 @@ module Mod_arith = struct ~ts_bounds in with_label ~label:"Mod_arith.is_zero" - @@ (* b is the output of [is_zero]: b = 1 if x = 0 and b = 0 otherwise *) + @@ + (* b is the output of [is_zero]: b = 1 if x = 0 and b = 0 otherwise *) let* b = fresh Dummy.bool in let* rs = fresh @@ Dummy.list nb_limbs Dummy.scalar in let (Bool out) = b in diff --git a/src/lib_plompiler/gadget_ed25519.ml b/src/lib_plompiler/gadget_ed25519.ml index 1d52bca663d88b9912ec8e2605505527285e909f..f68926a5cecdd689c124e41630563bf795016ede 100644 --- a/src/lib_plompiler/gadget_ed25519.ml +++ b/src/lib_plompiler/gadget_ed25519.ml @@ -269,7 +269,8 @@ module Ed25519 = struct in Num.range_check ~nb_bits:253 order_minus_s >* with_label ~label:"Ed25519.verify" - @@ (* h <- H (compressed (R) || compressed (pk) || msg ) *) + @@ + (* h <- H (compressed (R) || compressed (pk) || msg ) *) let* h = compute_h msg pk r in (* NOTE: we do not reduce a result of compute_h modulo Curve.Scalar.order *) with_label ~label:"Ed25519.scalar_mul" diff --git a/src/lib_plompiler/gadget_schnorr.ml b/src/lib_plompiler/gadget_schnorr.ml index 52481ed8c2e7ddf8e675a0571d63f7a5248f955c..f6f60c24bed251f3ff6de58206f42e1a85518561 100644 --- a/src/lib_plompiler/gadget_schnorr.ml +++ b/src/lib_plompiler/gadget_schnorr.ml @@ -24,7 +24,8 @@ (*****************************************************************************) module Make - (Curve : Mec.CurveSig.AffineEdwardsT) (H : sig + (Curve : Mec.CurveSig.AffineEdwardsT) + (H : sig module P : Hash_sig.P_HASH module V : Hash_sig.HASH diff --git a/src/lib_plonk/test_plompiler/benchmark.ml b/src/lib_plonk/test_plompiler/benchmark.ml index 3aca488225aceecd64406e5d8e953e9c3b2cabb2..f84a71c1c7eecc877484f5bb1354fc5155c8efdf 100644 --- a/src/lib_plonk/test_plompiler/benchmark.ml +++ b/src/lib_plonk/test_plompiler/benchmark.ml @@ -514,7 +514,8 @@ module Benchmark (L : LIB) = struct let x_g = of_pair generator |> fst in let* diff = Num.add x_pk ~qr:S.mone x_g in Num.assert_nonzero diff - >* (* Building signature message *) + >* + (* Building signature message *) let* compressed = monadic_compress [ diff --git a/src/lib_plonk/test_plompiler/test_poseidon.ml b/src/lib_plonk/test_plompiler/test_poseidon.ml index a49491a67e7cba22b379f0f1190ba696751baac6..430edeb4083b6ed3e6a17a8e41d75f4d06c8c779 100644 --- a/src/lib_plonk/test_plompiler/test_poseidon.ml +++ b/src/lib_plonk/test_plompiler/test_poseidon.ml @@ -29,7 +29,10 @@ module CS = Plonk.Circuit open Helpers module Poseidon_test - (Mec : Plompiler__Hash_sig.P_HASH) (P : functor (L : LIB) -> sig + (Mec : Plompiler__Hash_sig.P_HASH) + (P : functor + (L : LIB) + -> sig val digest : ?input_length:int -> L.scalar list L.repr -> L.scalar L.repr L.t end) diff --git a/src/lib_protocol_compiler/packer.ml b/src/lib_protocol_compiler/packer.ml index 552dbec1f7b83b216464936f37619724bf93ec88..b6b73a3099d684ac8d964dbc506199932c04eb97 100644 --- a/src/lib_protocol_compiler/packer.ml +++ b/src/lib_protocol_compiler/packer.ml @@ -34,7 +34,7 @@ let dump_file oc file = oc "%s" (if len = buflen then Bytes.unsafe_to_string buf - else Bytes.sub_string buf 0 len) ; + else Bytes.sub_string buf 0 len) ; loop ()) in loop () ; diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 5632ac2d8e562a01f784bdd7987e5a3bf71afe4e..d56b74a79edc66d05253f74a700f713f3d45bc41 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -90,21 +90,19 @@ module type T = sig and type operation = P.operation and type validation_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct module CamlinternalFormatBasics = CamlinternalFormatBasics include Stdlib @@ -562,58 +560,57 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V0.mli b/src/lib_protocol_environment/environment_V0.mli index 16aca09f9c6d6dcd80a23aa0cb506e7fbf8be42c..ba4637a649087fde1b189b04e0041cd02368e5fa 100644 --- a/src/lib_protocol_environment/environment_V0.mli +++ b/src/lib_protocol_environment/environment_V0.mli @@ -90,21 +90,19 @@ module type T = sig and type operation = P.operation and type validation_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index 1f7ef70bfe31253fbb0e5535eed81d56cd6f9bba..3bef8f2e93f94c070c15517ce2732ca1b8e7d435 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -91,21 +91,19 @@ module type T = sig and type operation = P.operation and type validation_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct module CamlinternalFormatBasics = CamlinternalFormatBasics include Stdlib @@ -690,58 +688,57 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V1.mli b/src/lib_protocol_environment/environment_V1.mli index 8520815a2f34b8d1812fe9c38de48940a01b8c2a..4eddcd25750dfc0399ea31ab7d978e0142eb2d54 100644 --- a/src/lib_protocol_environment/environment_V1.mli +++ b/src/lib_protocol_environment/environment_V1.mli @@ -90,21 +90,19 @@ module type T = sig and type operation = P.operation and type validation_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V10.ml b/src/lib_protocol_environment/environment_V10.ml index 365dceebd502fa7cb30c311426af540582e166fc..4323d73523e0c9c3f5f57f3d03a35d181384f4e3 100644 --- a/src/lib_protocol_environment/environment_V10.ml +++ b/src/lib_protocol_environment/environment_V10.ml @@ -154,21 +154,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct (* The protocol V10 only supports 64-bits architectures. We ensure this the hard way with a dynamic check. *) @@ -923,70 +921,69 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - t, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - t * 'a, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + t, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + t * 'a, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V10.mli b/src/lib_protocol_environment/environment_V10.mli index d4f07896faf322440673c99261a88eb2e2f0e0f3..dd6adbe9ced0a91cf549814a2135dbe27a999314 100644 --- a/src/lib_protocol_environment/environment_V10.mli +++ b/src/lib_protocol_environment/environment_V10.mli @@ -178,21 +178,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V11.ml b/src/lib_protocol_environment/environment_V11.ml index 9123d2de9b19550c826b156a32fb8320923123c3..9c7f021895d69d453c2a41d05540533a93d990cc 100644 --- a/src/lib_protocol_environment/environment_V11.ml +++ b/src/lib_protocol_environment/environment_V11.ml @@ -154,21 +154,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct (* The protocol V11 only supports 64-bits architectures. We ensure this the hard way with a dynamic check. *) @@ -934,70 +932,69 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - t, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - t * 'a, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + t, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + t * 'a, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V11.mli b/src/lib_protocol_environment/environment_V11.mli index 311307153f11e28ff9111c9e30bb7f68c7bdd24e..a215ac3bb17a1e14750a8b3d322f69bc8cfa93e8 100644 --- a/src/lib_protocol_environment/environment_V11.mli +++ b/src/lib_protocol_environment/environment_V11.mli @@ -178,21 +178,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index 2f86f2f934f2e4242e9cf49fd53b84b0922fe6b4..6e0fc2fb66f740750af202ee30aadcd752c3736c 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -96,21 +96,19 @@ module type T = sig and type operation = P.operation and type validation_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct module CamlinternalFormatBasics = CamlinternalFormatBasics include Stdlib @@ -703,58 +701,57 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V2.mli b/src/lib_protocol_environment/environment_V2.mli index ae13045d843733639c84779b3bc38959327a4ffe..1be3a0289b5e98d25af53c80673f8c1f40a626bd 100644 --- a/src/lib_protocol_environment/environment_V2.mli +++ b/src/lib_protocol_environment/environment_V2.mli @@ -119,21 +119,19 @@ module type T = sig and type operation = P.operation and type validation_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V3.ml b/src/lib_protocol_environment/environment_V3.ml index 360e490704c969c5a1f212b6067b2a99abd986e7..9f168384fe81a8ca7b36a4c65e83d903efe037bd 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -105,21 +105,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct (* The protocol V3 only supports 64-bits architectures. We ensure this the hard way with a dynamic check. *) @@ -852,58 +850,57 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V3.mli b/src/lib_protocol_environment/environment_V3.mli index 7c7e3588ace5ba43417930ef2401425a41d95c1c..d458679688142580aec8fa302ba6ae320f0653ba 100644 --- a/src/lib_protocol_environment/environment_V3.mli +++ b/src/lib_protocol_environment/environment_V3.mli @@ -128,21 +128,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V4.ml b/src/lib_protocol_environment/environment_V4.ml index ed770f9a98e8ecfafb96f56107a9c6482bb4c015..858606768ec493e85370e79effb9be9444c73202 100644 --- a/src/lib_protocol_environment/environment_V4.ml +++ b/src/lib_protocol_environment/environment_V4.ml @@ -111,21 +111,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct (* The protocol V4 only supports 64-bits architectures. We ensure this the hard way with a dynamic check. *) @@ -883,58 +881,57 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V4.mli b/src/lib_protocol_environment/environment_V4.mli index 07f784e22a5d74c3a1ed68e998bcb145c61202ee..90d1182d94a4d113bc62ec6404f8b4569ce97060 100644 --- a/src/lib_protocol_environment/environment_V4.mli +++ b/src/lib_protocol_environment/environment_V4.mli @@ -130,21 +130,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V5.ml b/src/lib_protocol_environment/environment_V5.ml index 43dddd2cfc189132d3586d3dc7dde95ed575af9a..abecf272f45a6a676051742bba61941b3fba9b92 100644 --- a/src/lib_protocol_environment/environment_V5.ml +++ b/src/lib_protocol_environment/environment_V5.ml @@ -118,21 +118,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct (* The protocol V5 only supports 64-bits architectures. We ensure this the hard way with a dynamic check. *) @@ -857,58 +855,57 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V5.mli b/src/lib_protocol_environment/environment_V5.mli index 745d58c4875ed7ccf94bc0a25e5d1fea06b15a76..ffe2ee5bc25142c4af1cec54706778fd9ca61f9a 100644 --- a/src/lib_protocol_environment/environment_V5.mli +++ b/src/lib_protocol_environment/environment_V5.mli @@ -143,21 +143,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 6b021941c143c7dbe69b9eea2bf7a2b8951728a8..753eb12a2b304cf0454204c6d8dfbc8b22f9f8d5 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -119,21 +119,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct (* The protocol V6 only supports 64-bits architectures. We ensure this the hard way with a dynamic check. *) @@ -859,58 +857,57 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V6.mli b/src/lib_protocol_environment/environment_V6.mli index ae1d240aefeb1d14efdc3d075dc532577a358492..78cfe006617b5681ad3968dabf71a84a5d9a8885 100644 --- a/src/lib_protocol_environment/environment_V6.mli +++ b/src/lib_protocol_environment/environment_V6.mli @@ -144,21 +144,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.validation_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V7.ml b/src/lib_protocol_environment/environment_V7.ml index 60df5f376f19938ec6d45c3f12fff351181e7d3a..51dcc1189424a1f3408fc098908a0148cf6d0b46 100644 --- a/src/lib_protocol_environment/environment_V7.ml +++ b/src/lib_protocol_environment/environment_V7.ml @@ -131,21 +131,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct (* The protocol V7 only supports 64-bits architectures. We ensure this the hard way with a dynamic check. *) @@ -868,58 +866,57 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V7.mli b/src/lib_protocol_environment/environment_V7.mli index a8c8ec9a9d4eed0f2d1aa9ab4e0ce04e4fc3016a..145d76fc80a5231ba5f21d617e0b5f6ca84355dd 100644 --- a/src/lib_protocol_environment/environment_V7.mli +++ b/src/lib_protocol_environment/environment_V7.mli @@ -155,21 +155,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V8.ml b/src/lib_protocol_environment/environment_V8.ml index 6f6351e1a68697989be0ed01bba7a71aa8a63b1f..af2da05db2065ed0f93944e276f7791226fcb161 100644 --- a/src/lib_protocol_environment/environment_V8.ml +++ b/src/lib_protocol_environment/environment_V8.ml @@ -138,21 +138,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct (* The protocol V8 only supports 64-bits architectures. We ensure this the hard way with a dynamic check. *) @@ -913,70 +911,69 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - t, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - t * 'a, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + t, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + t * 'a, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V8.mli b/src/lib_protocol_environment/environment_V8.mli index d8a363953bff2169b6edc1c19251e5c1dba9ef03..c45595125ba92e856d9a90cbadc46b13c2d02699 100644 --- a/src/lib_protocol_environment/environment_V8.mli +++ b/src/lib_protocol_environment/environment_V8.mli @@ -162,21 +162,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/environment_V9.ml b/src/lib_protocol_environment/environment_V9.ml index 0e8a620135e03538ee6ab469259a948c7091e20a..93defdfebff22fa1bf401fe7f594f100b399525d 100644 --- a/src/lib_protocol_environment/environment_V9.ml +++ b/src/lib_protocol_environment/environment_V9.ml @@ -142,21 +142,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple - - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple + + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() = +module Make + (Param : sig + val name : string + end) + () = struct (* The protocol V9 only supports 64-bits architectures. We ensure this the hard way with a dynamic check. *) @@ -911,70 +909,69 @@ struct module RPC_context = struct type t = rpc_context - class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - t, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service1 : - 'm 'a 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - t * 'a, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - t, - (t * 'a) * 'b, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + t, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service1 : + 'm 'a 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + t * 'a, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + ( ([< Tezos_rpc.Service.meth] as 'm), + t, + (t * 'a) * 'b, + 'q, + 'i, + 'o ) + Tezos_rpc.Service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t + end let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s diff --git a/src/lib_protocol_environment/environment_V9.mli b/src/lib_protocol_environment/environment_V9.mli index ffe3f8a7b6182c51d699638620b70b6b26b8a34b..d27f723e40b28e25c7a8b2bc7fbf08080396995e 100644 --- a/src/lib_protocol_environment/environment_V9.mli +++ b/src/lib_protocol_environment/environment_V9.mli @@ -166,21 +166,19 @@ module type T = sig and type validation_state = P.validation_state and type application_state = P.application_state - class ['chain, 'block] proto_rpc_context : - Tezos_rpc.Context.t - -> (unit, (unit * 'chain) * 'block) RPC_path.t - -> ['chain * 'block] RPC_context.simple + class ['chain, 'block] proto_rpc_context : Tezos_rpc.Context.t -> + (unit, (unit * 'chain) * 'block) RPC_path.t -> + ['chain * 'block] RPC_context.simple - class ['block] proto_rpc_context_of_directory : - ('block -> RPC_context.t) - -> RPC_context.t RPC_directory.t - -> ['block] RPC_context.simple + class ['block] proto_rpc_context_of_directory : ('block -> RPC_context.t) -> + RPC_context.t RPC_directory.t -> ['block] RPC_context.simple end -module Make (Param : sig - val name : string -end) -() : +module Make + (Param : sig + val name : string + end) + () : T with type Updater.validation_result = validation_result and type Updater.quota = quota diff --git a/src/lib_protocol_environment/sigs/v0/RPC_context.mli b/src/lib_protocol_environment/sigs/v0/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v0/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v0/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v0/blake2B.mli b/src/lib_protocol_environment/sigs/v0/blake2B.mli index efdbfbe9ccdd268eea94191c31e7ea9a67eeb735..defc65d2d5830c068587a793de35a8105bd05c72 100644 --- a/src/lib_protocol_environment/sigs/v0/blake2B.mli +++ b/src/lib_protocol_environment/sigs/v0/blake2B.mli @@ -45,13 +45,14 @@ end module Make_minimal (Name : Name) : S.MINIMAL_HASH -module Make (Register : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Base58.data) -> - 'a Base58.encoding -end) -(Name : PrefixedName) : S.HASH +module Make + (Register : sig + val register_encoding : + prefix:string -> + length:int -> + to_raw:('a -> string) -> + of_raw:(string -> 'a option) -> + wrap:('a -> Base58.data) -> + 'a Base58.encoding + end) + (Name : PrefixedName) : S.HASH diff --git a/src/lib_protocol_environment/sigs/v0/int32.mli b/src/lib_protocol_environment/sigs/v0/int32.mli index 3f66909635293a7821e3be999f95acab09be1534..a856e260603d71300d5f388546a21df2fb1283b4 100644 --- a/src/lib_protocol_environment/sigs/v0/int32.mli +++ b/src/lib_protocol_environment/sigs/v0/int32.mli @@ -124,12 +124,12 @@ external to_int : int32 -> int = "%int32_to_int" the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *) external of_float : float -> int32 = "caml_int32_of_float" "caml_int32_of_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Convert the given 32-bit integer to a floating-point number. *) external to_float : int32 -> float = "caml_int32_to_float" "caml_int32_to_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Convert the given string to a 32-bit integer. The string is read in decimal (by default, or if the string @@ -162,14 +162,14 @@ val to_string : int32 -> string represent the mantissa. *) external bits_of_float : float -> int32 = "caml_int32_bits_of_float" "caml_int32_bits_of_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Return the floating-point number whose internal representation, according to the IEEE 754 floating-point 'single format' bit layout, is the given [int32]. *) external float_of_bits : int32 -> float = "caml_int32_float_of_bits" "caml_int32_float_of_bits_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** An alias for the type of 32-bit integers. *) type t = int32 diff --git a/src/lib_protocol_environment/sigs/v0/int64.mli b/src/lib_protocol_environment/sigs/v0/int64.mli index 3ff2be8c7e37626400c9d996c2143672f843c35b..56141c49599f0501bbfb0f4745c17737ecdff786 100644 --- a/src/lib_protocol_environment/sigs/v0/int64.mli +++ b/src/lib_protocol_environment/sigs/v0/int64.mli @@ -125,12 +125,12 @@ external to_int : int64 -> int = "%int64_to_int" the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *) external of_float : float -> int64 = "caml_int64_of_float" "caml_int64_of_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Convert the given 64-bit integer to a floating-point number. *) external to_float : int64 -> float = "caml_int64_to_float" "caml_int64_to_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Convert the given 32-bit integer (type [int32]) to a 64-bit integer (type [int64]). *) @@ -183,14 +183,14 @@ val to_string : int64 -> string represent the mantissa. *) external bits_of_float : float -> int64 = "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** Return the floating-point number whose internal representation, according to the IEEE 754 floating-point 'double format' bit layout, is the given [int64]. *) external float_of_bits : int64 -> float = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed" - [@@unboxed] [@@noalloc] +[@@unboxed] [@@noalloc] (** An alias for the type of 64-bit integers. *) type t = int64 diff --git a/src/lib_protocol_environment/sigs/v1/RPC_context.mli b/src/lib_protocol_environment/sigs/v1/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v1/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v1/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v10/RPC_context.mli b/src/lib_protocol_environment/sigs/v10/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v10/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v10/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v11/RPC_context.mli b/src/lib_protocol_environment/sigs/v11/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v11/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v11/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v2/RPC_context.mli b/src/lib_protocol_environment/sigs/v2/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v2/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v2/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v3/RPC_context.mli b/src/lib_protocol_environment/sigs/v3/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v3/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v3/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v4/RPC_context.mli b/src/lib_protocol_environment/sigs/v4/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v4/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v4/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v5/RPC_context.mli b/src/lib_protocol_environment/sigs/v5/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v5/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v5/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v6/RPC_context.mli b/src/lib_protocol_environment/sigs/v6/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v6/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v6/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v7/RPC_context.mli b/src/lib_protocol_environment/sigs/v7/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v7/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v7/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v8/RPC_context.mli b/src/lib_protocol_environment/sigs/v8/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v8/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v8/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/sigs/v9/RPC_context.mli b/src/lib_protocol_environment/sigs/v9/RPC_context.mli index 3eb4b4094aeec81200f734d0459dd7321b26ac6f..786a271bdaa5c10ba40d49c4a0fde11a3cc4d670 100644 --- a/src/lib_protocol_environment/sigs/v9/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v9/RPC_context.mli @@ -25,52 +25,51 @@ type t = Updater.rpc_context -class type ['pr] simple = - object - method call_proto_service0 : - 'm 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t +class type ['pr] simple = object + method call_proto_service0 : + 'm 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service1 : - 'm 'a 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service1 : + 'm 'a 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service2 : - 'm 'a 'b 'q 'i 'o. - (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t + method call_proto_service2 : + 'm 'a 'b 'q 'i 'o. + (([< RPC_service.meth] as 'm), t, (t * 'a) * 'b, 'q, 'i, 'o) RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t - method call_proto_service3 : - 'm 'a 'b 'c 'q 'i 'o. - ( ([< RPC_service.meth] as 'm), - t, - ((t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - RPC_service.t -> - 'pr -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o Error_monad.shell_tzresult Lwt.t - end + method call_proto_service3 : + 'm 'a 'b 'c 'q 'i 'o. + ( ([< RPC_service.meth] as 'm), + t, + ((t * 'a) * 'b) * 'c, + 'q, + 'i, + 'o ) + RPC_service.t -> + 'pr -> + 'a -> + 'b -> + 'c -> + 'q -> + 'i -> + 'o Error_monad.shell_tzresult Lwt.t +end val make_call0 : ([< RPC_service.meth], t, t, 'q, 'i, 'o) RPC_service.t -> diff --git a/src/lib_protocol_environment/structs/v0_blake2B.ml b/src/lib_protocol_environment/structs/v0_blake2B.ml index 5f31e02a0cc9d142e52ceda018ee6024ab8184a9..5c376f34fd042b5c812853d474050b8a286fa185 100644 --- a/src/lib_protocol_environment/structs/v0_blake2B.ml +++ b/src/lib_protocol_environment/structs/v0_blake2B.ml @@ -25,16 +25,17 @@ include Tezos_crypto.Blake2B -module Make (Register : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Tezos_crypto.Base58.data) -> - 'a Tezos_crypto.Base58.encoding -end) -(Name : PrefixedName) = +module Make + (Register : sig + val register_encoding : + prefix:string -> + length:int -> + to_raw:('a -> string) -> + of_raw:(string -> 'a option) -> + wrap:('a -> Tezos_crypto.Base58.data) -> + 'a Tezos_crypto.Base58.encoding + end) + (Name : PrefixedName) = struct include Tezos_crypto.Blake2B.Make (Register) (Name) diff --git a/src/lib_protocol_updater/registered_protocol.mli b/src/lib_protocol_updater/registered_protocol.mli index 9db928f88729780e060d234560ada28bb6180250..0540f26eca31fa83daff64d3f048e98eee8a7aeb 100644 --- a/src/lib_protocol_updater/registered_protocol.mli +++ b/src/lib_protocol_updater/registered_protocol.mli @@ -52,7 +52,8 @@ val get_embedded_sources : Protocol_hash.t -> Protocol.t option module Register_embedded_V0 (Env : Tezos_protocol_environment.V0.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -65,7 +66,8 @@ module Register_embedded_V0 module Register_embedded_V1 (Env : Tezos_protocol_environment.V1.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -78,7 +80,8 @@ module Register_embedded_V1 module Register_embedded_V2 (Env : Tezos_protocol_environment.V2.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -92,7 +95,8 @@ module Register_embedded_V2 module Register_embedded_V3 (Env : Tezos_protocol_environment.V3.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -106,7 +110,8 @@ module Register_embedded_V3 module Register_embedded_V4 (Env : Tezos_protocol_environment.V4.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -120,7 +125,8 @@ module Register_embedded_V4 module Register_embedded_V5 (Env : Tezos_protocol_environment.V5.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -134,7 +140,8 @@ module Register_embedded_V5 module Register_embedded_V6 (Env : Tezos_protocol_environment.V6.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -148,7 +155,8 @@ module Register_embedded_V6 module Register_embedded_V7 (Env : Tezos_protocol_environment.V7.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -162,7 +170,8 @@ module Register_embedded_V7 module Register_embedded_V8 (Env : Tezos_protocol_environment.V8.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -176,7 +185,8 @@ module Register_embedded_V8 module Register_embedded_V9 (Env : Tezos_protocol_environment.V9.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -190,7 +200,8 @@ module Register_embedded_V9 module Register_embedded_V10 (Env : Tezos_protocol_environment.V10.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t @@ -204,7 +215,8 @@ module Register_embedded_V10 module Register_embedded_V11 (Env : Tezos_protocol_environment.V11.T) - (Proto : Env.Updater.PROTOCOL) (Source : sig + (Proto : Env.Updater.PROTOCOL) + (Source : sig val hash : Protocol_hash.t option val sources : Protocol.t diff --git a/src/lib_proxy/light_core.ml b/src/lib_proxy/light_core.ml index 502765cadb3ae2725d0efb5e50ee20b4d98c8c6c..36aa3370b8df6976526afaa5053f6f094df81243 100644 --- a/src/lib_proxy/light_core.ml +++ b/src/lib_proxy/light_core.ml @@ -49,13 +49,14 @@ let light_failwith (pgi : Proxy.proxy_getter_input) ?(warn_symbolic = false) msg (chain_n_block_to_string pgi.chain pgi.block) msg (if warn_symbolic && symbolic_block then - Format.sprintf - ". Because requested block is symbolic: %s (it has no hash), it could \ - be that the different endpoints are mapping this symbolic identifier \ - to different concrete blocks. If you are using the 'head' identifier \ - (or 'head~1', etc.) in a RPC path, replace it with a concrete hash." - @@ Block_services.to_string pgi.block - else "") + Format.sprintf + ". Because requested block is symbolic: %s (it has no hash), it \ + could be that the different endpoints are mapping this symbolic \ + identifier to different concrete blocks. If you are using the \ + 'head' identifier (or 'head~1', etc.) in a RPC path, replace it \ + with a concrete hash." + @@ Block_services.to_string pgi.block + else "") in let* () = Logger.(emit failing full_msg) in failwith "%s" full_msg diff --git a/src/lib_proxy/rpc/RPC_client.mli b/src/lib_proxy/rpc/RPC_client.mli index 4e47edf417f8ee361eec86fcf6fc4e68a7c7ddba..7c8d64102f0cbfb2b02ac2fb6249b2ef04057e1a 100644 --- a/src/lib_proxy/rpc/RPC_client.mli +++ b/src/lib_proxy/rpc/RPC_client.mli @@ -29,9 +29,6 @@ over http), and whether [tezos-proxy-server] or [octez-client] is running - the protocol-dependent implementation of the proxy (the proxy mode obtains data from endpoints with protocol-dependent RPCs). *) -class http_local_ctxt : - Tezos_client_base.Client_context.printer - -> Tezos_rpc.Context.generic - -> Tezos_proxy.Proxy_services.mode - -> Protocol_hash.t option - -> Tezos_rpc.Context.generic +class http_local_ctxt : Tezos_client_base.Client_context.printer -> + Tezos_rpc.Context.generic -> Tezos_proxy.Proxy_services.mode -> + Protocol_hash.t option -> Tezos_rpc.Context.generic diff --git a/src/lib_proxy/test/test_fuzzing_light.ml b/src/lib_proxy/test/test_fuzzing_light.ml index aed9ed3c38a5d14fe9615fe9665e2c96fd5b0ed4..f5ace70e3ef1c5e16af6937972fc9914dc8afe05 100644 --- a/src/lib_proxy/test/test_fuzzing_light.ml +++ b/src/lib_proxy/test/test_fuzzing_light.ml @@ -128,7 +128,7 @@ module Consensus = struct let printer = mock_printer () in let input : Tezos_proxy.Light_consensus.input = { - printer = (printer :> Tezos_client_base.Client_context.printer); + printer :> Tezos_client_base.Client_context.printer; min_agreement; chain; block; diff --git a/src/lib_proxy/test_helpers/shell_services/test_helpers_shell_services.ml b/src/lib_proxy/test_helpers/shell_services/test_helpers_shell_services.ml index 48563c7e7ec37ce1c2599369896679f7f7f2cb31..606b6a9f4e6369939c5c0b1789c663b3accf1845 100644 --- a/src/lib_proxy/test_helpers/shell_services/test_helpers_shell_services.ml +++ b/src/lib_proxy/test_helpers/shell_services/test_helpers_shell_services.ml @@ -96,9 +96,9 @@ let merkle_proof_gen = (Store.index store) kinded_key (let open Lwt_syntax in - fun t -> - let* _ = Store.Tree.find t path in - return (t, ())) + fun t -> + let* _ = Store.Tree.find t path in + return (t, ())) |> Lwt_main.run in return (proof, tree, path) diff --git a/src/lib_requester/requester.ml b/src/lib_requester/requester.ml index 7cc1d7452e01649daa399212b55dca69112fabcc..e344f23c5dd718f5ca958e7381bd7882d75ca906 100644 --- a/src/lib_requester/requester.ml +++ b/src/lib_requester/requester.ml @@ -383,8 +383,8 @@ end = struct let requested_peer = P2p_peer.Id.Set.random_elt (if P2p_peer.Set.is_empty remaining_peers then - active_peers - else remaining_peers) + active_peers + else remaining_peers) in let next_request = Option.value ~default:Ptime.max (Ptime.add_span now delay) diff --git a/src/lib_rpc/RPC_context.ml b/src/lib_rpc/RPC_context.ml index e9d1f268f5132e5868a8aab0709b888540d9e8c9..35a3f588252a2ed6f7fdbce32561fd4ecc45eaf4 100644 --- a/src/lib_rpc/RPC_context.ml +++ b/src/lib_rpc/RPC_context.ml @@ -25,53 +25,47 @@ open Error_monad -class type ['pr] gen_simple = - object - method call_service : - 'm 'p 'q 'i 'o. - (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> - 'p -> - 'q -> - 'i -> - 'o tzresult Lwt.t - end +class type ['pr] gen_simple = object + method call_service : + 'm 'p 'q 'i 'o. + (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> + 'p -> + 'q -> + 'i -> + 'o tzresult Lwt.t +end -class type ['pr] gen_streamed = - object - method call_streamed_service : - 'm 'p 'q 'i 'o. - (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> - on_chunk:('o -> unit) -> - on_close:(unit -> unit) -> - 'p -> - 'q -> - 'i -> - (unit -> unit) tzresult Lwt.t - end +class type ['pr] gen_streamed = object + method call_streamed_service : + 'm 'p 'q 'i 'o. + (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> + on_chunk:('o -> unit) -> + on_close:(unit -> unit) -> + 'p -> + 'q -> + 'i -> + (unit -> unit) tzresult Lwt.t +end -class type ['pr] gen = - object - inherit ['pr] gen_simple +class type ['pr] gen = object + inherit ['pr] gen_simple - inherit ['pr] gen_streamed - end + inherit ['pr] gen_streamed +end -class type simple = - object - inherit [unit] gen_simple - end +class type simple = object + inherit [unit] gen_simple +end -class type streamed = - object - inherit [unit] gen_streamed - end +class type streamed = object + inherit [unit] gen_streamed +end -class type t = - object - inherit simple +class type t = object + inherit simple - inherit streamed - end + inherit streamed +end type ('o, 'e) rest = [ `Ok of 'o @@ -89,18 +83,17 @@ type generic_call_result = | `Binary of (string, string option) rest | `Other of (string * string) option * (string, string option) rest ] -class type generic = - object - inherit t +class type generic = object + inherit t - method generic_media_type_call : - RPC_service.meth -> - ?body:Data_encoding.json -> - Uri.t -> - generic_call_result tzresult Lwt.t + method generic_media_type_call : + RPC_service.meth -> + ?body:Data_encoding.json -> + Uri.t -> + generic_call_result tzresult Lwt.t - method base : Uri.t - end + method base : Uri.t +end type error += | Not_found of {meth : RPC_service.meth; uri : Uri.t} diff --git a/src/lib_rpc/RPC_context.mli b/src/lib_rpc/RPC_context.mli index 0846f47c46a0f9d793fcab51a4735f6c6fe33917..0f59c7ae8db1802515f6cd060bee7185a0bd36aa 100644 --- a/src/lib_rpc/RPC_context.mli +++ b/src/lib_rpc/RPC_context.mli @@ -25,53 +25,47 @@ open Error_monad -class type ['pr] gen_simple = - object - method call_service : - 'm 'p 'q 'i 'o. - (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> - 'p -> - 'q -> - 'i -> - 'o tzresult Lwt.t - end - -class type ['pr] gen_streamed = - object - method call_streamed_service : - 'm 'p 'q 'i 'o. - (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> - on_chunk:('o -> unit) -> - on_close:(unit -> unit) -> - 'p -> - 'q -> - 'i -> - (unit -> unit) tzresult Lwt.t - end - -class type ['pr] gen = - object - inherit ['pr] gen_simple - - inherit ['pr] gen_streamed - end - -class type simple = - object - inherit [unit] gen_simple - end - -class type streamed = - object - inherit [unit] gen_streamed - end - -class type t = - object - inherit simple - - inherit streamed - end +class type ['pr] gen_simple = object + method call_service : + 'm 'p 'q 'i 'o. + (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> + 'p -> + 'q -> + 'i -> + 'o tzresult Lwt.t +end + +class type ['pr] gen_streamed = object + method call_streamed_service : + 'm 'p 'q 'i 'o. + (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> + on_chunk:('o -> unit) -> + on_close:(unit -> unit) -> + 'p -> + 'q -> + 'i -> + (unit -> unit) tzresult Lwt.t +end + +class type ['pr] gen = object + inherit ['pr] gen_simple + + inherit ['pr] gen_streamed +end + +class type simple = object + inherit [unit] gen_simple +end + +class type streamed = object + inherit [unit] gen_streamed +end + +class type t = object + inherit simple + + inherit streamed +end (** ['o] is the type of the result (output) and ['e] the type of the error *) type ('o, 'e) rest = @@ -93,18 +87,17 @@ type generic_call_result = (string * string) option * (string, string option) rest (* [(string * string) option] corresponds to the content type *) ] -class type generic = - object - inherit t +class type generic = object + inherit t - method generic_media_type_call : - RPC_service.meth -> - ?body:Data_encoding.json -> - Uri.t -> - generic_call_result tzresult Lwt.t + method generic_media_type_call : + RPC_service.meth -> + ?body:Data_encoding.json -> + Uri.t -> + generic_call_result tzresult Lwt.t - method base : Uri.t - end + method base : Uri.t +end class ['pr] of_directory : 'pr RPC_directory.t -> ['pr] gen diff --git a/src/lib_rpc_http/test/test_rpc_http.ml b/src/lib_rpc_http/test/test_rpc_http.ml index 3fc7e7e3b09f6b8dd6de0dc71a8eb1477deb7078..4937f77be88af68c89cc00f38be6469aa7fe5f78 100644 --- a/src/lib_rpc_http/test/test_rpc_http.ml +++ b/src/lib_rpc_http/test/test_rpc_http.ml @@ -353,16 +353,16 @@ let test_matching_with_name_resolving = (fun () -> Lwt_main.run (let open Lwt_syntax in - let* policy = resolve_domain_names_in_policy example_policy in - List.iter - (fun (ip_addr, port, expected) -> - check_acl_search - "a domain name should match an appropriate IP address" - policy - expected - (ip_addr, port)) - to_test ; - return_unit)) + let* policy = resolve_domain_names_in_policy example_policy in + List.iter + (fun (ip_addr, port, expected) -> + check_acl_search + "a domain name should match an appropriate IP address" + policy + expected + (ip_addr, port)) + to_test ; + return_unit)) let test_media_type_pp_parse = let open Tezos_rpc_http.Media_type.Command_line in diff --git a/src/lib_sapling/bindings/gen_runtime_js.ml b/src/lib_sapling/bindings/gen_runtime_js.ml index 97490bd039751ab8f044fa87f32ba96e57232206..e1efe8327629cef59bf97a5137c0770f33d51685 100644 --- a/src/lib_sapling/bindings/gen_runtime_js.ml +++ b/src/lib_sapling/bindings/gen_runtime_js.ml @@ -24,10 +24,10 @@ (*****************************************************************************) let rec compute_arity : 'a. 'a Ctypes_static.fn -> int = - fun (type a) (t : a Ctypes_static.fn) -> - match t with - | Ctypes_static.Returns _ -> 0 - | Function (_, x) -> 1 + compute_arity x + fun (type a) (t : a Ctypes_static.fn) -> + match t with + | Ctypes_static.Returns _ -> 0 + | Function (_, x) -> 1 + compute_arity x let max_arity = 5 diff --git a/src/lib_scoru_wasm/test/test_debug.ml b/src/lib_scoru_wasm/test/test_debug.ml index fff2d853ee7c98e6a0b8dea4c5d23ab76551fda8..ac5fd7d44ee2b57fe3401af1b93706d31c6ec596 100644 --- a/src/lib_scoru_wasm/test/test_debug.ml +++ b/src/lib_scoru_wasm/test/test_debug.ml @@ -55,8 +55,8 @@ let write_debug ~version ~debug ~init ~values memories = ~version ~write_debug: (if debug then - Printer (fun str -> Lwt.return @@ Format.printf "%s" str) - else Noop)) + Printer (fun str -> Lwt.return @@ Format.printf "%s" str) + else Noop)) ~input ~init Host_funcs.Internal_for_tests.write_debug diff --git a/src/lib_shell/distributed_db.ml b/src/lib_shell/distributed_db.ml index 907934442b9c8799e5d30affc2506b8fa28d6401..4959ba17a80c85c4f37bab4a305c0f8a0e50c1f4 100644 --- a/src/lib_shell/distributed_db.ml +++ b/src/lib_shell/distributed_db.ml @@ -331,7 +331,8 @@ let commit_protocol db h p = [Distributed_db_requester.Raw_*.t] has been properly created before it is possible to use it *) module Make - (Table : Requester.REQUESTER) (Kind : sig + (Table : Requester.REQUESTER) + (Kind : sig type t val proj : t -> Table.t diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index 804f4fd643e88e85c0b387708a4e55ac92c54dbd..5ad6c8662d15cfb8eebaa7c2943ddea09b4775fa 100644 --- a/src/lib_shell/prevalidator.ml +++ b/src/lib_shell/prevalidator.ml @@ -949,265 +949,269 @@ module Make let build_rpc_directory w = lazy (let open Lwt_result_syntax in - let dir : state Tezos_rpc.Directory.t ref = - ref Tezos_rpc.Directory.empty - in - let module Proto_services = Block_services.Make (Proto) (Proto) in - dir := - Tezos_rpc.Directory.register - !dir - (Proto_services.S.Mempool.get_filter Tezos_rpc.Path.open_root) - (fun pv params () -> - return (get_config_json ~include_default:params#include_default pv)) ; - dir := - Tezos_rpc.Directory.register - !dir - (Proto_services.S.Mempool.set_filter Tezos_rpc.Path.open_root) - (fun pv () obj -> - let open Lwt_syntax in - let* () = - try - let config = - Data_encoding.Json.destruct - Prevalidation_t.config_encoding - obj - in - pv.config <- config ; - Lwt.return_unit - with _ -> Events.(emit invalid_mempool_filter_configuration) () - in - (* We return [get_config_json pv] rather than [obj] in - order to show omitted fields (which have been reset to - their default values), and also in case [obj] is invalid. *) - return_ok (get_config_json pv)) ; - (* Ban an operation (from its given hash): remove it from the - mempool if present. Add it to the set pv.banned_operations - to prevent it from being fetched/processed/injected in the - future. - Note: If the baker has already received the operation, then - it's necessary to restart it manually to flush the operation - from it. *) - dir := - Tezos_rpc.Directory.register - !dir - (Proto_services.S.Mempool.ban_operation Tezos_rpc.Path.open_root) - (fun _pv () oph -> - let open Lwt_result_syntax in - let*! r = Worker.Queue.push_request_and_wait w (Request.Ban oph) in - match r with - | Error (Closed None) -> fail [Worker_types.Terminated] - | Error (Closed (Some errs)) -> fail errs - | Error (Request_error err) -> fail err - | Error (Any exn) -> fail [Exn exn] - | Ok () -> return_unit) ; - (* Unban an operation (from its given hash): remove it from the - set pv.banned_operations (nothing happens if it was not banned). *) - dir := - Tezos_rpc.Directory.register - !dir - (Proto_services.S.Mempool.unban_operation Tezos_rpc.Path.open_root) - (fun pv () oph -> - pv.shell.banned_operations <- - Operation_hash.Set.remove oph pv.shell.banned_operations ; - return_unit) ; - (* Unban all operations: clear the set pv.banned_operations. *) - dir := - Tezos_rpc.Directory.register - !dir - (Proto_services.S.Mempool.unban_all_operations - Tezos_rpc.Path.open_root) - (fun pv () () -> - pv.shell.banned_operations <- Operation_hash.Set.empty ; - return_unit) ; - dir := - Tezos_rpc.Directory.gen_register - !dir - (Proto_services.S.Mempool.pending_operations Tezos_rpc.Path.open_root) - (fun pv params () -> - let validated = - if - params#validated && Option.value ~default:true params#applied - (* https://gitlab.com/tezos/tezos/-/issues/5891 - applied is deprecated and should be removed in a future - version of Octez *) - then - Classification.Sized_map.to_map - pv.shell.classification.validated - |> Operation_hash.Map.to_seq - |> Seq.filter_map (fun (oph, op) -> - if - filter_validation_passes - params#validation_passes - op.protocol - then Some (oph, op.protocol) - else None) - |> List.of_seq - else [] - in - let process_map map = - let open Operation_hash in - Map.filter_map - (fun _oph (op, error) -> - if - filter_validation_passes - params#validation_passes - op.protocol - then Some (op.protocol, error) - else None) - map - in - let refused = - if params#refused then - process_map (Classification.map pv.shell.classification.refused) - else Operation_hash.Map.empty - in - let outdated = - if params#outdated then - process_map - (Classification.map pv.shell.classification.outdated) - else Operation_hash.Map.empty - in - let branch_refused = - if params#branch_refused then - process_map - (Classification.map pv.shell.classification.branch_refused) - else Operation_hash.Map.empty - in - let branch_delayed = - if params#branch_delayed then - process_map - (Classification.map pv.shell.classification.branch_delayed) - else Operation_hash.Map.empty - in - let unprocessed = - Operation_hash.Map.filter_map - (fun _ {protocol; _} -> - if filter_validation_passes params#validation_passes protocol - then Some protocol - else None) - (Pending_ops.operations pv.shell.pending) - in - let pending_operations = - { - Proto_services.Mempool.validated; - refused; - outdated; - branch_refused; - branch_delayed; - unprocessed; - } - in - Tezos_rpc.Answer.return (params#version, pending_operations)) ; - dir := - Tezos_rpc.Directory.register - !dir - (Proto_services.S.Mempool.request_operations Tezos_rpc.Path.open_root) - (fun pv t () -> - pv.shell.parameters.tools.send_get_current_head ?peer:t#peer_id () ; - return_unit) ; - dir := - Tezos_rpc.Directory.gen_register - !dir - (Proto_services.S.Mempool.monitor_operations Tezos_rpc.Path.open_root) - (fun pv params () -> - Lwt_mutex.with_lock pv.lock @@ fun () -> - let op_stream, stopper = - Lwt_watcher.create_stream pv.operation_stream - in - (* First call : retrieve the current set of op from the mempool *) - let validated_seq = - if - params#validated && Option.value ~default:true params#applied - (* https://gitlab.com/tezos/tezos/-/issues/5891 - applied is deprecated and should be removed in a future - version of Octez *) - then - Classification.Sized_map.to_map - pv.shell.classification.validated - |> Operation_hash.Map.to_seq - |> Seq.map (fun (hash, {protocol; _}) -> - ((hash, protocol), None)) - else Seq.empty - in - let process_error_map map = - let open Operation_hash in - map |> Map.to_seq - |> Seq.map (fun (hash, (op, error)) -> - ((hash, op.protocol), Some error)) - in - let refused_seq = - if params#refused then - process_error_map - (Classification.map pv.shell.classification.refused) - else Seq.empty - in - let branch_refused_seq = - if params#branch_refused then - process_error_map - (Classification.map pv.shell.classification.branch_refused) - else Seq.empty - in - let branch_delayed_seq = - if params#branch_delayed then - process_error_map - (Classification.map pv.shell.classification.branch_delayed) - else Seq.empty - in - let outdated_seq = - if params#outdated then - process_error_map - (Classification.map pv.shell.classification.outdated) - else Seq.empty - in - let filter ((_, op), _) = - filter_validation_passes params#validation_passes op - in - let current_mempool = - Seq.append outdated_seq branch_delayed_seq - |> Seq.append branch_refused_seq - |> Seq.append refused_seq |> Seq.append validated_seq - |> Seq.filter filter |> List.of_seq - in - let current_mempool = ref (Some current_mempool) in - let filter_result = function - | `Validated -> - params#validated && Option.value ~default:true params#applied - | `Refused _ -> params#refused - | `Outdated _ -> params#outdated - | `Branch_refused _ -> params#branch_refused - | `Branch_delayed _ -> params#branch_delayed - in - let rec next () = - let open Lwt_syntax in - match !current_mempool with - | Some mempool -> - current_mempool := None ; - Lwt.return_some (params#version, mempool) - | None -> ( - let* o = Lwt_stream.get op_stream in - match o with - | Some (kind, op) - when filter_result kind - && filter_validation_passes - params#validation_passes - op.protocol -> - let errors = - match kind with - | `Validated -> None - | `Branch_delayed errors - | `Branch_refused errors - | `Refused errors - | `Outdated errors -> - Some errors - in - Lwt.return_some - (params#version, [((op.hash, op.protocol), errors)]) - | Some _ -> next () - | None -> Lwt.return_none) - in - let shutdown () = Lwt_watcher.shutdown stopper in - Tezos_rpc.Answer.return_stream {next; shutdown}) ; - !dir) + let dir : state Tezos_rpc.Directory.t ref = + ref Tezos_rpc.Directory.empty + in + let module Proto_services = Block_services.Make (Proto) (Proto) in + dir := + Tezos_rpc.Directory.register + !dir + (Proto_services.S.Mempool.get_filter Tezos_rpc.Path.open_root) + (fun pv params () -> + return (get_config_json ~include_default:params#include_default pv)) ; + dir := + Tezos_rpc.Directory.register + !dir + (Proto_services.S.Mempool.set_filter Tezos_rpc.Path.open_root) + (fun pv () obj -> + let open Lwt_syntax in + let* () = + try + let config = + Data_encoding.Json.destruct + Prevalidation_t.config_encoding + obj + in + pv.config <- config ; + Lwt.return_unit + with _ -> Events.(emit invalid_mempool_filter_configuration) () + in + (* We return [get_config_json pv] rather than [obj] in + order to show omitted fields (which have been reset to + their default values), and also in case [obj] is invalid. *) + return_ok (get_config_json pv)) ; + (* Ban an operation (from its given hash): remove it from the + mempool if present. Add it to the set pv.banned_operations + to prevent it from being fetched/processed/injected in the + future. + Note: If the baker has already received the operation, then + it's necessary to restart it manually to flush the operation + from it. *) + dir := + Tezos_rpc.Directory.register + !dir + (Proto_services.S.Mempool.ban_operation Tezos_rpc.Path.open_root) + (fun _pv () oph -> + let open Lwt_result_syntax in + let*! r = Worker.Queue.push_request_and_wait w (Request.Ban oph) in + match r with + | Error (Closed None) -> fail [Worker_types.Terminated] + | Error (Closed (Some errs)) -> fail errs + | Error (Request_error err) -> fail err + | Error (Any exn) -> fail [Exn exn] + | Ok () -> return_unit) ; + (* Unban an operation (from its given hash): remove it from the + set pv.banned_operations (nothing happens if it was not banned). *) + dir := + Tezos_rpc.Directory.register + !dir + (Proto_services.S.Mempool.unban_operation Tezos_rpc.Path.open_root) + (fun pv () oph -> + pv.shell.banned_operations <- + Operation_hash.Set.remove oph pv.shell.banned_operations ; + return_unit) ; + (* Unban all operations: clear the set pv.banned_operations. *) + dir := + Tezos_rpc.Directory.register + !dir + (Proto_services.S.Mempool.unban_all_operations + Tezos_rpc.Path.open_root) + (fun pv () () -> + pv.shell.banned_operations <- Operation_hash.Set.empty ; + return_unit) ; + dir := + Tezos_rpc.Directory.gen_register + !dir + (Proto_services.S.Mempool.pending_operations + Tezos_rpc.Path.open_root) + (fun pv params () -> + let validated = + if + params#validated && Option.value ~default:true params#applied + (* https://gitlab.com/tezos/tezos/-/issues/5891 + applied is deprecated and should be removed in a future + version of Octez *) + then + Classification.Sized_map.to_map + pv.shell.classification.validated + |> Operation_hash.Map.to_seq + |> Seq.filter_map (fun (oph, op) -> + if + filter_validation_passes + params#validation_passes + op.protocol + then Some (oph, op.protocol) + else None) + |> List.of_seq + else [] + in + let process_map map = + let open Operation_hash in + Map.filter_map + (fun _oph (op, error) -> + if + filter_validation_passes + params#validation_passes + op.protocol + then Some (op.protocol, error) + else None) + map + in + let refused = + if params#refused then + process_map + (Classification.map pv.shell.classification.refused) + else Operation_hash.Map.empty + in + let outdated = + if params#outdated then + process_map + (Classification.map pv.shell.classification.outdated) + else Operation_hash.Map.empty + in + let branch_refused = + if params#branch_refused then + process_map + (Classification.map pv.shell.classification.branch_refused) + else Operation_hash.Map.empty + in + let branch_delayed = + if params#branch_delayed then + process_map + (Classification.map pv.shell.classification.branch_delayed) + else Operation_hash.Map.empty + in + let unprocessed = + Operation_hash.Map.filter_map + (fun _ {protocol; _} -> + if filter_validation_passes params#validation_passes protocol + then Some protocol + else None) + (Pending_ops.operations pv.shell.pending) + in + let pending_operations = + { + Proto_services.Mempool.validated; + refused; + outdated; + branch_refused; + branch_delayed; + unprocessed; + } + in + Tezos_rpc.Answer.return (params#version, pending_operations)) ; + dir := + Tezos_rpc.Directory.register + !dir + (Proto_services.S.Mempool.request_operations + Tezos_rpc.Path.open_root) + (fun pv t () -> + pv.shell.parameters.tools.send_get_current_head ?peer:t#peer_id () ; + return_unit) ; + dir := + Tezos_rpc.Directory.gen_register + !dir + (Proto_services.S.Mempool.monitor_operations + Tezos_rpc.Path.open_root) + (fun pv params () -> + Lwt_mutex.with_lock pv.lock @@ fun () -> + let op_stream, stopper = + Lwt_watcher.create_stream pv.operation_stream + in + (* First call : retrieve the current set of op from the mempool *) + let validated_seq = + if + params#validated && Option.value ~default:true params#applied + (* https://gitlab.com/tezos/tezos/-/issues/5891 + applied is deprecated and should be removed in a future + version of Octez *) + then + Classification.Sized_map.to_map + pv.shell.classification.validated + |> Operation_hash.Map.to_seq + |> Seq.map (fun (hash, {protocol; _}) -> + ((hash, protocol), None)) + else Seq.empty + in + let process_error_map map = + let open Operation_hash in + map |> Map.to_seq + |> Seq.map (fun (hash, (op, error)) -> + ((hash, op.protocol), Some error)) + in + let refused_seq = + if params#refused then + process_error_map + (Classification.map pv.shell.classification.refused) + else Seq.empty + in + let branch_refused_seq = + if params#branch_refused then + process_error_map + (Classification.map pv.shell.classification.branch_refused) + else Seq.empty + in + let branch_delayed_seq = + if params#branch_delayed then + process_error_map + (Classification.map pv.shell.classification.branch_delayed) + else Seq.empty + in + let outdated_seq = + if params#outdated then + process_error_map + (Classification.map pv.shell.classification.outdated) + else Seq.empty + in + let filter ((_, op), _) = + filter_validation_passes params#validation_passes op + in + let current_mempool = + Seq.append outdated_seq branch_delayed_seq + |> Seq.append branch_refused_seq + |> Seq.append refused_seq |> Seq.append validated_seq + |> Seq.filter filter |> List.of_seq + in + let current_mempool = ref (Some current_mempool) in + let filter_result = function + | `Validated -> + params#validated && Option.value ~default:true params#applied + | `Refused _ -> params#refused + | `Outdated _ -> params#outdated + | `Branch_refused _ -> params#branch_refused + | `Branch_delayed _ -> params#branch_delayed + in + let rec next () = + let open Lwt_syntax in + match !current_mempool with + | Some mempool -> + current_mempool := None ; + Lwt.return_some (params#version, mempool) + | None -> ( + let* o = Lwt_stream.get op_stream in + match o with + | Some (kind, op) + when filter_result kind + && filter_validation_passes + params#validation_passes + op.protocol -> + let errors = + match kind with + | `Validated -> None + | `Branch_delayed errors + | `Branch_refused errors + | `Refused errors + | `Outdated errors -> + Some errors + in + Lwt.return_some + (params#version, [((op.hash, op.protocol), errors)]) + | Some _ -> next () + | None -> Lwt.return_none) + in + let shutdown () = Lwt_watcher.shutdown stopper in + Tezos_rpc.Answer.return_stream {next; shutdown}) ; + !dir) (** Module implementing the events at the {!Worker} level. Contrary to {!Requests}, these functions depend on [Worker]. *) @@ -1233,7 +1237,7 @@ module Make post_processing @@ match request with - | Request.Flush (hash, event, live_blocks, live_operations) -> + | Request.Flush (hash, event, live_blocks, live_operations) -> ( Requests.on_advertise pv.shell ; (* TODO: https://gitlab.com/tezos/tezos/-/issues/1727 Rebase the advertisement instead. *) @@ -1251,7 +1255,7 @@ module Make pv block live_blocks - live_operations + live_operations) | Request.Notify (peer, mempool) -> Requests.on_notify pv.shell peer mempool ; return_unit diff --git a/src/lib_shell/prevalidator_pending_operations.ml b/src/lib_shell/prevalidator_pending_operations.ml index bd334181ab6169996ec85672c2bbb49a999455e3..105693377f4cdf8f8a15854bb7671fe003a2c327 100644 --- a/src/lib_shell/prevalidator_pending_operations.ml +++ b/src/lib_shell/prevalidator_pending_operations.ml @@ -114,7 +114,7 @@ let remove oph ({pending; hashes; priority_of} as t) = { pending = (if Map.is_empty mp then Priority_map.remove prio pending - else Priority_map.add prio mp pending); + else Priority_map.add prio mp pending); hashes = Sized_set.remove oph hashes; priority_of = Map.remove oph priority_of; } diff --git a/src/lib_shell_benchmarks/io_benchmarks.ml b/src/lib_shell_benchmarks/io_benchmarks.ml index 716f4eb4933f8d193e602f772b7b086e75d3b2f5..f6682998ba1d7b6fc8fc74ec86d8d24f52ff0376 100644 --- a/src/lib_shell_benchmarks/io_benchmarks.ml +++ b/src/lib_shell_benchmarks/io_benchmarks.ml @@ -126,10 +126,10 @@ module Helpers = struct in Lwt_main.run (let open Lwt_syntax in - let* context, index = - random_contents rng_state base_dir index context keys commit_batch_size - in - Io_helpers.commit_and_reload base_dir index context) + let* context, index = + random_contents rng_state base_dir index context keys commit_batch_size + in + Io_helpers.commit_and_reload base_dir index context) end module Context_size_dependent_shared = struct @@ -324,8 +324,8 @@ module Context_size_dependent_read_bench : Benchmark.Simple = struct Gc.compact () ; Lwt_main.run (let open Lwt_syntax in - let* () = Tezos_context.Context.close index in - Tezos_stdlib_unix.Lwt_utils_unix.remove_dir base_dir) + let* () = Tezos_context.Context.close index in + Tezos_stdlib_unix.Lwt_utils_unix.remove_dir base_dir) in let result = try f context @@ -382,8 +382,8 @@ module Context_size_dependent_write_bench : Benchmark.Simple = struct let closure context = Lwt_main.run (let open Lwt_syntax in - let* _ = Io_helpers.commit context in - Lwt.return_unit) + let* _ = Io_helpers.commit context in + Lwt.return_unit) in let workload = Random_context_random_access @@ -413,8 +413,8 @@ module Context_size_dependent_write_bench : Benchmark.Simple = struct Gc.compact () ; Lwt_main.run (let open Lwt_syntax in - let* () = Tezos_context.Context.close index in - Tezos_stdlib_unix.Lwt_utils_unix.remove_dir base_dir) + let* () = Tezos_context.Context.close index in + Tezos_stdlib_unix.Lwt_utils_unix.remove_dir base_dir) in let result = try f context @@ -675,8 +675,8 @@ module Irmin_pack_read_bench : Benchmark.Simple = struct Gc.compact () ; Lwt_main.run (let open Lwt_syntax in - let* () = Tezos_context.Context.close index in - Tezos_stdlib_unix.Lwt_utils_unix.remove_dir base_dir) + let* () = Tezos_context.Context.close index in + Tezos_stdlib_unix.Lwt_utils_unix.remove_dir base_dir) in let result = try f context @@ -847,8 +847,8 @@ module Irmin_pack_write_bench : Benchmark.Simple = struct Gc.compact () ; Lwt_main.run (let open Lwt_syntax in - let* () = Tezos_context.Context.close index in - Tezos_stdlib_unix.Lwt_utils_unix.remove_dir base_dir) + let* () = Tezos_context.Context.close index in + Tezos_stdlib_unix.Lwt_utils_unix.remove_dir base_dir) in let result = try f context @@ -862,8 +862,8 @@ module Irmin_pack_write_bench : Benchmark.Simple = struct let closure context = Lwt_main.run (let open Lwt_syntax in - let* _ = Io_helpers.commit context in - Lwt.return_unit) + let* _ = Io_helpers.commit context in + Lwt.return_unit) in let workload = Irmin_pack_write @@ -1137,8 +1137,8 @@ module Write_random_keys_bench : Benchmark.Simple_with_num = struct Gc.compact () ; Lwt_main.run (let open Lwt_syntax in - let* () = Tezos_context.Context.close index in - Tezos_stdlib_unix.Lwt_utils_unix.remove_dir target_base_dir) + let* () = Tezos_context.Context.close index in + Tezos_stdlib_unix.Lwt_utils_unix.remove_dir target_base_dir) in let result = try f context @@ -1152,8 +1152,8 @@ module Write_random_keys_bench : Benchmark.Simple_with_num = struct let closure context = Lwt_main.run (let open Lwt_syntax in - let* _context_hash = Io_helpers.commit context in - Lwt.return_unit) + let* _context_hash = Io_helpers.commit context in + Lwt.return_unit) in let workload = Write_random_keys diff --git a/src/lib_shell_benchmarks/io_helpers.ml b/src/lib_shell_benchmarks/io_helpers.ml index dbbf1c9eeb075cb6b4a0472e3a51c7c9c93240c9..01fef0d92401708f0594130317aec30cda48256c 100644 --- a/src/lib_shell_benchmarks/io_helpers.ml +++ b/src/lib_shell_benchmarks/io_helpers.ml @@ -88,9 +88,9 @@ let with_context ~base_dir ~context_hash f = let context, index = load_context_from_disk base_dir context_hash in Lwt_main.run (let open Lwt_syntax in - let* res = f context in - let* () = Tezos_context.Context.close index in - Lwt.return res) + let* res = f context in + let* () = Tezos_context.Context.close index in + Lwt.return res) let prepare_base_dir base_dir = Unix.unlink base_dir ; diff --git a/src/lib_shell_services/block_services.ml b/src/lib_shell_services/block_services.ml index 898acde03dabfae6c3a65b2fce83dac493514df3..a3d9a22ff4a5ae8d3cea5fd0b3c7e13f1c6e2648 100644 --- a/src/lib_shell_services/block_services.ml +++ b/src/lib_shell_services/block_services.ml @@ -75,11 +75,11 @@ let pp_supported_version fmt ~complete {supported; latest; default} = | false, true -> "(deprecated)" | false, false -> "") (if complete then - if use_legacy_attestation_name then - " that will output attestation operations as \"endorsement\" in \ - the \"kind\" field" - else " that will output \"attestation\" in the \"kind\" field" - else ""))) + if use_legacy_attestation_name then + " that will output attestation operations as \"endorsement\" in \ + the \"kind\" field" + else " that will output \"attestation\" in the \"kind\" field" + else ""))) fmt supported @@ -563,8 +563,8 @@ module Make (Proto : PROTO) (Next_proto : PROTO) = struct let block_metadata_encoding ~use_legacy_attestation_name = def (if use_legacy_attestation_name then - "block_header_metadata_with_legacy_attestation_name" - else "block_header_metadata") + "block_header_metadata_with_legacy_attestation_name" + else "block_header_metadata") @@ conv (fun { protocol_data; @@ -610,8 +610,8 @@ module Make (Proto : PROTO) (Next_proto : PROTO) = struct "max_operation_list_length" (dynamic_size (list operation_list_quota_encoding)))) (if use_legacy_attestation_name then - Proto.block_header_metadata_encoding_with_legacy_attestation_name - else Proto.block_header_metadata_encoding)) + Proto.block_header_metadata_encoding_with_legacy_attestation_name + else Proto.block_header_metadata_encoding)) let next_operation_encoding_with_legacy_attestation_name = let open Data_encoding in @@ -696,8 +696,8 @@ module Make (Proto : PROTO) (Next_proto : PROTO) = struct let operation_encoding ~use_legacy_attestation_name = def (if use_legacy_attestation_name then - "operation_with_legacy_attestation_name" - else "operation") + "operation_with_legacy_attestation_name" + else "operation") @@ let open Data_encoding in conv @@ -1448,9 +1448,9 @@ module Make (Proto : PROTO) (Next_proto : PROTO) = struct Operation.shell_header_encoding) (dynamic_size (if use_legacy_name then - Next_proto - .operation_data_encoding_with_legacy_attestation_name - else Next_proto.operation_data_encoding)))))) + Next_proto + .operation_data_encoding_with_legacy_attestation_name + else Next_proto.operation_data_encoding)))))) (operations_with_error_encoding "refused") (operations_with_error_encoding "outdated") (operations_with_error_encoding "branch_refused") @@ -1711,8 +1711,8 @@ module Make (Proto : PROTO) (Next_proto : PROTO) = struct (merge_objs (obj1 (req "hash" Operation_hash.encoding)) (if use_legacy_name then - next_operation_encoding_with_legacy_attestation_name - else next_operation_encoding)) + next_operation_encoding_with_legacy_attestation_name + else next_operation_encoding)) (obj1 (dft "error" Tezos_rpc.Error.opt_encoding None)) let processed_operation_encoding = diff --git a/src/lib_shell_services/injection_services.ml b/src/lib_shell_services/injection_services.ml index 9b451c8a6945c6d857acab38c47a2bb88736d705..30e508c17880c8fc3338df072259203003230f90 100644 --- a/src/lib_shell_services/injection_services.ml +++ b/src/lib_shell_services/injection_services.ml @@ -169,8 +169,8 @@ module S = struct ~input:bytes ~output:Operation_hash.encoding (if private_ then - Tezos_rpc.Path.(root / "private" / "injection" / "operation") - else Tezos_rpc.Path.(path / "operation")) + Tezos_rpc.Path.(root / "private" / "injection" / "operation") + else Tezos_rpc.Path.(path / "operation")) let private_operations = Tezos_rpc.Service.post_service diff --git a/src/lib_shell_services/store_errors.ml b/src/lib_shell_services/store_errors.ml index ae57e85584551e29a370b353161a319e895737e8..bdc535c2d610eb12620acffa56b1e1eebfb442a7 100644 --- a/src/lib_shell_services/store_errors.ml +++ b/src/lib_shell_services/store_errors.ml @@ -1126,14 +1126,10 @@ let () = ~id:"store.bad_ordering_invariant" ~title:"Bad ordering invariant" ~description:"The ordering invariant does not hold" - ~pp: - (fun ppf - ( genesis, - caboose, - savepoint, - cementing_highwatermark, - checkpoint, - head ) -> + ~pp:(fun + ppf + (genesis, caboose, savepoint, cementing_highwatermark, checkpoint, head) + -> Format.fprintf ppf "Invariant '%ld (genesis) ≤ %ld (caboose) ≤ %ld (savepoint) ≤ %a \ diff --git a/src/lib_signer_backends/http.mli b/src/lib_signer_backends/http.mli index eae9cfa9f0a430c8119534989235e296dea3965e..d333efb1880416934ed15cde789de5e905805765 100644 --- a/src/lib_signer_backends/http.mli +++ b/src/lib_signer_backends/http.mli @@ -24,7 +24,8 @@ (*****************************************************************************) module Make - (RPC_client : RPC_client.S) (P : sig + (RPC_client : RPC_client.S) + (P : sig val authenticate : Tezos_crypto.Signature.Public_key_hash.t list -> Bytes.t -> diff --git a/src/lib_signer_backends/http_gen.ml b/src/lib_signer_backends/http_gen.ml index d2ef037e4b57d0ec6b2f0046787268edf9cb6af6..8979416c1e93fce4115ee063dbe4cefed956f11b 100644 --- a/src/lib_signer_backends/http_gen.ml +++ b/src/lib_signer_backends/http_gen.ml @@ -30,7 +30,8 @@ struct let scheme = N.scheme module Make - (RPC_client : RPC_client.S) (P : sig + (RPC_client : RPC_client.S) + (P : sig val authenticate : Tezos_crypto.Signature.Public_key_hash.t list -> Bytes.t -> diff --git a/src/lib_signer_backends/http_gen.mli b/src/lib_signer_backends/http_gen.mli index 5f7ec48809a90264edf1bfcc89010b3359ad5c09..0625a67fd067d611ab3bb9776c9160dcca0a934c 100644 --- a/src/lib_signer_backends/http_gen.mli +++ b/src/lib_signer_backends/http_gen.mli @@ -27,7 +27,8 @@ module Make (N : sig val scheme : string end) : sig module Make - (RPC_client : RPC_client.S) (P : sig + (RPC_client : RPC_client.S) + (P : sig val authenticate : Tezos_crypto.Signature.Public_key_hash.t list -> Bytes.t -> diff --git a/src/lib_signer_backends/https.mli b/src/lib_signer_backends/https.mli index eae9cfa9f0a430c8119534989235e296dea3965e..d333efb1880416934ed15cde789de5e905805765 100644 --- a/src/lib_signer_backends/https.mli +++ b/src/lib_signer_backends/https.mli @@ -24,7 +24,8 @@ (*****************************************************************************) module Make - (RPC_client : RPC_client.S) (P : sig + (RPC_client : RPC_client.S) + (P : sig val authenticate : Tezos_crypto.Signature.Public_key_hash.t list -> Bytes.t -> diff --git a/src/lib_signer_backends/unix/remote.ml b/src/lib_signer_backends/unix/remote.ml index 8925b17b72dd4cdbdab32593abee514606be817d..ab243fe69e7aad6c6c5b3d96f01f4f5010e0509a 100644 --- a/src/lib_signer_backends/unix/remote.ml +++ b/src/lib_signer_backends/unix/remote.ml @@ -28,7 +28,8 @@ open Client_keys let scheme = "remote" module Make - (RPC_client : RPC_client.S) (S : sig + (RPC_client : RPC_client.S) + (S : sig val default : Uri.t val authenticate : diff --git a/src/lib_signer_backends/unix/remote.mli b/src/lib_signer_backends/unix/remote.mli index 6956e9cb2193c461e4046048a74c4e593185b309..f72f4a3058eaeeadb264b54ba1de2e87031b2a67 100644 --- a/src/lib_signer_backends/unix/remote.mli +++ b/src/lib_signer_backends/unix/remote.mli @@ -24,7 +24,8 @@ (*****************************************************************************) module Make - (RPC_client : RPC_client.S) (S : sig + (RPC_client : RPC_client.S) + (S : sig val default : Uri.t val authenticate : diff --git a/src/lib_smart_rollup_node/daemon_event.ml b/src/lib_smart_rollup_node/daemon_event.ml index 0c5da136c4894298da2c3c8e9807ee27b7fcd63c..1ac024333f92ad12e11f8978494fa1ecd11b2b27 100644 --- a/src/lib_smart_rollup_node/daemon_event.ml +++ b/src/lib_smart_rollup_node/daemon_event.ml @@ -102,10 +102,9 @@ module Simple = struct ]) ) ("error", Data_encoding.option Error_monad.trace_encoding) ~pp1:L1_operation.pp - ~pp3: - (fun ppf -> function - | None -> Format.pp_print_string ppf "none" - | Some e -> Error_monad.pp_print_trace ppf e) + ~pp3:(fun ppf -> function + | None -> Format.pp_print_string ppf "none" + | Some e -> Error_monad.pp_print_trace ppf e) let migration = declare_5 diff --git a/src/lib_smart_rollup_node/interpreter.ml b/src/lib_smart_rollup_node/interpreter.ml index 9ae9aae34228ec2ff7e9414fe1f04446451c683a..8a5db3ef76d9e3ab93ce1584872cb06f4ad216ab 100644 --- a/src/lib_smart_rollup_node/interpreter.ml +++ b/src/lib_smart_rollup_node/interpreter.ml @@ -141,8 +141,8 @@ let start_state_of_block plugin node_ctxt (block : Sc_rollup_block.t) = Plugin.Pvm.start_of_level_serialized :: (if is_first_block then - Option.to_list Plugin.Pvm.protocol_migration_serialized - else []) + Option.to_list Plugin.Pvm.protocol_migration_serialized + else []) @ Plugin.Pvm.info_per_level_serialized ~predecessor ~predecessor_timestamp :: messages @ [Plugin.Pvm.end_of_level_serialized] diff --git a/src/lib_smart_rollup_node/layer1.ml b/src/lib_smart_rollup_node/layer1.ml index 974a26c7742e93fced1524ae8f1b0ef22acf82f8..c6f1b1ec272739325b8eefdf86c3d8be8811f3c8 100644 --- a/src/lib_smart_rollup_node/layer1.ml +++ b/src/lib_smart_rollup_node/layer1.ml @@ -157,7 +157,7 @@ module Internal_for_tests = struct let dummy cctxt = { l1 = Internal_for_tests.dummy cctxt; - cctxt = (cctxt :> Client_context.full); + cctxt :> Client_context.full; blocks_cache = Blocks_cache.create 1; headers_cache = Blocks_cache.create 1; prefetch_blocks = 0; diff --git a/src/lib_smart_rollup_node/node_context.ml b/src/lib_smart_rollup_node/node_context.ml index 145525ae737f173a46d70e16e5b2242c349852af..d26f4c95ff7c0b42859cef8e7a18abb41b7a3f8b 100644 --- a/src/lib_smart_rollup_node/node_context.ml +++ b/src/lib_smart_rollup_node/node_context.ml @@ -198,7 +198,7 @@ let init (cctxt : #Client_context.full) ~data_dir ?log_kernel_debug_file mode in return { - cctxt = (cctxt :> Client_context.full); + cctxt :> Client_context.full; dal_cctxt; dac_client; data_dir; @@ -805,8 +805,8 @@ let save_protocol_info node_ctxt (block : Layer1.header) { level = (if Protocol_hash.(pred_current_protocol = pred_next_protocol) - then First_known predecessor.level - else Activation_level predecessor.level); + then First_known predecessor.level + else Activation_level predecessor.level); proto_level = predecessor.header.proto_level; protocol = pred_next_protocol; } @@ -956,7 +956,7 @@ module Internal_for_tests = struct let lpc = Reference.new_ None in return { - cctxt = (cctxt :> Client_context.full); + cctxt :> Client_context.full; dal_cctxt = None; dac_client = None; data_dir; diff --git a/src/lib_smart_rollup_node/refutation_game_event.ml b/src/lib_smart_rollup_node/refutation_game_event.ml index 73964d94f9c01a776df41945096160036bba514f..5b8afd0ed56002fd70f3bdc700c36deed0c1b40f 100644 --- a/src/lib_smart_rollup_node/refutation_game_event.ml +++ b/src/lib_smart_rollup_node/refutation_game_event.ml @@ -105,10 +105,11 @@ module Simple = struct ( "dissection", Data_encoding.list Octez_smart_rollup.Game.dissection_chunk_encoding ) - module Worker (ARG : sig - val section : string list - end) - (Request : Worker_intf.REQUEST) = + module Worker + (ARG : sig + val section : string list + end) + (Request : Worker_intf.REQUEST) = struct include ARG diff --git a/src/lib_stdlib/compare.ml b/src/lib_stdlib/compare.ml index 96bcd6345184a4bded4773814087e34fd017389a..e041882af1ffb4d211c2f5c86547b45685139a3c 100644 --- a/src/lib_stdlib/compare.ml +++ b/src/lib_stdlib/compare.ml @@ -175,7 +175,8 @@ module Int32 = Make (Int32) module Int64 = Make (Int64) module MakeUnsigned - (Int : S) (Z : sig + (Int : S) + (Z : sig val zero : Int.t end) = struct diff --git a/src/lib_stdlib/hash_queue.ml b/src/lib_stdlib/hash_queue.ml index e9b85e91c4becc1e3bce8552ef96aa62b248639e..69921761b0d22d882bfc3e092f7db8c31691dff1 100644 --- a/src/lib_stdlib/hash_queue.ml +++ b/src/lib_stdlib/hash_queue.ml @@ -24,7 +24,8 @@ (*****************************************************************************) module Make - (K : Hashtbl.HashedType) (V : sig + (K : Hashtbl.HashedType) + (V : sig type t end) = struct diff --git a/src/lib_stdlib/hash_queue.mli b/src/lib_stdlib/hash_queue.mli index e6040589638aad2acbd06131b8da93ed67098b69..58cefb3f611ee6821148afcbf2979b45e186073b 100644 --- a/src/lib_stdlib/hash_queue.mli +++ b/src/lib_stdlib/hash_queue.mli @@ -32,7 +32,8 @@ *) module Make - (K : Hashtbl.HashedType) (V : sig + (K : Hashtbl.HashedType) + (V : sig type t end) : sig (** The type of hash queues holding bindings from [K.t] to [V.t] *) diff --git a/src/lib_stdlib/tzHex.mli b/src/lib_stdlib/tzHex.mli index 432d02f6d9a667b5ee62db7148b80a6ea82aaa91..9ef4b842ca22149aa73a5c9783befc120ff87dea 100644 --- a/src/lib_stdlib/tzHex.mli +++ b/src/lib_stdlib/tzHex.mli @@ -81,7 +81,7 @@ val hexdump_s : ?print_row_numbers:bool -> ?print_chars:bool -> t -> string (** [pp fmt t] will output a human-readable hex representation of [t] to the formatter [fmt]. *) val pp : Format.formatter -> t -> unit - [@@ocaml.toplevel_printer] +[@@ocaml.toplevel_printer] (** [show t] will return a human-readable hex representation of [t] as a string. *) diff --git a/src/lib_store/shared/block_repr.ml b/src/lib_store/shared/block_repr.ml index 2a6bcbcae6343b5952e55bfda79447c4b39dc184..09a3bc225e98fecb51806be865d2a9e1921e3104 100644 --- a/src/lib_store/shared/block_repr.ml +++ b/src/lib_store/shared/block_repr.ml @@ -224,7 +224,7 @@ let legacy_encoding = let with_contents {header; operations; block_metadata_hash; operations_metadata_hashes} f = f header operations block_metadata_hash operations_metadata_hashes - [@@ocaml.inline] +[@@ocaml.inline] let with_metadata { @@ -240,7 +240,7 @@ let with_metadata last_allowed_fork_level block_metadata operations_metadata - [@@ocaml.inline] +[@@ocaml.inline] let contents_equal c1 c2 = with_contents c1 @@ fun h1 o1 b1 omh1 -> diff --git a/src/lib_store/unix/consistency.ml b/src/lib_store/unix/consistency.ml index 1cc5aa656c2eaa7f20c443dae6a778a19f95d253..573d383ba9b93a1622464c52cd0646a68fd86608 100644 --- a/src/lib_store/unix/consistency.ml +++ b/src/lib_store/unix/consistency.ml @@ -412,8 +412,8 @@ let lowest_cemented_metadata cemented_dir = let*! m = Seq_s.of_seq (Array.to_seq metadata_files) |> Seq_s.S.find_map - (fun {Cemented_block_store.metadata_file; start_level; end_level} - -> + (fun + {Cemented_block_store.metadata_file; start_level; end_level} -> let*! lowest_metadata_entry = Option.catch_s (fun () -> lowest_metadata_entry metadata_file) in diff --git a/src/lib_store/unix/test/test_locator.ml b/src/lib_store/unix/test/test_locator.ml index 3cca2f2f60ba26f7f36955923f6989741936f321..8f6b2f1b7495a59c66d8a34ef274e284e8ef69dc 100644 --- a/src/lib_store/unix/test/test_locator.ml +++ b/src/lib_store/unix/test/test_locator.ml @@ -182,8 +182,7 @@ let make_multiple_protocol_chain (chain_store : Store.Chain.t) { pred_header.shell with predecessor = - (if lvl = 1 then genesis_hash - else Block_header.hash pred_header); + (if lvl = 1 then genesis_hash else Block_header.hash pred_header); level = Int32.of_int lvl; proto_level; }; diff --git a/src/lib_store/unix/test/test_utils.ml b/src/lib_store/unix/test/test_utils.ml index f0292d9432474dde390ce00afd79942dbec11e2e..38ac26353a4f4704f456e9874209ce2d0daa5a50 100644 --- a/src/lib_store/unix/test/test_utils.ml +++ b/src/lib_store/unix/test/test_utils.ml @@ -441,11 +441,11 @@ let make_raw_block ?min_lafl ?(max_operations_ttl = default_max_operations_ttl) (if Random.bool () then Some Block_metadata_hash.zero else None); operations_metadata_hashes = (if Random.bool () then - Some - (List.map - (List.map (fun _ -> Operation_metadata_hash.zero)) - operations) - else None); + Some + (List.map + (List.map (fun _ -> Operation_metadata_hash.zero)) + operations) + else None); }; metadata; } diff --git a/src/lib_time_measurement/.ocamlformat b/src/lib_time_measurement/.ocamlformat index fb8540e41041d1518b3266f44113d2847281564c..53d8f893264a4cee99c04af63cd4438732105e7b 100644 --- a/src/lib_time_measurement/.ocamlformat +++ b/src/lib_time_measurement/.ocamlformat @@ -1,4 +1,4 @@ -version=0.24.1 +version=0.26.0 ocaml-version=4.14 wrap-fun-args=false let-binding-spacing=compact diff --git a/src/lib_tree_encoding/tezos_tree_encoding.ml b/src/lib_tree_encoding/tezos_tree_encoding.ml index e9786c583930a0bf9890f25a8cf8ec550324450b..363dedeb7c679cbee6edb001cb17535e9c4a4d18 100644 --- a/src/lib_tree_encoding/tezos_tree_encoding.ml +++ b/src/lib_tree_encoding/tezos_tree_encoding.ml @@ -234,8 +234,8 @@ module Lazy_map_encoding = struct D.map (fun (origin, produce_value) -> Map.create ?origin ~produce_value ()) (let open D.Syntax in - let+ produce_value = D.lazy_mapping to_key value.decode in - produce_value) + let+ produce_value = D.lazy_mapping to_key value.decode in + produce_value) in {encode; decode} end @@ -297,10 +297,10 @@ module Lazy_vector_encoding = struct (fun ((origin, produce_value), len, head) -> Vector.create ~produce_value ~first_key:head ?origin len) (let open D.Syntax in - let+ x = D.scope ["contents"] (D.lazy_mapping to_key value.decode) - and+ y = D.scope ["length"] with_key.decode - and+ z = D.scope ["head"] with_key.decode in - (x, y, z)) + let+ x = D.scope ["contents"] (D.lazy_mapping to_key value.decode) + and+ y = D.scope ["length"] with_key.decode + and+ z = D.scope ["head"] with_key.decode in + (x, y, z)) in {encode; decode} end @@ -345,9 +345,9 @@ module CBV_encoding = struct D.map (fun ((origin, get_chunk), len) -> CBV.create ?origin ~get_chunk len) (let open D.Syntax in - let+ x = D.scope ["contents"] @@ D.lazy_mapping to_key chunk.decode - and+ y = D.value ["length"] Data_encoding.int64 in - (x, y)) + let+ x = D.scope ["contents"] @@ D.lazy_mapping to_key chunk.decode + and+ y = D.value ["length"] Data_encoding.int64 in + (x, y)) in {encode; decode} end diff --git a/src/lib_validation/command_line.ml b/src/lib_validation/command_line.ml index 35ff992a03bf8f0870b818283711937993ff94d6..cb7ade58f0b31550464a7ee16dc450b607e0b094 100644 --- a/src/lib_validation/command_line.ml +++ b/src/lib_validation/command_line.ml @@ -74,10 +74,10 @@ let run () = let main_promise = External_validator.main ?socket_dir ~readonly () in Stdlib.exit (let open Lwt_syntax in - Lwt_main.run - (let* r = Lwt_exit.wrap_and_exit main_promise in - match r with - | Ok () -> Lwt_exit.exit_and_wait 0 - | Error err -> - Format.eprintf "%a\n%!" pp_print_trace err ; - Lwt_exit.exit_and_wait 1)) + Lwt_main.run + (let* r = Lwt_exit.wrap_and_exit main_promise in + match r with + | Ok () -> Lwt_exit.exit_and_wait 0 + | Error err -> + Format.eprintf "%a\n%!" pp_print_trace err ; + Lwt_exit.exit_and_wait 1)) diff --git a/src/lib_wasmer/vectors.ml b/src/lib_wasmer/vectors.ml index 580898da05573dac3be31b4c5ef60ff3ee4db2cf..aaddea80aafe0cdb5cffeed51619d617cdb026e6 100644 --- a/src/lib_wasmer/vectors.ml +++ b/src/lib_wasmer/vectors.ml @@ -26,7 +26,8 @@ open Api module Make_vector - (Vector_type : Api_types.Vec) (Vector_funs : sig + (Vector_type : Api_types.Vec) + (Vector_funs : sig val new_ : Vector_type.t Ctypes.ptr -> Unsigned.Size_t.t -> diff --git a/src/lib_webassembly/bin/script/js.ml b/src/lib_webassembly/bin/script/js.ml index 050a13fe7de600fa9b3ed9c97697cb389ada7077..b4ba1121bbe262f094fbafd406c33c6e9abf78f7 100644 --- a/src/lib_webassembly/bin/script/js.ml +++ b/src/lib_webassembly/bin/script/js.ml @@ -649,7 +649,7 @@ let of_wrapper mods x_opt name wrap_action wrap_assertion at = let of_action mods act = match act.it with - | Invoke (x_opt, name, vs) -> ( + | Invoke (x_opt, name, vs) -> ( "call(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ", " ^ "[" ^ String.concat ", " (List.map of_value vs) ^ "])", @@ -657,14 +657,14 @@ let of_action mods act = | ExternFuncType ft when not (is_js_func_type ft) -> let (FuncType (_, out)) = ft in Some (of_wrapper mods x_opt name (invoke ft vs), out) - | _ -> None )) - | Get (x_opt, name) -> ( + | _ -> None ) + | Get (x_opt, name) -> ( "get(" ^ of_var_opt mods x_opt ^ ", " ^ of_name name ^ ")", match lookup mods x_opt name act.at with | ExternGlobalType gt when not (is_js_global_type gt) -> let (GlobalType (t, _)) = gt in Some (of_wrapper mods x_opt name (get gt), Vector.singleton t) - | _ -> None )) + | _ -> None ) let of_assertion' mods act name args wrapper_opt = let open Lwt.Syntax in diff --git a/src/lib_webassembly/bin/script/run.ml b/src/lib_webassembly/bin/script/run.ml index 2ec8503ef187165f4a5d2d51ecaafae4c8ab94cd..17779e3e5b8da9b4f22073137f8fc0b5fbc9b2a8 100644 --- a/src/lib_webassembly/bin/script/run.ml +++ b/src/lib_webassembly/bin/script/run.ml @@ -6,11 +6,8 @@ open Source (* Errors & Tracing *) module Script = Error.Make () - module Abort = Error.Make () - module Assert = Error.Make () - module IO = Error.Make () exception Abort = Abort.Error @@ -346,7 +343,7 @@ let lookup category map x_opt at = IO.error at (if key = "" then "no " ^ category ^ " defined" - else "unknown " ^ category ^ " " ^ key) + else "unknown " ^ category ^ " " ^ key) let lookup_script = lookup "script" scripts @@ -362,7 +359,7 @@ let lookup_instance name at = IO.error at (if key = "" then "no " ^ category ^ " defined" - else "unknown " ^ category ^ " " ^ key) + else "unknown " ^ category ^ " " ^ key) | exn -> raise exn) let lookup_registry module_name item_name = diff --git a/src/lib_webassembly/binary/decode.ml b/src/lib_webassembly/binary/decode.ml index 286f70c153be6b745cc0a213f5ea2eef78e3d156..ace9f84176cef8674491ba37939a7cc9cc5085a8 100644 --- a/src/lib_webassembly/binary/decode.ml +++ b/src/lib_webassembly/binary/decode.ml @@ -2368,7 +2368,7 @@ let module_step ~allow_floats bytes state = fbs, vec, (if no_datas_in_func then Some (LazyVec {offset; vector}) - else None), + else None), no_datas_in_func ) | MKBuild (funcs, no_datas_in_func) -> let { diff --git a/src/lib_webassembly/exec/eval.ml b/src/lib_webassembly/exec/eval.ml index 76834dc6843ee101b4fdbd054736065a37d1a479..919728508525175b80cb27ae6172aa0b91f126db 100644 --- a/src/lib_webassembly/exec/eval.ml +++ b/src/lib_webassembly/exec/eval.ml @@ -80,11 +80,8 @@ let concat_completed {lv; rv; offset; _} = (* Errors *) module Link = Error.Make () - module Trap = Error.Make () - module Crash = Error.Make () - module Exhaustion = Error.Make () exception Link = Link.Error @@ -762,7 +759,7 @@ let step_instr module_reg frame label vs at e' es_rst stack : vs' [ (if i = 0l then Plain (Block (bt, es2)) @@ at - else Plain (Block (bt, es1)) @@ at); + else Plain (Block (bt, es1)) @@ at); ] | Br x -> return_label_kont_with_code (Vector.empty ()) [Breaking (x.it, vs) @@ at] @@ -776,7 +773,7 @@ let step_instr module_reg frame label vs at e' es_rst stack : label_kont_with_code vs' (if I32.ge_u i (Lib.List32.length xs) then [Plain (Br x) @@ at] - else [Plain (Br (Lib.List32.nth xs i)) @@ at]) + else [Plain (Br (Lib.List32.nth xs i)) @@ at]) | Return -> return_label_kont_with_code (Vector.empty ()) [Returning vs @@ at] | Call x -> let* inst = resolve_module_ref module_reg frame.inst in @@ -792,7 +789,7 @@ let step_instr module_reg frame label vs at e' es_rst stack : label_kont_with_code vs' (if not check_eq then [Trapping "indirect call type mismatch" @@ at] - else [Invoke func @@ at]) + else [Invoke func @@ at]) | Drop -> (* _ :: vs' *) let+ _, vs' = vector_pop_map vs Option.some at in @@ -899,11 +896,11 @@ let step_instr module_reg frame label vs at e' es_rst stack : label_kont_with_code vs' (if oob_d || oob_s then [Trapping (table_error at Table.Bounds) @@ at] - else if n = 0l then [] - else if I32.le_u d s then - [Table_copy_meta (0l, d, s, n, x, y, true) @@ at] - else (* d > s *) - [Table_copy_meta (0l, d, s, n, x, y, false) @@ at]) + else if n = 0l then [] + else if I32.le_u d s then + [Table_copy_meta (0l, d, s, n, x, y, true) @@ at] + else (* d > s *) + [Table_copy_meta (0l, d, s, n, x, y, false) @@ at]) | TableInit (x, y) -> (* Num (I32 n) :: Num (I32 s) :: Num (I32 d) :: vs' *) let* n, vs = vector_pop_map vs num_i32 at in @@ -1083,8 +1080,8 @@ let step_instr module_reg frame label vs at e' es_rst stack : label_kont_with_code vs' (if oob then [Trapping (memory_error at Memory.Bounds) @@ at] - else if n = 0l then [] - else [Memory_fill_meta (0l, i, k, n) @@ at]) + else if n = 0l then [] + else [Memory_fill_meta (0l, i, k, n) @@ at]) | MemoryCopy -> (* Num (I32 n) :: Num (I32 s) :: Num (I32 d) :: vs' *) let* n, vs = vector_pop_map vs num_i32 at in @@ -1095,10 +1092,10 @@ let step_instr module_reg frame label vs at e' es_rst stack : label_kont_with_code vs' (if oob_s || oob_d then [Trapping (memory_error at Memory.Bounds) @@ at] - else if n = 0l then [] - else if I32.le_u d s then [Memory_copy_meta (0l, d, s, n, true) @@ at] - else (* d > s *) - [Memory_copy_meta (0l, d, s, n, false) @@ at]) + else if n = 0l then [] + else if I32.le_u d s then [Memory_copy_meta (0l, d, s, n, true) @@ at] + else (* d > s *) + [Memory_copy_meta (0l, d, s, n, false) @@ at]) | MemoryInit x -> (* Num (I32 n) :: Num (I32 s) :: Num (I32 d) :: vs' *) let* n, vs = vector_pop_map vs num_i32 at in @@ -1764,15 +1761,15 @@ let add_import (m : module_) (ext : extern) (im : import) (inst : module_inst) : let* t = import_type m im in let+ type_match = match_extern_type (extern_type_of ext) t in (if not type_match then - let module_name = im.it.module_name in - let item_name = im.it.item_name in - Link.error - im.at - ("incompatible import type for " ^ "\"" ^ module_name ^ "\" " ^ "\"" - ^ item_name ^ "\": " ^ "expected " - ^ Types.string_of_extern_type t - ^ ", got " - ^ Types.string_of_extern_type (extern_type_of ext))) ; + let module_name = im.it.module_name in + let item_name = im.it.item_name in + Link.error + im.at + ("incompatible import type for " ^ "\"" ^ module_name ^ "\" " ^ "\"" + ^ item_name ^ "\": " ^ "expected " + ^ Types.string_of_extern_type t + ^ ", got " + ^ Types.string_of_extern_type (extern_type_of ext))) ; match ext with | ExternFunc func -> {inst with funcs = Vector.cons func inst.funcs} diff --git a/src/lib_webassembly/script/import.ml b/src/lib_webassembly/script/import.ml index 1a654c007e2d0f19bb3af12c58a13ab53ae14a6d..4106cb0003a49d815e590f0224a34190234f6515 100644 --- a/src/lib_webassembly/script/import.ml +++ b/src/lib_webassembly/script/import.ml @@ -1,7 +1,6 @@ module TzStdLib = Tezos_lwt_result_stdlib.Lwtreslib.Bare open Source open Ast - module Unknown = Error.Make () exception Unknown = Unknown.Error (* indicates unknown import name *) diff --git a/src/proto_001_PtCJ7pwo/lib_client/alpha_client_context.ml b/src/proto_001_PtCJ7pwo/lib_client/alpha_client_context.ml index 3f94c91488b7c03c63873c1c7d9b0abb03310332..dbdaa9b75681945839e574565c2198fdbe974b65 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/alpha_client_context.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/alpha_client_context.ml @@ -29,14 +29,12 @@ module Alpha_block_services = (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = object @@ -70,17 +68,15 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = Shell_services.Blocks.path end -class type full = - object - inherit Client_context.full +class type full = object + inherit Client_context.full - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end class wrap_full (t : Client_context.full) : full = object diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_macros.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_macros.ml index 8eee36af2235625e3b1f7fc747c8273801109a22..a7bf3c4f5d6b59aaf5947d1b5ae1ea8400e9c49c 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_macros.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_macros.ml @@ -575,7 +575,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -583,7 +583,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_context_commands.ml b/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_context_commands.ml index 09b66847b456ce7e64067e1c16a396a47f696d53..73a1e75f03d9dc3f8f0f10eae98f883c4d926cfd 100644 --- a/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_context_commands.ml @@ -67,7 +67,7 @@ let commands () = Shell_services.Blocks.Header.shell_header cctxt ~block:cctxt#block () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group diff --git a/src/proto_002_PsYLVpVv/lib_client/alpha_client_context.ml b/src/proto_002_PsYLVpVv/lib_client/alpha_client_context.ml index 48d4e495fd9377f6c6879cc1343c2986fd2fa76a..568e4fc006c89b00a8ae72eb6752b0bb79fd828d 100644 --- a/src/proto_002_PsYLVpVv/lib_client/alpha_client_context.ml +++ b/src/proto_002_PsYLVpVv/lib_client/alpha_client_context.ml @@ -29,14 +29,12 @@ module Alpha_block_services = (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = object @@ -70,17 +68,15 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = Shell_services.Blocks.path end -class type full = - object - inherit Client_context.full +class type full = object + inherit Client_context.full - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end class wrap_full (t : Client_context.full) : full = object diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_macros.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_macros.ml index 238a46a52f9015a4503faa745494a3dfb535d380..1d8662437b059ebdf289c612b5e520c3cbbdad76 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_macros.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_macros.ml @@ -575,7 +575,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -583,7 +583,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_context_commands.ml b/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_context_commands.ml index f3f18d0bf60cc5a450a7876fc9a3206e87f0acb3..eb4b8e5ddf967b7c4141d2b2fa23d8e9eb2d676d 100644 --- a/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_context_commands.ml @@ -78,7 +78,7 @@ let commands () = Shell_services.Blocks.Header.shell_header cctxt ~block:cctxt#block () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group diff --git a/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_programs_commands.ml b/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_programs_commands.ml index 6cc8b85a27f9d3051762f435110f521c5d4711f5..e3d8084511e22d5ea4cb1654d3f99b18955f3476 100644 --- a/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_programs_commands.ml @@ -328,9 +328,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_003_PsddFKi3/lib_client/alpha_client_context.ml b/src/proto_003_PsddFKi3/lib_client/alpha_client_context.ml index 16a35685f3efd9ae678c6b760f6f7c84bb50cd20..3391cc62752923a09bc2dc614b22377ad2aa9fb8 100644 --- a/src/proto_003_PsddFKi3/lib_client/alpha_client_context.ml +++ b/src/proto_003_PsddFKi3/lib_client/alpha_client_context.ml @@ -29,14 +29,12 @@ module Alpha_block_services = (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = object @@ -70,17 +68,15 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = Shell_services.Blocks.path end -class type full = - object - inherit Client_context.full +class type full = object + inherit Client_context.full - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end class wrap_full (t : Client_context.full) : full = object diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml index 048c629d2bba2ea2afe1cb522bc639b9f221d471..4563ee4a6ddecae7c6db9fd9d4cfa9c05a5bf3ac 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml @@ -576,7 +576,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -584,7 +584,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_context_commands.ml b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_context_commands.ml index 260866601a54683da85aacebd4927f2588a3e0ab..7ec49a977c865f1f8c14501bf7036e72e24fa6bc 100644 --- a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_context_commands.ml @@ -82,7 +82,7 @@ let commands () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -310,8 +310,8 @@ let commands () = p w (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_programs_commands.ml b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_programs_commands.ml index 4819e938679685b14fb8f44e1ab272bfa4eaf071..200650924d2cefa0b793392f373a388206b8612f 100644 --- a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_programs_commands.ml @@ -317,9 +317,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_004_Pt24m4xi/lib_client/alpha_client_context.ml b/src/proto_004_Pt24m4xi/lib_client/alpha_client_context.ml index 40c46fc88f1ab30ce6b31aba31ac1008d3ea43ce..ede505a901ae307ab6c76c6461976d54acd13693 100644 --- a/src/proto_004_Pt24m4xi/lib_client/alpha_client_context.ml +++ b/src/proto_004_Pt24m4xi/lib_client/alpha_client_context.ml @@ -29,14 +29,12 @@ module Alpha_block_services = (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = object @@ -70,17 +68,15 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = Shell_services.Blocks.path end -class type full = - object - inherit Client_context.full +class type full = object + inherit Client_context.full - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end class wrap_full (t : Client_context.full) : full = object diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml index 048c629d2bba2ea2afe1cb522bc639b9f221d471..4563ee4a6ddecae7c6db9fd9d4cfa9c05a5bf3ac 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml @@ -576,7 +576,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -584,7 +584,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_context_commands.ml b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_context_commands.ml index 260866601a54683da85aacebd4927f2588a3e0ab..7ec49a977c865f1f8c14501bf7036e72e24fa6bc 100644 --- a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_context_commands.ml @@ -82,7 +82,7 @@ let commands () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -310,8 +310,8 @@ let commands () = p w (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_programs_commands.ml b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_programs_commands.ml index cbabe381428490672221fd21ed1fb05b7adc146b..c2053ae01ee9495193c3bef1ce2e87f8cfe34486 100644 --- a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_programs_commands.ml @@ -351,9 +351,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_005_PsBabyM1/lib_client/injection.ml b/src/proto_005_PsBabyM1/lib_client/injection.ml index ac43d32265cef097e455f1aaf650fe0e14a2d8c7..79f836f3077bbbd0c6747186cce68e853452525e 100644 --- a/src/proto_005_PsBabyM1/lib_client/injection.ml +++ b/src/proto_005_PsBabyM1/lib_client/injection.ml @@ -241,10 +241,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -535,30 +535,30 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun first -> function | Manager_operation c, (Manager_operation_result _ as result) -> (if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then - Lwt.return (estimated_gas_single result) >>=? fun gas -> - if Z.equal gas Z.zero then - cctxt#message "Estimated gas: none" >>= fun () -> return Z.zero - else - cctxt#message - "Estimated gas: %s units (will add 100 for safety)" - (Z.to_string gas) - >>= fun () -> return (Z.min (Z.add gas (Z.of_int 100)) gas_limit) - else return c.gas_limit) + Lwt.return (estimated_gas_single result) >>=? fun gas -> + if Z.equal gas Z.zero then + cctxt#message "Estimated gas: none" >>= fun () -> return Z.zero + else + cctxt#message + "Estimated gas: %s units (will add 100 for safety)" + (Z.to_string gas) + >>= fun () -> return (Z.min (Z.add gas (Z.of_int 100)) gas_limit) + else return c.gas_limit) >>=? fun gas_limit -> (if c.storage_limit < Z.zero || storage_limit <= c.storage_limit then - Lwt.return - (estimated_storage_single (Z.of_int origination_size) result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return Z.zero - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - return (Z.min (Z.add storage (Z.of_int 20)) storage_limit) - else return c.storage_limit) + Lwt.return + (estimated_storage_single (Z.of_int origination_size) result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return Z.zero + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + return (Z.min (Z.add storage (Z.of_int 20)) storage_limit) + else return c.storage_limit) >>=? fun storage_limit -> let c = Manager_operation {c with gas_limit; storage_limit} in if compute_fee then return (patch_fee first c) else return c diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_entrypoints.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_entrypoints.ml index a1aac91a8ee1699694f64f1b8be144a324911c5a..dedbb80006bad69a9bbf60d086ddfd4f50379ce5 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_entrypoints.ml @@ -77,17 +77,17 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %s) (type . %a))@]@." - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %s: %a@]@." - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %s) (type . %a))@]@." + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %s: %a@]@." + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -136,37 +136,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -174,40 +174,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_macros.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_macros.ml index b70063ccdf4ae7bb6d19fa34607009b13f9d643a..f87cc99e85fea0869d2658c2c800640b9c183958 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_macros.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_macros.ml @@ -610,7 +610,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -618,7 +618,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_005_PsBabyM1/lib_client/operation_result.ml b/src/proto_005_PsBabyM1/lib_client/operation_result.ml index 46c3d69989cb3469b72d38b4bcb0194119590525..91c7736bd0a02909a385a559ebce4643493a1c62 100644 --- a/src/proto_005_PsBabyM1/lib_client/operation_result.ml +++ b/src/proto_005_PsBabyM1/lib_client/operation_result.ml @@ -47,16 +47,16 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf | "default" -> () | _ -> Format.fprintf ppf "@,Entrypoint: %s" entrypoint) ; (if not (Script_repr.is_unit_parameter parameters) then - let expr = - WithExceptions.Option.to_exn - ~none:(Failure "ill-serialized argument") - (Data_encoding.force_decode parameters) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr) ; + let expr = + WithExceptions.Option.to_exn + ~none:(Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr) ; pp_result ppf result ; Format.fprintf ppf "@]" | Origination {delegate; credit; script = {code; storage}; preorigination = _} diff --git a/src/proto_005_PsBabyM1/lib_client/protocol_client_context.ml b/src/proto_005_PsBabyM1/lib_client/protocol_client_context.ml index 497bddda859c2b28d74d754d33c9ebe15c2ea7d1..81bbb0f1d704ffe4ed3997dc17798a495039c15b 100644 --- a/src/proto_005_PsBabyM1/lib_client/protocol_client_context.ml +++ b/src/proto_005_PsBabyM1/lib_client/protocol_client_context.ml @@ -29,14 +29,12 @@ module Alpha_block_services = (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = object @@ -70,17 +68,15 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = Shell_services.Blocks.path end -class type full = - object - inherit Client_context.full +class type full = object + inherit Client_context.full - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end class wrap_full (t : Client_context.full) : full = object diff --git a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_context_commands.ml b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_context_commands.ml index a09214620a1b0fbc25294a6414f50c788d67719b..b00cdb6699b5896b254e6139d8624ba534c99a68 100644 --- a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_context_commands.ml @@ -86,7 +86,7 @@ let commands () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -374,8 +374,8 @@ let commands () = p w (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_programs_commands.ml b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_programs_commands.ml index 4c2d282e2395b812f640aa098e172c5b2e35b470..0a2ffc4d0c1ec2912452f4ceb48dfd332ed2bce9 100644 --- a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_programs_commands.ml @@ -414,9 +414,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml b/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml index 31f087c2b69de6527b3521a952042d30a779f4c9..31cdeabd8d90627d1d81e07a9b26e1da33832153 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml @@ -384,8 +384,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V0.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys_v0.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> diff --git a/src/proto_006_PsCARTHA/lib_client/injection.ml b/src/proto_006_PsCARTHA/lib_client/injection.ml index ac43d32265cef097e455f1aaf650fe0e14a2d8c7..79f836f3077bbbd0c6747186cce68e853452525e 100644 --- a/src/proto_006_PsCARTHA/lib_client/injection.ml +++ b/src/proto_006_PsCARTHA/lib_client/injection.ml @@ -241,10 +241,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -535,30 +535,30 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun first -> function | Manager_operation c, (Manager_operation_result _ as result) -> (if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then - Lwt.return (estimated_gas_single result) >>=? fun gas -> - if Z.equal gas Z.zero then - cctxt#message "Estimated gas: none" >>= fun () -> return Z.zero - else - cctxt#message - "Estimated gas: %s units (will add 100 for safety)" - (Z.to_string gas) - >>= fun () -> return (Z.min (Z.add gas (Z.of_int 100)) gas_limit) - else return c.gas_limit) + Lwt.return (estimated_gas_single result) >>=? fun gas -> + if Z.equal gas Z.zero then + cctxt#message "Estimated gas: none" >>= fun () -> return Z.zero + else + cctxt#message + "Estimated gas: %s units (will add 100 for safety)" + (Z.to_string gas) + >>= fun () -> return (Z.min (Z.add gas (Z.of_int 100)) gas_limit) + else return c.gas_limit) >>=? fun gas_limit -> (if c.storage_limit < Z.zero || storage_limit <= c.storage_limit then - Lwt.return - (estimated_storage_single (Z.of_int origination_size) result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return Z.zero - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - return (Z.min (Z.add storage (Z.of_int 20)) storage_limit) - else return c.storage_limit) + Lwt.return + (estimated_storage_single (Z.of_int origination_size) result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return Z.zero + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + return (Z.min (Z.add storage (Z.of_int 20)) storage_limit) + else return c.storage_limit) >>=? fun storage_limit -> let c = Manager_operation {c with gas_limit; storage_limit} in if compute_fee then return (patch_fee first c) else return c diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_entrypoints.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_entrypoints.ml index 13fe5260ec741f83c7df77a63543f5ffb00a6c69..3f0a51e7a554083c864a592cdfcd9f01c586954c 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_entrypoints.ml @@ -77,17 +77,17 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %s) (type . %a))@]@." - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %s: %a@]@." - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %s) (type . %a))@]@." + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %s: %a@]@." + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -138,37 +138,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -176,40 +176,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_macros.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_macros.ml index b70063ccdf4ae7bb6d19fa34607009b13f9d643a..f87cc99e85fea0869d2658c2c800640b9c183958 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_macros.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_macros.ml @@ -610,7 +610,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -618,7 +618,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_006_PsCARTHA/lib_client/operation_result.ml b/src/proto_006_PsCARTHA/lib_client/operation_result.ml index c9c85f2645f60619caebc5a2e48677d5fe1e2835..dc0a4b0b01fa52c7facf236fc571486eb6ed3a7c 100644 --- a/src/proto_006_PsCARTHA/lib_client/operation_result.ml +++ b/src/proto_006_PsCARTHA/lib_client/operation_result.ml @@ -47,16 +47,16 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf | "default" -> () | _ -> Format.fprintf ppf "@,Entrypoint: %s" entrypoint) ; (if not (Script_repr.is_unit_parameter parameters) then - let expr = - WithExceptions.Option.to_exn - ~none:(Failure "ill-serialized argument") - (Data_encoding.force_decode parameters) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr) ; + let expr = + WithExceptions.Option.to_exn + ~none:(Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr) ; pp_result ppf result ; Format.fprintf ppf "@]" | Origination {delegate; credit; script = {code; storage}; preorigination = _} diff --git a/src/proto_006_PsCARTHA/lib_client/protocol_client_context.ml b/src/proto_006_PsCARTHA/lib_client/protocol_client_context.ml index a8fa7b12ce3a01df2a1cf3bcc29c64c05842b1d8..40d27c01b4b030d6dc2cc14d547549ead22e2e6a 100644 --- a/src/proto_006_PsCARTHA/lib_client/protocol_client_context.ml +++ b/src/proto_006_PsCARTHA/lib_client/protocol_client_context.ml @@ -29,14 +29,12 @@ module Alpha_block_services = (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = object @@ -70,17 +68,15 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = Shell_services.Blocks.path end -class type full = - object - inherit Client_context.full +class type full = object + inherit Client_context.full - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end class wrap_full (t : Client_context.full) : full = object diff --git a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml index 39c7ceaa3abd551c951da526c1ee7b2861caaa90..23111586d4b47c0bfacc314eb179f581518a656d 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_context_commands.ml @@ -202,7 +202,7 @@ let commands network () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -1159,8 +1159,8 @@ let commands network () = error "There %s: %a." (if Compare.List_length_with.(dups = 1) then - "is a duplicate proposal" - else "are duplicate proposals") + "is a duplicate proposal" + else "are duplicate proposals") Format.( pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf ", ") @@ -1197,8 +1197,8 @@ let commands network () = cctxt#message "There %s with the submission:%t" (if Compare.List_length_with.(!errors = 1) then - "is an issue" - else "are issues") + "is an issue" + else "are issues") Format.( fun ppf -> pp_print_cut ppf () ; @@ -1217,10 +1217,11 @@ let commands network () = in check_proposals proposals >>=? fun all_valid -> (if all_valid then cctxt#message "All proposals are valid." - else if force then - cctxt#message - "Some proposals are not valid, but `--force` was used." - else cctxt#error "Submission failed because of invalid proposals.") + else if force then + cctxt#message + "Some proposals are not valid, but `--force` was used." + else + cctxt#error "Submission failed because of invalid proposals.") >>= fun () -> submit_proposals ~dry_run @@ -1351,8 +1352,8 @@ let commands network () = p w (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_programs_commands.ml b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_programs_commands.ml index 4c2d282e2395b812f640aa098e172c5b2e35b470..0a2ffc4d0c1ec2912452f4ceb48dfd332ed2bce9 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_programs_commands.ml @@ -414,9 +414,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_entrypoints.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_entrypoints.ml index 13fe5260ec741f83c7df77a63543f5ffb00a6c69..3f0a51e7a554083c864a592cdfcd9f01c586954c 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_entrypoints.ml @@ -77,17 +77,17 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %s) (type . %a))@]@." - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %s: %a@]@." - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %s) (type . %a))@]@." + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %s: %a@]@." + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -138,37 +138,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -176,40 +176,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_macros.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_macros.ml index b70063ccdf4ae7bb6d19fa34607009b13f9d643a..f87cc99e85fea0869d2658c2c800640b9c183958 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_macros.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_macros.ml @@ -610,7 +610,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -618,7 +618,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_007_PsDELPH1/lib_client/operation_result.ml b/src/proto_007_PsDELPH1/lib_client/operation_result.ml index 93b83f017b7bbc5698258fd32577ce5f26b29a6c..f7b4e538ef139ac85927c3a0ddd6f0b1c42defe9 100644 --- a/src/proto_007_PsDELPH1/lib_client/operation_result.ml +++ b/src/proto_007_PsDELPH1/lib_client/operation_result.ml @@ -47,16 +47,16 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf | "default" -> () | _ -> Format.fprintf ppf "@,Entrypoint: %s" entrypoint) ; (if not (Script_repr.is_unit_parameter parameters) then - let expr = - WithExceptions.Option.to_exn - ~none:(Failure "ill-serialized argument") - (Data_encoding.force_decode parameters) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr) ; + let expr = + WithExceptions.Option.to_exn + ~none:(Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr) ; pp_result ppf result ; Format.fprintf ppf "@]" | Origination {delegate; credit; script = {code; storage}; preorigination = _} diff --git a/src/proto_007_PsDELPH1/lib_client/protocol_client_context.ml b/src/proto_007_PsDELPH1/lib_client/protocol_client_context.ml index f0b0e91da63550c688af8e3562687dcc4e1b0724..5125c5621ecc1434a33c312cbe6daf37fad63235 100644 --- a/src/proto_007_PsDELPH1/lib_client/protocol_client_context.ml +++ b/src/proto_007_PsDELPH1/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific procotol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_context_commands.ml b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_context_commands.ml index 60341df0fcda62c5a7d91edce06c8d537ba1f440..0a3802b8db4e32391dd456b3ee518ce1e3def3c6 100644 --- a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_context_commands.ml @@ -70,7 +70,7 @@ let commands () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -358,8 +358,8 @@ let commands () = p w (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_programs_commands.ml b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_programs_commands.ml index 0fe9bb4846937311c29993b23b2b006ffa417e87..ddd44f12ac0af77af709e93ea69a4c394f892442 100644 --- a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_programs_commands.ml @@ -170,9 +170,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml b/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml index 0bd43bf71b05a9baa3da20528590745fa21afd7d..f042635cff93acee638cd1e2d55564517b1914eb 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/client_proto_context.ml @@ -459,8 +459,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V0.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys_v0.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -521,7 +521,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_008_PtEdo2Zk/lib_client/injection.ml b/src/proto_008_PtEdo2Zk/lib_client/injection.ml index c7ecbb59e25d5ab8153cf1476f3540cf4be98292..134d1c2df310776d96254cad185049cc55702883 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/injection.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/injection.ml @@ -283,10 +283,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -584,39 +584,39 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun first -> function | Manager_operation c, (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>=? fun gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return Gas.Arith.zero - else - cctxt#message - "Estimated gas: %a units (will add 100 for safety)" - Gas.Arith.pp - gas - >>= fun () -> - let gas_plus_100 = - Gas.Arith.(add (ceil gas) (integral_of_int 100)) - in - let patched_gas = - Gas.Arith.min gas_plus_100 hard_gas_limit_per_operation - in - return patched_gas - else return c.gas_limit) + Lwt.return (estimated_gas_single result) >>=? fun gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return Gas.Arith.zero + else + cctxt#message + "Estimated gas: %a units (will add 100 for safety)" + Gas.Arith.pp + gas + >>= fun () -> + let gas_plus_100 = + Gas.Arith.(add (ceil gas) (integral_of_int 100)) + in + let patched_gas = + Gas.Arith.min gas_plus_100 hard_gas_limit_per_operation + in + return patched_gas + else return c.gas_limit) >>=? fun gas_limit -> (if c.storage_limit < Z.zero || storage_limit <= c.storage_limit then - Lwt.return - (estimated_storage_single (Z.of_int origination_size) result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return Z.zero - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - return (Z.min (Z.add storage (Z.of_int 20)) storage_limit) - else return c.storage_limit) + Lwt.return + (estimated_storage_single (Z.of_int origination_size) result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return Z.zero + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + return (Z.min (Z.add storage (Z.of_int 20)) storage_limit) + else return c.storage_limit) >>=? fun storage_limit -> let cm = Manager_operation {c with gas_limit; storage_limit} in if compute_fee && c.fee = Tez.zero then return (patch_fee first cm) @@ -691,16 +691,16 @@ let inject_operation (type kind) cctxt ~chain ~block ?confirmations contents >>=? fun contents -> (if simulation then simulate cctxt ~chain ~block ?branch contents - else - preapply - cctxt - ~chain - ~block - ~fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + else + preapply + cctxt + ~chain + ~block + ~fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml index 824a13fcc7f255c8ba542281940df87417ae435d..cc20e6a26286a44393724167afe11c9dd4a8adab 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_entrypoints.ml @@ -78,17 +78,17 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %s) (type . %a))@]@." - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %s: %a@]@." - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %s) (type . %a))@]@." + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %s: %a@]@." + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -145,37 +145,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -183,40 +183,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml index ca6574ceff29359c07fe5bacf544febd1cc122e9..cf37e93d4440a6716380297d0c0219226de5e733 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_008_PtEdo2Zk/lib_client/operation_result.ml b/src/proto_008_PtEdo2Zk/lib_client/operation_result.ml index d2d74bbde99045d3545e71780cb4ce02c37604c3..459efa708f655f48d3cf3afd2ae4fa92f077aab2 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/operation_result.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/operation_result.ml @@ -47,16 +47,16 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf | "default" -> () | _ -> Format.fprintf ppf "@,Entrypoint: %s" entrypoint) ; (if not (Script_repr.is_unit_parameter parameters) then - let expr = - WithExceptions.Option.to_exn - ~none:(Failure "ill-serialized argument") - (Data_encoding.force_decode parameters) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr) ; + let expr = + WithExceptions.Option.to_exn + ~none:(Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr) ; pp_result ppf result ; Format.fprintf ppf "@]" | Origination {delegate; credit; script = {code; storage}; preorigination = _} diff --git a/src/proto_008_PtEdo2Zk/lib_client/protocol_client_context.ml b/src/proto_008_PtEdo2Zk/lib_client/protocol_client_context.ml index fe9af6ee57ec09c1f31da0891ef5843af0578607..8ed4e4b8c167bb5f0e2a601ecca7a042b5483778 100644 --- a/src/proto_008_PtEdo2Zk/lib_client/protocol_client_context.ml +++ b/src/proto_008_PtEdo2Zk/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific procotol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml index 897b2a5f1c428635fbd72f706113b3b655d63a27..c8d1138e1142624e3989d5ed19bcfff40c7ea113 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_context_commands.ml @@ -266,7 +266,7 @@ let commands network () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -1420,8 +1420,8 @@ let commands network () = error "There %s: %a." (if Compare.List_length_with.(dups = 1) then - "is a duplicate proposal" - else "are duplicate proposals") + "is a duplicate proposal" + else "are duplicate proposals") Format.( pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf ", ") @@ -1458,8 +1458,8 @@ let commands network () = cctxt#message "There %s with the submission:%t" (if Compare.List_length_with.(!errors = 1) then - "is an issue" - else "are issues") + "is an issue" + else "are issues") Format.( fun ppf -> pp_print_cut ppf () ; @@ -1478,10 +1478,11 @@ let commands network () = in check_proposals proposals >>=? fun all_valid -> (if all_valid then cctxt#message "All proposals are valid." - else if force then - cctxt#message - "Some proposals are not valid, but `--force` was used." - else cctxt#error "Submission failed because of invalid proposals.") + else if force then + cctxt#message + "Some proposals are not valid, but `--force` was used." + else + cctxt#error "Submission failed because of invalid proposals.") >>= fun () -> submit_proposals ~dry_run @@ -1618,8 +1619,8 @@ let commands network () = p w (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml index 8d25621a14e920f01182d1dd85ef70e2577e6b59..c2c328bc74244ddb6d50e1a4041f8e2a04aeb543 100644 --- a/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_008_PtEdo2Zk/lib_client_commands/client_proto_programs_commands.ml @@ -502,9 +502,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_009_PsFLoren/lib_client/client_proto_context.ml b/src/proto_009_PsFLoren/lib_client/client_proto_context.ml index 7f780848ab9e2acb2dd8688656fb061041a121d7..4fb5dd609c072ee9645a838173bc34a7e2703ae0 100644 --- a/src/proto_009_PsFLoren/lib_client/client_proto_context.ml +++ b/src/proto_009_PsFLoren/lib_client/client_proto_context.ml @@ -469,8 +469,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V0.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys_v0.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -531,7 +531,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_009_PsFLoren/lib_client/client_proto_utils.ml b/src/proto_009_PsFLoren/lib_client/client_proto_utils.ml index 7495f6a00449eb30333a3bcef164c71d6c073a9e..05ef300c13d0e646ae1fec1a8eaa805d7bc6b7cb 100644 --- a/src/proto_009_PsFLoren/lib_client/client_proto_utils.ml +++ b/src/proto_009_PsFLoren/lib_client/client_proto_utils.ml @@ -50,7 +50,7 @@ let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit - else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) + else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> Client_keys_v0.check ~watermark:Tezos_crypto.Signature.V0.Generic_operation diff --git a/src/proto_009_PsFLoren/lib_client/injection.ml b/src/proto_009_PsFLoren/lib_client/injection.ml index 8280da1a2bb4c8085035b248119011e8c33aeb35..53ed76e1fdf619734fefe0d50e8e19630f4b5a31 100644 --- a/src/proto_009_PsFLoren/lib_client/injection.ml +++ b/src/proto_009_PsFLoren/lib_client/injection.ml @@ -244,10 +244,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -571,54 +571,54 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun ~first -> function | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>=? fun gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return - (Annotated_manager_operation.set_gas_limit - (Limit.known Gas.Arith.zero) - op) - else - cctxt#message - "Estimated gas: %a units (will add 100 for safety)" - Gas.Arith.pp - gas - >>= fun () -> - let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in - let patched_gas = - Gas.Arith.min safe_gas hard_gas_limit_per_operation - in - return - (Annotated_manager_operation.set_gas_limit - (Limit.known patched_gas) - op) - else return op) + Lwt.return (estimated_gas_single result) >>=? fun gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return + (Annotated_manager_operation.set_gas_limit + (Limit.known Gas.Arith.zero) + op) + else + cctxt#message + "Estimated gas: %a units (will add 100 for safety)" + Gas.Arith.pp + gas + >>= fun () -> + let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in + let patched_gas = + Gas.Arith.min safe_gas hard_gas_limit_per_operation + in + return + (Annotated_manager_operation.set_gas_limit + (Limit.known patched_gas) + op) + else return op) >>=? fun op -> (if user_storage_limit_needs_patching c.storage_limit then - Lwt.return - (estimated_storage_single (Z.of_int origination_size) result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return - (Annotated_manager_operation.set_storage_limit - (Limit.known Z.zero) - op) - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - let storage_limit = - Z.min - (Z.add storage (Z.of_int 20)) - hard_storage_limit_per_operation - in - return - (Annotated_manager_operation.set_storage_limit - (Limit.known storage_limit) - op) - else return op) + Lwt.return + (estimated_storage_single (Z.of_int origination_size) result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return + (Annotated_manager_operation.set_storage_limit + (Limit.known Z.zero) + op) + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + let storage_limit = + Z.min + (Z.add storage (Z.of_int 20)) + hard_storage_limit_per_operation + in + return + (Annotated_manager_operation.set_storage_limit + (Limit.known storage_limit) + op) + else return op) >>=? fun op -> if Limit.is_unknown c.fee then (* Setting a dummy fee is required for converting to manager op *) @@ -693,16 +693,16 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?(dry_run = false) ?(simulation = false) ?branch ?src_sk ?verbose_signing ~fee_parameter (contents : kind contents_list) = (if simulation then simulate cctxt ~chain ~block ?branch contents - else - preapply - cctxt - ~chain - ~block - ~fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + else + preapply + cctxt + ~chain + ~block + ~fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit @@ -896,8 +896,8 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run match key with | None when not (has_reveal operations) -> ( (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then - reveal_error cctxt - else return_unit) + reveal_error cctxt + else return_unit) >>=? fun () -> let reveal = prepare_manager_operation diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_entrypoints.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_entrypoints.ml index 824a13fcc7f255c8ba542281940df87417ae435d..cc20e6a26286a44393724167afe11c9dd4a8adab 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_entrypoints.ml @@ -78,17 +78,17 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %s) (type . %a))@]@." - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %s: %a@]@." - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %s) (type . %a))@]@." + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %s: %a@]@." + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -145,37 +145,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -183,40 +183,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_009_PsFLoren/lib_client/michelson_v1_macros.ml b/src/proto_009_PsFLoren/lib_client/michelson_v1_macros.ml index ca6574ceff29359c07fe5bacf544febd1cc122e9..cf37e93d4440a6716380297d0c0219226de5e733 100644 --- a/src/proto_009_PsFLoren/lib_client/michelson_v1_macros.ml +++ b/src/proto_009_PsFLoren/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_009_PsFLoren/lib_client/operation_result.ml b/src/proto_009_PsFLoren/lib_client/operation_result.ml index b56c51b4b88551e6beb3c28dc9e66086420b443b..b95ba0ab17a1ddd180a863bed1b45e0bc2a0a1ed 100644 --- a/src/proto_009_PsFLoren/lib_client/operation_result.ml +++ b/src/proto_009_PsFLoren/lib_client/operation_result.ml @@ -47,16 +47,16 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf | "default" -> () | _ -> Format.fprintf ppf "@,Entrypoint: %s" entrypoint) ; (if not (Script_repr.is_unit_parameter parameters) then - let expr = - WithExceptions.Option.to_exn - ~none:(Failure "ill-serialized argument") - (Data_encoding.force_decode parameters) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr) ; + let expr = + WithExceptions.Option.to_exn + ~none:(Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr) ; pp_result ppf result ; Format.fprintf ppf "@]" | Origination {delegate; credit; script = {code; storage}; preorigination = _} diff --git a/src/proto_009_PsFLoren/lib_client/protocol_client_context.ml b/src/proto_009_PsFLoren/lib_client/protocol_client_context.ml index f9d91316fd951520a54425c3cf90dd3e79460093..1ca2a65141fc9bdea00079b8502b198d6619399f 100644 --- a/src/proto_009_PsFLoren/lib_client/protocol_client_context.ml +++ b/src/proto_009_PsFLoren/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific procotol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml b/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml index 7ddb24a4b7b307b912e61fb294ccb5821853431b..16b06ba3f139e025893ba6da719429efdf20b0e0 100644 --- a/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_commands/client_proto_context_commands.ml @@ -267,7 +267,7 @@ let commands network () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -1413,8 +1413,8 @@ let commands network () = error "There %s: %a." (if Compare.List_length_with.(dups = 1) then - "is a duplicate proposal" - else "are duplicate proposals") + "is a duplicate proposal" + else "are duplicate proposals") Format.( pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf ", ") @@ -1451,8 +1451,8 @@ let commands network () = cctxt#message "There %s with the submission:%t" (if Compare.List_length_with.(!errors = 1) then - "is an issue" - else "are issues") + "is an issue" + else "are issues") Format.( fun ppf -> pp_print_cut ppf () ; @@ -1471,10 +1471,11 @@ let commands network () = in check_proposals proposals >>=? fun all_valid -> (if all_valid then cctxt#message "All proposals are valid." - else if force then - cctxt#message - "Some proposals are not valid, but `--force` was used." - else cctxt#error "Submission failed because of invalid proposals.") + else if force then + cctxt#message + "Some proposals are not valid, but `--force` was used." + else + cctxt#error "Submission failed because of invalid proposals.") >>= fun () -> submit_proposals ~dry_run @@ -1617,9 +1618,12 @@ let commands network () = p w (if - List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_009_PsFLoren/lib_client_commands/client_proto_programs_commands.ml b/src/proto_009_PsFLoren/lib_client_commands/client_proto_programs_commands.ml index f4dcbabdc7e31163f2f8f8cad0560249766e8384..320f243cb2c783091c8c33c53d6ed777e1419bad 100644 --- a/src/proto_009_PsFLoren/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_009_PsFLoren/lib_client_commands/client_proto_programs_commands.ml @@ -517,9 +517,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_010_PtGRANAD/lib_client/client_proto_context.ml b/src/proto_010_PtGRANAD/lib_client/client_proto_context.ml index d62dd8f634c3a3dced8eb100d5ed2c5c61242a9c..9fcf5dfbafcba6e773fa58ccc448bbfbd5270de3 100644 --- a/src/proto_010_PtGRANAD/lib_client/client_proto_context.ml +++ b/src/proto_010_PtGRANAD/lib_client/client_proto_context.ml @@ -496,8 +496,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V0.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys_v0.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -558,7 +558,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_010_PtGRANAD/lib_client/client_proto_utils.ml b/src/proto_010_PtGRANAD/lib_client/client_proto_utils.ml index 7495f6a00449eb30333a3bcef164c71d6c073a9e..05ef300c13d0e646ae1fec1a8eaa805d7bc6b7cb 100644 --- a/src/proto_010_PtGRANAD/lib_client/client_proto_utils.ml +++ b/src/proto_010_PtGRANAD/lib_client/client_proto_utils.ml @@ -50,7 +50,7 @@ let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit - else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) + else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> Client_keys_v0.check ~watermark:Tezos_crypto.Signature.V0.Generic_operation diff --git a/src/proto_010_PtGRANAD/lib_client/injection.ml b/src/proto_010_PtGRANAD/lib_client/injection.ml index f64047a1a11a5cbf84a99e7c1b092a913959e423..70103ddbd07e124c312b0124374bbe9ce2f4138e 100644 --- a/src/proto_010_PtGRANAD/lib_client/injection.ml +++ b/src/proto_010_PtGRANAD/lib_client/injection.ml @@ -250,10 +250,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -645,54 +645,54 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun ~first -> function | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>=? fun gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return - (Annotated_manager_operation.set_gas_limit - (Limit.known Gas.Arith.zero) - op) - else - cctxt#message - "Estimated gas: %a units (will add 100 for safety)" - Gas.Arith.pp - gas - >>= fun () -> - let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in - let patched_gas = - Gas.Arith.min safe_gas hard_gas_limit_per_operation - in - return - (Annotated_manager_operation.set_gas_limit - (Limit.known patched_gas) - op) - else return op) + Lwt.return (estimated_gas_single result) >>=? fun gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return + (Annotated_manager_operation.set_gas_limit + (Limit.known Gas.Arith.zero) + op) + else + cctxt#message + "Estimated gas: %a units (will add 100 for safety)" + Gas.Arith.pp + gas + >>= fun () -> + let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in + let patched_gas = + Gas.Arith.min safe_gas hard_gas_limit_per_operation + in + return + (Annotated_manager_operation.set_gas_limit + (Limit.known patched_gas) + op) + else return op) >>=? fun op -> (if user_storage_limit_needs_patching c.storage_limit then - Lwt.return - (estimated_storage_single (Z.of_int origination_size) result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return - (Annotated_manager_operation.set_storage_limit - (Limit.known Z.zero) - op) - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - let storage_limit = - Z.min - (Z.add storage (Z.of_int 20)) - hard_storage_limit_per_operation - in - return - (Annotated_manager_operation.set_storage_limit - (Limit.known storage_limit) - op) - else return op) + Lwt.return + (estimated_storage_single (Z.of_int origination_size) result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return + (Annotated_manager_operation.set_storage_limit + (Limit.known Z.zero) + op) + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + let storage_limit = + Z.min + (Z.add storage (Z.of_int 20)) + hard_storage_limit_per_operation + in + return + (Annotated_manager_operation.set_storage_limit + (Limit.known storage_limit) + op) + else return op) >>=? fun op -> if Limit.is_unknown c.fee then (* Setting a dummy fee is required for converting to manager op *) @@ -782,16 +782,16 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?(dry_run = false) ?(simulation = false) ?branch ?src_sk ?verbose_signing ~fee_parameter (contents : kind contents_list) = (if simulation then simulate cctxt ~chain ~block ?branch contents - else - preapply - cctxt - ~chain - ~block - ~fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + else + preapply + cctxt + ~chain + ~block + ~fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit @@ -987,8 +987,8 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run match key with | None when not (has_reveal operations) -> ( (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then - reveal_error cctxt - else return_unit) + reveal_error cctxt + else return_unit) >>=? fun () -> let reveal = prepare_manager_operation diff --git a/src/proto_010_PtGRANAD/lib_client/michelson_v1_entrypoints.ml b/src/proto_010_PtGRANAD/lib_client/michelson_v1_entrypoints.ml index 7f8fa8a6e65fa394bba355a7b18f7c569b72fb20..d3a67f2369f61e6be187ab065a0eeb0f3879fcc4 100644 --- a/src/proto_010_PtGRANAD/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_010_PtGRANAD/lib_client/michelson_v1_entrypoints.ml @@ -78,17 +78,17 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %s) (type . %a))@]@." - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %s: %a@]@." - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %s) (type . %a))@]@." + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %s: %a@]@." + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -139,37 +139,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -177,40 +177,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_010_PtGRANAD/lib_client/michelson_v1_macros.ml b/src/proto_010_PtGRANAD/lib_client/michelson_v1_macros.ml index ca6574ceff29359c07fe5bacf544febd1cc122e9..cf37e93d4440a6716380297d0c0219226de5e733 100644 --- a/src/proto_010_PtGRANAD/lib_client/michelson_v1_macros.ml +++ b/src/proto_010_PtGRANAD/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_010_PtGRANAD/lib_client/operation_result.ml b/src/proto_010_PtGRANAD/lib_client/operation_result.ml index 813e4dc0801fc5dbd348b68d53aa968791d75434..63ad903742682430d3008dd51a40078a0fcadf9b 100644 --- a/src/proto_010_PtGRANAD/lib_client/operation_result.ml +++ b/src/proto_010_PtGRANAD/lib_client/operation_result.ml @@ -47,16 +47,16 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf | "default" -> () | _ -> Format.fprintf ppf "@,Entrypoint: %s" entrypoint) ; (if not (Script_repr.is_unit_parameter parameters) then - let expr = - WithExceptions.Option.to_exn - ~none:(Failure "ill-serialized argument") - (Data_encoding.force_decode parameters) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr) ; + let expr = + WithExceptions.Option.to_exn + ~none:(Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr) ; pp_result ppf result ; Format.fprintf ppf "@]" | Origination {delegate; credit; script = {code; storage}; preorigination = _} diff --git a/src/proto_010_PtGRANAD/lib_client/protocol_client_context.ml b/src/proto_010_PtGRANAD/lib_client/protocol_client_context.ml index 2afb56e9240f5d3305c0fce6aead08933cdad3f9..c5ace46f8ca0180837424ea282a17898ff6bf7c2 100644 --- a/src/proto_010_PtGRANAD/lib_client/protocol_client_context.ml +++ b/src/proto_010_PtGRANAD/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific procotol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_context_commands.ml b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_context_commands.ml index df85062ab5e2fd874f5ea758cd338988162bb386..0b5ffea78385c73aa9b1ef28f376c0d6a1ebf202 100644 --- a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_context_commands.ml @@ -267,7 +267,7 @@ let commands network () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -1407,8 +1407,8 @@ let commands network () = error "There %s: %a." (if Compare.List_length_with.(dups = 1) then - "is a duplicate proposal" - else "are duplicate proposals") + "is a duplicate proposal" + else "are duplicate proposals") Format.( pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf ", ") @@ -1445,8 +1445,8 @@ let commands network () = cctxt#message "There %s with the submission:%t" (if Compare.List_length_with.(!errors = 1) then - "is an issue" - else "are issues") + "is an issue" + else "are issues") Format.( fun ppf -> pp_print_cut ppf () ; @@ -1465,10 +1465,11 @@ let commands network () = in check_proposals proposals >>=? fun all_valid -> (if all_valid then cctxt#message "All proposals are valid." - else if force then - cctxt#message - "Some proposals are not valid, but `--force` was used." - else cctxt#error "Submission failed because of invalid proposals.") + else if force then + cctxt#message + "Some proposals are not valid, but `--force` was used." + else + cctxt#error "Submission failed because of invalid proposals.") >>= fun () -> submit_proposals ~dry_run @@ -1611,9 +1612,12 @@ let commands network () = p w (if - List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_programs_commands.ml b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_programs_commands.ml index 1b8b6a485070730ae14477e68a19f6267a17209d..6f4b279f2921a06263d025e3a43f8d5f8608aedb 100644 --- a/src/proto_010_PtGRANAD/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_010_PtGRANAD/lib_client_commands/client_proto_programs_commands.ml @@ -517,9 +517,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_011_PtHangz2/lib_client/client_proto_context.ml b/src/proto_011_PtHangz2/lib_client/client_proto_context.ml index 75c9f43338c89271c075e52c2ef16564437562e0..81fb9847c6c389928102f7f97c8e39b5fe168aa7 100644 --- a/src/proto_011_PtHangz2/lib_client/client_proto_context.ml +++ b/src/proto_011_PtHangz2/lib_client/client_proto_context.ml @@ -540,8 +540,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V0.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Lwt.return @@ Tezos_signer_backends.Unencrypted.make_sk sk) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Lwt.return @@ Tezos_signer_backends.Unencrypted.make_sk sk) >>=? fun sk_uri -> Client_keys_v0.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -602,7 +602,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_011_PtHangz2/lib_client/client_proto_utils.ml b/src/proto_011_PtHangz2/lib_client/client_proto_utils.ml index 7495f6a00449eb30333a3bcef164c71d6c073a9e..05ef300c13d0e646ae1fec1a8eaa805d7bc6b7cb 100644 --- a/src/proto_011_PtHangz2/lib_client/client_proto_utils.ml +++ b/src/proto_011_PtHangz2/lib_client/client_proto_utils.ml @@ -50,7 +50,7 @@ let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit - else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) + else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> Client_keys_v0.check ~watermark:Tezos_crypto.Signature.V0.Generic_operation diff --git a/src/proto_011_PtHangz2/lib_client/injection.ml b/src/proto_011_PtHangz2/lib_client/injection.ml index eb67f8adc79a7f1c8495e6fb6c9579dcbe686433..2c940f51e2deb2c827853368cc123c59adbed1ea 100644 --- a/src/proto_011_PtHangz2/lib_client/injection.ml +++ b/src/proto_011_PtHangz2/lib_client/injection.ml @@ -250,10 +250,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -657,54 +657,54 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun ~first -> function | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>=? fun gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return - (Annotated_manager_operation.set_gas_limit - (Limit.known Gas.Arith.zero) - op) - else - cctxt#message - "Estimated gas: %a units (will add 100 for safety)" - Gas.Arith.pp - gas - >>= fun () -> - let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in - let patched_gas = - Gas.Arith.min safe_gas hard_gas_limit_per_operation - in - return - (Annotated_manager_operation.set_gas_limit - (Limit.known patched_gas) - op) - else return op) + Lwt.return (estimated_gas_single result) >>=? fun gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return + (Annotated_manager_operation.set_gas_limit + (Limit.known Gas.Arith.zero) + op) + else + cctxt#message + "Estimated gas: %a units (will add 100 for safety)" + Gas.Arith.pp + gas + >>= fun () -> + let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in + let patched_gas = + Gas.Arith.min safe_gas hard_gas_limit_per_operation + in + return + (Annotated_manager_operation.set_gas_limit + (Limit.known patched_gas) + op) + else return op) >>=? fun op -> (if user_storage_limit_needs_patching c.storage_limit then - Lwt.return - (estimated_storage_single (Z.of_int origination_size) result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return - (Annotated_manager_operation.set_storage_limit - (Limit.known Z.zero) - op) - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - let storage_limit = - Z.min - (Z.add storage (Z.of_int 20)) - hard_storage_limit_per_operation - in - return - (Annotated_manager_operation.set_storage_limit - (Limit.known storage_limit) - op) - else return op) + Lwt.return + (estimated_storage_single (Z.of_int origination_size) result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return + (Annotated_manager_operation.set_storage_limit + (Limit.known Z.zero) + op) + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + let storage_limit = + Z.min + (Z.add storage (Z.of_int 20)) + hard_storage_limit_per_operation + in + return + (Annotated_manager_operation.set_storage_limit + (Limit.known storage_limit) + op) + else return op) >>=? fun op -> if Limit.is_unknown c.fee then (* Setting a dummy fee is required for converting to manager op *) @@ -794,16 +794,16 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?(dry_run = false) ?(simulation = false) ?(force = false) ?branch ?src_sk ?verbose_signing ~fee_parameter (contents : kind contents_list) = (if simulation then simulate cctxt ~chain ~block ?branch contents - else - preapply - cctxt - ~chain - ~block - ~fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + else + preapply + cctxt + ~chain + ~block + ~fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit @@ -1000,8 +1000,8 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run match key with | None when not (has_reveal operations) -> ( (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then - reveal_error cctxt - else return_unit) + reveal_error cctxt + else return_unit) >>=? fun () -> let reveal = prepare_manager_operation diff --git a/src/proto_011_PtHangz2/lib_client/michelson_v1_entrypoints.ml b/src/proto_011_PtHangz2/lib_client/michelson_v1_entrypoints.ml index af81e469516c00dd16433a2b244bc4eb6eed5c43..2cb1760ce23415c87b70c2036e470f8f2ca94cf1 100644 --- a/src/proto_011_PtHangz2/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_011_PtHangz2/lib_client/michelson_v1_entrypoints.ml @@ -78,17 +78,17 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %s) (type . %a))@]@." - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %s: %a@]@." - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %s) (type . %a))@]@." + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %s: %a@]@." + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -139,37 +139,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -177,40 +177,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_011_PtHangz2/lib_client/michelson_v1_macros.ml b/src/proto_011_PtHangz2/lib_client/michelson_v1_macros.ml index 3b1eaa5028d406200e27b127af40a1e5d81df9ac..600fb5da98f59465ab385c6ae134d16b11539ac8 100644 --- a/src/proto_011_PtHangz2/lib_client/michelson_v1_macros.ml +++ b/src/proto_011_PtHangz2/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_011_PtHangz2/lib_client/mockup.ml b/src/proto_011_PtHangz2/lib_client/mockup.ml index f84ad9f56771a43f05f6c51a7d714af7d293d5d7..b8f2e7175c51e6cfa1721564a9de8fbb405b9ac8 100644 --- a/src/proto_011_PtHangz2/lib_client/mockup.ml +++ b/src/proto_011_PtHangz2/lib_client/mockup.ml @@ -492,11 +492,11 @@ module Protocol_constants_overrides = struct Option.is_some override_value) in (if fields_with_override <> [] then - cctxt#message - "@[mockup client uses protocol overrides:@,%a@]@?" - (pp_print_list field_pp) - fields_with_override - else Lwt.return_unit) + cctxt#message + "@[mockup client uses protocol overrides:@,%a@]@?" + (pp_print_list field_pp) + fields_with_override + else Lwt.return_unit) >>= fun () -> return ({ @@ -885,8 +885,8 @@ let mem_init : let default = parameters.initial_timestamp in let timestamp = Option.value ~default protocol_overrides.timestamp in (if not @@ Time.Protocol.equal default timestamp then - cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp - else Lwt.return_unit) + cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp + else Lwt.return_unit) >>= fun () -> let shell_header = Forge.make_shell diff --git a/src/proto_011_PtHangz2/lib_client/operation_result.ml b/src/proto_011_PtHangz2/lib_client/operation_result.ml index 92dcf24f9f1fd143bc30fa889c1fbfdd4e91d1d2..363c83671e1ca08558687950ab097997326b4a12 100644 --- a/src/proto_011_PtHangz2/lib_client/operation_result.ml +++ b/src/proto_011_PtHangz2/lib_client/operation_result.ml @@ -47,16 +47,16 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf | "default" -> () | _ -> Format.fprintf ppf "@,Entrypoint: %s" entrypoint) ; (if not (Script_repr.is_unit_parameter parameters) then - let expr = - WithExceptions.Option.to_exn - ~none:(Failure "ill-serialized argument") - (Data_encoding.force_decode parameters) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr) ; + let expr = + WithExceptions.Option.to_exn + ~none:(Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr) ; pp_result ppf result ; Format.fprintf ppf "@]" | Origination {delegate; credit; script = {code; storage}; preorigination = _} diff --git a/src/proto_011_PtHangz2/lib_client/protocol_client_context.ml b/src/proto_011_PtHangz2/lib_client/protocol_client_context.ml index c523652a91935209af4576b2daea80e3278916e7..cf448061890f2175aa124c3dde634dd335cd02e3 100644 --- a/src/proto_011_PtHangz2/lib_client/protocol_client_context.ml +++ b/src/proto_011_PtHangz2/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific procotol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_011_PtHangz2/lib_client_commands/client_proto_context_commands.ml b/src/proto_011_PtHangz2/lib_client_commands/client_proto_context_commands.ml index 9949fad4ed22eeecfa89741468ca285ba5f22ea2..da189b082dc5f6d52ba12218b764c085d4c700fa 100644 --- a/src/proto_011_PtHangz2/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_commands/client_proto_context_commands.ml @@ -151,10 +151,10 @@ let transfer_command amount source destination (cctxt : #Client_context.printer) | _ -> Lwt.return_unit in (if force then - check_force_dependency "--gas-limit" gas_limit >>= fun () -> - check_force_dependency "--storage-limit" storage_limit >>= fun () -> - check_force_dependency "--fee" fee - else Lwt.return_unit) + check_force_dependency "--gas-limit" gas_limit >>= fun () -> + check_force_dependency "--storage-limit" storage_limit >>= fun () -> + check_force_dependency "--fee" fee + else Lwt.return_unit) >>= fun () -> (match Contract.is_implicit source with | None -> @@ -288,7 +288,7 @@ let commands network () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -1564,8 +1564,8 @@ let commands network () = error "There %s: %a." (if Compare.List_length_with.(dups = 1) then - "is a duplicate proposal" - else "are duplicate proposals") + "is a duplicate proposal" + else "are duplicate proposals") Format.( pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf ", ") @@ -1602,8 +1602,8 @@ let commands network () = cctxt#message "There %s with the submission:%t" (if Compare.List_length_with.(!errors = 1) then - "is an issue" - else "are issues") + "is an issue" + else "are issues") Format.( fun ppf -> pp_print_cut ppf () ; @@ -1622,10 +1622,11 @@ let commands network () = in check_proposals proposals >>=? fun all_valid -> (if all_valid then cctxt#message "All proposals are valid." - else if force then - cctxt#message - "Some proposals are not valid, but `--force` was used." - else cctxt#error "Submission failed because of invalid proposals.") + else if force then + cctxt#message + "Some proposals are not valid, but `--force` was used." + else + cctxt#error "Submission failed because of invalid proposals.") >>= fun () -> submit_proposals ~dry_run @@ -1768,9 +1769,12 @@ let commands network () = p w (if - List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_011_PtHangz2/lib_client_commands/client_proto_programs_commands.ml b/src/proto_011_PtHangz2/lib_client_commands/client_proto_programs_commands.ml index d1a28d1ae141b3cc7f7eaee491d550982c4cbb2b..6180b5812c1a8ca7c8bf6a101eaed6a5467cb25b 100644 --- a/src/proto_011_PtHangz2/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_commands/client_proto_programs_commands.ml @@ -539,9 +539,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_011_PtHangz2/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_011_PtHangz2/lib_client_commands/client_proto_stresstest_commands.ml index 652a15fa25196cb248e6a75541a047a70e189509..0137e00c64123917f5b08cf7457a5da0f27a98d1 100644 --- a/src/proto_011_PtHangz2/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_commands/client_proto_stresstest_commands.ml @@ -401,7 +401,7 @@ let rec sample_transfer (cctxt : Protocol_client_context.full) chain block else let fresh = Random.State.float rng 1.0 < parameters.fresh_probability in (if fresh then Lwt.return (generate_fresh_source state rng) - else sample_any_source_from_pool state rng) + else sample_any_source_from_pool state rng) >>= fun dest -> let amount = match parameters.strategy with @@ -505,94 +505,94 @@ let inject_transfer (cctxt : Protocol_client_context.full) parameters state rng pcounter in (if - Tezos_crypto.Signature.V0.Public_key_hash.Set.mem - transfer.src.pkh - state.revealed - then return true - else ( - (* Either the [manager_key] RPC tells us the key is already - revealed, or we immediately inject a reveal operation: in any - case the key is revealed in the end. *) - state.revealed <- - Tezos_crypto.Signature.V0.Public_key_hash.Set.add - transfer.src.pkh - state.revealed ; - Alpha_services.Contract.manager_key cctxt (chain, block) transfer.src.pkh - >>=? fun pk_opt -> return (Option.is_some pk_opt))) + Tezos_crypto.Signature.V0.Public_key_hash.Set.mem + transfer.src.pkh + state.revealed + then return true + else ( + (* Either the [manager_key] RPC tells us the key is already + revealed, or we immediately inject a reveal operation: in any + case the key is revealed in the end. *) + state.revealed <- + Tezos_crypto.Signature.V0.Public_key_hash.Set.add + transfer.src.pkh + state.revealed ; + Alpha_services.Contract.manager_key cctxt (chain, block) transfer.src.pkh + >>=? fun pk_opt -> return (Option.is_some pk_opt))) >>=? fun already_revealed -> (if not already_revealed then ( - let reveal_counter = Z.succ freshest_counter in - let transf_counter = Z.succ reveal_counter in - let reveal = - Manager_operation - { - source = transfer.src.pkh; - fee = Tez.zero; - counter = reveal_counter; - gas_limit = cost_of_manager_operation; - storage_limit = Z.zero; - operation = Reveal transfer.src.pk; - } - in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Cons (reveal, Single manager_op) in - Tezos_crypto.Signature.V0.Public_key_hash.Table.remove - state.counters - transfer.src.pkh ; - Tezos_crypto.Signature.V0.Public_key_hash.Table.add - state.counters - transfer.src.pkh - (branch, transf_counter) ; - (if !verbose then - cctxt#message - "injecting reveal+transfer from %a (counters=%a,%a) to %a" - Tezos_crypto.Signature.V0.Public_key_hash.pp - transfer.src.pkh - Z.pp_print - reveal_counter - Z.pp_print - transf_counter - Tezos_crypto.Signature.V0.Public_key_hash.pp - transfer.dst - else Lwt.return_unit) - >>= fun () -> - (* NB: regardless of our best efforts to keep track of counters, injection can fail with - "counter in the future" if a block switch happens in between the moment we - get the branch and the moment we inject, and the new block does not include - all the operations we injected. *) - inject_contents cctxt chain branch transfer.src.sk list) - else - let transf_counter = Z.succ freshest_counter in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Single manager_op in - Tezos_crypto.Signature.V0.Public_key_hash.Table.remove - state.counters - transfer.src.pkh ; - Tezos_crypto.Signature.V0.Public_key_hash.Table.add - state.counters - transfer.src.pkh - (branch, transf_counter) ; - (if !verbose then - cctxt#message - "injecting transfer from %a (counter=%a) to %a" - Tezos_crypto.Signature.V0.Public_key_hash.pp + let reveal_counter = Z.succ freshest_counter in + let transf_counter = Z.succ reveal_counter in + let reveal = + Manager_operation + { + source = transfer.src.pkh; + fee = Tez.zero; + counter = reveal_counter; + gas_limit = cost_of_manager_operation; + storage_limit = Z.zero; + operation = Reveal transfer.src.pk; + } + in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Cons (reveal, Single manager_op) in + Tezos_crypto.Signature.V0.Public_key_hash.Table.remove + state.counters + transfer.src.pkh ; + Tezos_crypto.Signature.V0.Public_key_hash.Table.add + state.counters transfer.src.pkh - Z.pp_print - transf_counter - Tezos_crypto.Signature.V0.Public_key_hash.pp - transfer.dst - else Lwt.return_unit) - >>= fun () -> - (* See comment above. *) - inject_contents cctxt chain branch transfer.src.sk list) + (branch, transf_counter) ; + (if !verbose then + cctxt#message + "injecting reveal+transfer from %a (counters=%a,%a) to %a" + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + reveal_counter + Z.pp_print + transf_counter + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.dst + else Lwt.return_unit) + >>= fun () -> + (* NB: regardless of our best efforts to keep track of counters, injection can fail with + "counter in the future" if a block switch happens in between the moment we + get the branch and the moment we inject, and the new block does not include + all the operations we injected. *) + inject_contents cctxt chain branch transfer.src.sk list) + else + let transf_counter = Z.succ freshest_counter in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Single manager_op in + Tezos_crypto.Signature.V0.Public_key_hash.Table.remove + state.counters + transfer.src.pkh ; + Tezos_crypto.Signature.V0.Public_key_hash.Table.add + state.counters + transfer.src.pkh + (branch, transf_counter) ; + (if !verbose then + cctxt#message + "injecting transfer from %a (counter=%a) to %a" + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + transf_counter + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.dst + else Lwt.return_unit) + >>= fun () -> + (* See comment above. *) + inject_contents cctxt chain branch transfer.src.sk list) >>= function | Ok op_hash -> debug_msg (fun () -> @@ -696,7 +696,7 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = included). Note that the operations injected during the last block are \ ignored because they should not be currently included." (if Int.equal injected_ops_count 0 then "N/A" - else Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + else Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) injected_ops_count included_ops_count >>= fun () -> return_unit @@ -766,10 +766,10 @@ let launch (cctxt : Protocol_client_context.full) (parameters : parameters) let elapsed = Mtime.Span.(to_s stop -. to_s start) in let remaining = dt -. elapsed in (if remaining <= 0.0 then - cctxt#warning - "warning: tps target could not be reached, consider using a lower \ - value for --tps" - else Lwt_unix.sleep remaining) + cctxt#warning + "warning: tps target could not be reached, consider using a lower \ + value for --tps" + else Lwt_unix.sleep remaining) >>= loop in let on_new_head : Block_hash.t * Tezos_base.Block_header.t -> unit Lwt.t = @@ -1076,11 +1076,11 @@ let generate_random_transactions = | [] -> cctxt#error "It is required to provide sources" | sources -> (if !verbose then cctxt#message "starting to normalize sources" - else Lwt.return_unit) + else Lwt.return_unit) >>= fun () -> List.filter_map_s (normalize_source cctxt) sources >>= fun sources -> (if !verbose then cctxt#message "all sources have been normalized" - else Lwt.return_unit) + else Lwt.return_unit) >>= fun () -> let counters = Tezos_crypto.Signature.V0.Public_key_hash.Table.create 1023 @@ -1097,11 +1097,11 @@ let generate_random_transactions = pool_size = List.length sources; shuffled_pool = (if parameters.single_op_per_pkh_per_block then - Some - (List.shuffle - ~rng - (List.map (fun src_org -> src_org.source) sources)) - else None); + Some + (List.shuffle + ~rng + (List.map (fun src_org -> src_org.source) sources)) + else None); revealed = Tezos_crypto.Signature.V0.Public_key_hash.Set.empty; last_block = current_head_on_start; last_level = Int32.to_int header_on_start.shell.level; diff --git a/src/proto_011_PtHangz2/lib_client_sapling/client_sapling_commands.ml b/src/proto_011_PtHangz2/lib_client_sapling/client_sapling_commands.ml index 4e7ac236869a1265724990aaa3198fa3dec8fc5c..f760d690c7f4a78b745857a679afde391f4b53a3 100644 --- a/src/proto_011_PtHangz2/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_011_PtHangz2/lib_client_sapling/client_sapling_commands.ml @@ -414,19 +414,19 @@ let forge_shielded_cmd = let file = Option.value ~default:sapling_transaction_file file in cctxt#message "Writing transaction to %s@." file >>= fun () -> (if use_json_format then - save_json_to_file - (Data_encoding.Json.construct UTXO.transaction_encoding transaction) - file - else - let bytes = - Hex.of_bytes - (Data_encoding.Binary.to_bytes_exn - UTXO.transaction_encoding - transaction) - in - let file = open_out_bin file in - Printf.fprintf file "0x%s" (Hex.show bytes) ; - close_out file) ; + save_json_to_file + (Data_encoding.Json.construct UTXO.transaction_encoding transaction) + file + else + let bytes = + Hex.of_bytes + (Data_encoding.Binary.to_bytes_exn + UTXO.transaction_encoding + transaction) + in + let file = open_out_bin file in + Printf.fprintf file "0x%s" (Hex.show bytes) ; + close_out file) ; return_unit) let submit_shielded_cmd = @@ -491,18 +491,18 @@ let submit_shielded_cmd = >>= fun () -> let open Context in (if use_json_format then - Lwt_utils_unix.Json.read_file filename >>=? fun json -> - return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json - else - Lwt_utils_unix.read_file filename >>= fun hex -> - let hex = - (* remove 0x *) - String.sub hex 2 (String.length hex - 2) - in - return - @@ Data_encoding.Binary.of_bytes_exn - UTXO.transaction_encoding - Hex.(to_bytes_exn (`Hex hex))) + Lwt_utils_unix.Json.read_file filename >>=? fun json -> + return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json + else + Lwt_utils_unix.read_file filename >>= fun hex -> + let hex = + (* remove 0x *) + String.sub hex 2 (String.length hex - 2) + in + return + @@ Data_encoding.Binary.of_bytes_exn + UTXO.transaction_encoding + Hex.(to_bytes_exn (`Hex hex))) >>=? fun transaction -> return Shielded_tez_contract_input.(as_arg (create transaction)) >>=? fun contract_input -> @@ -769,12 +769,12 @@ let commands () = | None -> cctxt#error "Account %s not found" name | Some account -> (if verbose then - cctxt#answer - "@[Received Sapling transactions for %s@,@[%a@]@]" - name - Context.Account.pp_unspent - account - else Lwt.return_unit) + cctxt#answer + "@[Received Sapling transactions for %s@,@[%a@]@]" + name + Context.Account.pp_unspent + account + else Lwt.return_unit) >>= fun () -> cctxt#answer "Total Sapling funds %a%s" diff --git a/src/proto_012_Psithaca/lib_client/client_proto_context.ml b/src/proto_012_Psithaca/lib_client/client_proto_context.ml index 0950db34768a6cace0c36c726f3b54138925d3a2..014d230f93b5c781b89337166cfc7c7122089e07 100644 --- a/src/proto_012_Psithaca/lib_client/client_proto_context.ml +++ b/src/proto_012_Psithaca/lib_client/client_proto_context.ml @@ -576,8 +576,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V0.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys_v0.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -638,7 +638,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_012_Psithaca/lib_client/client_proto_utils.ml b/src/proto_012_Psithaca/lib_client/client_proto_utils.ml index 7495f6a00449eb30333a3bcef164c71d6c073a9e..05ef300c13d0e646ae1fec1a8eaa805d7bc6b7cb 100644 --- a/src/proto_012_Psithaca/lib_client/client_proto_utils.ml +++ b/src/proto_012_Psithaca/lib_client/client_proto_utils.ml @@ -50,7 +50,7 @@ let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit - else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) + else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> Client_keys_v0.check ~watermark:Tezos_crypto.Signature.V0.Generic_operation diff --git a/src/proto_012_Psithaca/lib_client/injection.ml b/src/proto_012_Psithaca/lib_client/injection.ml index b0735485a7d2335f9bbff0f270b0a9488816f8ea..0b01cdfe74bc1916781c5f99894214c938fb502c 100644 --- a/src/proto_012_Psithaca/lib_client/injection.ml +++ b/src/proto_012_Psithaca/lib_client/injection.ml @@ -253,10 +253,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -663,64 +663,65 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun ~first -> function | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>=? fun gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return - (Annotated_manager_operation.set_gas_limit - (Limit.known Gas.Arith.zero) - op) - else - let safety_guard = - match c.operation with - | Transaction {destination; _} - when Option.is_some (Contract.is_implicit destination) -> - Gas.Arith.zero - | Reveal _ | Delegation _ | Set_deposits_limit _ -> Gas.Arith.zero - | _ -> safety_guard - in - cctxt#message - "Estimated gas: %a units (will add %a for safety)" - Gas.Arith.pp - gas - Gas.Arith.pp - safety_guard - >>= fun () -> - let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in - let patched_gas = - Gas.Arith.min safe_gas hard_gas_limit_per_operation - in - return - (Annotated_manager_operation.set_gas_limit - (Limit.known patched_gas) - op) - else return op) + Lwt.return (estimated_gas_single result) >>=? fun gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return + (Annotated_manager_operation.set_gas_limit + (Limit.known Gas.Arith.zero) + op) + else + let safety_guard = + match c.operation with + | Transaction {destination; _} + when Option.is_some (Contract.is_implicit destination) -> + Gas.Arith.zero + | Reveal _ | Delegation _ | Set_deposits_limit _ -> + Gas.Arith.zero + | _ -> safety_guard + in + cctxt#message + "Estimated gas: %a units (will add %a for safety)" + Gas.Arith.pp + gas + Gas.Arith.pp + safety_guard + >>= fun () -> + let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in + let patched_gas = + Gas.Arith.min safe_gas hard_gas_limit_per_operation + in + return + (Annotated_manager_operation.set_gas_limit + (Limit.known patched_gas) + op) + else return op) >>=? fun op -> (if user_storage_limit_needs_patching c.storage_limit then - Lwt.return - (estimated_storage_single (Z.of_int origination_size) result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return - (Annotated_manager_operation.set_storage_limit - (Limit.known Z.zero) - op) - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - let storage_limit = - Z.min - (Z.add storage (Z.of_int 20)) - hard_storage_limit_per_operation - in - return - (Annotated_manager_operation.set_storage_limit - (Limit.known storage_limit) - op) - else return op) + Lwt.return + (estimated_storage_single (Z.of_int origination_size) result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return + (Annotated_manager_operation.set_storage_limit + (Limit.known Z.zero) + op) + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + let storage_limit = + Z.min + (Z.add storage (Z.of_int 20)) + hard_storage_limit_per_operation + in + return + (Annotated_manager_operation.set_storage_limit + (Limit.known storage_limit) + op) + else return op) >>=? fun op -> if Limit.is_unknown c.fee then (* Setting a dummy fee is required for converting to manager op *) @@ -831,16 +832,16 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?(dry_run = false) ?(simulation = false) ?(force = false) ?branch ?src_sk ?verbose_signing ~fee_parameter (contents : kind contents_list) = (if simulation then simulate cctxt ~chain ~block ?branch contents - else - preapply - cctxt - ~chain - ~block - ~fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + else + preapply + cctxt + ~chain + ~block + ~fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit @@ -1039,8 +1040,8 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run match key with | None when not (has_reveal operations) -> ( (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then - reveal_error cctxt - else return_unit) + reveal_error cctxt + else return_unit) >>=? fun () -> let reveal = prepare_manager_operation diff --git a/src/proto_012_Psithaca/lib_client/michelson_v1_entrypoints.ml b/src/proto_012_Psithaca/lib_client/michelson_v1_entrypoints.ml index 7f8fa8a6e65fa394bba355a7b18f7c569b72fb20..d3a67f2369f61e6be187ab065a0eeb0f3879fcc4 100644 --- a/src/proto_012_Psithaca/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_012_Psithaca/lib_client/michelson_v1_entrypoints.ml @@ -78,17 +78,17 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %s) (type . %a))@]@." - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %s: %a@]@." - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %s) (type . %a))@]@." + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %s: %a@]@." + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -139,37 +139,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -177,40 +177,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_012_Psithaca/lib_client/michelson_v1_macros.ml b/src/proto_012_Psithaca/lib_client/michelson_v1_macros.ml index 3b1eaa5028d406200e27b127af40a1e5d81df9ac..600fb5da98f59465ab385c6ae134d16b11539ac8 100644 --- a/src/proto_012_Psithaca/lib_client/michelson_v1_macros.ml +++ b/src/proto_012_Psithaca/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_012_Psithaca/lib_client/mockup.ml b/src/proto_012_Psithaca/lib_client/mockup.ml index 1d3ec2e34a33fb2f42ebe4dce561cf50b10a4f6c..a7fddbab579d7537e196ae8f35bdbfa1e5271a04 100644 --- a/src/proto_012_Psithaca/lib_client/mockup.ml +++ b/src/proto_012_Psithaca/lib_client/mockup.ml @@ -559,11 +559,11 @@ module Protocol_constants_overrides = struct Option.is_some override_value) in (if fields_with_override <> [] then - cctxt#message - "@[mockup client uses protocol overrides:@,%a@]@?" - (pp_print_list field_pp) - fields_with_override - else Lwt.return_unit) + cctxt#message + "@[mockup client uses protocol overrides:@,%a@]@?" + (pp_print_list field_pp) + fields_with_override + else Lwt.return_unit) >>= fun () -> return ({ @@ -985,8 +985,8 @@ let mem_init : let default = parameters.initial_timestamp in let timestamp = Option.value ~default protocol_overrides.timestamp in (if not @@ Time.Protocol.equal default timestamp then - cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp - else Lwt.return_unit) + cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp + else Lwt.return_unit) >>= fun () -> let fitness = Protocol.Alpha_context.( diff --git a/src/proto_012_Psithaca/lib_client/operation_result.ml b/src/proto_012_Psithaca/lib_client/operation_result.ml index f9d94f94ef5866fe0cd6fa66ddc0ed52f851ab95..370d74187cfe64a03f72d51ee644bea7b8e22943 100644 --- a/src/proto_012_Psithaca/lib_client/operation_result.ml +++ b/src/proto_012_Psithaca/lib_client/operation_result.ml @@ -47,16 +47,16 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf | "default" -> () | _ -> Format.fprintf ppf "@,Entrypoint: %s" entrypoint) ; (if not (Script_repr.is_unit_parameter parameters) then - let expr = - WithExceptions.Option.to_exn - ~none:(Failure "ill-serialized argument") - (Data_encoding.force_decode parameters) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr) ; + let expr = + WithExceptions.Option.to_exn + ~none:(Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr) ; pp_result ppf result ; Format.fprintf ppf "@]" | Origination {delegate; credit; script = {code; storage}; preorigination = _} @@ -148,7 +148,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:@,Delegate: %a@,Unlimited deposits%a@]" (if internal then "Internal set deposits limit" - else "Set deposits limit") + else "Set deposits limit") Contract.pp source pp_result @@ -158,7 +158,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:@,Delegate: %a@,Limit: %a%a@]" (if internal then "Internal set deposits limit" - else "Set deposits limit") + else "Set deposits limit") Contract.pp source Tez.pp diff --git a/src/proto_012_Psithaca/lib_client/protocol_client_context.ml b/src/proto_012_Psithaca/lib_client/protocol_client_context.ml index 3ce9e8d4033a52a4e6ae2e739aecd3a59d32972c..de61519f47ec1694469f6ae50625e626f24ed3fa 100644 --- a/src/proto_012_Psithaca/lib_client/protocol_client_context.ml +++ b/src/proto_012_Psithaca/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific procotol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_012_Psithaca/lib_client_commands/client_proto_context_commands.ml b/src/proto_012_Psithaca/lib_client_commands/client_proto_context_commands.ml index c9e8426a4d2aa90a5aa1f2694632a061165b4a60..377e0c1675f30f284e26e1475b8eaad15032eb38 100644 --- a/src/proto_012_Psithaca/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_012_Psithaca/lib_client_commands/client_proto_context_commands.ml @@ -127,7 +127,7 @@ let commands_ro () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -466,8 +466,8 @@ let commands_ro () = p w (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_012_Psithaca/lib_client_commands/client_proto_programs_commands.ml b/src/proto_012_Psithaca/lib_client_commands/client_proto_programs_commands.ml index 942a4857a626d7fd5ecf3e0a775c5a63957eecb2..872bf804f6fa6dc901f06e9d5ccfaffa20154ec6 100644 --- a/src/proto_012_Psithaca/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_012_Psithaca/lib_client_commands/client_proto_programs_commands.ml @@ -542,9 +542,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_012_Psithaca/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_012_Psithaca/lib_client_commands/client_proto_stresstest_commands.ml index 91437eaa2c9549637de3fb3410035ee060130c72..0fb49c9abcb9b0824656d196c1e604f9b7718ff0 100644 --- a/src/proto_012_Psithaca/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_012_Psithaca/lib_client_commands/client_proto_stresstest_commands.ml @@ -401,7 +401,7 @@ let rec sample_transfer (cctxt : Protocol_client_context.full) chain block else let fresh = Random.State.float rng 1.0 < parameters.fresh_probability in (if fresh then Lwt.return (generate_fresh_source state rng) - else sample_any_source_from_pool state rng) + else sample_any_source_from_pool state rng) >>= fun dest -> let amount = match parameters.strategy with @@ -505,94 +505,94 @@ let inject_transfer (cctxt : Protocol_client_context.full) parameters state rng pcounter in (if - Tezos_crypto.Signature.V0.Public_key_hash.Set.mem - transfer.src.pkh - state.revealed - then return true - else ( - (* Either the [manager_key] RPC tells us the key is already - revealed, or we immediately inject a reveal operation: in any - case the key is revealed in the end. *) - state.revealed <- - Tezos_crypto.Signature.V0.Public_key_hash.Set.add - transfer.src.pkh - state.revealed ; - Alpha_services.Contract.manager_key cctxt (chain, block) transfer.src.pkh - >>=? fun pk_opt -> return (Option.is_some pk_opt))) + Tezos_crypto.Signature.V0.Public_key_hash.Set.mem + transfer.src.pkh + state.revealed + then return true + else ( + (* Either the [manager_key] RPC tells us the key is already + revealed, or we immediately inject a reveal operation: in any + case the key is revealed in the end. *) + state.revealed <- + Tezos_crypto.Signature.V0.Public_key_hash.Set.add + transfer.src.pkh + state.revealed ; + Alpha_services.Contract.manager_key cctxt (chain, block) transfer.src.pkh + >>=? fun pk_opt -> return (Option.is_some pk_opt))) >>=? fun already_revealed -> (if not already_revealed then ( - let reveal_counter = Z.succ freshest_counter in - let transf_counter = Z.succ reveal_counter in - let reveal = - Manager_operation - { - source = transfer.src.pkh; - fee = Tez.zero; - counter = reveal_counter; - gas_limit = cost_of_manager_operation; - storage_limit = Z.zero; - operation = Reveal transfer.src.pk; - } - in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Cons (reveal, Single manager_op) in - Tezos_crypto.Signature.V0.Public_key_hash.Table.remove - state.counters - transfer.src.pkh ; - Tezos_crypto.Signature.V0.Public_key_hash.Table.add - state.counters - transfer.src.pkh - (branch, transf_counter) ; - (if !verbose then - cctxt#message - "injecting reveal+transfer from %a (counters=%a,%a) to %a" - Tezos_crypto.Signature.V0.Public_key_hash.pp - transfer.src.pkh - Z.pp_print - reveal_counter - Z.pp_print - transf_counter - Tezos_crypto.Signature.V0.Public_key_hash.pp - transfer.dst - else Lwt.return_unit) - >>= fun () -> - (* NB: regardless of our best efforts to keep track of counters, injection can fail with - "counter in the future" if a block switch happens in between the moment we - get the branch and the moment we inject, and the new block does not include - all the operations we injected. *) - inject_contents cctxt chain branch transfer.src.sk list) - else - let transf_counter = Z.succ freshest_counter in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Single manager_op in - Tezos_crypto.Signature.V0.Public_key_hash.Table.remove - state.counters - transfer.src.pkh ; - Tezos_crypto.Signature.V0.Public_key_hash.Table.add - state.counters - transfer.src.pkh - (branch, transf_counter) ; - (if !verbose then - cctxt#message - "injecting transfer from %a (counter=%a) to %a" - Tezos_crypto.Signature.V0.Public_key_hash.pp + let reveal_counter = Z.succ freshest_counter in + let transf_counter = Z.succ reveal_counter in + let reveal = + Manager_operation + { + source = transfer.src.pkh; + fee = Tez.zero; + counter = reveal_counter; + gas_limit = cost_of_manager_operation; + storage_limit = Z.zero; + operation = Reveal transfer.src.pk; + } + in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Cons (reveal, Single manager_op) in + Tezos_crypto.Signature.V0.Public_key_hash.Table.remove + state.counters + transfer.src.pkh ; + Tezos_crypto.Signature.V0.Public_key_hash.Table.add + state.counters transfer.src.pkh - Z.pp_print - transf_counter - Tezos_crypto.Signature.V0.Public_key_hash.pp - transfer.dst - else Lwt.return_unit) - >>= fun () -> - (* See comment above. *) - inject_contents cctxt chain branch transfer.src.sk list) + (branch, transf_counter) ; + (if !verbose then + cctxt#message + "injecting reveal+transfer from %a (counters=%a,%a) to %a" + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + reveal_counter + Z.pp_print + transf_counter + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.dst + else Lwt.return_unit) + >>= fun () -> + (* NB: regardless of our best efforts to keep track of counters, injection can fail with + "counter in the future" if a block switch happens in between the moment we + get the branch and the moment we inject, and the new block does not include + all the operations we injected. *) + inject_contents cctxt chain branch transfer.src.sk list) + else + let transf_counter = Z.succ freshest_counter in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Single manager_op in + Tezos_crypto.Signature.V0.Public_key_hash.Table.remove + state.counters + transfer.src.pkh ; + Tezos_crypto.Signature.V0.Public_key_hash.Table.add + state.counters + transfer.src.pkh + (branch, transf_counter) ; + (if !verbose then + cctxt#message + "injecting transfer from %a (counter=%a) to %a" + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + transf_counter + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.dst + else Lwt.return_unit) + >>= fun () -> + (* See comment above. *) + inject_contents cctxt chain branch transfer.src.sk list) >>= function | Ok op_hash -> debug_msg (fun () -> @@ -696,7 +696,7 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = included). Note that the operations injected during the last block are \ ignored because they should not be currently included." (if Int.equal injected_ops_count 0 then "N/A" - else Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + else Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) injected_ops_count included_ops_count >>= fun () -> return_unit @@ -766,10 +766,10 @@ let launch (cctxt : Protocol_client_context.full) (parameters : parameters) let elapsed = Mtime.Span.(to_s stop -. to_s start) in let remaining = dt -. elapsed in (if remaining <= 0.0 then - cctxt#warning - "warning: tps target could not be reached, consider using a lower \ - value for --tps" - else Lwt_unix.sleep remaining) + cctxt#warning + "warning: tps target could not be reached, consider using a lower \ + value for --tps" + else Lwt_unix.sleep remaining) >>= loop in let on_new_head : Block_hash.t * Tezos_base.Block_header.t -> unit Lwt.t = @@ -1091,11 +1091,11 @@ let generate_random_transactions = pool_size = List.length sources; shuffled_pool = (if parameters.single_op_per_pkh_per_block then - Some - (List.shuffle - ~rng - (List.map (fun src_org -> src_org.source) sources)) - else None); + Some + (List.shuffle + ~rng + (List.map (fun src_org -> src_org.source) sources)) + else None); revealed = Tezos_crypto.Signature.V0.Public_key_hash.Set.empty; last_block = current_head_on_start; last_level = Int32.to_int header_on_start.shell.level; diff --git a/src/proto_012_Psithaca/lib_client_sapling/client_sapling_commands.ml b/src/proto_012_Psithaca/lib_client_sapling/client_sapling_commands.ml index 4e7ac236869a1265724990aaa3198fa3dec8fc5c..f760d690c7f4a78b745857a679afde391f4b53a3 100644 --- a/src/proto_012_Psithaca/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_012_Psithaca/lib_client_sapling/client_sapling_commands.ml @@ -414,19 +414,19 @@ let forge_shielded_cmd = let file = Option.value ~default:sapling_transaction_file file in cctxt#message "Writing transaction to %s@." file >>= fun () -> (if use_json_format then - save_json_to_file - (Data_encoding.Json.construct UTXO.transaction_encoding transaction) - file - else - let bytes = - Hex.of_bytes - (Data_encoding.Binary.to_bytes_exn - UTXO.transaction_encoding - transaction) - in - let file = open_out_bin file in - Printf.fprintf file "0x%s" (Hex.show bytes) ; - close_out file) ; + save_json_to_file + (Data_encoding.Json.construct UTXO.transaction_encoding transaction) + file + else + let bytes = + Hex.of_bytes + (Data_encoding.Binary.to_bytes_exn + UTXO.transaction_encoding + transaction) + in + let file = open_out_bin file in + Printf.fprintf file "0x%s" (Hex.show bytes) ; + close_out file) ; return_unit) let submit_shielded_cmd = @@ -491,18 +491,18 @@ let submit_shielded_cmd = >>= fun () -> let open Context in (if use_json_format then - Lwt_utils_unix.Json.read_file filename >>=? fun json -> - return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json - else - Lwt_utils_unix.read_file filename >>= fun hex -> - let hex = - (* remove 0x *) - String.sub hex 2 (String.length hex - 2) - in - return - @@ Data_encoding.Binary.of_bytes_exn - UTXO.transaction_encoding - Hex.(to_bytes_exn (`Hex hex))) + Lwt_utils_unix.Json.read_file filename >>=? fun json -> + return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json + else + Lwt_utils_unix.read_file filename >>= fun hex -> + let hex = + (* remove 0x *) + String.sub hex 2 (String.length hex - 2) + in + return + @@ Data_encoding.Binary.of_bytes_exn + UTXO.transaction_encoding + Hex.(to_bytes_exn (`Hex hex))) >>=? fun transaction -> return Shielded_tez_contract_input.(as_arg (create transaction)) >>=? fun contract_input -> @@ -769,12 +769,12 @@ let commands () = | None -> cctxt#error "Account %s not found" name | Some account -> (if verbose then - cctxt#answer - "@[Received Sapling transactions for %s@,@[%a@]@]" - name - Context.Account.pp_unspent - account - else Lwt.return_unit) + cctxt#answer + "@[Received Sapling transactions for %s@,@[%a@]@]" + name + Context.Account.pp_unspent + account + else Lwt.return_unit) >>= fun () -> cctxt#answer "Total Sapling funds %a%s" diff --git a/src/proto_013_PtJakart/lib_client/client_proto_context.ml b/src/proto_013_PtJakart/lib_client/client_proto_context.ml index a2d7165778988f02c3d380f12fe209b272f73f12..57aaefcb6d1cdf00355af65b87b0e1a1b17d1778 100644 --- a/src/proto_013_PtJakart/lib_client/client_proto_context.ml +++ b/src/proto_013_PtJakart/lib_client/client_proto_context.ml @@ -365,10 +365,10 @@ let check_for_timelock code = let build_origination_operation ?(allow_timelock = false) ?fee ?gas_limit ?storage_limit ~initial_storage ~code ~delegate ~balance () = (if (not allow_timelock) && check_for_timelock code then - failwith - "Origination of contracts containing time lock related instructions is \ - disabled in the client because of a vulnerability." - else return_unit) + failwith + "Origination of contracts containing time lock related instructions is \ + disabled in the client because of a vulnerability." + else return_unit) >>=? fun () -> (* With the change of making implicit accounts delegatable, the following 3 arguments are being defaulted before they can be safely removed. *) @@ -623,8 +623,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V0.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys_v0.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -689,7 +689,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_013_PtJakart/lib_client/client_proto_utils.ml b/src/proto_013_PtJakart/lib_client/client_proto_utils.ml index 7495f6a00449eb30333a3bcef164c71d6c073a9e..05ef300c13d0e646ae1fec1a8eaa805d7bc6b7cb 100644 --- a/src/proto_013_PtJakart/lib_client/client_proto_utils.ml +++ b/src/proto_013_PtJakart/lib_client/client_proto_utils.ml @@ -50,7 +50,7 @@ let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit - else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) + else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> Client_keys_v0.check ~watermark:Tezos_crypto.Signature.V0.Generic_operation diff --git a/src/proto_013_PtJakart/lib_client/injection.ml b/src/proto_013_PtJakart/lib_client/injection.ml index c565634fdf20167eafa46285a20a0d91bce5df7a..9881c63e7b6eaef809eed3793774d8b42990dc6e 100644 --- a/src/proto_013_PtJakart/lib_client/injection.ml +++ b/src/proto_013_PtJakart/lib_client/injection.ml @@ -252,10 +252,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -744,82 +744,85 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun ~first -> function | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>= fun gas -> - match gas with - | Error _ when force -> - (* When doing a simulation, set gas to hard limit so as to not change - the error. When force injecting a failing operation, set gas to - zero to not pay fees for this operation. *) - let gas = - if simulation then hard_gas_limit_per_operation - else Gas.Arith.zero - in - return - (Annotated_manager_operation.set_gas_limit (Limit.known gas) op) - | Error _ as res -> Lwt.return res - | Ok gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return - (Annotated_manager_operation.set_gas_limit - (Limit.known Gas.Arith.zero) - op) - else - let safety_guard = - match c.operation with - | Transaction {destination = Contract destination; _} - when Option.is_some (Contract.is_implicit destination) -> - Gas.Arith.zero - | Reveal _ | Delegation _ | Set_deposits_limit _ -> - Gas.Arith.zero - | _ -> safety_guard - in - cctxt#message - "Estimated gas: %a units (will add %a for safety)" - Gas.Arith.pp - gas - Gas.Arith.pp - safety_guard - >>= fun () -> - let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in - let patched_gas = - Gas.Arith.min safe_gas hard_gas_limit_per_operation + Lwt.return (estimated_gas_single result) >>= fun gas -> + match gas with + | Error _ when force -> + (* When doing a simulation, set gas to hard limit so as to not change + the error. When force injecting a failing operation, set gas to + zero to not pay fees for this operation. *) + let gas = + if simulation then hard_gas_limit_per_operation + else Gas.Arith.zero in return (Annotated_manager_operation.set_gas_limit - (Limit.known patched_gas) + (Limit.known gas) op) - else return op) + | Error _ as res -> Lwt.return res + | Ok gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return + (Annotated_manager_operation.set_gas_limit + (Limit.known Gas.Arith.zero) + op) + else + let safety_guard = + match c.operation with + | Transaction {destination = Contract destination; _} + when Option.is_some (Contract.is_implicit destination) -> + Gas.Arith.zero + | Reveal _ | Delegation _ | Set_deposits_limit _ -> + Gas.Arith.zero + | _ -> safety_guard + in + cctxt#message + "Estimated gas: %a units (will add %a for safety)" + Gas.Arith.pp + gas + Gas.Arith.pp + safety_guard + >>= fun () -> + let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in + let patched_gas = + Gas.Arith.min safe_gas hard_gas_limit_per_operation + in + return + (Annotated_manager_operation.set_gas_limit + (Limit.known patched_gas) + op) + else return op) >>=? fun op -> (if user_storage_limit_needs_patching c.storage_limit then - Lwt.return - (estimated_storage_single - ~tx_rollup_origination_size:(Z.of_int tx_rollup_origination_size) - ~origination_size:(Z.of_int origination_size) - ~force - result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return - (Annotated_manager_operation.set_storage_limit - (Limit.known Z.zero) - op) - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - let storage_limit = - Z.min - (Z.add storage (Z.of_int 20)) - hard_storage_limit_per_operation - in - return - (Annotated_manager_operation.set_storage_limit - (Limit.known storage_limit) - op) - else return op) + Lwt.return + (estimated_storage_single + ~tx_rollup_origination_size: + (Z.of_int tx_rollup_origination_size) + ~origination_size:(Z.of_int origination_size) + ~force + result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return + (Annotated_manager_operation.set_storage_limit + (Limit.known Z.zero) + op) + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + let storage_limit = + Z.min + (Z.add storage (Z.of_int 20)) + hard_storage_limit_per_operation + in + return + (Annotated_manager_operation.set_storage_limit + (Limit.known storage_limit) + op) + else return op) >>=? fun op -> if Limit.is_unknown c.fee then (* Setting a dummy fee is required for converting to manager op *) @@ -941,17 +944,17 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?branch ?src_sk ?verbose_signing ~fee_parameter (contents : kind contents_list) = (if simulation then - simulate cctxt ~chain ~block ?successor_level ?branch contents - else - preapply - cctxt - ~chain - ~block - ~fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + simulate cctxt ~chain ~block ?successor_level ?branch contents + else + preapply + cctxt + ~chain + ~block + ~fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit @@ -1333,8 +1336,8 @@ let inject_manager_operation cctxt ~chain ~block ?successor_level ?branch match key with | None when not (has_reveal operations) -> ( (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then - reveal_error cctxt - else return_unit) + reveal_error cctxt + else return_unit) >>=? fun () -> let reveal = prepare_manager_operation diff --git a/src/proto_013_PtJakart/lib_client/michelson_v1_entrypoints.ml b/src/proto_013_PtJakart/lib_client/michelson_v1_entrypoints.ml index 29db7a2f053d13ab4d2df23342ea1dcbe182b567..bf6b1e37ed1b517b9bef1603e806c087897c14dc 100644 --- a/src/proto_013_PtJakart/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_013_PtJakart/lib_client/michelson_v1_entrypoints.ml @@ -79,19 +79,19 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %a) (type . %a))@]@." - Entrypoint.pp - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %a: %a@]@." - Entrypoint.pp - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %a) (type . %a))@]@." + Entrypoint.pp + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %a: %a@]@." + Entrypoint.pp + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -173,37 +173,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -211,40 +211,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_013_PtJakart/lib_client/michelson_v1_macros.ml b/src/proto_013_PtJakart/lib_client/michelson_v1_macros.ml index 3b1eaa5028d406200e27b127af40a1e5d81df9ac..600fb5da98f59465ab385c6ae134d16b11539ac8 100644 --- a/src/proto_013_PtJakart/lib_client/michelson_v1_macros.ml +++ b/src/proto_013_PtJakart/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_013_PtJakart/lib_client/mockup.ml b/src/proto_013_PtJakart/lib_client/mockup.ml index b692107b993eb5d76b6810c04558df4380b94e48..c8b83571f160eb493623bf0fc7e51a4123b80469 100644 --- a/src/proto_013_PtJakart/lib_client/mockup.ml +++ b/src/proto_013_PtJakart/lib_client/mockup.ml @@ -803,11 +803,11 @@ module Protocol_constants_overrides = struct Option.is_some override_value) in (if fields_with_override <> [] then - cctxt#message - "@[mockup client uses protocol overrides:@,%a@]@?" - (pp_print_list field_pp) - fields_with_override - else Lwt.return_unit) + cctxt#message + "@[mockup client uses protocol overrides:@,%a@]@?" + (pp_print_list field_pp) + fields_with_override + else Lwt.return_unit) >>= fun () -> return ({ @@ -1310,8 +1310,8 @@ let mem_init : let default = parameters.initial_timestamp in let timestamp = Option.value ~default protocol_overrides.timestamp in (if not @@ Time.Protocol.equal default timestamp then - cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp - else Lwt.return_unit) + cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp + else Lwt.return_unit) >>= fun () -> let fitness = Protocol.Alpha_context.( diff --git a/src/proto_013_PtJakart/lib_client/operation_result.ml b/src/proto_013_PtJakart/lib_client/operation_result.ml index 52aa931c23eb2d0fc4eb77ec0f733d9eb63c5cd8..81d86dad47f87f252d8a6106223d6127009af2e1 100644 --- a/src/proto_013_PtJakart/lib_client/operation_result.ml +++ b/src/proto_013_PtJakart/lib_client/operation_result.ml @@ -46,16 +46,16 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf if not (Entrypoint.is_default entrypoint) then Format.fprintf ppf "@,Entrypoint: %a" Entrypoint.pp entrypoint ; (if not (Script_repr.is_unit_parameter parameters) then - let expr = - WithExceptions.Option.to_exn - ~none:(Failure "ill-serialized argument") - (Data_encoding.force_decode parameters) - in - Format.fprintf - ppf - "@,Parameter: @[%a@]" - Michelson_v1_printer.print_expr - expr) ; + let expr = + WithExceptions.Option.to_exn + ~none:(Failure "ill-serialized argument") + (Data_encoding.force_decode parameters) + in + Format.fprintf + ppf + "@,Parameter: @[%a@]" + Michelson_v1_printer.print_expr + expr) ; pp_result ppf result ; Format.fprintf ppf "@]" | Origination {delegate; credit; script = {code; storage}} -> @@ -146,7 +146,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:@,Delegate: %a@,Unlimited deposits%a@]" (if internal then "Internal set deposits limit" - else "Set deposits limit") + else "Set deposits limit") Contract.pp source pp_result @@ -156,7 +156,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:@,Delegate: %a@,Limit: %a%a@]" (if internal then "Internal set deposits limit" - else "Set deposits limit") + else "Set deposits limit") Contract.pp source Tez.pp @@ -168,7 +168,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:@,From: %a%a@]" (if internal then "Internal tx rollup origination" - else "Tx rollup origination") + else "Tx rollup origination") Contract.pp source pp_result @@ -178,7 +178,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:%a, %d bytes, From: %a%a@]" (if internal then "Internal tx rollup transaction" - else "Tx rollup transaction") + else "Tx rollup transaction") Tx_rollup.pp tx_rollup (String.length content) @@ -191,7 +191,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:%a, %a@,From: %a%a@]" (if internal then "Internal tx rollup commitment" - else "Tx rollup commitment") + else "Tx rollup commitment") Tx_rollup.pp tx_rollup Tx_rollup_commitment.Full.pp @@ -205,7 +205,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:%a @,From: %a%a@]" (if internal then "Internal tx rollup return commitment bond" - else "Tx rollup return commitment bond") + else "Tx rollup return commitment bond") Tx_rollup.pp tx_rollup Contract.pp @@ -217,7 +217,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:%a @,From: %a%a@]" (if internal then "Internal tx rollup finalize commitment" - else "Tx rollup finalize commitment") + else "Tx rollup finalize commitment") Tx_rollup.pp tx_rollup Contract.pp @@ -229,7 +229,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:%a @,From: %a%a@]" (if internal then "Internal tx rollup remove commitment" - else "Tx rollup remove commitment") + else "Tx rollup remove commitment") Tx_rollup.pp tx_rollup Contract.pp @@ -242,7 +242,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:%a @,From: %a%a@]" (if internal then "Internal tx rollup rejection" - else "Tx rollup rejection") + else "Tx rollup rejection") Tx_rollup.pp tx_rollup Contract.pp @@ -254,7 +254,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf ppf "@[%s:%a@,From: %a%a@]" (if internal then "Internal tx rollup dispatch tickets" - else "Tx rollup dispatch tickets") + else "Tx rollup dispatch tickets") Tx_rollup.pp tx_rollup Contract.pp diff --git a/src/proto_013_PtJakart/lib_client/protocol_client_context.ml b/src/proto_013_PtJakart/lib_client/protocol_client_context.ml index 96fc97ae99266ded688c009a83ce39316ee7b4ff..36a706f815e6020c22e95fb182cf9857f784830a 100644 --- a/src/proto_013_PtJakart/lib_client/protocol_client_context.ml +++ b/src/proto_013_PtJakart/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific procotol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_context_commands.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_context_commands.ml index 2f812513fb12e4d0cf4782cace4e7c4aea570ef3..dff30b5fa1d2d5087a0652175a6fbfcb25e3fbba 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_context_commands.ml @@ -152,7 +152,7 @@ let commands_ro () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -504,8 +504,8 @@ let commands_ro () = (Tez.of_mutez_exn w) Client_proto_args.tez_sym (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_programs_commands.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_programs_commands.ml index f8790982e5e533cbc31a503954f1f4413782a006..97f5f34717e0140615b747d856a790f49094b0fb 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_programs_commands.ml @@ -552,9 +552,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_commands.ml index 113942e6804178bc56be5bb86848aed728448d69..bb8e632e8efce269273382394a8717936cc8039f 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_commands.ml @@ -386,7 +386,7 @@ let rec sample_transfer (cctxt : Protocol_client_context.full) chain block with | None -> (if fresh then Lwt.return (generate_fresh_source state rng) - else sample_any_source_from_pool state rng) + else sample_any_source_from_pool state rng) >|= fun dest -> Ok ( Implicit dest.pkh, @@ -514,94 +514,94 @@ let inject_transfer (cctxt : Protocol_client_context.full) parameters state rng pcounter in (if - Tezos_crypto.Signature.V0.Public_key_hash.Set.mem - transfer.src.pkh - state.revealed - then return true - else ( - (* Either the [manager_key] RPC tells us the key is already - revealed, or we immediately inject a reveal operation: in any - case the key is revealed in the end. *) - state.revealed <- - Tezos_crypto.Signature.V0.Public_key_hash.Set.add - transfer.src.pkh - state.revealed ; - Alpha_services.Contract.manager_key cctxt (chain, block) transfer.src.pkh - >>=? fun pk_opt -> return (Option.is_some pk_opt))) + Tezos_crypto.Signature.V0.Public_key_hash.Set.mem + transfer.src.pkh + state.revealed + then return true + else ( + (* Either the [manager_key] RPC tells us the key is already + revealed, or we immediately inject a reveal operation: in any + case the key is revealed in the end. *) + state.revealed <- + Tezos_crypto.Signature.V0.Public_key_hash.Set.add + transfer.src.pkh + state.revealed ; + Alpha_services.Contract.manager_key cctxt (chain, block) transfer.src.pkh + >>=? fun pk_opt -> return (Option.is_some pk_opt))) >>=? fun already_revealed -> (if not already_revealed then ( - let reveal_counter = Z.succ freshest_counter in - let transf_counter = Z.succ reveal_counter in - let reveal = - Manager_operation - { - source = transfer.src.pkh; - fee = Tez.zero; - counter = reveal_counter; - gas_limit = cost_of_manager_operation; - storage_limit = Z.zero; - operation = Reveal transfer.src.pk; - } - in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Cons (reveal, Single manager_op) in - Tezos_crypto.Signature.V0.Public_key_hash.Table.remove - state.counters - transfer.src.pkh ; - Tezos_crypto.Signature.V0.Public_key_hash.Table.add - state.counters - transfer.src.pkh - (branch, transf_counter) ; - (if !verbose then - cctxt#message - "injecting reveal+transfer from %a (counters=%a,%a) to %a" - Tezos_crypto.Signature.V0.Public_key_hash.pp - transfer.src.pkh - Z.pp_print - reveal_counter - Z.pp_print - transf_counter - Contract.pp - (destination_to_contract transfer.dst) - else Lwt.return_unit) - >>= fun () -> - (* NB: regardless of our best efforts to keep track of counters, injection can fail with - "counter in the future" if a block switch happens in between the moment we - get the branch and the moment we inject, and the new block does not include - all the operations we injected. *) - inject_contents cctxt chain state.target_block transfer.src.sk list) - else - let transf_counter = Z.succ freshest_counter in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Single manager_op in - Tezos_crypto.Signature.V0.Public_key_hash.Table.remove - state.counters - transfer.src.pkh ; - Tezos_crypto.Signature.V0.Public_key_hash.Table.add - state.counters - transfer.src.pkh - (branch, transf_counter) ; - (if !verbose then - cctxt#message - "injecting transfer from %a (counter=%a) to %a" - Tezos_crypto.Signature.V0.Public_key_hash.pp + let reveal_counter = Z.succ freshest_counter in + let transf_counter = Z.succ reveal_counter in + let reveal = + Manager_operation + { + source = transfer.src.pkh; + fee = Tez.zero; + counter = reveal_counter; + gas_limit = cost_of_manager_operation; + storage_limit = Z.zero; + operation = Reveal transfer.src.pk; + } + in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Cons (reveal, Single manager_op) in + Tezos_crypto.Signature.V0.Public_key_hash.Table.remove + state.counters + transfer.src.pkh ; + Tezos_crypto.Signature.V0.Public_key_hash.Table.add + state.counters transfer.src.pkh - Z.pp_print - transf_counter - Contract.pp - (destination_to_contract transfer.dst) - else Lwt.return_unit) - >>= fun () -> - (* See comment above. *) - inject_contents cctxt chain state.target_block transfer.src.sk list) + (branch, transf_counter) ; + (if !verbose then + cctxt#message + "injecting reveal+transfer from %a (counters=%a,%a) to %a" + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + reveal_counter + Z.pp_print + transf_counter + Contract.pp + (destination_to_contract transfer.dst) + else Lwt.return_unit) + >>= fun () -> + (* NB: regardless of our best efforts to keep track of counters, injection can fail with + "counter in the future" if a block switch happens in between the moment we + get the branch and the moment we inject, and the new block does not include + all the operations we injected. *) + inject_contents cctxt chain state.target_block transfer.src.sk list) + else + let transf_counter = Z.succ freshest_counter in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Single manager_op in + Tezos_crypto.Signature.V0.Public_key_hash.Table.remove + state.counters + transfer.src.pkh ; + Tezos_crypto.Signature.V0.Public_key_hash.Table.add + state.counters + transfer.src.pkh + (branch, transf_counter) ; + (if !verbose then + cctxt#message + "injecting transfer from %a (counter=%a) to %a" + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + transf_counter + Contract.pp + (destination_to_contract transfer.dst) + else Lwt.return_unit) + >>= fun () -> + (* See comment above. *) + inject_contents cctxt chain state.target_block transfer.src.sk list) >>= function | Ok op_hash -> debug_msg (fun () -> @@ -708,7 +708,7 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = included). Note that the operations injected during the last block are \ ignored because they should not be currently included." (if Int.equal injected_ops_count 0 then "N/A" - else Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + else Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) injected_ops_count included_ops_count >>= fun () -> return_unit @@ -778,10 +778,10 @@ let launch (cctxt : Protocol_client_context.full) (parameters : parameters) let elapsed = Mtime.Span.(to_s stop -. to_s start) in let remaining = dt -. elapsed in (if remaining <= 0.0 then - cctxt#warning - "warning: tps target could not be reached, consider using a lower \ - value for --tps" - else Lwt_unix.sleep remaining) + cctxt#warning + "warning: tps target could not be reached, consider using a lower \ + value for --tps" + else Lwt_unix.sleep remaining) >>= loop in (* True, if and only if [single_op_per_pkh_per_block] is true. *) @@ -1121,11 +1121,11 @@ let generate_random_transactions = | [] -> cctxt#error "It is required to provide sources" | sources -> (if !verbose then cctxt#message "starting to normalize sources" - else Lwt.return_unit) + else Lwt.return_unit) >>= fun () -> List.filter_map_s (normalize_source cctxt) sources >>= fun sources -> (if !verbose then cctxt#message "all sources have been normalized" - else Lwt.return_unit) + else Lwt.return_unit) >>= fun () -> let counters = Tezos_crypto.Signature.V0.Public_key_hash.Table.create 1023 @@ -1144,11 +1144,11 @@ let generate_random_transactions = pool_size = List.length sources; shuffled_pool = (if parameters.single_op_per_pkh_per_block then - Some - (List.shuffle - ~rng - (List.map (fun src_org -> src_org.source) sources)) - else None); + Some + (List.shuffle + ~rng + (List.map (fun src_org -> src_org.source) sources)) + else None); revealed = Tezos_crypto.Signature.V0.Public_key_hash.Set.empty; last_block = current_head_on_start; last_level = Int32.to_int header_on_start.level; diff --git a/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_contracts.ml b/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_contracts.ml index b877e24b652c8be1baad08395f3234e7a0b12b74..0b0773277c321ce81fbe92129ad5ddcb422b433c 100644 --- a/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_contracts.ml +++ b/src/proto_013_PtJakart/lib_client_commands/client_proto_stresstest_contracts.ml @@ -121,8 +121,8 @@ let init (cctxt : Protocol_client_context.full) contract_parameters in (if sum_of_probabilities > 1.0 then - failwith "sum of smart contract call probabilities is greater than 1.0!" - else return_unit) + failwith "sum of smart contract call probabilities is greater than 1.0!" + else return_unit) >>=? fun () -> let init_one (alias, params) = Client_proto_contracts.Contract_alias.get_contract cctxt alias diff --git a/src/proto_013_PtJakart/lib_client_sapling/client_sapling_commands.ml b/src/proto_013_PtJakart/lib_client_sapling/client_sapling_commands.ml index fd3b391b71897573d23169453c09e35012defd84..d4c119dfcad0d31ea7b4417cfb1095d3a580e6a1 100644 --- a/src/proto_013_PtJakart/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_013_PtJakart/lib_client_sapling/client_sapling_commands.ml @@ -436,19 +436,19 @@ let forge_shielded_cmd = let file = Option.value ~default:sapling_transaction_file file in cctxt#message "Writing transaction to %s@." file >>= fun () -> (if use_json_format then - save_json_to_file - (Data_encoding.Json.construct UTXO.transaction_encoding transaction) - file - else - let bytes = - Hex.of_bytes - (Data_encoding.Binary.to_bytes_exn - UTXO.transaction_encoding - transaction) - in - let file = open_out_bin file in - Printf.fprintf file "0x%s" (Hex.show bytes) ; - close_out file) ; + save_json_to_file + (Data_encoding.Json.construct UTXO.transaction_encoding transaction) + file + else + let bytes = + Hex.of_bytes + (Data_encoding.Binary.to_bytes_exn + UTXO.transaction_encoding + transaction) + in + let file = open_out_bin file in + Printf.fprintf file "0x%s" (Hex.show bytes) ; + close_out file) ; return_unit) let submit_shielded_cmd = @@ -513,18 +513,18 @@ let submit_shielded_cmd = >>= fun () -> let open Context in (if use_json_format then - Lwt_utils_unix.Json.read_file filename >>=? fun json -> - return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json - else - Lwt_utils_unix.read_file filename >>= fun hex -> - let hex = - (* remove 0x *) - String.sub hex 2 (String.length hex - 2) - in - return - @@ Data_encoding.Binary.of_bytes_exn - UTXO.transaction_encoding - Hex.(to_bytes_exn (`Hex hex))) + Lwt_utils_unix.Json.read_file filename >>=? fun json -> + return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json + else + Lwt_utils_unix.read_file filename >>= fun hex -> + let hex = + (* remove 0x *) + String.sub hex 2 (String.length hex - 2) + in + return + @@ Data_encoding.Binary.of_bytes_exn + UTXO.transaction_encoding + Hex.(to_bytes_exn (`Hex hex))) >>=? fun transaction -> return (sapling_transaction_as_arg transaction) >>=? fun contract_input -> let chain = cctxt#chain and block = cctxt#block in @@ -790,12 +790,12 @@ let commands () = | None -> cctxt#error "Account %s not found" name | Some account -> (if verbose then - cctxt#answer - "@[Received Sapling transactions for %s@,@[%a@]@]" - name - Context.Account.pp_unspent - account - else Lwt.return_unit) + cctxt#answer + "@[Received Sapling transactions for %s@,@[%a@]@]" + name + Context.Account.pp_unspent + account + else Lwt.return_unit) >>= fun () -> cctxt#answer "Total Sapling funds %a%s" diff --git a/src/proto_014_PtKathma/lib_client/client_proto_args.ml b/src/proto_014_PtKathma/lib_client/client_proto_args.ml index bc871b0523d4f8fc2bec4e9813a601f5b508e5cb..47872b7223335005183e9ec71296d5cc73c75855 100644 --- a/src/proto_014_PtKathma/lib_client/client_proto_args.ml +++ b/src/proto_014_PtKathma/lib_client/client_proto_args.ml @@ -993,14 +993,15 @@ let fee_parameter_args = | None -> failwith "Bad burn cap")) in Tezos_clic.map_arg - ~f: - (fun _cctxt - ( minimal_fees, - minimal_nanotez_per_byte, - minimal_nanotez_per_gas_unit, - force_low_fee, - fee_cap, - burn_cap ) -> + ~f:(fun + _cctxt + ( minimal_fees, + minimal_nanotez_per_byte, + minimal_nanotez_per_gas_unit, + force_low_fee, + fee_cap, + burn_cap ) + -> return { Injection.minimal_fees; diff --git a/src/proto_014_PtKathma/lib_client/client_proto_context.ml b/src/proto_014_PtKathma/lib_client/client_proto_context.ml index 7f0651385109b9e9ac6289254264bee6f9a6f2be..c93a747de092ebbfa04cb39b9e0d889dade2ae5e 100644 --- a/src/proto_014_PtKathma/lib_client/client_proto_context.ml +++ b/src/proto_014_PtKathma/lib_client/client_proto_context.ml @@ -399,10 +399,10 @@ let check_for_timelock code = let build_origination_operation ?(allow_timelock = false) ?fee ?gas_limit ?storage_limit ~initial_storage ~code ~delegate ~balance () = (if (not allow_timelock) && check_for_timelock code then - failwith - "Origination of contracts containing time lock related instructions is \ - disabled in the client because of a vulnerability." - else return_unit) + failwith + "Origination of contracts containing time lock related instructions is \ + disabled in the client because of a vulnerability." + else return_unit) >>=? fun () -> (* With the change of making implicit accounts delegatable, the following 3 arguments are being defaulted before they can be safely removed. *) @@ -656,8 +656,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V0.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys_v0.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -722,7 +722,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_014_PtKathma/lib_client/client_proto_utils.ml b/src/proto_014_PtKathma/lib_client/client_proto_utils.ml index 7495f6a00449eb30333a3bcef164c71d6c073a9e..05ef300c13d0e646ae1fec1a8eaa805d7bc6b7cb 100644 --- a/src/proto_014_PtKathma/lib_client/client_proto_utils.ml +++ b/src/proto_014_PtKathma/lib_client/client_proto_utils.ml @@ -50,7 +50,7 @@ let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit - else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) + else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> Client_keys_v0.check ~watermark:Tezos_crypto.Signature.V0.Generic_operation diff --git a/src/proto_014_PtKathma/lib_client/injection.ml b/src/proto_014_PtKathma/lib_client/injection.ml index ec2294df760c5f0116a98487c8ee1bdb79552afe..af865f136eca9a30cbddfed9c6b093a132747ebd 100644 --- a/src/proto_014_PtKathma/lib_client/injection.ml +++ b/src/proto_014_PtKathma/lib_client/injection.ml @@ -244,10 +244,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -817,81 +817,84 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun ~first -> function | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>= fun gas -> - match gas with - | Error _ when force -> - (* When doing a simulation, set gas to hard limit so as to not change - the error. When force injecting a failing operation, set gas to - zero to not pay fees for this operation. *) - let gas = - if simulation then hard_gas_limit_per_operation - else Gas.Arith.zero - in - return - (Annotated_manager_operation.set_gas_limit (Limit.known gas) op) - | Error _ as res -> Lwt.return res - | Ok gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return - (Annotated_manager_operation.set_gas_limit - (Limit.known Gas.Arith.zero) - op) - else - let safety_guard = - match c.operation with - | Transaction {destination = Implicit _; _} - | Reveal _ | Delegation _ | Set_deposits_limit _ - | Increase_paid_storage _ -> - Gas.Arith.zero - | _ -> safety_guard - in - cctxt#message - "Estimated gas: %a units (will add %a for safety)" - Gas.Arith.pp - gas - Gas.Arith.pp - safety_guard - >>= fun () -> - let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in - let patched_gas = - Gas.Arith.min safe_gas hard_gas_limit_per_operation + Lwt.return (estimated_gas_single result) >>= fun gas -> + match gas with + | Error _ when force -> + (* When doing a simulation, set gas to hard limit so as to not change + the error. When force injecting a failing operation, set gas to + zero to not pay fees for this operation. *) + let gas = + if simulation then hard_gas_limit_per_operation + else Gas.Arith.zero in return (Annotated_manager_operation.set_gas_limit - (Limit.known patched_gas) + (Limit.known gas) op) - else return op) + | Error _ as res -> Lwt.return res + | Ok gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return + (Annotated_manager_operation.set_gas_limit + (Limit.known Gas.Arith.zero) + op) + else + let safety_guard = + match c.operation with + | Transaction {destination = Implicit _; _} + | Reveal _ | Delegation _ | Set_deposits_limit _ + | Increase_paid_storage _ -> + Gas.Arith.zero + | _ -> safety_guard + in + cctxt#message + "Estimated gas: %a units (will add %a for safety)" + Gas.Arith.pp + gas + Gas.Arith.pp + safety_guard + >>= fun () -> + let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in + let patched_gas = + Gas.Arith.min safe_gas hard_gas_limit_per_operation + in + return + (Annotated_manager_operation.set_gas_limit + (Limit.known patched_gas) + op) + else return op) >>=? fun op -> (if user_storage_limit_needs_patching c.storage_limit then - Lwt.return - (estimated_storage_single - ~tx_rollup_origination_size:(Z.of_int tx_rollup_origination_size) - ~origination_size:(Z.of_int origination_size) - ~force - result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return - (Annotated_manager_operation.set_storage_limit - (Limit.known Z.zero) - op) - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - let storage_limit = - Z.min - (Z.add storage (Z.of_int 20)) - hard_storage_limit_per_operation - in - return - (Annotated_manager_operation.set_storage_limit - (Limit.known storage_limit) - op) - else return op) + Lwt.return + (estimated_storage_single + ~tx_rollup_origination_size: + (Z.of_int tx_rollup_origination_size) + ~origination_size:(Z.of_int origination_size) + ~force + result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return + (Annotated_manager_operation.set_storage_limit + (Limit.known Z.zero) + op) + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + let storage_limit = + Z.min + (Z.add storage (Z.of_int 20)) + hard_storage_limit_per_operation + in + return + (Annotated_manager_operation.set_storage_limit + (Limit.known storage_limit) + op) + else return op) >>=? fun op -> if Limit.is_unknown c.fee then (* Setting a dummy fee is required for converting to manager op *) @@ -1013,17 +1016,17 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?branch ?src_sk ?verbose_signing ?fee_parameter (contents : kind contents_list) = (if simulation then - simulate cctxt ~chain ~block ?successor_level ?branch contents - else - preapply - cctxt - ~chain - ~block - ?fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + simulate cctxt ~chain ~block ?successor_level ?branch contents + else + preapply + cctxt + ~chain + ~block + ?fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit @@ -1405,8 +1408,8 @@ let inject_manager_operation cctxt ~chain ~block ?successor_level ?branch match key with | None when not (has_reveal operations) -> ( (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then - reveal_error cctxt - else return_unit) + reveal_error cctxt + else return_unit) >>=? fun () -> let reveal = prepare_manager_operation diff --git a/src/proto_014_PtKathma/lib_client/michelson_v1_entrypoints.ml b/src/proto_014_PtKathma/lib_client/michelson_v1_entrypoints.ml index aeb9596dea05de7ef714e973047796133f2d86b3..8039540bfdcee72f2376da864b24cb5f3e0b1e08 100644 --- a/src/proto_014_PtKathma/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_014_PtKathma/lib_client/michelson_v1_entrypoints.ml @@ -79,19 +79,19 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %a) (type . %a))@]@." - Entrypoint.pp - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %a: %a@]@." - Entrypoint.pp - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %a) (type . %a))@]@." + Entrypoint.pp + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %a: %a@]@." + Entrypoint.pp + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -173,37 +173,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract_hash.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract_hash.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -211,40 +211,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract_hash.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract_hash.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_014_PtKathma/lib_client/michelson_v1_macros.ml b/src/proto_014_PtKathma/lib_client/michelson_v1_macros.ml index 3b1eaa5028d406200e27b127af40a1e5d81df9ac..600fb5da98f59465ab385c6ae134d16b11539ac8 100644 --- a/src/proto_014_PtKathma/lib_client/michelson_v1_macros.ml +++ b/src/proto_014_PtKathma/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_014_PtKathma/lib_client/mockup.ml b/src/proto_014_PtKathma/lib_client/mockup.ml index 5c37f9dfef34be4c9fe52431f6921d22406b76dd..5b21d7096965984238eb831d385f21d19a855eee 100644 --- a/src/proto_014_PtKathma/lib_client/mockup.ml +++ b/src/proto_014_PtKathma/lib_client/mockup.ml @@ -923,11 +923,11 @@ module Protocol_constants_overrides = struct Option.is_some override_value) in (if fields_with_override <> [] then - cctxt#message - "@[mockup client uses protocol overrides:@,%a@]@?" - (pp_print_list field_pp) - fields_with_override - else Lwt.return_unit) + cctxt#message + "@[mockup client uses protocol overrides:@,%a@]@?" + (pp_print_list field_pp) + fields_with_override + else Lwt.return_unit) >>= fun () -> return ({ @@ -1495,8 +1495,8 @@ let mem_init : let default = parameters.initial_timestamp in let timestamp = Option.value ~default protocol_overrides.timestamp in (if not @@ Time.Protocol.equal default timestamp then - cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp - else Lwt.return_unit) + cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp + else Lwt.return_unit) >>= fun () -> let fitness = Protocol.Alpha_context.( diff --git a/src/proto_014_PtKathma/lib_client/protocol_client_context.ml b/src/proto_014_PtKathma/lib_client/protocol_client_context.ml index 33ccdaadc9ffb0a97955f65897ac390a740811bf..f98be0dfceb62314a6c15dab70969b9357e202f7 100644 --- a/src/proto_014_PtKathma/lib_client/protocol_client_context.ml +++ b/src/proto_014_PtKathma/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific protocol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_014_PtKathma/lib_client_commands/client_proto_context_commands.ml b/src/proto_014_PtKathma/lib_client_commands/client_proto_context_commands.ml index c56d8d14a78a0896bb9072718d3bc52708a3399c..43a5b10975505d5aca68add2dafb79d6d789c526 100644 --- a/src/proto_014_PtKathma/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_014_PtKathma/lib_client_commands/client_proto_context_commands.ml @@ -125,7 +125,7 @@ let commands_ro () = () >>=? fun {timestamp = v; _} -> (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) + else cctxt#message "%s" (Time.Protocol.to_notation v)) >>= fun () -> return_unit); command ~group @@ -489,8 +489,8 @@ let commands_ro () = (Tez.of_mutez_exn w) Operation_result.tez_sym (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + then "" + else "not ")) ranks ; pp_close_box ppf ()) >>= fun () -> return_unit diff --git a/src/proto_014_PtKathma/lib_client_commands/client_proto_programs_commands.ml b/src/proto_014_PtKathma/lib_client_commands/client_proto_programs_commands.ml index 7ebe8f205ccdedf24b8b845589b5a2ae6cfe5e42..2765ad30fb208aa99970d16db9a8a56b48fd44c2 100644 --- a/src/proto_014_PtKathma/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_014_PtKathma/lib_client_commands/client_proto_programs_commands.ml @@ -549,9 +549,9 @@ let commands () = @@ stop) (fun () bytes cctxt -> (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit) >>=? fun () -> (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in diff --git a/src/proto_014_PtKathma/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_014_PtKathma/lib_client_commands/client_proto_stresstest_commands.ml index bf3a395b27528f1dadecae5a6c0f4f4b78f5d478..6813c5a5e00db62dbb6f5a0cc575eec08641c93a 100644 --- a/src/proto_014_PtKathma/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_014_PtKathma/lib_client_commands/client_proto_stresstest_commands.ml @@ -449,7 +449,7 @@ let rec sample_transfer (cctxt : Protocol_client_context.full) chain block with | None -> (if fresh then Lwt.return (generate_fresh_source state) - else sample_any_source_from_pool state) + else sample_any_source_from_pool state) >|= fun dest -> Ok ( Implicit dest.pkh, @@ -533,78 +533,78 @@ let inject_transfer (cctxt : Protocol_client_context.full) parameters state Alpha_services.Contract.counter cctxt (`Main, `Head 0) transfer.src.pkh >>=? fun current_counter -> (if - Tezos_crypto.Signature.V0.Public_key_hash.Set.mem - transfer.src.pkh - state.revealed - then return true - else ( - (* Either the [manager_key] RPC tells us the key is already - revealed, or we immediately inject a reveal operation: in any - case the key is revealed in the end. *) - state.revealed <- - Tezos_crypto.Signature.V0.Public_key_hash.Set.add - transfer.src.pkh - state.revealed ; - Alpha_services.Contract.manager_key cctxt (`Main, `Head 0) transfer.src.pkh - >>=? fun pk_opt -> return (Option.is_some pk_opt))) + Tezos_crypto.Signature.V0.Public_key_hash.Set.mem + transfer.src.pkh + state.revealed + then return true + else ( + (* Either the [manager_key] RPC tells us the key is already + revealed, or we immediately inject a reveal operation: in any + case the key is revealed in the end. *) + state.revealed <- + Tezos_crypto.Signature.V0.Public_key_hash.Set.add + transfer.src.pkh + state.revealed ; + Alpha_services.Contract.manager_key cctxt (`Main, `Head 0) transfer.src.pkh + >>=? fun pk_opt -> return (Option.is_some pk_opt))) >>=? fun already_revealed -> (if not already_revealed then - let reveal_counter = Z.succ current_counter in - let transf_counter = Z.succ reveal_counter in - let reveal = - Manager_operation - { - source = transfer.src.pkh; - fee = Tez.zero; - counter = reveal_counter; - gas_limit = cost_of_manager_operation; - storage_limit = Z.zero; - operation = Reveal transfer.src.pk; - } - in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Cons (reveal, Single manager_op) in - log Info (fun () -> - cctxt#message - "injecting reveal+transfer from %a (counters=%a,%a) to %a" - Tezos_crypto.Signature.V0.Public_key_hash.pp - transfer.src.pkh - Z.pp_print - reveal_counter - Z.pp_print - transf_counter - Contract.pp - (destination_to_contract transfer.dst)) - >>= fun () -> - (* NB: regardless of our best efforts to keep track of counters, injection can fail with - "counter in the future" if a block switch happens in between the moment we - get the branch and the moment we inject, and the new block does not include - all the operations we injected. *) - inject_contents cctxt state.target_block transfer.src.sk list - else - let transf_counter = Z.succ current_counter in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Single manager_op in - log Info (fun () -> - cctxt#message - "injecting transfer from %a (counter=%a) to %a" - Tezos_crypto.Signature.V0.Public_key_hash.pp - transfer.src.pkh - Z.pp_print - transf_counter - Contract.pp - (destination_to_contract transfer.dst)) - >>= fun () -> - (* See comment above. *) - inject_contents cctxt state.target_block transfer.src.sk list) + let reveal_counter = Z.succ current_counter in + let transf_counter = Z.succ reveal_counter in + let reveal = + Manager_operation + { + source = transfer.src.pkh; + fee = Tez.zero; + counter = reveal_counter; + gas_limit = cost_of_manager_operation; + storage_limit = Z.zero; + operation = Reveal transfer.src.pk; + } + in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Cons (reveal, Single manager_op) in + log Info (fun () -> + cctxt#message + "injecting reveal+transfer from %a (counters=%a,%a) to %a" + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + reveal_counter + Z.pp_print + transf_counter + Contract.pp + (destination_to_contract transfer.dst)) + >>= fun () -> + (* NB: regardless of our best efforts to keep track of counters, injection can fail with + "counter in the future" if a block switch happens in between the moment we + get the branch and the moment we inject, and the new block does not include + all the operations we injected. *) + inject_contents cctxt state.target_block transfer.src.sk list + else + let transf_counter = Z.succ current_counter in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Single manager_op in + log Info (fun () -> + cctxt#message + "injecting transfer from %a (counter=%a) to %a" + Tezos_crypto.Signature.V0.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + transf_counter + Contract.pp + (destination_to_contract transfer.dst)) + >>= fun () -> + (* See comment above. *) + inject_contents cctxt state.target_block transfer.src.sk list) >>= function | Ok op_hash -> log Debug (fun () -> @@ -708,7 +708,7 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = included). Note that the operations injected during the last block are \ ignored because they should not be currently included." (if Int.equal injected_ops_count 0 then "N/A" - else Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + else Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) injected_ops_count included_ops_count >>= fun () -> return_unit @@ -770,10 +770,10 @@ let launch (cctxt : Protocol_client_context.full) (parameters : parameters) let elapsed = Mtime.Span.(to_s stop -. to_s start) in let remaining = dt -. elapsed in (if remaining <= 0.0 then - cctxt#warning - "warning: tps target could not be reached, consider using a lower \ - value for --tps" - else Lwt_unix.sleep remaining) + cctxt#warning + "warning: tps target could not be reached, consider using a lower \ + value for --tps" + else Lwt_unix.sleep remaining) >>= loop in let on_new_head : @@ -1124,13 +1124,13 @@ let generate_random_transactions = Shell_services.Blocks.Header.shell_header cctxt () >>=? fun header_on_start -> (if header_on_start.level <= 2l then - cctxt#error - "The level of the head (%a) needs to be greater than 2 and is \ - actually %ld." - Block_hash.pp - current_head_on_start - header_on_start.level - else return_unit) + cctxt#error + "The level of the head (%a) needs to be greater than 2 and is \ + actually %ld." + Block_hash.pp + current_head_on_start + header_on_start.level + else return_unit) >>=? fun () -> Shell_services.Blocks.hash cctxt ~block:(`Head 2) () >>=? fun current_target_block -> diff --git a/src/proto_014_PtKathma/lib_client_commands/client_proto_stresstest_contracts.ml b/src/proto_014_PtKathma/lib_client_commands/client_proto_stresstest_contracts.ml index 287cedeac5594802718194926222cd31da1420f7..206129ac562064124d7592666641d40b3e72704b 100644 --- a/src/proto_014_PtKathma/lib_client_commands/client_proto_stresstest_contracts.ml +++ b/src/proto_014_PtKathma/lib_client_commands/client_proto_stresstest_contracts.ml @@ -121,8 +121,8 @@ let init (cctxt : Protocol_client_context.full) contract_parameters in (if sum_of_probabilities > 1.0 then - failwith "sum of smart contract call probabilities is greater than 1.0!" - else return_unit) + failwith "sum of smart contract call probabilities is greater than 1.0!" + else return_unit) >>=? fun () -> let init_one (alias, params) = Client_proto_contracts.Contract_alias.get_contract cctxt alias diff --git a/src/proto_014_PtKathma/lib_client_sapling/client_sapling_commands.ml b/src/proto_014_PtKathma/lib_client_sapling/client_sapling_commands.ml index 73028a519dbe7ac4ec9ea0861a1c65dc46047771..a2d76dda0fd8eb52f887c927a103055f6037cdf8 100644 --- a/src/proto_014_PtKathma/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_014_PtKathma/lib_client_sapling/client_sapling_commands.ml @@ -387,19 +387,19 @@ let forge_shielded_cmd = let file = Option.value ~default:sapling_transaction_file file in cctxt#message "Writing transaction to %s@." file >>= fun () -> (if use_json_format then - save_json_to_file - (Data_encoding.Json.construct UTXO.transaction_encoding transaction) - file - else - let bytes = - Hex.of_bytes - (Data_encoding.Binary.to_bytes_exn - UTXO.transaction_encoding - transaction) - in - let file = open_out_bin file in - Printf.fprintf file "0x%s" (Hex.show bytes) ; - close_out file) ; + save_json_to_file + (Data_encoding.Json.construct UTXO.transaction_encoding transaction) + file + else + let bytes = + Hex.of_bytes + (Data_encoding.Binary.to_bytes_exn + UTXO.transaction_encoding + transaction) + in + let file = open_out_bin file in + Printf.fprintf file "0x%s" (Hex.show bytes) ; + close_out file) ; return_unit) let submit_shielded_cmd = @@ -455,18 +455,18 @@ let submit_shielded_cmd = >>= fun () -> let open Context in (if use_json_format then - Lwt_utils_unix.Json.read_file filename >>=? fun json -> - return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json - else - Lwt_utils_unix.read_file filename >>= fun hex -> - let hex = - (* remove 0x *) - String.sub hex 2 (String.length hex - 2) - in - return - @@ Data_encoding.Binary.of_bytes_exn - UTXO.transaction_encoding - Hex.(to_bytes_exn (`Hex hex))) + Lwt_utils_unix.Json.read_file filename >>=? fun json -> + return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json + else + Lwt_utils_unix.read_file filename >>= fun hex -> + let hex = + (* remove 0x *) + String.sub hex 2 (String.length hex - 2) + in + return + @@ Data_encoding.Binary.of_bytes_exn + UTXO.transaction_encoding + Hex.(to_bytes_exn (`Hex hex))) >>=? fun transaction -> return (sapling_transaction_as_arg transaction) >>=? fun contract_input -> let chain = cctxt#chain and block = cctxt#block in @@ -721,12 +721,12 @@ let commands () = | None -> cctxt#error "Account %s not found" name | Some account -> (if verbose then - cctxt#answer - "@[Received Sapling transactions for %s@,@[%a@]@]" - name - Context.Account.pp_unspent - account - else Lwt.return_unit) + cctxt#answer + "@[Received Sapling transactions for %s@,@[%a@]@]" + name + Context.Account.pp_unspent + account + else Lwt.return_unit) >>= fun () -> cctxt#answer "Total Sapling funds %a%s" diff --git a/src/proto_015_PtLimaPt/lib_client/client_proto_args.ml b/src/proto_015_PtLimaPt/lib_client/client_proto_args.ml index f8ae1a374598dc937412148b52df567f5f815e4a..626a7e493e0c2393f2719f384f93e8b99420fb64 100644 --- a/src/proto_015_PtLimaPt/lib_client/client_proto_args.ml +++ b/src/proto_015_PtLimaPt/lib_client/client_proto_args.ml @@ -1020,14 +1020,15 @@ let fee_parameter_args = | None -> failwith "Bad burn cap")) in map_arg - ~f: - (fun _cctxt - ( minimal_fees, - minimal_nanotez_per_byte, - minimal_nanotez_per_gas_unit, - force_low_fee, - fee_cap, - burn_cap ) -> + ~f:(fun + _cctxt + ( minimal_fees, + minimal_nanotez_per_byte, + minimal_nanotez_per_gas_unit, + force_low_fee, + fee_cap, + burn_cap ) + -> return { Injection.minimal_fees; diff --git a/src/proto_015_PtLimaPt/lib_client/client_proto_context.ml b/src/proto_015_PtLimaPt/lib_client/client_proto_context.ml index 84e7ca5d17f5cc0caadf712736087ba7f2633372..ed8a651b3fdeed56ec42229b58e0c85152f4cd01 100644 --- a/src/proto_015_PtLimaPt/lib_client/client_proto_context.ml +++ b/src/proto_015_PtLimaPt/lib_client/client_proto_context.ml @@ -506,10 +506,10 @@ let check_for_timelock code = let build_origination_operation ?(allow_timelock = false) ?fee ?gas_limit ?storage_limit ~initial_storage ~code ~delegate ~balance () = (if (not allow_timelock) && check_for_timelock code then - failwith - "Origination of contracts containing time lock related instructions is \ - disabled in the client because of a vulnerability." - else return_unit) + failwith + "Origination of contracts containing time lock related instructions is \ + disabled in the client because of a vulnerability." + else return_unit) >>=? fun () -> (* With the change of making implicit accounts delegatable, the following 3 arguments are being defaulted before they can be safely removed. *) @@ -763,8 +763,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V0.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys_v0.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -829,7 +829,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_015_PtLimaPt/lib_client/client_proto_utils.ml b/src/proto_015_PtLimaPt/lib_client/client_proto_utils.ml index 7495f6a00449eb30333a3bcef164c71d6c073a9e..05ef300c13d0e646ae1fec1a8eaa805d7bc6b7cb 100644 --- a/src/proto_015_PtLimaPt/lib_client/client_proto_utils.ml +++ b/src/proto_015_PtLimaPt/lib_client/client_proto_utils.ml @@ -50,7 +50,7 @@ let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit - else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) + else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> Client_keys_v0.check ~watermark:Tezos_crypto.Signature.V0.Generic_operation diff --git a/src/proto_015_PtLimaPt/lib_client/injection.ml b/src/proto_015_PtLimaPt/lib_client/injection.ml index 4c1b8723039f1074892fead8badaa7d98bc6ec42..bd4c7066333596c67192c44bb0cc49947a5004e2 100644 --- a/src/proto_015_PtLimaPt/lib_client/injection.ml +++ b/src/proto_015_PtLimaPt/lib_client/injection.ml @@ -244,10 +244,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.V0.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -844,81 +844,84 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun ~first -> function | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>= fun gas -> - match gas with - | Error _ when force -> - (* When doing a simulation, set gas to the maximum possible value - so as to not change the error. When force injecting a failing - operation, set gas to zero to not pay fees for this - operation. *) - let gas = - if simulation then gas_limit_per_patched_op else Gas.Arith.zero - in - return - (Annotated_manager_operation.set_gas_limit (Limit.known gas) op) - | Error _ as res -> Lwt.return res - | Ok gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return - (Annotated_manager_operation.set_gas_limit - (Limit.known Gas.Arith.zero) - op) - else - let safety_guard = - match c.operation with - | Transaction {destination = Implicit _; _} - | Reveal _ | Delegation _ | Set_deposits_limit _ - | Increase_paid_storage _ -> - Gas.Arith.zero - | _ -> safety_guard - in - cctxt#message - "Estimated gas: %a units (will add %a for safety)" - Gas.Arith.pp - gas - Gas.Arith.pp - safety_guard - >>= fun () -> - let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in - let patched_gas = - Gas.Arith.min safe_gas hard_gas_limit_per_operation + Lwt.return (estimated_gas_single result) >>= fun gas -> + match gas with + | Error _ when force -> + (* When doing a simulation, set gas to the maximum possible value + so as to not change the error. When force injecting a failing + operation, set gas to zero to not pay fees for this + operation. *) + let gas = + if simulation then gas_limit_per_patched_op else Gas.Arith.zero in return (Annotated_manager_operation.set_gas_limit - (Limit.known patched_gas) + (Limit.known gas) op) - else return op) + | Error _ as res -> Lwt.return res + | Ok gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return + (Annotated_manager_operation.set_gas_limit + (Limit.known Gas.Arith.zero) + op) + else + let safety_guard = + match c.operation with + | Transaction {destination = Implicit _; _} + | Reveal _ | Delegation _ | Set_deposits_limit _ + | Increase_paid_storage _ -> + Gas.Arith.zero + | _ -> safety_guard + in + cctxt#message + "Estimated gas: %a units (will add %a for safety)" + Gas.Arith.pp + gas + Gas.Arith.pp + safety_guard + >>= fun () -> + let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in + let patched_gas = + Gas.Arith.min safe_gas hard_gas_limit_per_operation + in + return + (Annotated_manager_operation.set_gas_limit + (Limit.known patched_gas) + op) + else return op) >>=? fun op -> (if user_storage_limit_needs_patching c.storage_limit then - Lwt.return - (estimated_storage_single - ~tx_rollup_origination_size:(Z.of_int tx_rollup_origination_size) - ~origination_size:(Z.of_int origination_size) - ~force - result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return - (Annotated_manager_operation.set_storage_limit - (Limit.known Z.zero) - op) - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - let storage_limit = - Z.min - (Z.add storage (Z.of_int 20)) - hard_storage_limit_per_operation - in - return - (Annotated_manager_operation.set_storage_limit - (Limit.known storage_limit) - op) - else return op) + Lwt.return + (estimated_storage_single + ~tx_rollup_origination_size: + (Z.of_int tx_rollup_origination_size) + ~origination_size:(Z.of_int origination_size) + ~force + result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return + (Annotated_manager_operation.set_storage_limit + (Limit.known Z.zero) + op) + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + let storage_limit = + Z.min + (Z.add storage (Z.of_int 20)) + hard_storage_limit_per_operation + in + return + (Annotated_manager_operation.set_storage_limit + (Limit.known storage_limit) + op) + else return op) >>=? fun op -> if Limit.is_unknown c.fee then (* Setting a dummy fee is required for converting to manager op *) @@ -1025,17 +1028,17 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?branch ?src_sk ?verbose_signing ?fee_parameter (contents : kind contents_list) = (if simulation then - simulate cctxt ~chain ~block ?successor_level ?branch contents - else - preapply - cctxt - ~chain - ~block - ?fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + simulate cctxt ~chain ~block ?successor_level ?branch contents + else + preapply + cctxt + ~chain + ~block + ?fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit @@ -1417,8 +1420,8 @@ let inject_manager_operation cctxt ~chain ~block ?successor_level ?branch match key with | None when not (has_reveal operations) -> ( (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then - reveal_error cctxt - else return_unit) + reveal_error cctxt + else return_unit) >>=? fun () -> let reveal = prepare_manager_operation diff --git a/src/proto_015_PtLimaPt/lib_client/michelson_v1_entrypoints.ml b/src/proto_015_PtLimaPt/lib_client/michelson_v1_entrypoints.ml index aeb9596dea05de7ef714e973047796133f2d86b3..8039540bfdcee72f2376da864b24cb5f3e0b1e08 100644 --- a/src/proto_015_PtLimaPt/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_015_PtLimaPt/lib_client/michelson_v1_entrypoints.ml @@ -79,19 +79,19 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %a) (type . %a))@]@." - Entrypoint.pp - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %a: %a@]@." - Entrypoint.pp - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %a) (type . %a))@]@." + Entrypoint.pp + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %a: %a@]@." + Entrypoint.pp + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -173,37 +173,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract_hash.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract_hash.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -211,40 +211,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract_hash.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract_hash.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_015_PtLimaPt/lib_client/michelson_v1_macros.ml b/src/proto_015_PtLimaPt/lib_client/michelson_v1_macros.ml index 3b1eaa5028d406200e27b127af40a1e5d81df9ac..600fb5da98f59465ab385c6ae134d16b11539ac8 100644 --- a/src/proto_015_PtLimaPt/lib_client/michelson_v1_macros.ml +++ b/src/proto_015_PtLimaPt/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_015_PtLimaPt/lib_client/mockup.ml b/src/proto_015_PtLimaPt/lib_client/mockup.ml index bcc326b62f450d52e29781cee4add09a0dffa36b..9b981b177e01077c09a5c4a85f84f966d3a97d95 100644 --- a/src/proto_015_PtLimaPt/lib_client/mockup.ml +++ b/src/proto_015_PtLimaPt/lib_client/mockup.ml @@ -414,11 +414,11 @@ let mem_init : Format.fprintf ppf "@[%s: %a@]" name Data_encoding.Json.pp value in (if fields_with_override <> [] then - cctxt#message - "@[mockup client uses protocol overrides:@,%a@]@?" - (Format.pp_print_list field_pp) - fields_with_override - else Lwt.return_unit) + cctxt#message + "@[mockup client uses protocol overrides:@,%a@]@?" + (Format.pp_print_list field_pp) + fields_with_override + else Lwt.return_unit) >>= fun () -> return protocol_overrides | None -> return @@ -438,8 +438,8 @@ let mem_init : let default = parameters.initial_timestamp in let timestamp = Option.value ~default protocol_overrides.timestamp in (if not @@ Time.Protocol.equal default timestamp then - cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp - else Lwt.return_unit) + cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp + else Lwt.return_unit) >>= fun () -> let fitness = Protocol.Alpha_context.( diff --git a/src/proto_015_PtLimaPt/lib_client/protocol_client_context.ml b/src/proto_015_PtLimaPt/lib_client/protocol_client_context.ml index 67c8054c67204896ba6437f708276f68b3fedcea..fdf1b41ff26f0cdf88b4c089fed8315d45df596b 100644 --- a/src/proto_015_PtLimaPt/lib_client/protocol_client_context.ml +++ b/src/proto_015_PtLimaPt/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose RPC_context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific protocol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_015_PtLimaPt/lib_client_commands/client_proto_context_commands.ml b/src/proto_015_PtLimaPt/lib_client_commands/client_proto_context_commands.ml index 8f877583209d291e4e67ac2c200a6a4ba16669b4..f0591ab1a3146def9d66d36e6927b898ac3ba2ad 100644 --- a/src/proto_015_PtLimaPt/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_015_PtLimaPt/lib_client_commands/client_proto_context_commands.ml @@ -605,9 +605,12 @@ let commands_ro () = (Tez.of_mutez_exn w) Operation_result.tez_sym (if - List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not ")) ranks ; pp_close_box ppf ()) else cctxt#message "The proposals have already been cleared." diff --git a/src/proto_015_PtLimaPt/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_015_PtLimaPt/lib_client_commands/client_proto_stresstest_commands.ml index 2c1f6e4b871b8776308c7849016b919651b7ed18..97e7d9dc2f0e10f573551319f57a821bcab3461f 100644 --- a/src/proto_015_PtLimaPt/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_015_PtLimaPt/lib_client_commands/client_proto_stresstest_commands.ml @@ -756,8 +756,8 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = included). Note that the operations injected during the last block \ are ignored because they should not be currently included." (if Int.equal injected_ops_count 0 then "N/A" - else - Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + else + Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) injected_ops_count included_ops_count in diff --git a/src/proto_015_PtLimaPt/lib_client_sapling/client_sapling_commands.ml b/src/proto_015_PtLimaPt/lib_client_sapling/client_sapling_commands.ml index cc8087425debdc69e7e9b5e08adbd57dc7741ef0..9791ee9ce6432cecaa27692d88355ef76c88083c 100644 --- a/src/proto_015_PtLimaPt/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_015_PtLimaPt/lib_client_sapling/client_sapling_commands.ml @@ -388,19 +388,19 @@ let forge_shielded_cmd = let file = Option.value ~default:sapling_transaction_file file in cctxt#message "Writing transaction to %s@." file >>= fun () -> (if use_json_format then - save_json_to_file - (Data_encoding.Json.construct UTXO.transaction_encoding transaction) - file - else - let bytes = - Hex.of_bytes - (Data_encoding.Binary.to_bytes_exn - UTXO.transaction_encoding - transaction) - in - let file = open_out_bin file in - Printf.fprintf file "0x%s" (Hex.show bytes) ; - close_out file) ; + save_json_to_file + (Data_encoding.Json.construct UTXO.transaction_encoding transaction) + file + else + let bytes = + Hex.of_bytes + (Data_encoding.Binary.to_bytes_exn + UTXO.transaction_encoding + transaction) + in + let file = open_out_bin file in + Printf.fprintf file "0x%s" (Hex.show bytes) ; + close_out file) ; return_unit) let submit_shielded_cmd = @@ -456,18 +456,18 @@ let submit_shielded_cmd = >>= fun () -> let open Context in (if use_json_format then - Lwt_utils_unix.Json.read_file filename >>=? fun json -> - return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json - else - Lwt_utils_unix.read_file filename >>= fun hex -> - let hex = - (* remove 0x *) - String.sub hex 2 (String.length hex - 2) - in - return - @@ Data_encoding.Binary.of_bytes_exn - UTXO.transaction_encoding - Hex.(to_bytes_exn (`Hex hex))) + Lwt_utils_unix.Json.read_file filename >>=? fun json -> + return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json + else + Lwt_utils_unix.read_file filename >>= fun hex -> + let hex = + (* remove 0x *) + String.sub hex 2 (String.length hex - 2) + in + return + @@ Data_encoding.Binary.of_bytes_exn + UTXO.transaction_encoding + Hex.(to_bytes_exn (`Hex hex))) >>=? fun transaction -> return (sapling_transaction_as_arg transaction) >>=? fun contract_input -> let chain = cctxt#chain and block = cctxt#block in @@ -720,12 +720,12 @@ let commands () = | None -> cctxt#error "Account %s not found" name | Some account -> (if verbose then - cctxt#answer - "@[Received Sapling transactions for %s@,@[%a@]@]" - name - Context.Account.pp_unspent - account - else Lwt.return_unit) + cctxt#answer + "@[Received Sapling transactions for %s@,@[%a@]@]" + name + Context.Account.pp_unspent + account + else Lwt.return_unit) >>= fun () -> cctxt#answer "Total Sapling funds %a%s" diff --git a/src/proto_016_PtMumbai/lib_client/client_proto_args.ml b/src/proto_016_PtMumbai/lib_client/client_proto_args.ml index 89027b0c65e7cb8d54c7254a64eb5cc53bb23c31..1a9e12977e6636366a4cecca878094520b3f8fbc 100644 --- a/src/proto_016_PtMumbai/lib_client/client_proto_args.ml +++ b/src/proto_016_PtMumbai/lib_client/client_proto_args.ml @@ -1148,14 +1148,15 @@ let fee_parameter_args = | None -> failwith "Bad burn cap")) in Tezos_clic.map_arg - ~f: - (fun _cctxt - ( minimal_fees, - minimal_nanotez_per_byte, - minimal_nanotez_per_gas_unit, - force_low_fee, - fee_cap, - burn_cap ) -> + ~f:(fun + _cctxt + ( minimal_fees, + minimal_nanotez_per_byte, + minimal_nanotez_per_gas_unit, + force_low_fee, + fee_cap, + burn_cap ) + -> return { Injection.minimal_fees; diff --git a/src/proto_016_PtMumbai/lib_client/client_proto_context.ml b/src/proto_016_PtMumbai/lib_client/client_proto_context.ml index 128db6387c33b26e0d5e6ff7a6dbf841327cc216..1f6ce39e72a9adbb234067833f51138c5b1681dd 100644 --- a/src/proto_016_PtMumbai/lib_client/client_proto_context.ml +++ b/src/proto_016_PtMumbai/lib_client/client_proto_context.ml @@ -516,10 +516,10 @@ let check_for_timelock code = let build_origination_operation ?(allow_timelock = false) ?fee ?gas_limit ?storage_limit ~initial_storage ~code ~delegate ~balance () = (if (not allow_timelock) && check_for_timelock code then - failwith - "Origination of contracts containing time lock related instructions is \ - disabled in the client because of a vulnerability." - else return_unit) + failwith + "Origination of contracts containing time lock related instructions is \ + disabled in the client because of a vulnerability." + else return_unit) >>=? fun () -> (* With the change of making implicit accounts delegatable, the following 3 arguments are being defaulted before they can be safely removed. *) @@ -775,8 +775,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Tezos_crypto.Signature.Of_V1.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -841,7 +841,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_016_PtMumbai/lib_client/client_proto_utils.ml b/src/proto_016_PtMumbai/lib_client/client_proto_utils.ml index 5f98e3c9228609825d851deb977c117ec234a4c7..9f67616f2e9da183a2fa3839b0c6bfd750a2e4ce 100644 --- a/src/proto_016_PtMumbai/lib_client/client_proto_utils.ml +++ b/src/proto_016_PtMumbai/lib_client/client_proto_utils.ml @@ -50,7 +50,7 @@ let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit - else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) + else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> Client_keys.check ~watermark:Tezos_crypto.Signature.Generic_operation diff --git a/src/proto_016_PtMumbai/lib_client/injection.ml b/src/proto_016_PtMumbai/lib_client/injection.ml index 8d50a55a6d6007917970546be9d5726212273ab1..55033fd726b5dacf1e4cf12d888742e3bdc8c2df 100644 --- a/src/proto_016_PtMumbai/lib_client/injection.ml +++ b/src/proto_016_PtMumbai/lib_client/injection.ml @@ -244,10 +244,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Tezos_crypto.Signature.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -855,81 +855,84 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun ~first -> function | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>= fun gas -> - match gas with - | Error _ when force -> - (* When doing a simulation, set gas to the maximum possible value - so as to not change the error. When force injecting a failing - operation, set gas to zero to not pay fees for this - operation. *) - let gas = - if simulation then gas_limit_per_patched_op else Gas.Arith.zero - in - return - (Annotated_manager_operation.set_gas_limit (Limit.known gas) op) - | Error _ as res -> Lwt.return res - | Ok gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return - (Annotated_manager_operation.set_gas_limit - (Limit.known Gas.Arith.zero) - op) - else - let safety_guard = - match c.operation with - | Transaction {destination = Implicit _; _} - | Reveal _ | Delegation _ | Set_deposits_limit _ - | Increase_paid_storage _ -> - Gas.Arith.zero - | _ -> safety_guard - in - cctxt#message - "Estimated gas: %a units (will add %a for safety)" - Gas.Arith.pp - gas - Gas.Arith.pp - safety_guard - >>= fun () -> - let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in - let patched_gas = - Gas.Arith.min safe_gas hard_gas_limit_per_operation + Lwt.return (estimated_gas_single result) >>= fun gas -> + match gas with + | Error _ when force -> + (* When doing a simulation, set gas to the maximum possible value + so as to not change the error. When force injecting a failing + operation, set gas to zero to not pay fees for this + operation. *) + let gas = + if simulation then gas_limit_per_patched_op else Gas.Arith.zero in return (Annotated_manager_operation.set_gas_limit - (Limit.known patched_gas) + (Limit.known gas) op) - else return op) + | Error _ as res -> Lwt.return res + | Ok gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return + (Annotated_manager_operation.set_gas_limit + (Limit.known Gas.Arith.zero) + op) + else + let safety_guard = + match c.operation with + | Transaction {destination = Implicit _; _} + | Reveal _ | Delegation _ | Set_deposits_limit _ + | Increase_paid_storage _ -> + Gas.Arith.zero + | _ -> safety_guard + in + cctxt#message + "Estimated gas: %a units (will add %a for safety)" + Gas.Arith.pp + gas + Gas.Arith.pp + safety_guard + >>= fun () -> + let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in + let patched_gas = + Gas.Arith.min safe_gas hard_gas_limit_per_operation + in + return + (Annotated_manager_operation.set_gas_limit + (Limit.known patched_gas) + op) + else return op) >>=? fun op -> (if user_storage_limit_needs_patching c.storage_limit then - Lwt.return - (estimated_storage_single - ~tx_rollup_origination_size:(Z.of_int tx_rollup_origination_size) - ~origination_size:(Z.of_int origination_size) - ~force - result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return - (Annotated_manager_operation.set_storage_limit - (Limit.known Z.zero) - op) - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - let storage_limit = - Z.min - (Z.add storage (Z.of_int 20)) - hard_storage_limit_per_operation - in - return - (Annotated_manager_operation.set_storage_limit - (Limit.known storage_limit) - op) - else return op) + Lwt.return + (estimated_storage_single + ~tx_rollup_origination_size: + (Z.of_int tx_rollup_origination_size) + ~origination_size:(Z.of_int origination_size) + ~force + result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return + (Annotated_manager_operation.set_storage_limit + (Limit.known Z.zero) + op) + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + let storage_limit = + Z.min + (Z.add storage (Z.of_int 20)) + hard_storage_limit_per_operation + in + return + (Annotated_manager_operation.set_storage_limit + (Limit.known storage_limit) + op) + else return op) >>=? fun op -> if Limit.is_unknown c.fee then (* Setting a dummy fee is required for converting to manager op *) @@ -1036,17 +1039,17 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?branch ?src_sk ?verbose_signing ?fee_parameter (contents : kind contents_list) = (if simulation then - simulate cctxt ~chain ~block ?successor_level ?branch contents - else - preapply - cctxt - ~chain - ~block - ?fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + simulate cctxt ~chain ~block ?successor_level ?branch contents + else + preapply + cctxt + ~chain + ~block + ?fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit @@ -1433,8 +1436,8 @@ let inject_manager_operation cctxt ~chain ~block ?successor_level ?branch match key with | None when not (has_reveal operations) -> ( (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then - reveal_error cctxt - else return_unit) + reveal_error cctxt + else return_unit) >>=? fun () -> let reveal = prepare_manager_operation diff --git a/src/proto_016_PtMumbai/lib_client/michelson_v1_entrypoints.ml b/src/proto_016_PtMumbai/lib_client/michelson_v1_entrypoints.ml index aeb9596dea05de7ef714e973047796133f2d86b3..8039540bfdcee72f2376da864b24cb5f3e0b1e08 100644 --- a/src/proto_016_PtMumbai/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_016_PtMumbai/lib_client/michelson_v1_entrypoints.ml @@ -79,19 +79,19 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %a) (type . %a))@]@." - Entrypoint.pp - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %a: %a@]@." - Entrypoint.pp - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %a) (type . %a))@]@." + Entrypoint.pp + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %a: %a@]@." + Entrypoint.pp + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -173,37 +173,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract_hash.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract_hash.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -211,40 +211,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract_hash.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract_hash.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_016_PtMumbai/lib_client/michelson_v1_macros.ml b/src/proto_016_PtMumbai/lib_client/michelson_v1_macros.ml index 3b1eaa5028d406200e27b127af40a1e5d81df9ac..600fb5da98f59465ab385c6ae134d16b11539ac8 100644 --- a/src/proto_016_PtMumbai/lib_client/michelson_v1_macros.ml +++ b/src/proto_016_PtMumbai/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_016_PtMumbai/lib_client/mockup.ml b/src/proto_016_PtMumbai/lib_client/mockup.ml index e82f935fb341c0c324d5c294030350d8a60e1225..68fe34f0dbff21fa93cdfae1f8a0b3f4b220b9a9 100644 --- a/src/proto_016_PtMumbai/lib_client/mockup.ml +++ b/src/proto_016_PtMumbai/lib_client/mockup.ml @@ -410,11 +410,11 @@ let mem_init : Format.fprintf ppf "@[%s: %a@]" name Data_encoding.Json.pp value in (if fields_with_override <> [] then - cctxt#message - "@[mockup client uses protocol overrides:@,%a@]@?" - (Format.pp_print_list field_pp) - fields_with_override - else Lwt.return_unit) + cctxt#message + "@[mockup client uses protocol overrides:@,%a@]@?" + (Format.pp_print_list field_pp) + fields_with_override + else Lwt.return_unit) >>= fun () -> return protocol_overrides | None -> return @@ -434,8 +434,8 @@ let mem_init : let default = parameters.initial_timestamp in let timestamp = Option.value ~default protocol_overrides.timestamp in (if not @@ Time.Protocol.equal default timestamp then - cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp - else Lwt.return_unit) + cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp + else Lwt.return_unit) >>= fun () -> let fitness = Protocol.Alpha_context.( diff --git a/src/proto_016_PtMumbai/lib_client/protocol_client_context.ml b/src/proto_016_PtMumbai/lib_client/protocol_client_context.ml index a318eacc85ba92ba60c1a4bb1be02bb6a59e0267..3c9fbd954b40f05021e55eb6199e32b28930c777 100644 --- a/src/proto_016_PtMumbai/lib_client/protocol_client_context.ml +++ b/src/proto_016_PtMumbai/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific protocol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_016_PtMumbai/lib_client_commands/client_proto_context_commands.ml b/src/proto_016_PtMumbai/lib_client_commands/client_proto_context_commands.ml index e284b16f04113000ee9da3f24d7c03fabb37068f..71531fb13fb47122f4211dd0089180767c2a03fd 100644 --- a/src/proto_016_PtMumbai/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_016_PtMumbai/lib_client_commands/client_proto_context_commands.ml @@ -692,9 +692,12 @@ let commands_ro () = (Tez.of_mutez_exn w) Operation_result.tez_sym (if - List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not ")) ranks ; pp_close_box ppf ()) else cctxt#message "The proposals have already been cleared." diff --git a/src/proto_016_PtMumbai/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_016_PtMumbai/lib_client_commands/client_proto_stresstest_commands.ml index 62dcac500b99a338659e8267e1c7e516e6b39b0b..8343ae090f2af5e10a1fa0c256d0d8f2258d3ef8 100644 --- a/src/proto_016_PtMumbai/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_016_PtMumbai/lib_client_commands/client_proto_stresstest_commands.ml @@ -756,8 +756,8 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = included). Note that the operations injected during the last block \ are ignored because they should not be currently included." (if Int.equal injected_ops_count 0 then "N/A" - else - Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + else + Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) injected_ops_count included_ops_count in diff --git a/src/proto_016_PtMumbai/lib_client_sapling/client_sapling_commands.ml b/src/proto_016_PtMumbai/lib_client_sapling/client_sapling_commands.ml index 2e6d27f898756f30b711ad3d0024b93bf5966deb..40b7267112ae9ce89ea774c642fc8df3ce6bac52 100644 --- a/src/proto_016_PtMumbai/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_016_PtMumbai/lib_client_sapling/client_sapling_commands.ml @@ -386,19 +386,19 @@ let forge_shielded_cmd = let file = Option.value ~default:sapling_transaction_file file in cctxt#message "Writing transaction to %s@." file >>= fun () -> (if use_json_format then - save_json_to_file - (Data_encoding.Json.construct UTXO.transaction_encoding transaction) - file - else - let bytes = - Hex.of_bytes - (Data_encoding.Binary.to_bytes_exn - UTXO.transaction_encoding - transaction) - in - let file = open_out_bin file in - Printf.fprintf file "0x%s" (Hex.show bytes) ; - close_out file) ; + save_json_to_file + (Data_encoding.Json.construct UTXO.transaction_encoding transaction) + file + else + let bytes = + Hex.of_bytes + (Data_encoding.Binary.to_bytes_exn + UTXO.transaction_encoding + transaction) + in + let file = open_out_bin file in + Printf.fprintf file "0x%s" (Hex.show bytes) ; + close_out file) ; return_unit) let submit_shielded_cmd = @@ -454,18 +454,18 @@ let submit_shielded_cmd = >>= fun () -> let open Context in (if use_json_format then - Lwt_utils_unix.Json.read_file filename >>=? fun json -> - return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json - else - Lwt_utils_unix.read_file filename >>= fun hex -> - let hex = - (* remove 0x *) - String.sub hex 2 (String.length hex - 2) - in - return - @@ Data_encoding.Binary.of_bytes_exn - UTXO.transaction_encoding - Hex.(to_bytes_exn (`Hex hex))) + Lwt_utils_unix.Json.read_file filename >>=? fun json -> + return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json + else + Lwt_utils_unix.read_file filename >>= fun hex -> + let hex = + (* remove 0x *) + String.sub hex 2 (String.length hex - 2) + in + return + @@ Data_encoding.Binary.of_bytes_exn + UTXO.transaction_encoding + Hex.(to_bytes_exn (`Hex hex))) >>=? fun transaction -> return (sapling_transaction_as_arg transaction) >>=? fun contract_input -> let chain = cctxt#chain and block = cctxt#block in @@ -720,12 +720,12 @@ let commands () = | None -> cctxt#error "Account %s not found" name | Some account -> (if verbose then - cctxt#answer - "@[Received Sapling transactions for %s@,@[%a@]@]" - name - Context.Account.pp_unspent - account - else Lwt.return_unit) + cctxt#answer + "@[Received Sapling transactions for %s@,@[%a@]@]" + name + Context.Account.pp_unspent + account + else Lwt.return_unit) >>= fun () -> cctxt#answer "Total Sapling funds %a%s" diff --git a/src/proto_016_PtMumbai/lib_plugin/script_interpreter_logging.ml b/src/proto_016_PtMumbai/lib_plugin/script_interpreter_logging.ml index ac496687e854d651fc8bf12bcbac96b30edaae61..1bf023babc3ebefeb36fe913eba5e29581ba5f92 100644 --- a/src/proto_016_PtMumbai/lib_plugin/script_interpreter_logging.ml +++ b/src/proto_016_PtMumbai/lib_plugin/script_interpreter_logging.ml @@ -2197,7 +2197,7 @@ module Logger (Base : Logger_base) = struct accu stack | _ -> (step [@ocaml.tailcall]) g gas k ks accu stack - [@@inline] + [@@inline] let klog : type a s r f. @@ -2307,7 +2307,7 @@ module Logger (Base : Logger_base) = struct (* This case should never happen. *) (next [@ocaml.tailcall]) g gas k accu stack | KNil as k -> (next [@ocaml.tailcall]) g gas k accu stack - [@@inline] + [@@inline] end let make (module Base : Logger_base) = diff --git a/src/proto_016_PtMumbai/lib_sc_rollup/game_helpers.ml b/src/proto_016_PtMumbai/lib_sc_rollup/game_helpers.ml index b3ddddc305e12c4da450b9f45af89f5b29257023..80237a59d1c56be495ecbec0511c418923cbc1ac 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup/game_helpers.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup/game_helpers.ml @@ -104,7 +104,7 @@ module Wasm = struct (* If [is_stop_chunk_aligned] is false, we allocate one sections for the surplus. *) (if is_stop_chunk_aligned then default_number_of_sections - else default_number_of_sections - 1)) + else default_number_of_sections - 1)) max_number_of_sections in diff --git a/src/proto_017_PtNairob/lib_benchmark/autocomp.ml b/src/proto_017_PtNairob/lib_benchmark/autocomp.ml index 0b3f0d8b62debbb1bc48a95a505df191e45ccaf4..18c9685b4c6a71b3c78570b57b2f9ca70073c060 100644 --- a/src/proto_017_PtNairob/lib_benchmark/autocomp.ml +++ b/src/proto_017_PtNairob/lib_benchmark/autocomp.ml @@ -143,11 +143,11 @@ module SM = struct fun m f rng_state s -> let x, s = m rng_state s in f x rng_state s - [@@inline] + [@@inline] let sample : 'a sampler -> 'a Inference.M.t sampler = fun x rng_state st -> (x rng_state, st) - [@@inline] + [@@inline] let deterministic : 'a Inference.M.t -> 'a t = fun x _rng_state -> x diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.ml index d8c47801dca357ac1905cd72a3dd51d9c2cd7ad1..65ec8932a5e671bf1c46a9bde101e5d7b45f2a43 100644 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.ml +++ b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.ml @@ -249,7 +249,7 @@ module M = struct let ( >>= ) m f s = let x, s = m s in f x s - [@@inline] + [@@inline] let return x s = (x, s) @@ -259,25 +259,25 @@ module M = struct fun computation state -> let res, uf = computation state.uf in (res, {state with uf}) - [@@inline] + [@@inline] let repr_lift : 'a Repr_sm.t -> 'a t = fun computation state -> let res, repr = computation state.repr in (res, {state with repr}) - [@@inline] + [@@inline] let annot_instr_lift : 'a Annot_instr_sm.t -> 'a t = fun computation state -> let res, annot_instr = computation state.annot_instr in (res, {state with annot_instr}) - [@@inline] + [@@inline] let annot_data_lift : 'a Annot_data_sm.t -> 'a t = fun computation state -> let res, annot_data = computation state.annot_data in (res, {state with annot_data}) - [@@inline] + [@@inline] let set_repr k v = repr_lift (Repr_sm.set k v) [@@inline] @@ -285,7 +285,7 @@ module M = struct repr_lift (Repr_sm.get k) >>= function | None -> Stdlib.failwith "get_repr_exn" | Some res -> return res - [@@inline] + [@@inline] let set_instr_annot k v = annot_instr_lift (Annot_instr_sm.set k v) [@@inline] @@ -400,8 +400,8 @@ and unify_base (x : Type.Base.t) (y : Type.Base.t) : unit M.t = let open M in let unify_single_var v x = (if List.mem v (Type.Base.vars x) then - raise (Ill_typed_script Cyclic_base_type) - else return ()) + raise (Ill_typed_script Cyclic_base_type) + else return ()) >>= fun () -> M.uf_lift (UF.find v) >>= fun root -> get_repr_exn root >>= fun repr -> diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml index 4b702dd05667a8ab593401e650ca5f4a203d962d..29a59f6fc4bfcec068d382e67c16cdd540bf4a50 100644 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml +++ b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml @@ -142,33 +142,33 @@ module Test3 = struct try ignore ((let open Inference in - let open M in - M.uf_lift Uf.UF.show >>= fun uf_state -> - Inference.M.repr_lift (fun s -> (Inference.Repr_store.to_string s, s)) - >>= fun repr_state -> - Printf.printf "uf_state:\n%s\n" uf_state ; - Printf.printf "repr_state:\n%s\n" repr_state ; - let path = - Path.(at_index 2 (at_index 0 (at_index 0 (at_index 3 root)))) - in - let subterm = Rewriter.get_subterm ~term:program ~path in - Format.printf - "subterm at path %s:\n%a\n" - (Path.to_string path) - Mikhailsky.pp - subterm ; - Inference.M.annot_instr_lift (Inference.Annot_instr_sm.get path) - >>= fun typ -> - (match typ with - | None -> assert false - | Some {bef; aft} -> - Inference.instantiate bef >>= fun bef -> - Inference.instantiate aft >>= fun aft -> - Format.printf "Type of subterm:\n" ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - return ()) - >>= fun () -> return ()) + let open M in + M.uf_lift Uf.UF.show >>= fun uf_state -> + Inference.M.repr_lift (fun s -> (Inference.Repr_store.to_string s, s)) + >>= fun repr_state -> + Printf.printf "uf_state:\n%s\n" uf_state ; + Printf.printf "repr_state:\n%s\n" repr_state ; + let path = + Path.(at_index 2 (at_index 0 (at_index 0 (at_index 3 root)))) + in + let subterm = Rewriter.get_subterm ~term:program ~path in + Format.printf + "subterm at path %s:\n%a\n" + (Path.to_string path) + Mikhailsky.pp + subterm ; + Inference.M.annot_instr_lift (Inference.Annot_instr_sm.get path) + >>= fun typ -> + (match typ with + | None -> assert false + | Some {bef; aft} -> + Inference.instantiate bef >>= fun bef -> + Inference.instantiate aft >>= fun aft -> + Format.printf "Type of subterm:\n" ; + Format.printf "bef: %a@." Type.Stack.pp bef ; + Format.printf "aft: %a@." Type.Stack.pp aft ; + return ()) + >>= fun () -> return ()) state) with Inference.Ill_typed_script error -> let s = Mikhailsky.to_string program in diff --git a/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.ml b/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.ml index a5b66c0f53afcd95e260889a9ef43d0b66504b78..0515479b29f642d6cecb4403f85a3a54a2c6de2a 100644 --- a/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.ml +++ b/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.ml @@ -211,7 +211,8 @@ end module Make_code_sampler (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) (X : sig + (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) + (X : sig val rng_state : Random.State.t val target_size : int @@ -270,7 +271,8 @@ end module Make_data_sampler (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) (X : sig + (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) + (X : sig val rng_state : Random.State.t val target_size : int diff --git a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.ml b/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.ml index 0bad66b9794432d338d5ab0d7dd7b2a52f2373cd..61d14942d216c3b2aad3021a9aaab7517692360b 100644 --- a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.ml +++ b/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.ml @@ -258,10 +258,11 @@ exception SamplingError of string let fail_sampling error = raise (SamplingError error) -module Make (P : sig - val parameters : parameters -end) -(Crypto_samplers : Crypto_samplers.Finite_key_pool_S) : S = struct +module Make + (P : sig + val parameters : parameters + end) + (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) : S = struct module Michelson_base = Michelson_samplers_base.Make (struct let parameters = P.parameters.base_parameters end) diff --git a/src/proto_017_PtNairob/lib_benchmark/sampling_helpers.ml b/src/proto_017_PtNairob/lib_benchmark/sampling_helpers.ml index 8b36fc09e0bf983a58e280dd2eed654cbd151b67..b371a6aa1e1e37a7a35c65936ac8d2f212358ba7 100644 --- a/src/proto_017_PtNairob/lib_benchmark/sampling_helpers.ml +++ b/src/proto_017_PtNairob/lib_benchmark/sampling_helpers.ml @@ -33,7 +33,7 @@ module M = struct fun sampler f rng_state -> let x = sampler rng_state in f x rng_state - [@@inline] + [@@inline] let bind = ( let* ) diff --git a/src/proto_017_PtNairob/lib_client/client_proto_args.ml b/src/proto_017_PtNairob/lib_client/client_proto_args.ml index aa9a53e1d8c6496fa00d3352967812be94f18cff..0f469a4f033d1c4038e3fcde91933701c2284067 100644 --- a/src/proto_017_PtNairob/lib_client/client_proto_args.ml +++ b/src/proto_017_PtNairob/lib_client/client_proto_args.ml @@ -897,14 +897,15 @@ let fee_parameter_args = | None -> cctxt#error "Bad burn cap")) in Tezos_clic.map_arg - ~f: - (fun _cctxt - ( minimal_fees, - minimal_nanotez_per_byte, - minimal_nanotez_per_gas_unit, - force_low_fee, - fee_cap, - burn_cap ) -> + ~f:(fun + _cctxt + ( minimal_fees, + minimal_nanotez_per_byte, + minimal_nanotez_per_gas_unit, + force_low_fee, + fee_cap, + burn_cap ) + -> return { Injection.minimal_fees; diff --git a/src/proto_017_PtNairob/lib_client/client_proto_context.ml b/src/proto_017_PtNairob/lib_client/client_proto_context.ml index 973a12ad2a531953f802c1d31cd718f964432d63..3ce88c84c3fdbfe972060fe89efec440a98005f8 100644 --- a/src/proto_017_PtNairob/lib_client/client_proto_context.ml +++ b/src/proto_017_PtNairob/lib_client/client_proto_context.ml @@ -516,10 +516,10 @@ let check_for_timelock code = let build_origination_operation ?(allow_timelock = false) ?fee ?gas_limit ?storage_limit ~initial_storage ~code ~delegate ~balance () = (if (not allow_timelock) && check_for_timelock code then - failwith - "Origination of contracts containing time lock related instructions is \ - disabled in the client because of a vulnerability." - else return_unit) + failwith + "Origination of contracts containing time lock related instructions is \ + disabled in the client because of a vulnerability." + else return_unit) >>=? fun () -> (* With the change of making implicit accounts delegatable, the following 3 arguments are being defaulted before they can be safely removed. *) @@ -773,8 +773,8 @@ let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run let sk = Signature.Of_V1.secret_key sk in Tezos_signer_backends.Unencrypted.make_pk pk >>?= fun pk_uri -> (if encrypted then - Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk - else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) + Tezos_signer_backends.Encrypted.prompt_twice_and_encrypt cctxt sk + else Tezos_signer_backends.Unencrypted.make_sk sk >>?= return) >>=? fun sk_uri -> Client_keys.register_key cctxt ?force (pkh, pk_uri, sk_uri) name >>=? fun () -> @@ -839,7 +839,7 @@ let get_ballots_info (cctxt : #full) ~chain ~block = let get_period_info ?(successor = false) (cctxt : #full) ~chain ~block = let cb = (chain, block) in (if successor then Alpha_services.Voting.successor_period - else Alpha_services.Voting.current_period) + else Alpha_services.Voting.current_period) cctxt cb >>=? fun voting_period -> diff --git a/src/proto_017_PtNairob/lib_client/client_proto_utils.ml b/src/proto_017_PtNairob/lib_client/client_proto_utils.ml index be6844cc5cf7a8fbbe36d7c56415db8784587f10..78f9efe737129b9c623347b0a6f2d27da12e50f6 100644 --- a/src/proto_017_PtNairob/lib_client/client_proto_utils.ml +++ b/src/proto_017_PtNairob/lib_client/client_proto_utils.ml @@ -46,7 +46,7 @@ let check_message (cctxt : #full) ~block ~key_locator ~quiet ~message ~signature = let json, bytes = to_json_and_bytes block message in (if quiet then Lwt.return_unit - else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) + else cctxt#message "checked content: @[%a@]" Data_encoding.Json.pp json) >>= fun () -> Client_keys.check ~watermark:Signature.Generic_operation diff --git a/src/proto_017_PtNairob/lib_client/injection.ml b/src/proto_017_PtNairob/lib_client/injection.ml index dc3014ab495e3e922c0d56a654bc0f02bca64930..82753f08d7cd8b9ed0b1d98a5943543754cdb078 100644 --- a/src/proto_017_PtNairob/lib_client/injection.ml +++ b/src/proto_017_PtNairob/lib_client/injection.ml @@ -243,10 +243,10 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block | _ -> Signature.Generic_operation in (if verbose_signing then - cctxt#message - "Pre-signature information (verbose signing):@.%t%!" - (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) - else Lwt.return_unit) + cctxt#message + "Pre-signature information (verbose signing):@.%t%!" + (print_for_verbose_signing ~watermark ~bytes ~branch ~contents) + else Lwt.return_unit) >>= fun () -> Client_keys.sign cctxt ~watermark src_sk bytes >>=? fun signature -> return_some signature) @@ -819,80 +819,82 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun ~first -> function | (Manager_info c as op), (Manager_operation_result _ as result) -> (if user_gas_limit_needs_patching c.gas_limit then - Lwt.return (estimated_gas_single result) >>= fun gas -> - match gas with - | Error _ when force -> - (* When doing a simulation, set gas to the maximum possible value - so as to not change the error. When force injecting a failing - operation, set gas to zero to not pay fees for this - operation. *) - let gas = - if simulation then gas_limit_per_patched_op else Gas.Arith.zero - in - return - (Annotated_manager_operation.set_gas_limit (Limit.known gas) op) - | Error _ as res -> Lwt.return res - | Ok gas -> - if Gas.Arith.(gas = zero) then - cctxt#message "Estimated gas: none" >>= fun () -> - return - (Annotated_manager_operation.set_gas_limit - (Limit.known Gas.Arith.zero) - op) - else - let safety_guard = - match c.operation with - | Transaction {destination = Implicit _; _} - | Reveal _ | Delegation _ | Set_deposits_limit _ - | Increase_paid_storage _ -> - Gas.Arith.zero - | _ -> safety_guard - in - cctxt#message - "Estimated gas: %a units (will add %a for safety)" - Gas.Arith.pp - gas - Gas.Arith.pp - safety_guard - >>= fun () -> - let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in - let patched_gas = - Gas.Arith.min safe_gas hard_gas_limit_per_operation + Lwt.return (estimated_gas_single result) >>= fun gas -> + match gas with + | Error _ when force -> + (* When doing a simulation, set gas to the maximum possible value + so as to not change the error. When force injecting a failing + operation, set gas to zero to not pay fees for this + operation. *) + let gas = + if simulation then gas_limit_per_patched_op else Gas.Arith.zero in return (Annotated_manager_operation.set_gas_limit - (Limit.known patched_gas) + (Limit.known gas) op) - else return op) + | Error _ as res -> Lwt.return res + | Ok gas -> + if Gas.Arith.(gas = zero) then + cctxt#message "Estimated gas: none" >>= fun () -> + return + (Annotated_manager_operation.set_gas_limit + (Limit.known Gas.Arith.zero) + op) + else + let safety_guard = + match c.operation with + | Transaction {destination = Implicit _; _} + | Reveal _ | Delegation _ | Set_deposits_limit _ + | Increase_paid_storage _ -> + Gas.Arith.zero + | _ -> safety_guard + in + cctxt#message + "Estimated gas: %a units (will add %a for safety)" + Gas.Arith.pp + gas + Gas.Arith.pp + safety_guard + >>= fun () -> + let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in + let patched_gas = + Gas.Arith.min safe_gas hard_gas_limit_per_operation + in + return + (Annotated_manager_operation.set_gas_limit + (Limit.known patched_gas) + op) + else return op) >>=? fun op -> (if user_storage_limit_needs_patching c.storage_limit then - Lwt.return - (estimated_storage_single - ~origination_size:(Z.of_int origination_size) - ~force - result) - >>=? fun storage -> - if Z.equal storage Z.zero then - cctxt#message "Estimated storage: no bytes added" >>= fun () -> - return - (Annotated_manager_operation.set_storage_limit - (Limit.known Z.zero) - op) - else - cctxt#message - "Estimated storage: %s bytes added (will add 20 for safety)" - (Z.to_string storage) - >>= fun () -> - let storage_limit = - Z.min - (Z.add storage (Z.of_int 20)) - hard_storage_limit_per_operation - in - return - (Annotated_manager_operation.set_storage_limit - (Limit.known storage_limit) - op) - else return op) + Lwt.return + (estimated_storage_single + ~origination_size:(Z.of_int origination_size) + ~force + result) + >>=? fun storage -> + if Z.equal storage Z.zero then + cctxt#message "Estimated storage: no bytes added" >>= fun () -> + return + (Annotated_manager_operation.set_storage_limit + (Limit.known Z.zero) + op) + else + cctxt#message + "Estimated storage: %s bytes added (will add 20 for safety)" + (Z.to_string storage) + >>= fun () -> + let storage_limit = + Z.min + (Z.add storage (Z.of_int 20)) + hard_storage_limit_per_operation + in + return + (Annotated_manager_operation.set_storage_limit + (Limit.known storage_limit) + op) + else return op) >>=? fun op -> if Limit.is_unknown c.fee then (* Setting a dummy fee is required for converting to manager op *) @@ -998,17 +1000,17 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations ?branch ?src_sk ?verbose_signing ?fee_parameter (contents : kind contents_list) = (if simulation then - simulate cctxt ~chain ~block ?successor_level ?branch contents - else - preapply - cctxt - ~chain - ~block - ?fee_parameter - ?verbose_signing - ?branch - ?src_sk - contents) + simulate cctxt ~chain ~block ?successor_level ?branch contents + else + preapply + cctxt + ~chain + ~block + ?fee_parameter + ?verbose_signing + ?branch + ?src_sk + contents) >>=? fun (_oph, op, result) -> (match detect_script_failure result with | Ok () -> return_unit @@ -1391,8 +1393,8 @@ let inject_manager_operation cctxt ~chain ~block ?successor_level ?branch match key with | None when not (has_reveal operations) -> ( (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then - reveal_error cctxt - else return_unit) + reveal_error cctxt + else return_unit) >>=? fun () -> let reveal = prepare_manager_operation diff --git a/src/proto_017_PtNairob/lib_client/michelson_v1_entrypoints.ml b/src/proto_017_PtNairob/lib_client/michelson_v1_entrypoints.ml index aeb9596dea05de7ef714e973047796133f2d86b3..8039540bfdcee72f2376da864b24cb5f3e0b1e08 100644 --- a/src/proto_017_PtNairob/lib_client/michelson_v1_entrypoints.ml +++ b/src/proto_017_PtNairob/lib_client/michelson_v1_entrypoints.ml @@ -79,19 +79,19 @@ let print_entrypoint_type (cctxt : #Client_context.printer) = function | Ok (Some ty) -> (if emacs then - cctxt#message - "@[((entrypoint . %a) (type . %a))@]@." - Entrypoint.pp - entrypoint - Michelson_v1_emacs.print_expr - ty - else - cctxt#message - "@[Entrypoint %a: %a@]@." - Entrypoint.pp - entrypoint - Michelson_v1_printer.print_expr - ty) + cctxt#message + "@[((entrypoint . %a) (type . %a))@]@." + Entrypoint.pp + entrypoint + Michelson_v1_emacs.print_expr + ty + else + cctxt#message + "@[Entrypoint %a: %a@]@." + Entrypoint.pp + entrypoint + Michelson_v1_printer.print_expr + ty) >>= fun () -> return_unit | Ok None -> cctxt#message @@ -173,37 +173,37 @@ let print_entrypoints_list (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok entrypoint_list -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" - entrypoint - Michelson_v1_emacs.print_expr - ty)) - entrypoint_list - else - cctxt#message - "@[Entrypoints%a%a: @,%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for contract %a" Contract_hash.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " for script %s")) - script_name - (Format.pp_print_list - ~pp_sep:Format.pp_print_cut - (fun ppf (entrypoint, ty) -> - Format.fprintf - ppf - "@[%s: @[%a@]@]" - entrypoint - Michelson_v1_printer.print_expr - ty)) - entrypoint_list) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[( ( entrypoint . %s ) ( type . @[%a@]))@]" + entrypoint + Michelson_v1_emacs.print_expr + ty)) + entrypoint_list + else + cctxt#message + "@[Entrypoints%a%a: @,%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for contract %a" Contract_hash.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " for script %s")) + script_name + (Format.pp_print_list + ~pp_sep:Format.pp_print_cut + (fun ppf (entrypoint, ty) -> + Format.fprintf + ppf + "@[%s: @[%a@]@]" + entrypoint + Michelson_v1_printer.print_expr + ty)) + entrypoint_list) >>= fun () -> return_unit | Error errs -> on_errors errs @@ -211,40 +211,40 @@ let print_unreachables (cctxt : #Client_context.printer) ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function | Ok unreachable -> (if emacs then - cctxt#message - "@[(@[%a@])@." - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> - Format.fprintf - ppf - "@[( unreachable-path . %a )@]" - (Format.pp_print_list - ~pp_sep:Format.pp_print_space - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)) - path)) - unreachable - else - match unreachable with - | [] -> cctxt#message "@[None.@]@." - | _ -> - cctxt#message - "@[Unreachable paths in the argument%a%a: @[%a@]@." - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of contract %a" Contract_hash.pp)) - contract - (Format.pp_print_option (fun ppf -> - Format.fprintf ppf " of script %s")) - script_name - (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> - Format.fprintf - ppf - "@[ %a @]" - (Format.pp_print_list - ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") - (fun ppf prim -> - Format.pp_print_string ppf - @@ Michelson_v1_primitives.string_of_prim prim)))) - unreachable) + cctxt#message + "@[(@[%a@])@." + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path -> + Format.fprintf + ppf + "@[( unreachable-path . %a )@]" + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)) + path)) + unreachable + else + match unreachable with + | [] -> cctxt#message "@[None.@]@." + | _ -> + cctxt#message + "@[Unreachable paths in the argument%a%a: @[%a@]@." + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of contract %a" Contract_hash.pp)) + contract + (Format.pp_print_option (fun ppf -> + Format.fprintf ppf " of script %s")) + script_name + (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf -> + Format.fprintf + ppf + "@[ %a @]" + (Format.pp_print_list + ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/") + (fun ppf prim -> + Format.pp_print_string ppf + @@ Michelson_v1_primitives.string_of_prim prim)))) + unreachable) >>= fun () -> return_unit | Error errs -> on_errors errs diff --git a/src/proto_017_PtNairob/lib_client/michelson_v1_macros.ml b/src/proto_017_PtNairob/lib_client/michelson_v1_macros.ml index 3b1eaa5028d406200e27b127af40a1e5d81df9ac..600fb5da98f59465ab385c6ae134d16b11539ac8 100644 --- a/src/proto_017_PtNairob/lib_client/michelson_v1_macros.ml +++ b/src/proto_017_PtNairob/lib_client/michelson_v1_macros.ml @@ -588,7 +588,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> error (Invalid_arity (str, List.length args, 2)) @@ -596,7 +596,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> error (Unexpected_macro_annotation str) diff --git a/src/proto_017_PtNairob/lib_client/mockup.ml b/src/proto_017_PtNairob/lib_client/mockup.ml index 31f3685e652c0707104a32fa5e26fd89821325f9..9f7fe4af6034edff65b36445bd5c77cf301e4621 100644 --- a/src/proto_017_PtNairob/lib_client/mockup.ml +++ b/src/proto_017_PtNairob/lib_client/mockup.ml @@ -419,11 +419,11 @@ let mem_init : Format.fprintf ppf "@[%s: %a@]" name Data_encoding.Json.pp value in (if fields_with_override <> [] then - cctxt#message - "@[mockup client uses protocol overrides:@,%a@]@?" - (Format.pp_print_list field_pp) - fields_with_override - else Lwt.return_unit) + cctxt#message + "@[mockup client uses protocol overrides:@,%a@]@?" + (Format.pp_print_list field_pp) + fields_with_override + else Lwt.return_unit) >>= fun () -> return protocol_overrides | None -> return @@ -443,8 +443,8 @@ let mem_init : let default = parameters.initial_timestamp in let timestamp = Option.value ~default protocol_overrides.timestamp in (if not @@ Time.Protocol.equal default timestamp then - cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp - else Lwt.return_unit) + cctxt#message "@[initial_timestamp: %a@]" Time.Protocol.pp_hum timestamp + else Lwt.return_unit) >>= fun () -> let fitness = Protocol.Alpha_context.( diff --git a/src/proto_017_PtNairob/lib_client/protocol_client_context.ml b/src/proto_017_PtNairob/lib_client/protocol_client_context.ml index 28017d8476271384bae54f85fd645c1d3c5a0ae0..d3aa9ffd9d7dfb47bd8e35edabb1cf6803834172 100644 --- a/src/proto_017_PtNairob/lib_client/protocol_client_context.ml +++ b/src/proto_017_PtNairob/lib_client/protocol_client_context.ml @@ -28,14 +28,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -81,24 +79,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific protocol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_017_PtNairob/lib_client_commands/client_proto_context_commands.ml b/src/proto_017_PtNairob/lib_client_commands/client_proto_context_commands.ml index 7e36eaa3890872ad48132421f2d0a86386368990..3ab5b360dfe09ec8829c09d29f5d31c760480b27 100644 --- a/src/proto_017_PtNairob/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_017_PtNairob/lib_client_commands/client_proto_context_commands.ml @@ -678,9 +678,12 @@ let commands_ro () = (Tez.of_mutez_exn w) Operation_result.tez_sym (if - List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not ")) ranks ; pp_close_box ppf ()) else cctxt#message "The proposals have already been cleared." @@ -2205,8 +2208,8 @@ let commands_rw () = error "There %s: %a." (if Compare.List_length_with.(dups = 1) then - "is a duplicate proposal" - else "are duplicate proposals") + "is a duplicate proposal" + else "are duplicate proposals") Format.( pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf ", ") @@ -2233,7 +2236,7 @@ let commands_rw () = cctxt#message "There %s with the submission:%t" (if Compare.List_length_with.(!errors = 1) then "is an issue" - else "are issues") + else "are issues") Format.( fun ppf -> pp_print_cut ppf () ; diff --git a/src/proto_017_PtNairob/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_017_PtNairob/lib_client_commands/client_proto_stresstest_commands.ml index d5e33b91cb58993252b1d29daac2963d84b600ce..133937ab21f44608dd827616c542058f867ad738 100644 --- a/src/proto_017_PtNairob/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_017_PtNairob/lib_client_commands/client_proto_stresstest_commands.ml @@ -743,8 +743,8 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = included). Note that the operations injected during the last block \ are ignored because they should not be currently included." (if Int.equal injected_ops_count 0 then "N/A" - else - Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + else + Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) injected_ops_count included_ops_count in diff --git a/src/proto_017_PtNairob/lib_client_sapling/client_sapling_commands.ml b/src/proto_017_PtNairob/lib_client_sapling/client_sapling_commands.ml index 2048f65d59ea9f146b5c5df543b423a04ae19b46..b40b3d9576be5527c2654dbb7f0c35f586167aa7 100644 --- a/src/proto_017_PtNairob/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_017_PtNairob/lib_client_sapling/client_sapling_commands.ml @@ -384,19 +384,19 @@ let forge_shielded_cmd = let file = Option.value ~default:sapling_transaction_file file in cctxt#message "Writing transaction to %s@." file >>= fun () -> (if use_json_format then - save_json_to_file - (Data_encoding.Json.construct UTXO.transaction_encoding transaction) - file - else - let bytes = - Hex.of_bytes - (Data_encoding.Binary.to_bytes_exn - UTXO.transaction_encoding - transaction) - in - let file = open_out_bin file in - Printf.fprintf file "0x%s" (Hex.show bytes) ; - close_out file) ; + save_json_to_file + (Data_encoding.Json.construct UTXO.transaction_encoding transaction) + file + else + let bytes = + Hex.of_bytes + (Data_encoding.Binary.to_bytes_exn + UTXO.transaction_encoding + transaction) + in + let file = open_out_bin file in + Printf.fprintf file "0x%s" (Hex.show bytes) ; + close_out file) ; return_unit) let submit_shielded_cmd = @@ -452,18 +452,18 @@ let submit_shielded_cmd = >>= fun () -> let open Context in (if use_json_format then - Lwt_utils_unix.Json.read_file filename >>=? fun json -> - return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json - else - Lwt_utils_unix.read_file filename >>= fun hex -> - let hex = - (* remove 0x *) - String.sub hex 2 (String.length hex - 2) - in - return - @@ Data_encoding.Binary.of_bytes_exn - UTXO.transaction_encoding - Hex.(to_bytes_exn (`Hex hex))) + Lwt_utils_unix.Json.read_file filename >>=? fun json -> + return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json + else + Lwt_utils_unix.read_file filename >>= fun hex -> + let hex = + (* remove 0x *) + String.sub hex 2 (String.length hex - 2) + in + return + @@ Data_encoding.Binary.of_bytes_exn + UTXO.transaction_encoding + Hex.(to_bytes_exn (`Hex hex))) >>=? fun transaction -> return (sapling_transaction_as_arg transaction) >>=? fun contract_input -> let chain = cctxt#chain and block = cctxt#block in @@ -718,12 +718,12 @@ let commands () = | None -> cctxt#error "Account %s not found" name | Some account -> (if verbose then - cctxt#answer - "@[Received Sapling transactions for %s@,@[%a@]@]" - name - Context.Account.pp_unspent - account - else Lwt.return_unit) + cctxt#answer + "@[Received Sapling transactions for %s@,@[%a@]@]" + name + Context.Account.pp_unspent + account + else Lwt.return_unit) >>= fun () -> cctxt#answer "Total Sapling funds %a%s" diff --git a/src/proto_017_PtNairob/lib_delegate/baking_actions.ml b/src/proto_017_PtNairob/lib_delegate/baking_actions.ml index 33941479fa980654192c4c135e0f5067da7871c2..78feb6ad54176eba44468313b3e640bc299589ec 100644 --- a/src/proto_017_PtNairob/lib_delegate/baking_actions.ml +++ b/src/proto_017_PtNairob/lib_delegate/baking_actions.ml @@ -412,16 +412,17 @@ let inject_preendorsements state ~preendorsements = | false -> return state.global_state.config.force) >>=? fun may_sign -> (if may_sign then - let unsigned_operation = (shell, Contents_list contents) in - let watermark = Operation.(to_watermark (Preendorsement chain_id)) in - let unsigned_operation_bytes = - Data_encoding.Binary.to_bytes_exn - Operation.unsigned_encoding - unsigned_operation - in - Client_keys.sign cctxt ~watermark sk_uri unsigned_operation_bytes - else - fail (Baking_highwatermarks.Block_previously_preendorsed {round; level})) + let unsigned_operation = (shell, Contents_list contents) in + let watermark = Operation.(to_watermark (Preendorsement chain_id)) in + let unsigned_operation_bytes = + Data_encoding.Binary.to_bytes_exn + Operation.unsigned_encoding + unsigned_operation + in + Client_keys.sign cctxt ~watermark sk_uri unsigned_operation_bytes + else + fail + (Baking_highwatermarks.Block_previously_preendorsed {round; level})) >>= function | Error err -> Events.(emit skipping_preendorsement (delegate, err)) >>= fun () -> @@ -493,15 +494,16 @@ let sign_endorsements state endorsements = | false -> return state.global_state.config.force) >>=? fun may_sign -> (if may_sign then - let watermark = Operation.(to_watermark (Endorsement chain_id)) in - let unsigned_operation = (shell, Contents_list contents) in - let unsigned_operation_bytes = - Data_encoding.Binary.to_bytes_exn - Operation.unsigned_encoding - unsigned_operation - in - Client_keys.sign cctxt ~watermark sk_uri unsigned_operation_bytes - else fail (Baking_highwatermarks.Block_previously_endorsed {round; level})) + let watermark = Operation.(to_watermark (Endorsement chain_id)) in + let unsigned_operation = (shell, Contents_list contents) in + let unsigned_operation_bytes = + Data_encoding.Binary.to_bytes_exn + Operation.unsigned_encoding + unsigned_operation + in + Client_keys.sign cctxt ~watermark sk_uri unsigned_operation_bytes + else + fail (Baking_highwatermarks.Block_previously_endorsed {round; level})) >>= function | Error err -> Events.(emit skipping_endorsement (delegate, err)) >>= fun () -> @@ -603,8 +605,8 @@ let only_if_dal_feature_enabled state ~default_value f = | None -> incr no_dal_node_warning_counter ; (if !no_dal_node_warning_counter mod 10 = 1 then - Events.(emit no_dal_node ()) - else Lwt.return_unit) + Events.(emit no_dal_node ()) + else Lwt.return_unit) >>= fun () -> return default_value | Some ctxt -> f ctxt else return default_value @@ -731,9 +733,9 @@ let update_to_level state level_update = | Local index -> index.sync_fun ()) >>= fun () -> (if Int32.(new_level = succ state.level_state.current_level) then - return state.level_state.next_level_delegate_slots - else - Baking_state.compute_delegate_slots cctxt delegates ~level:new_level ~chain) + return state.level_state.next_level_delegate_slots + else + Baking_state.compute_delegate_slots cctxt delegates ~level:new_level ~chain) >>=? fun delegate_slots -> Baking_state.compute_delegate_slots cctxt diff --git a/src/proto_017_PtNairob/lib_delegate/baking_commands.ml b/src/proto_017_PtNairob/lib_delegate/baking_commands.ml index 825be533761ede58f02c96c94bd70bb6b563d73c..4d2ae7dd5ff8ea45b2f08e04b943aa5e77d31cfd 100644 --- a/src/proto_017_PtNairob/lib_delegate/baking_commands.ml +++ b/src/proto_017_PtNairob/lib_delegate/baking_commands.ml @@ -151,14 +151,15 @@ let liquidity_baking_toggle_vote_parameter = Tezos_clic.parameter ~autocomplete:(fun _ctxt -> return ["on"; "off"; "pass"]) (let open Protocol.Alpha_context.Liquidity_baking in - fun _ctxt -> function - | "on" -> return LB_on - | "off" -> return LB_off - | "pass" -> return LB_pass - | s -> - failwith - "unexpected vote: %s, expected either \"on\", \"off\", or \"pass\"." - s) + fun _ctxt -> function + | "on" -> return LB_on + | "off" -> return LB_off + | "pass" -> return LB_pass + | s -> + failwith + "unexpected vote: %s, expected either \"on\", \"off\", or \ + \"pass\"." + s) let liquidity_baking_toggle_vote_arg = Tezos_clic.arg @@ -182,14 +183,14 @@ let get_delegates (cctxt : Protocol_client_context.full) } in (if pkhs = [] then - Client_keys.get_keys cctxt >>=? fun keys -> - List.map proj_delegate keys |> return - else - List.map_es - (fun pkh -> - Client_keys.get_key cctxt pkh >>=? function - | alias, pk, sk_uri -> return (proj_delegate (alias, pkh, pk, sk_uri))) - pkhs) + Client_keys.get_keys cctxt >>=? fun keys -> + List.map proj_delegate keys |> return + else + List.map_es + (fun pkh -> + Client_keys.get_key cctxt pkh >>=? function + | alias, pk, sk_uri -> return (proj_delegate (alias, pkh, pk, sk_uri))) + pkhs) >>=? fun delegates -> Tezos_signer_backends.Encrypted.decrypt_list cctxt @@ -200,10 +201,10 @@ let get_delegates (cctxt : Protocol_client_context.full) >>=? fun () -> let delegates_no_duplicates = List.sort_uniq compare delegates in (if List.compare_lengths delegates delegates_no_duplicates <> 0 then - cctxt#warning - "Warning: the list of public key hash aliases contains duplicate hashes, \ - which are ignored" - else Lwt.return ()) + cctxt#warning + "Warning: the list of public key hash aliases contains duplicate \ + hashes, which are ignored" + else Lwt.return ()) >>= fun () -> return delegates_no_duplicates let sources_param = @@ -391,10 +392,10 @@ let run_baker dal_node_endpoint ) baking_mode sources cctxt = may_lock_pidfile pidfile @@ fun () -> (if per_block_vote_file = None then - (* If the liquidity baking file was not explicitly given, we - look into default locations. *) - lookup_default_vote_file_path cctxt - else Lwt.return per_block_vote_file) + (* If the liquidity baking file was not explicitly given, we + look into default locations. *) + lookup_default_vote_file_path cctxt + else Lwt.return per_block_vote_file) >>= fun per_block_vote_file -> (* We don't let the user run the baker without providing some option (CLI, file path, or file in default location) for diff --git a/src/proto_017_PtNairob/lib_delegate/baking_pow.ml b/src/proto_017_PtNairob/lib_delegate/baking_pow.ml index 5a7306a3e31c6f464c2aa9715fa9e7086c9ee66c..a0b690886bfb09b52976d7db142a12a301d70f6c 100644 --- a/src/proto_017_PtNairob/lib_delegate/baking_pow.ml +++ b/src/proto_017_PtNairob/lib_delegate/baking_pow.ml @@ -108,8 +108,8 @@ let mine ~proof_of_work_threshold shell builder = else ( Bytes.blit_string (Z.to_bits z) 0 block_header offset z_len ; (if Hacl_star.AutoConfig2.(has_feature VEC256) then - Hacl_star.Hacl.Blake2b_256.Noalloc.hash - else Hacl_star.Hacl.Blake2b_32.Noalloc.hash) + Hacl_star.Hacl.Blake2b_256.Noalloc.hash + else Hacl_star.Hacl.Blake2b_32.Noalloc.hash) ~key:Bytes.empty ~msg:block_header ~digest:block_hash_bytes ; diff --git a/src/proto_017_PtNairob/lib_delegate/baking_scheduling.ml b/src/proto_017_PtNairob/lib_delegate/baking_scheduling.ml index 420d7be693dc5b65341bad957523dc725685cc8d..c1e13daffe1d73c84d2a1978e3b027cb117c1a6f 100644 --- a/src/proto_017_PtNairob/lib_delegate/baking_scheduling.ml +++ b/src/proto_017_PtNairob/lib_delegate/baking_scheduling.ml @@ -393,13 +393,13 @@ let compute_next_potential_baking_time_at_next_level state = compute the round from the current timestamp. This possibly means the baker has been late. *) (if Time.Protocol.(now < min_possible_time) then ok Round.zero - else - Environment.wrap_tzresult - @@ Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~predecessor_round - ~timestamp:now) + else + Environment.wrap_tzresult + @@ Round.round_of_timestamp + round_durations + ~predecessor_timestamp + ~predecessor_round + ~timestamp:now) |> function | Error _ -> Lwt.return_none | Ok earliest_round -> ( @@ -493,12 +493,12 @@ let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t let delay = Ptime.diff (Time.System.of_protocol_exn next_time) now in let current_round = Int32.pred @@ Round.to_int32 next_round in (if delta = 0L then - Events.(emit waiting_end_of_round (delay, current_round, next_time)) - else - Events.( - emit - waiting_delayed_end_of_round - (delay, current_round, next_time, delta))) + Events.(emit waiting_end_of_round (delay, current_round, next_time)) + else + Events.( + emit + waiting_delayed_end_of_round + (delay, current_round, next_time, delta))) >>= fun () -> let end_of_round = Lwt.return @@ -701,17 +701,17 @@ let create_initial_state cctxt ?(synchronize = true) ~chain config } in (if synchronize then - create_round_durations constants >>? fun round_durations -> - Baking_actions.compute_round current_proposal round_durations - >>? fun current_round -> - ok {current_round; current_phase = Idle; delayed_prequorum = None} - else - ok - { - Baking_state.current_round = Round.zero; - current_phase = Idle; - delayed_prequorum = None; - }) + create_round_durations constants >>? fun round_durations -> + Baking_actions.compute_round current_proposal round_durations + >>? fun current_round -> + ok {current_round; current_phase = Idle; delayed_prequorum = None} + else + ok + { + Baking_state.current_round = Round.zero; + current_phase = Idle; + delayed_prequorum = None; + }) >>?= fun round_state -> let state = {global_state; level_state; round_state} in (* Try loading locked round and endorsable round from disk *) diff --git a/src/proto_017_PtNairob/lib_delegate/baking_simulator.ml b/src/proto_017_PtNairob/lib_delegate/baking_simulator.ml index 000d7cc3c575fa85898ecaa3915ebaf135f33232..686ba439e104e38a980d75f4a2ba4b693ec6e68b 100644 --- a/src/proto_017_PtNairob/lib_delegate/baking_simulator.ml +++ b/src/proto_017_PtNairob/lib_delegate/baking_simulator.ml @@ -114,14 +114,14 @@ let begin_construction ~timestamp ~protocol_data ~force_apply ~cache:`Lazy >>=? fun validation_state -> (if force_apply then - Lifted_protocol.begin_application - context - chain_id - mode - ~predecessor:pred_shell - ~cache:`Lazy - >>=? return_some - else return_none) + Lifted_protocol.begin_application + context + chain_id + mode + ~predecessor:pred_shell + ~cache:`Lazy + >>=? return_some + else return_none) >>=? fun application_state -> let state = (validation_state, application_state) in return diff --git a/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.ml b/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.ml index aa9c790101e8a15733b17b1d4e458bccc0f70031..a2cb0bebaca48b9c1ea3e582bf9ca98add74d7b7 100644 --- a/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.ml @@ -331,7 +331,7 @@ let process_operations (cctxt : #Protocol_client_context.full) state match protocol_data with | Operation_data ({contents = Single (Preendorsement {round; slot; level; _}); _} as - protocol_data) -> + protocol_data) -> let new_preendorsement : Kind.preendorsement Alpha_context.operation = {shell; protocol_data} in @@ -346,7 +346,7 @@ let process_operations (cctxt : #Protocol_client_context.full) state slot | Operation_data ({contents = Single (Endorsement {round; slot; level; _}); _} as - protocol_data) -> + protocol_data) -> let new_endorsement : Kind.endorsement Alpha_context.operation = {shell; protocol_data} in diff --git a/src/proto_017_PtNairob/lib_delegate/operation_pool.ml b/src/proto_017_PtNairob/lib_delegate/operation_pool.ml index a654562fcb436a6b7d979ceb21cd5c12d4805d6e..3a5c25cf230e5552cf95d007b702daa8c1ba260e 100644 --- a/src/proto_017_PtNairob/lib_delegate/operation_pool.ml +++ b/src/proto_017_PtNairob/lib_delegate/operation_pool.ml @@ -167,8 +167,8 @@ let classify op = | None -> `Bad | Some pass -> let open Operation_repr in - if pass = consensus_pass then `Consensus - (* TODO filter outdated consensus ops ? *) + if pass = consensus_pass then + `Consensus (* TODO filter outdated consensus ops ? *) else if pass = voting_pass then `Votes else if pass = anonymous_pass then `Anonymous else if pass = manager_pass then `Managers diff --git a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.ml b/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.ml index 5fb836f50f346606877e37ae9672cecbdc06339e..a5e3fb79446d0a149697fd349c4b987e61b50ca0 100644 --- a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.ml +++ b/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.ml @@ -321,13 +321,13 @@ let make_mocked_services_hooks (state : state) (user_hooks : (module Hooks)) : { current_protocol = (if - Block_hash.equal hash genesis_block_hash - || is_predecessor_of_genesis - then Protocol_hash.zero - else Protocol.hash); + Block_hash.equal hash genesis_block_hash + || is_predecessor_of_genesis + then Protocol_hash.zero + else Protocol.hash); next_protocol = (if is_predecessor_of_genesis then Protocol_hash.zero - else Protocol.hash); + else Protocol.hash); } let may_lie_on_proto_level block x = @@ -762,12 +762,13 @@ let rec listener ~(user_hooks : (module Hooks)) ~state ~broadcast_pipe = Lwt_pipe.Unbounded.pop broadcast_pipe >>= function | Broadcast_op (operation_hash, packed_operation) -> (if - List.mem_assoc ~equal:Operation_hash.equal operation_hash state.mempool - then return_unit - else ( - state.mempool <- (operation_hash, packed_operation) :: state.mempool ; - state.operations_stream_push (Some [(operation_hash, packed_operation)]) ; - User_hooks.check_mempool_after_processing ~mempool:state.mempool)) + List.mem_assoc ~equal:Operation_hash.equal operation_hash state.mempool + then return_unit + else ( + state.mempool <- (operation_hash, packed_operation) :: state.mempool ; + state.operations_stream_push + (Some [(operation_hash, packed_operation)]) ; + User_hooks.check_mempool_after_processing ~mempool:state.mempool)) >>=? fun () -> listener ~user_hooks ~state ~broadcast_pipe | Broadcast_block (block_hash, block_header, operations) -> get_block_level block_header >>=? fun level -> @@ -1207,7 +1208,7 @@ let run ?(config = default_config) bakers_spec = In particular, it seems that when logging is enabled the baker process can get cancelled without executing its Lwt finalizer. *) (if config.debug then Tezos_base_unix.Internal_event_unix.init () - else Lwt.return_unit) + else Lwt.return_unit) >>= fun () -> let total_bakers = List.length bakers_spec in (List.init ~when_negative_length:() total_bakers (fun _ -> diff --git a/src/proto_017_PtNairob/lib_plugin/mempool.ml b/src/proto_017_PtNairob/lib_plugin/mempool.ml index f7737b7bcbd006a6392001e8b43cc49f48f5c6d8..8d99d3f19760548db8bf1497314921169bffd72e 100644 --- a/src/proto_017_PtNairob/lib_plugin/mempool.ml +++ b/src/proto_017_PtNairob/lib_plugin/mempool.ml @@ -762,25 +762,25 @@ let fee_needed_to_replace_by_fee config ~op_to_replace ~candidate_op = if is_manager_operation candidate_op && is_manager_operation op_to_replace then (let open Result_syntax in - let* _fee, candidate_gas = compute_fee_and_gas_limit candidate_op in - let* old_fee, old_gas = compute_fee_and_gas_limit op_to_replace in - if Gas.Arith.(old_gas = zero || candidate_gas = zero) then - (* This should not happen when both operations are valid. *) - Result.return_none - else - let candidate_gas = gas_as_q candidate_gas in - let bumped_old_fee, bumped_old_ratio = - bumped_fee_and_ratio_as_q config old_fee old_gas - in - (* The new operation needs to exceed both the bumped fee and the - bumped ratio to make {!better_fees_and_ratio} return [true]. - (Having fee or ratio equal to its bumped counterpart is ok too, - hence the [ceil] in [int64_ceil_of_q].) *) - let fee_needed_for_fee = int64_ceil_of_q bumped_old_fee in - let fee_needed_for_ratio = - int64_ceil_of_q Q.(bumped_old_ratio * candidate_gas) - in - Result.return_some (max fee_needed_for_fee fee_needed_for_ratio)) + let* _fee, candidate_gas = compute_fee_and_gas_limit candidate_op in + let* old_fee, old_gas = compute_fee_and_gas_limit op_to_replace in + if Gas.Arith.(old_gas = zero || candidate_gas = zero) then + (* This should not happen when both operations are valid. *) + Result.return_none + else + let candidate_gas = gas_as_q candidate_gas in + let bumped_old_fee, bumped_old_ratio = + bumped_fee_and_ratio_as_q config old_fee old_gas + in + (* The new operation needs to exceed both the bumped fee and the + bumped ratio to make {!better_fees_and_ratio} return [true]. + (Having fee or ratio equal to its bumped counterpart is ok too, + hence the [ceil] in [int64_ceil_of_q].) *) + let fee_needed_for_fee = int64_ceil_of_q bumped_old_fee in + let fee_needed_for_ratio = + int64_ceil_of_q Q.(bumped_old_ratio * candidate_gas) + in + Result.return_some (max fee_needed_for_fee fee_needed_for_ratio)) |> Option.of_result |> Option.join else None @@ -858,23 +858,25 @@ let fee_needed_to_overtake ~op_to_overtake ~candidate_op = if is_manager_operation candidate_op && is_manager_operation op_to_overtake then (let open Result_syntax in - let* _fee, candidate_gas = compute_fee_and_gas_limit candidate_op in - let* target_fee, target_gas = compute_fee_and_gas_limit op_to_overtake in - if Gas.Arith.(target_gas = zero || candidate_gas = zero) then - (* This should not happen when both operations are valid. *) - Result.return_none - else - (* Compute the target ratio as in {!Operation_repr.weight_manager}. - We purposefully don't use {!fee_and_ratio_as_q} because the code - here needs to stay in sync with {!Operation_repr.weight_manager} - rather than {!better_fees_and_ratio}. *) - let target_fee = Q.of_int64 (Tez.to_mutez target_fee) in - let target_gas = Q.of_bigint (Gas.Arith.integral_to_z target_gas) in - let target_ratio = Q.(target_fee / target_gas) in - (* Compute the minimal fee needed to have a strictly greater ratio. *) - let candidate_gas = Q.of_bigint (Gas.Arith.integral_to_z candidate_gas) in - Result.return_some - (Int64.succ Q.(to_int64 (target_ratio * candidate_gas)))) + let* _fee, candidate_gas = compute_fee_and_gas_limit candidate_op in + let* target_fee, target_gas = compute_fee_and_gas_limit op_to_overtake in + if Gas.Arith.(target_gas = zero || candidate_gas = zero) then + (* This should not happen when both operations are valid. *) + Result.return_none + else + (* Compute the target ratio as in {!Operation_repr.weight_manager}. + We purposefully don't use {!fee_and_ratio_as_q} because the code + here needs to stay in sync with {!Operation_repr.weight_manager} + rather than {!better_fees_and_ratio}. *) + let target_fee = Q.of_int64 (Tez.to_mutez target_fee) in + let target_gas = Q.of_bigint (Gas.Arith.integral_to_z target_gas) in + let target_ratio = Q.(target_fee / target_gas) in + (* Compute the minimal fee needed to have a strictly greater ratio. *) + let candidate_gas = + Q.of_bigint (Gas.Arith.integral_to_z candidate_gas) + in + Result.return_some + (Int64.succ Q.(to_int64 (target_ratio * candidate_gas)))) |> Option.of_result |> Option.join else None diff --git a/src/proto_017_PtNairob/lib_plugin/script_interpreter_logging.ml b/src/proto_017_PtNairob/lib_plugin/script_interpreter_logging.ml index 297f153d731f4867127fee836af48ab0795e93a7..7da160b7b3e6ca95f1eaa8927ad3b6f46aef6f6c 100644 --- a/src/proto_017_PtNairob/lib_plugin/script_interpreter_logging.ml +++ b/src/proto_017_PtNairob/lib_plugin/script_interpreter_logging.ml @@ -2197,7 +2197,7 @@ module Logger (Base : Logger_base) = struct accu stack | _ -> (step [@ocaml.tailcall]) g gas k ks accu stack - [@@inline] + [@@inline] let klog : type a s r f. @@ -2307,7 +2307,7 @@ module Logger (Base : Logger_base) = struct (* This case should never happen. *) (next [@ocaml.tailcall]) g gas k accu stack | KNil as k -> (next [@ocaml.tailcall]) g gas k accu stack - [@@inline] + [@@inline] end let make (module Base : Logger_base) = diff --git a/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml b/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml index f4604296f2230382f9cd1cc35b6f74d7a5b8bdbc..2627bf46f6e8763aca8a76e64744de75648309f8 100644 --- a/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml +++ b/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml @@ -95,24 +95,24 @@ let test_manager_ops config (op_to_replace, fee_r, gas_r) (fst candidate_op, Helpers.set_fee fee (snd candidate_op)) in (if fee_needed > 0L then - let fee_smaller = Int64.pred fee_needed in - match - Plugin.Mempool.conflict_handler - config - ~existing_operation:op_to_replace - ~new_operation:(with_fee fee_smaller) - with - | `Keep -> () - | `Replace -> - Test.fail - ~__LOC__ - "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee smaller than \ - fee_needed should not be allowed to replace op_to_replace: \ - {fee=%dmutez; gas=%d}" - fee_smaller - gas_c - fee_r - gas_r) ; + let fee_smaller = Int64.pred fee_needed in + match + Plugin.Mempool.conflict_handler + config + ~existing_operation:op_to_replace + ~new_operation:(with_fee fee_smaller) + with + | `Keep -> () + | `Replace -> + Test.fail + ~__LOC__ + "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee smaller \ + than fee_needed should not be allowed to replace op_to_replace: \ + {fee=%dmutez; gas=%d}" + fee_smaller + gas_c + fee_r + gas_r) ; match Plugin.Mempool.conflict_handler config diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/block.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/block.ml index 0713dcb66dfa4ed2bf188f8a957154db1155b7c3..7f0334fd6aa1fed079b65afe784a4f10b145f6a0 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/block.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/helpers/block.ml @@ -746,17 +746,17 @@ let apply_with_metadata ?(policy = By_round 0) ?(check_size = true) ~baking_mode List.fold_left_es (fun vstate op -> (if check_size then - let operation_size = - Data_encoding.Binary.length Operation.encoding op - in - if operation_size > Constants_repr.max_operation_data_length then - raise - (invalid_arg - (Format.sprintf - "The operation size is %d, it exceeds the constant maximum \ - size %d" - operation_size - Constants_repr.max_operation_data_length))) ; + let operation_size = + Data_encoding.Binary.length Operation.encoding op + in + if operation_size > Constants_repr.max_operation_data_length then + raise + (invalid_arg + (Format.sprintf + "The operation size is %d, it exceeds the constant \ + maximum size %d" + operation_size + Constants_repr.max_operation_data_length))) ; validate_and_apply_operation vstate op >>=? fun (state, result) -> if allow_manager_failures then return state else diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/dummy_zk_rollup.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/dummy_zk_rollup.ml index d02f6f5c5c43ebaa16fa005e84a7778b20e9e88c..03875ec112fd0ee9dcd40b0ff3889fe42d665cb9 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/dummy_zk_rollup.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/helpers/dummy_zk_rollup.ml @@ -380,7 +380,7 @@ end = struct let lazy_srs = lazy (let open Octez_bls12_381_polynomial in - (Srs.generate_insecure 9 1, Srs.generate_insecure 1 1)) + (Srs.generate_insecure 9 1, Srs.generate_insecure 1 1)) let dummy_l1_dst = Hex.to_bytes_exn (`Hex "0002298c03ed7d454a101eb7022bc95f7e5f41ac78") diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.ml index 20a6ba32c9b5ad3ad2ff4d4f3760f9d9837bcf7f..4edd9e95f24278d100a23d7b43ecead7ff4a1a23 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.ml @@ -645,7 +645,7 @@ module MachineBuilder = struct fun ?(invariant = fun _ _ -> pure true) ?(subsidy = default_subsidy) ({cpmm_min_xtz_balance; accounts_balances; cpmm_min_tzbtc_balance} as - specs) -> + specs) -> let accounts_balances_with_extra = predict_initial_balances accounts_balances subsidy in @@ -680,13 +680,14 @@ module MachineBuilder = struct >>= fun current_cpmm_tzbtc_balance -> let tzbtc_missing = cpmm_min_tzbtc_balance - current_cpmm_tzbtc_balance in (if 0 < tzbtc_missing then - (* 4.1. Provide the tokens to the [bootstrap1] account, as a - temporary holder for CPMM missing tzBTC balance *) - mint_tzbtc ~invariant env.holder tzbtc_missing env state >>= fun state -> - (* 4.1. Make [bootstrap1] buy some xtz against the appropriate - amount of tzbtc *) - sell_tzbtc ~invariant env.holder env.holder tzbtc_missing env state - else pure state) + (* 4.1. Provide the tokens to the [bootstrap1] account, as a + temporary holder for CPMM missing tzBTC balance *) + mint_tzbtc ~invariant env.holder tzbtc_missing env state + >>= fun state -> + (* 4.1. Make [bootstrap1] buy some xtz against the appropriate + amount of tzbtc *) + sell_tzbtc ~invariant env.holder env.holder tzbtc_missing env state + else pure state) >>= fun state -> (* 5. Provide any missing xtz tokens to [cpmm_contract], if necessary *) get_xtz_balance env.cpmm_contract state @@ -695,9 +696,9 @@ module MachineBuilder = struct Int64.sub cpmm_min_xtz_balance current_cpmm_xtz_balance in (if 0L < xtz_missing then - transaction ~src:env.holder env.cpmm_contract xtz_missing state - >>= fun op -> bake ~invariant ~baker:env.holder [op] env state - else pure state) + transaction ~src:env.holder env.cpmm_contract xtz_missing state + >>= fun op -> bake ~invariant ~baker:env.holder [op] env state + else pure state) >>= fun state -> check_state_satisfies_specs env state specs >>= fun () -> pure (state, env) end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/op.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/op.ml index e57b68457d9bfa6c408d58b67fdb6730235f2f8d..b7a4d6dbf9d1c884df5c44903b231046a9c2cb9d 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/op.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/helpers/op.ml @@ -183,20 +183,20 @@ let batch_operations ?(recompute_counters = false) ~source ctxt |> List.flatten in (if recompute_counters then - Context.Contract.counter ctxt source >>=? fun counter -> - (* Update counters and transform into a contents_list *) - let _, rev_operations = - List.fold_left - (fun (counter, acc) -> function - | Contents (Manager_operation m) -> - ( Manager_counter.succ counter, - Contents (Manager_operation {m with counter}) :: acc ) - | x -> (counter, x :: acc)) - (Manager_counter.succ counter, []) - operations - in - return (List.rev rev_operations) - else return operations) + Context.Contract.counter ctxt source >>=? fun counter -> + (* Update counters and transform into a contents_list *) + let _, rev_operations = + List.fold_left + (fun (counter, acc) -> function + | Contents (Manager_operation m) -> + ( Manager_counter.succ counter, + Contents (Manager_operation {m with counter}) :: acc ) + | x -> (counter, x :: acc)) + (Manager_counter.succ counter, []) + operations + in + return (List.rev rev_operations) + else return operations) >>=? fun operations -> Context.Contract.manager ctxt source >>=? fun account -> Environment.wrap_tzresult @@ Operation.of_list operations diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_baking.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_baking.ml index 6d2ee39ec61b4be1cae7cf749f31f6478e9f5c80..609ef000b627b8658d5f2bae18cd3073db170385 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_baking.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_baking.ml @@ -223,8 +223,8 @@ let test_rewards_block_and_payload_producer () = Context.get_baking_reward_fixed_portion (B b2) >>=? fun baking_reward -> Context.get_bonus_reward (B b2) ~endorsing_power >>=? fun bonus_reward -> (if Signature.Public_key_hash.equal baker_b2 baker_b1 then - Context.get_baking_reward_fixed_portion (B b1) - else return Tez.zero) + Context.get_baking_reward_fixed_portion (B b1) + else return Tez.zero) >>=? fun reward_for_b1 -> (* we are in the first scenario where the payload producer is the same as the block producer, in our case, [baker_b2]. [baker_b2] gets the baking reward diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_consensus_key.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_consensus_key.ml index b6a4e9ec6ab1ddecc3837443bb789970eeb43b81..3488c7e7c18db9b6edf1b367ef5b7ac303fbf5cb 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_consensus_key.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_consensus_key.ml @@ -130,18 +130,23 @@ let test_drain_delegate ~low_balance ~exclude_ck ~ck_delegates () = else Block.By_account delegate in (if ck_delegates then - may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> - delegate_stake blk consensus_pkh delegate - else return blk) + may_reveal_manager_key blk (consensus_pkh, consensus_pk) + >>=? fun blk -> delegate_stake blk consensus_pkh delegate + else return blk) >>=? fun blk -> Context.Contract.balance (B blk) (Contract.Implicit delegate) >>=? fun delegate_balance -> (if low_balance then - transfer_tokens blk delegate consensus_pkh delegate_balance - >>=? fun blk -> - may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> - transfer_tokens blk consensus_pkh delegate Tez.(of_mutez_exn 1_000_000L) - else return blk) + transfer_tokens blk delegate consensus_pkh delegate_balance + >>=? fun blk -> + may_reveal_manager_key blk (consensus_pkh, consensus_pk) + >>=? fun blk -> + transfer_tokens + blk + consensus_pkh + delegate + Tez.(of_mutez_exn 1_000_000L) + else return blk) >>=? fun blk -> Context.Contract.balance (B blk) (Contract.Implicit delegate) >>=? fun delegate_balance -> diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_endorsement.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_endorsement.ml index 5cd36103bb10f56ac17e4ba96c4bb995b5530099..430cbf9ada870e08a2b86ac3cbda8515be985843 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_endorsement.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_endorsement.ml @@ -345,8 +345,8 @@ let test_freeze_more_with_low_balance = | [d1; d2] -> return (if Signature.Public_key_hash.equal account d1.delegate then d1 - else if Signature.Public_key_hash.equal account d2.delegate then d2 - else assert false) + else if Signature.Public_key_hash.equal account d2.delegate then d2 + else assert false) .slots | _ -> assert false (* there are exactly two endorsers for this test. *) diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_seed.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_seed.ml index 93df78ac53a62d34a26bde2777ad3146e1fb4d1d..2e0f3ea6b0bcc3244f4fafdc2b4fbff93135f42f 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_seed.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_seed.ml @@ -65,14 +65,14 @@ let test_seed_no_commitment () = let* s = Context.get_seed (B b) in let seed_bytes = Data_encoding.Binary.to_bytes_exn Seed.seed_encoding s in (if expected_seed <> seed_bytes then - let seed_pp = - Hex.show - (Hex.of_string - (Data_encoding.Binary.to_string_exn Seed.seed_encoding s)) - in - let expected_seed_pp = Hex.show (Hex.of_bytes expected_seed) in - Stdlib.failwith - (Format.sprintf "Seed: %s\nExpected: %s\n\n" seed_pp expected_seed_pp)) ; + let seed_pp = + Hex.show + (Hex.of_string + (Data_encoding.Binary.to_string_exn Seed.seed_encoding s)) + in + let expected_seed_pp = Hex.show (Hex.of_bytes expected_seed) in + Stdlib.failwith + (Format.sprintf "Seed: %s\nExpected: %s\n\n" seed_pp expected_seed_pp)) ; return b in let rec bake_and_check_seed b = function diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_levels.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_levels.ml index abaa01b81a1533ce582eeba03bfae446e44f5986..73a63f056aade6bf77bba893ae3cd27dfb218bc1 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_levels.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_levels.ml @@ -215,20 +215,20 @@ let finalize_validation_and_application (validation_state, application_state) let apply_with_gas header ?(operations = []) (pred : Block.t) = let open Alpha_context in (let open Environment.Error_monad in - begin_validation_and_application - pred.context - Chain_id.zero - (Application header) - ~predecessor:pred.header.shell - >>=? fun vstate -> - List.fold_left_es - (fun vstate op -> - validate_and_apply_operation vstate op >|=? fun (state, _result) -> state) - vstate - operations - >>=? fun vstate -> - finalize_validation_and_application vstate (Some header.shell) - >|=? fun (validation, result) -> (validation.context, result.consumed_gas)) + begin_validation_and_application + pred.context + Chain_id.zero + (Application header) + ~predecessor:pred.header.shell + >>=? fun vstate -> + List.fold_left_es + (fun vstate op -> + validate_and_apply_operation vstate op >|=? fun (state, _result) -> state) + vstate + operations + >>=? fun vstate -> + finalize_validation_and_application vstate (Some header.shell) + >|=? fun (validation, result) -> (validation.context, result.consumed_gas)) >|= Environment.wrap_tzresult >|=? fun (context, consumed_gas) -> let hash = Block_header.hash header in diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_typechecking.ml index 1f7444fa7a7be0f1770f7e840733f30ff32b1a1e..ca39d8b6437a741ef27ed9fb65b4d461ed974602 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -582,8 +582,8 @@ let test_unparse_data loc ctxt ty x ~expected_readable ~expected_optimized = ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Readable ty x >>=? fun (actual_readable, ctxt) -> (if actual_readable = Micheline.strip_locations expected_readable then - return ctxt - else Alcotest.failf "Error in readable unparsing: %s" loc) + return ctxt + else Alcotest.failf "Error in readable unparsing: %s" loc) >>=? fun ctxt -> Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty x >>=? fun (actual_optimized, ctxt) -> diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup.ml index cd0d4d50cd3d0aaeaf581b0417095eaca0f3ec6f..84f137101985ef112f73b7625ce818656b092075 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -416,16 +416,16 @@ let verify_execute_outbox_message_operations incr rollup ~loc ~operations let*? ctxt = Environment.wrap_tzresult (let open Result_syntax in - let* eq, ctxt = - Gas_monad.run - ctxt - (Script_ir_translator.ty_eq - ~error_details:(Informative (-1)) - script_parameters_ty - parameters_ty) - in - let+ Eq = eq in - ctxt) + let* eq, ctxt = + Gas_monad.run + ctxt + (Script_ir_translator.ty_eq + ~error_details:(Informative (-1)) + script_parameters_ty + parameters_ty) + in + let+ Eq = eq in + ctxt) in return (ctxt, (destination, entrypoint, unparsed_parameters)) | _ -> @@ -640,8 +640,8 @@ let execute_outbox_message_without_proof_validation incr rollup let*@ res, ctxt = Sc_rollup_operations.Internal_for_tests.execute_outbox_message (Incremental.alpha_ctxt incr) - ~validate_and_decode_output_proof: - (fun ctxt ~cemented_commitment:_ _rollup ~output_proof:_ -> + ~validate_and_decode_output_proof:(fun + ctxt ~cemented_commitment:_ _rollup ~output_proof:_ -> return (outbox_message, ctxt)) rollup ~cemented_commitment @@ -3371,7 +3371,7 @@ let test_start_game_on_cemented_commitment () = let expect_apply_failure = function | Environment.Ecoproto_error (Sc_rollup_errors.Sc_rollup_wrong_staker_for_conflict_commitment _ - as e) + as e) :: _ -> Assert.test_error_encodings e ; return_unit diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_voting.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_voting.ml index 426292840eab7c66611b6508ce91012a852f6de4..429c0b6443edfc863ea65a07ed0780791b83f96a 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_voting.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_voting.ml @@ -449,7 +449,7 @@ let test_successful_vote num_delegates () = (* no proposals at the beginning of proposal period *) Context.Vote.get_proposals (B b) >>=? fun ps -> (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) + else failwith "%s - Unexpected proposals" __LOC__) >>=? fun () -> (* no current proposal during proposal period *) (Context.Vote.get_current_proposal (B b) >>=? function @@ -538,7 +538,7 @@ let test_successful_vote num_delegates () = (* no proposals during exploration period *) Context.Vote.get_proposals (B b) >>=? fun ps -> (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) + else failwith "%s - Unexpected proposals" __LOC__) >>=? fun () -> (* current proposal must be set during exploration period *) (Context.Vote.get_current_proposal (B b) >>=? function @@ -616,7 +616,7 @@ let test_successful_vote num_delegates () = (* no proposals during promotion period *) Context.Vote.get_proposals (B b) >>=? fun ps -> (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) + else failwith "%s - Unexpected proposals" __LOC__) >>=? fun () -> (* current proposal must be set during promotion period *) (Context.Vote.get_current_proposal (B b) >>=? function @@ -870,9 +870,9 @@ let test_supermajority_in_proposal there_is_a_winner () = minimal_stake >>=? fun op2 -> (if there_is_a_winner then Test_tez.( *? ) minimal_stake 3L - else - Test_tez.( *? ) minimal_stake 2L - >>? Test_tez.( +? ) (Test_tez.of_mutez_exn initial_balance)) + else + Test_tez.( *? ) minimal_stake 2L + >>? Test_tez.( +? ) (Test_tez.of_mutez_exn initial_balance)) >>?= fun bal3 -> Op.transaction (B b) @@ -891,7 +891,7 @@ let test_supermajority_in_proposal there_is_a_winner () = (* we remain in the proposal period when there is no winner, otherwise we move to the exploration period *) (if there_is_a_winner then assert_period ~expected_kind:Exploration b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) + else assert_period ~expected_kind:Proposal b __LOC__) >>=? fun () -> return_unit (** After one voting period, if [has_quorum] then the period kind must @@ -925,7 +925,7 @@ let test_quorum_in_proposal has_quorum () = (* we remain in the proposal period when there is no quorum, otherwise we move to the cooldown vote period *) (if has_quorum then assert_period ~expected_kind:Exploration b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) + else assert_period ~expected_kind:Proposal b __LOC__) >>=? fun () -> return_unit (** If a supermajority is reached, then the voting period must be @@ -969,7 +969,7 @@ let test_supermajority_in_exploration supermajority () = Block.bake ~operations b >>=? fun b -> bake_until_first_block_of_next_period b >>=? fun b -> (if supermajority then assert_period ~expected_kind:Cooldown b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) + else assert_period ~expected_kind:Proposal b __LOC__) >>=? fun () -> return_unit (** Test also how the selection scales: all delegates propose max diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bytes_conversion.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bytes_conversion.ml index 3e0c3762fca1ad2d7ab25a22499cc06ec6cf550b..8d493234d0300dc1446322702e8a272f76ab6cfb 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bytes_conversion.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bytes_conversion.ml @@ -161,9 +161,9 @@ let test_bytes_of_int_random () = (* [bytes_of_int] must return the shortest encoding: at most 1 char of zero or '\255's at the head. *) (if Bytes.length bytes >= 2 then - match (Bytes.get bytes 0, Bytes.get bytes 1) with - | '\000', '\000' | '\255', '\255' -> assert false - | _ -> ()) ; + match (Bytes.get bytes 0, Bytes.get bytes 1) with + | '\000', '\000' | '\255', '\255' -> assert false + | _ -> ()) ; (* [int_of_bytes @@ bytes_of_int z = z] *) (let z' = to_zint @@ int_of_bytes_be bytes in Z.Compare.(z = z')) diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_carbonated_map.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_carbonated_map.ml index 568ec816747d3788145a5c744210c439338dcdf9..88c58544a3aecfb38c1b6dac2875d08654c90838 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_carbonated_map.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_carbonated_map.ml @@ -79,9 +79,9 @@ let pp_int_map fmt map = in Lwt_main.run (let open Lwt_result_syntax in - let* ctxt = new_ctxt () in - let*?@ kvs, _ = CM.to_list ctxt map in - return kvs) + let* ctxt = new_ctxt () in + let*?@ kvs, _ = CM.to_list ctxt map in + return kvs) |> Result.value_f ~default:(fun () -> assert false) |> Format.fprintf fmt "%a" pp diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_gas_properties.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_gas_properties.ml index cfa59556041ff88f4bf0b4578ee42e23b688e299..03a5a78c6b91a88ffd8e2ecc8bef6cc306439fda 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_gas_properties.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_gas_properties.ml @@ -46,33 +46,33 @@ let test_free_neutral (start, any_cost) = let open Alpha_context in extract_qcheck_result (let open Result_syntax in - let* free_first = Gas.consume start Gas.free in - let* branch1 = Gas.consume free_first any_cost in - let* cost_first = Gas.consume start any_cost in - let+ branch2 = Gas.consume cost_first Gas.free in - let equal_consumption_from_start t1 t2 = - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:t1) - (Gas.consumed ~since:start ~until:t2)) - in - equal_consumption_from_start branch1 branch2 - && equal_consumption_from_start branch1 cost_first) + let* free_first = Gas.consume start Gas.free in + let* branch1 = Gas.consume free_first any_cost in + let* cost_first = Gas.consume start any_cost in + let+ branch2 = Gas.consume cost_first Gas.free in + let equal_consumption_from_start t1 t2 = + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:t1) + (Gas.consumed ~since:start ~until:t2)) + in + equal_consumption_from_start branch1 branch2 + && equal_consumption_from_start branch1 cost_first) (** Consuming [Gas.free] is equivalent to consuming nothing. *) let test_free_consumption start = let open Alpha_context in extract_qcheck_result (let open Result_syntax in - let+ after_empty_consumption = Gas.consume start Gas.free in - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:after_empty_consumption) - zero)) + let+ after_empty_consumption = Gas.consume start Gas.free in + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:after_empty_consumption) + zero)) (** Consuming [cost1] then [cost2] is equivalent to consuming [Gas.(cost1 +@ cost2)]. *) @@ -80,26 +80,26 @@ let test_consume_commutes (start, cost1, cost2) = let open Alpha_context in extract_qcheck_result (let open Result_syntax in - let* after_cost1 = Gas.consume start cost1 in - let* branch1 = Gas.consume after_cost1 cost2 in - let+ branch2 = Gas.consume start Gas.(cost1 +@ cost2) in - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:branch1) - (Gas.consumed ~since:start ~until:branch2))) + let* after_cost1 = Gas.consume start cost1 in + let* branch1 = Gas.consume after_cost1 cost2 in + let+ branch2 = Gas.consume start Gas.(cost1 +@ cost2) in + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:branch1) + (Gas.consumed ~since:start ~until:branch2))) (** Arbitrary context with a gas limit of 100_000_000. *) let context_gen : Alpha_context.t QCheck2.Gen.t = QCheck2.Gen.return (Lwt_main.run (let open Lwt_result_syntax in - let* b, _contract = Context.init1 () in - let+ inc = Incremental.begin_construction b in - Alpha_context.Gas.set_limit - (Incremental.alpha_ctxt inc) - Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000))) + let* b, _contract = Context.init1 () in + let+ inc = Incremental.begin_construction b in + Alpha_context.Gas.set_limit + (Incremental.alpha_ctxt inc) + Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000))) |> function | Ok a -> a | Error _ -> assert false) diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_refutation_game.ml index a7ddfeeb23336a78f84f5684da50270678346dba..c029db6ba8532fcf62de040adf42a78c5bd3097c 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_refutation_game.ml @@ -492,8 +492,8 @@ module Dissection = struct ~name:"gen_dissection produces a valid dissection" ~print ~gen - (fun (dissection, new_dissection, default_number_of_sections, our_states) - -> + (fun + (dissection, new_dissection, default_number_of_sections, our_states) -> let open Lwt_syntax in match new_dissection with | None -> return (final_dissection ~our_states dissection) @@ -542,16 +542,17 @@ module Dissection = struct "distance < nb_of_sections => (len dissection = succ (dist dissection))" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = 3 -- (number_of_sections - 1) in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_hash, stop_hash = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_hash, stop_hash, number_of_sections, ticks)) + let* number_of_sections = gen_num_sections in + let* ticks = 3 -- (number_of_sections - 1) in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_hash, stop_hash = + gen_dissection ~number_of_sections ~our_states dissection + in + return + (new_dissection, start_hash, stop_hash, number_of_sections, ticks)) (fun ( dissection, start_chunk, stop_chunk, @@ -575,16 +576,16 @@ module Dissection = struct ~name:"distance >= nb_of_sections => (len dissection = nb_of_sections" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = number_of_sections -- 1_000 in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) + let* number_of_sections = gen_num_sections in + let* ticks = number_of_sections -- 1_000 in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return (new_dissection, start_chunk, stop_chunk, number_of_sections)) (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> truncate_and_check_error dissection @@ -602,22 +603,22 @@ module Dissection = struct ~name:"dissection.start_chunk can not change" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - let* new_state_hash = gen_random_hash in - return - ( new_dissection, - start_chunk, - stop_chunk, - number_of_sections, - new_state_hash )) + let* number_of_sections = gen_num_sections in + let* ticks = gen_nonfinal_initial_dissection_ticks in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + let* new_state_hash = gen_random_hash in + return + ( new_dissection, + start_chunk, + stop_chunk, + number_of_sections, + new_state_hash )) (fun ( dissection, start_chunk, stop_chunk, @@ -649,16 +650,16 @@ module Dissection = struct ~name:"dissection.stop_chunk must change" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) + let* number_of_sections = gen_num_sections in + let* ticks = gen_nonfinal_initial_dissection_ticks in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return (new_dissection, start_chunk, stop_chunk, number_of_sections)) (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> let open Lwt_syntax in let check_failure_on_same_stop_hash stop_hash = @@ -694,16 +695,16 @@ module Dissection = struct "start_chunk.tick and stop_chunk.tick can not change in the dissection" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) + let* number_of_sections = gen_num_sections in + let* ticks = gen_nonfinal_initial_dissection_ticks in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return (new_dissection, start_chunk, stop_chunk, number_of_sections)) (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> let open Lwt_syntax in let expected_error dissection = @@ -751,29 +752,29 @@ module Dissection = struct ~name:"dissection must be well distributed" ~gen: (let open Gen in - (* The test is not general enough to support all kind of number of - sections. *) - let number_of_sections = - Tezos_protocol_017_PtNairob_parameters.Default_parameters - .constants_mainnet - .sc_rollup - .number_of_sections_in_dissection - in - let* picked_section = 0 -- (number_of_sections - 2) in - let* ticks = 100 -- 1_000 in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return - ( new_dissection, - start_chunk, - stop_chunk, - number_of_sections, - picked_section )) + (* The test is not general enough to support all kind of number of + sections. *) + let number_of_sections = + Tezos_protocol_017_PtNairob_parameters.Default_parameters + .constants_mainnet + .sc_rollup + .number_of_sections_in_dissection + in + let* picked_section = 0 -- (number_of_sections - 2) in + let* ticks = 100 -- 1_000 in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return + ( new_dissection, + start_chunk, + stop_chunk, + number_of_sections, + picked_section )) (fun ( dissection, start_chunk, stop_chunk, @@ -1655,15 +1656,16 @@ let test_game ?(count = 10) ~p1_strategy ~p2_strategy () = p2_strategy in qcheck_make_lwt_res - ~print: - (fun ( _block, - _rollup, - _commitment_level, - _lcc, - p1_client, - p2_client, - p1_start, - _payloads_per_levels ) -> + ~print:(fun + ( _block, + _rollup, + _commitment_level, + _lcc, + p1_client, + p2_client, + p1_start, + _payloads_per_levels ) + -> Format.asprintf "@[@,@[p1:@,%a@]@,@[p2:@,%a@]@,%s@,@]" pp_player_client diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_script_comparison.ml index e8c9c3266913e2085217034839689cee2de24d97..a058cb296b6595c298e438596b4ece8d6907aacb 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_script_comparison.ml @@ -195,9 +195,9 @@ let assert_return x = assert_ok (Lwt_main.run x) let ctxt = assert_return (let open Lwt_result_syntax in - let* b, _cs = Context.init3 () in - let* v = Incremental.begin_construction b in - return (Incremental.alpha_ctxt v)) + let* b, _cs = Context.init3 () in + let* v = Incremental.begin_construction b in + return (Incremental.alpha_ctxt v)) let unparse_comparable_ty ty = Micheline.strip_locations diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml index bc859e1506d6528ae425f44d2d63d8150f420eb4..ab28b09bc01b30a7301e64592122d924386836df 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml @@ -137,9 +137,9 @@ let test_encode_decode_internal_inbox_message_transfer () = let*? (Script_typed_ir.Ty_ex_c pair_nat_ticket_string_ty) = Environment.wrap_tzresult (let open Result_syntax in - let open Script_typed_ir in - let* ticket_t = ticket_t (-1) string_t in - pair_t (-1) nat_t ticket_t) + let open Script_typed_ir in + let* ticket_t = ticket_t (-1) string_t in + pair_t (-1) nat_t ticket_t) in let payload = ( Script_int.(abs @@ of_int 42), diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_storage.ml index eacf4255ec4bb72449aa011e6ab132b901454f9d..936e41936101fb9de5facec7474f5ef284af9c10 100644 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -1164,12 +1164,12 @@ module Stake_storage_tests = struct ~loc:__LOC__ (cement_commitment ctxt rollup commitment) (let open Sc_rollup_errors in - function - | Sc_rollup_disputed | Sc_rollup_parent_not_lcc - | Raw_context.Storage_error (Missing_key _) (* missing commitment *) - -> - true - | _ -> false)) + function + | Sc_rollup_disputed | Sc_rollup_parent_not_lcc + | Raw_context.Storage_error (Missing_key _) + (* missing commitment *) -> + true + | _ -> false)) in let* () = cant_cement ctxt honest_commitments in let* () = cant_cement ctxt dishonest_commitments in diff --git a/src/proto_017_PtNairob/lib_sc_rollup/game_helpers.ml b/src/proto_017_PtNairob/lib_sc_rollup/game_helpers.ml index b3ddddc305e12c4da450b9f45af89f5b29257023..80237a59d1c56be495ecbec0511c418923cbc1ac 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup/game_helpers.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup/game_helpers.ml @@ -104,7 +104,7 @@ module Wasm = struct (* If [is_stop_chunk_aligned] is false, we allocate one sections for the surplus. *) (if is_stop_chunk_aligned then default_number_of_sections - else default_number_of_sections - 1)) + else default_number_of_sections - 1)) max_number_of_sections in diff --git a/src/proto_017_PtNairob/lib_sc_rollup_client/configuration.ml b/src/proto_017_PtNairob/lib_sc_rollup_client/configuration.ml index 556750448844159ede5078025555fb84f081c32f..ed3d3a5c4ce956b38623c111b1d97064215a5ae5 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_client/configuration.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_client/configuration.ml @@ -85,12 +85,11 @@ let parse argv = in return (make opts, argv) -class type sc_client_context = - object - inherit Base.Client_context.io_wallet +class type sc_client_context = object + inherit Base.Client_context.io_wallet - inherit Tezos_rpc.Context.generic - end + inherit Tezos_rpc.Context.generic +end class unix_sc_client_context ~base_dir ~password_filename ~rpc_config : sc_client_context = diff --git a/src/proto_017_PtNairob/lib_sc_rollup_client/configuration.mli b/src/proto_017_PtNairob/lib_sc_rollup_client/configuration.mli index 56028f3da1439b653868644d57e7a5a0a7c593ec..3b54217a7486a6a90c8fcd40cdb05df1cdff463a 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_client/configuration.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_client/configuration.mli @@ -45,20 +45,18 @@ val global_options : (** Instance of [Tezos_client_base.Client_context] that only handles IOs and RPCs. Can be used for keys and RPCs related commands. *) -class type sc_client_context = - object - inherit Tezos_client_base.Client_context.io_wallet +class type sc_client_context = object + inherit Tezos_client_base.Client_context.io_wallet - inherit Tezos_rpc.Context.generic - end + inherit Tezos_rpc.Context.generic +end (** Instance of [sc_client_context] for linux systems. Relies on [Tezos_rpc_http_client_unix]. *) -class unix_sc_client_context : - base_dir:string - -> password_filename:string option - -> rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config - -> sc_client_context +class unix_sc_client_context : base_dir:string -> + password_filename:string option -> + rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config -> + sc_client_context (** [make_unix_client_context config] generates a unix_sc_client_context from the client configuration. *) diff --git a/src/proto_018_Proxford/lib_benchmark/autocomp.ml b/src/proto_018_Proxford/lib_benchmark/autocomp.ml index 0b3f0d8b62debbb1bc48a95a505df191e45ccaf4..18c9685b4c6a71b3c78570b57b2f9ca70073c060 100644 --- a/src/proto_018_Proxford/lib_benchmark/autocomp.ml +++ b/src/proto_018_Proxford/lib_benchmark/autocomp.ml @@ -143,11 +143,11 @@ module SM = struct fun m f rng_state s -> let x, s = m rng_state s in f x rng_state s - [@@inline] + [@@inline] let sample : 'a sampler -> 'a Inference.M.t sampler = fun x rng_state st -> (x rng_state, st) - [@@inline] + [@@inline] let deterministic : 'a Inference.M.t -> 'a t = fun x _rng_state -> x diff --git a/src/proto_018_Proxford/lib_benchmark/lib_benchmark_type_inference/inference.ml b/src/proto_018_Proxford/lib_benchmark/lib_benchmark_type_inference/inference.ml index d8c47801dca357ac1905cd72a3dd51d9c2cd7ad1..65ec8932a5e671bf1c46a9bde101e5d7b45f2a43 100644 --- a/src/proto_018_Proxford/lib_benchmark/lib_benchmark_type_inference/inference.ml +++ b/src/proto_018_Proxford/lib_benchmark/lib_benchmark_type_inference/inference.ml @@ -249,7 +249,7 @@ module M = struct let ( >>= ) m f s = let x, s = m s in f x s - [@@inline] + [@@inline] let return x s = (x, s) @@ -259,25 +259,25 @@ module M = struct fun computation state -> let res, uf = computation state.uf in (res, {state with uf}) - [@@inline] + [@@inline] let repr_lift : 'a Repr_sm.t -> 'a t = fun computation state -> let res, repr = computation state.repr in (res, {state with repr}) - [@@inline] + [@@inline] let annot_instr_lift : 'a Annot_instr_sm.t -> 'a t = fun computation state -> let res, annot_instr = computation state.annot_instr in (res, {state with annot_instr}) - [@@inline] + [@@inline] let annot_data_lift : 'a Annot_data_sm.t -> 'a t = fun computation state -> let res, annot_data = computation state.annot_data in (res, {state with annot_data}) - [@@inline] + [@@inline] let set_repr k v = repr_lift (Repr_sm.set k v) [@@inline] @@ -285,7 +285,7 @@ module M = struct repr_lift (Repr_sm.get k) >>= function | None -> Stdlib.failwith "get_repr_exn" | Some res -> return res - [@@inline] + [@@inline] let set_instr_annot k v = annot_instr_lift (Annot_instr_sm.set k v) [@@inline] @@ -400,8 +400,8 @@ and unify_base (x : Type.Base.t) (y : Type.Base.t) : unit M.t = let open M in let unify_single_var v x = (if List.mem v (Type.Base.vars x) then - raise (Ill_typed_script Cyclic_base_type) - else return ()) + raise (Ill_typed_script Cyclic_base_type) + else return ()) >>= fun () -> M.uf_lift (UF.find v) >>= fun root -> get_repr_exn root >>= fun repr -> diff --git a/src/proto_018_Proxford/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml b/src/proto_018_Proxford/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml index 4b702dd05667a8ab593401e650ca5f4a203d962d..29a59f6fc4bfcec068d382e67c16cdd540bf4a50 100644 --- a/src/proto_018_Proxford/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml +++ b/src/proto_018_Proxford/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml @@ -142,33 +142,33 @@ module Test3 = struct try ignore ((let open Inference in - let open M in - M.uf_lift Uf.UF.show >>= fun uf_state -> - Inference.M.repr_lift (fun s -> (Inference.Repr_store.to_string s, s)) - >>= fun repr_state -> - Printf.printf "uf_state:\n%s\n" uf_state ; - Printf.printf "repr_state:\n%s\n" repr_state ; - let path = - Path.(at_index 2 (at_index 0 (at_index 0 (at_index 3 root)))) - in - let subterm = Rewriter.get_subterm ~term:program ~path in - Format.printf - "subterm at path %s:\n%a\n" - (Path.to_string path) - Mikhailsky.pp - subterm ; - Inference.M.annot_instr_lift (Inference.Annot_instr_sm.get path) - >>= fun typ -> - (match typ with - | None -> assert false - | Some {bef; aft} -> - Inference.instantiate bef >>= fun bef -> - Inference.instantiate aft >>= fun aft -> - Format.printf "Type of subterm:\n" ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - return ()) - >>= fun () -> return ()) + let open M in + M.uf_lift Uf.UF.show >>= fun uf_state -> + Inference.M.repr_lift (fun s -> (Inference.Repr_store.to_string s, s)) + >>= fun repr_state -> + Printf.printf "uf_state:\n%s\n" uf_state ; + Printf.printf "repr_state:\n%s\n" repr_state ; + let path = + Path.(at_index 2 (at_index 0 (at_index 0 (at_index 3 root)))) + in + let subterm = Rewriter.get_subterm ~term:program ~path in + Format.printf + "subterm at path %s:\n%a\n" + (Path.to_string path) + Mikhailsky.pp + subterm ; + Inference.M.annot_instr_lift (Inference.Annot_instr_sm.get path) + >>= fun typ -> + (match typ with + | None -> assert false + | Some {bef; aft} -> + Inference.instantiate bef >>= fun bef -> + Inference.instantiate aft >>= fun aft -> + Format.printf "Type of subterm:\n" ; + Format.printf "bef: %a@." Type.Stack.pp bef ; + Format.printf "aft: %a@." Type.Stack.pp aft ; + return ()) + >>= fun () -> return ()) state) with Inference.Ill_typed_script error -> let s = Mikhailsky.to_string program in diff --git a/src/proto_018_Proxford/lib_benchmark/michelson_mcmc_samplers.ml b/src/proto_018_Proxford/lib_benchmark/michelson_mcmc_samplers.ml index a5b66c0f53afcd95e260889a9ef43d0b66504b78..0515479b29f642d6cecb4403f85a3a54a2c6de2a 100644 --- a/src/proto_018_Proxford/lib_benchmark/michelson_mcmc_samplers.ml +++ b/src/proto_018_Proxford/lib_benchmark/michelson_mcmc_samplers.ml @@ -211,7 +211,8 @@ end module Make_code_sampler (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) (X : sig + (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) + (X : sig val rng_state : Random.State.t val target_size : int @@ -270,7 +271,8 @@ end module Make_data_sampler (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) (X : sig + (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) + (X : sig val rng_state : Random.State.t val target_size : int diff --git a/src/proto_018_Proxford/lib_benchmark/michelson_samplers.ml b/src/proto_018_Proxford/lib_benchmark/michelson_samplers.ml index 395f9a67e92fac84d93db0249f0a5bd078e76e42..6dfba7f1bb3b75bdd75f801fa9ab4010cc89340b 100644 --- a/src/proto_018_Proxford/lib_benchmark/michelson_samplers.ml +++ b/src/proto_018_Proxford/lib_benchmark/michelson_samplers.ml @@ -258,10 +258,11 @@ exception SamplingError of string let fail_sampling error = raise (SamplingError error) -module Make (P : sig - val parameters : parameters -end) -(Crypto_samplers : Crypto_samplers.Finite_key_pool_S) : S = struct +module Make + (P : sig + val parameters : parameters + end) + (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) : S = struct module Michelson_base = Michelson_samplers_base.Make (struct let parameters = P.parameters.base_parameters end) diff --git a/src/proto_018_Proxford/lib_benchmark/sampling_helpers.ml b/src/proto_018_Proxford/lib_benchmark/sampling_helpers.ml index 8b36fc09e0bf983a58e280dd2eed654cbd151b67..b371a6aa1e1e37a7a35c65936ac8d2f212358ba7 100644 --- a/src/proto_018_Proxford/lib_benchmark/sampling_helpers.ml +++ b/src/proto_018_Proxford/lib_benchmark/sampling_helpers.ml @@ -33,7 +33,7 @@ module M = struct fun sampler f rng_state -> let x = sampler rng_state in f x rng_state - [@@inline] + [@@inline] let bind = ( let* ) diff --git a/src/proto_018_Proxford/lib_client/client_proto_args.ml b/src/proto_018_Proxford/lib_client/client_proto_args.ml index b39e84d102ec5203ee3231557da6c58f35e19473..83f69dba8bb0365e96f3cb3506974a339de7a55f 100644 --- a/src/proto_018_Proxford/lib_client/client_proto_args.ml +++ b/src/proto_018_Proxford/lib_client/client_proto_args.ml @@ -974,14 +974,15 @@ let fee_parameter_args = | None -> cctxt#error "Bad burn cap")) in Tezos_clic.map_arg - ~f: - (fun _cctxt - ( minimal_fees, - minimal_nanotez_per_byte, - minimal_nanotez_per_gas_unit, - force_low_fee, - fee_cap, - burn_cap ) -> + ~f:(fun + _cctxt + ( minimal_fees, + minimal_nanotez_per_byte, + minimal_nanotez_per_gas_unit, + force_low_fee, + fee_cap, + burn_cap ) + -> return { Injection.minimal_fees; diff --git a/src/proto_018_Proxford/lib_client/michelson_v1_macros.ml b/src/proto_018_Proxford/lib_client/michelson_v1_macros.ml index 2577ffa223d89e4e22a46cb7bd23191839292992..4e59be7406da922244e77d6eb002d6bb645265c9 100644 --- a/src/proto_018_Proxford/lib_client/michelson_v1_macros.ml +++ b/src/proto_018_Proxford/lib_client/michelson_v1_macros.ml @@ -605,7 +605,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> tzfail (Invalid_arity (str, List.length args, 2)) @@ -613,7 +613,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> tzfail (Unexpected_macro_annotation str) diff --git a/src/proto_018_Proxford/lib_client/protocol_client_context.ml b/src/proto_018_Proxford/lib_client/protocol_client_context.ml index ad1b36ea1f8db54a684f335a0d9b65b655b63a1c..09bd21be34525ea460170c3b77fca8488002a36d 100644 --- a/src/proto_018_Proxford/lib_client/protocol_client_context.ml +++ b/src/proto_018_Proxford/lib_client/protocol_client_context.ml @@ -27,14 +27,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -80,24 +78,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific protocol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_018_Proxford/lib_client_commands/client_proto_context_commands.ml b/src/proto_018_Proxford/lib_client_commands/client_proto_context_commands.ml index 97503d8ebc3f5a4a51b0359dab8d50f2bb96a616..fedf0a2c37a5ec193a6f1251cc3160192ddcebe1 100644 --- a/src/proto_018_Proxford/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_018_Proxford/lib_client_commands/client_proto_context_commands.ml @@ -737,9 +737,12 @@ let commands_ro () = (Tez.of_mutez_exn w) Operation_result.tez_sym (if - List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not ")) ranks ; pp_close_box ppf ()) else cctxt#message "The proposals have already been cleared." @@ -2531,8 +2534,8 @@ let commands_rw () = error "There %s: %a." (if Compare.List_length_with.(dups = 1) then - "is a duplicate proposal" - else "are duplicate proposals") + "is a duplicate proposal" + else "are duplicate proposals") Format.( pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf ", ") @@ -2559,7 +2562,7 @@ let commands_rw () = cctxt#message "There %s with the submission:%t" (if Compare.List_length_with.(!errors = 1) then "is an issue" - else "are issues") + else "are issues") Format.( fun ppf -> pp_print_cut ppf () ; diff --git a/src/proto_018_Proxford/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_018_Proxford/lib_client_commands/client_proto_stresstest_commands.ml index b1e114f7f075bf01a90140868456dbe8d3b31af5..a3c73baee6bf76835ffc2647b4be9fe304d649c7 100644 --- a/src/proto_018_Proxford/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_018_Proxford/lib_client_commands/client_proto_stresstest_commands.ml @@ -745,8 +745,8 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = included). Note that the operations injected during the last block \ are ignored because they should not be currently included." (if Int.equal injected_ops_count 0 then "N/A" - else - Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + else + Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) injected_ops_count included_ops_count in diff --git a/src/proto_018_Proxford/lib_client_sapling/client_sapling_commands.ml b/src/proto_018_Proxford/lib_client_sapling/client_sapling_commands.ml index 5a6292ccdba4ef0aad25c0c7d3c6cf7e8a0d781b..77d360fa153748c425111c02fd7b59ec83d9e942 100644 --- a/src/proto_018_Proxford/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_018_Proxford/lib_client_sapling/client_sapling_commands.ml @@ -378,19 +378,19 @@ let forge_shielded_cmd = let file = Option.value ~default:sapling_transaction_file file in cctxt#message "Writing transaction to %s@." file >>= fun () -> (if use_json_format then - save_json_to_file - (Data_encoding.Json.construct UTXO.transaction_encoding transaction) - file - else - let bytes = - Hex.of_bytes - (Data_encoding.Binary.to_bytes_exn - UTXO.transaction_encoding - transaction) - in - let file = open_out_bin file in - Printf.fprintf file "0x%s" (Hex.show bytes) ; - close_out file) ; + save_json_to_file + (Data_encoding.Json.construct UTXO.transaction_encoding transaction) + file + else + let bytes = + Hex.of_bytes + (Data_encoding.Binary.to_bytes_exn + UTXO.transaction_encoding + transaction) + in + let file = open_out_bin file in + Printf.fprintf file "0x%s" (Hex.show bytes) ; + close_out file) ; return_unit) let submit_shielded_cmd = @@ -446,18 +446,18 @@ let submit_shielded_cmd = >>= fun () -> let open Context in (if use_json_format then - Lwt_utils_unix.Json.read_file filename >>=? fun json -> - return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json - else - Lwt_utils_unix.read_file filename >>= fun hex -> - let hex = - (* remove 0x *) - String.sub hex 2 (String.length hex - 2) - in - return - @@ Data_encoding.Binary.of_bytes_exn - UTXO.transaction_encoding - Hex.(to_bytes_exn (`Hex hex))) + Lwt_utils_unix.Json.read_file filename >>=? fun json -> + return @@ Data_encoding.Json.destruct UTXO.transaction_encoding json + else + Lwt_utils_unix.read_file filename >>= fun hex -> + let hex = + (* remove 0x *) + String.sub hex 2 (String.length hex - 2) + in + return + @@ Data_encoding.Binary.of_bytes_exn + UTXO.transaction_encoding + Hex.(to_bytes_exn (`Hex hex))) >>=? fun transaction -> return (sapling_transaction_as_arg transaction) >>=? fun contract_input -> let chain = cctxt#chain and block = cctxt#block in @@ -712,12 +712,12 @@ let commands () = | None -> cctxt#error "Account %s not found" name | Some account -> (if verbose then - cctxt#answer - "@[Received Sapling transactions for %s@,@[%a@]@]" - name - Context.Account.pp_unspent - account - else Lwt.return_unit) + cctxt#answer + "@[Received Sapling transactions for %s@,@[%a@]@]" + name + Context.Account.pp_unspent + account + else Lwt.return_unit) >>= fun () -> cctxt#answer "Total Sapling funds %a%s" diff --git a/src/proto_018_Proxford/lib_delegate/baking_commands.ml b/src/proto_018_Proxford/lib_delegate/baking_commands.ml index d76316d25dfbb5b4465db777bc129cc482e71a46..80b69770799ecd6d64362ce60ad47f0af064bbb1 100644 --- a/src/proto_018_Proxford/lib_delegate/baking_commands.ml +++ b/src/proto_018_Proxford/lib_delegate/baking_commands.ml @@ -151,14 +151,15 @@ let per_block_vote_parameter = Tezos_clic.parameter ~autocomplete:(fun _ctxt -> return ["on"; "off"; "pass"]) (let open Protocol.Alpha_context.Per_block_votes in - fun _ctxt -> function - | "on" -> return Per_block_vote_on - | "off" -> return Per_block_vote_off - | "pass" -> return Per_block_vote_pass - | s -> - failwith - "unexpected vote: %s, expected either \"on\", \"off\", or \"pass\"." - s) + fun _ctxt -> function + | "on" -> return Per_block_vote_on + | "off" -> return Per_block_vote_off + | "pass" -> return Per_block_vote_pass + | s -> + failwith + "unexpected vote: %s, expected either \"on\", \"off\", or \ + \"pass\"." + s) let liquidity_baking_toggle_vote_arg = Tezos_clic.arg diff --git a/src/proto_018_Proxford/lib_delegate/baking_highwatermarks.ml b/src/proto_018_Proxford/lib_delegate/baking_highwatermarks.ml index d4e3201795c8e1c6d6b3a1c5fd3cc36d7a0aec33..337feaa1466ad85e8a5006f4da04cda1d5402715 100644 --- a/src/proto_018_Proxford/lib_delegate/baking_highwatermarks.ml +++ b/src/proto_018_Proxford/lib_delegate/baking_highwatermarks.ml @@ -134,11 +134,11 @@ let encoding ~use_legacy_attestation_name = (req "blocks" highwatermark_delegate_map_encoding) (req (if use_legacy_attestation_name then "preendorsements" - else "preattestations") + else "preattestations") highwatermark_delegate_map_encoding) (req (if use_legacy_attestation_name then "endorsements" - else "attestations") + else "attestations") highwatermark_delegate_map_encoding)) let load_encoding = diff --git a/src/proto_018_Proxford/lib_delegate/baking_pow.ml b/src/proto_018_Proxford/lib_delegate/baking_pow.ml index 5a7306a3e31c6f464c2aa9715fa9e7086c9ee66c..a0b690886bfb09b52976d7db142a12a301d70f6c 100644 --- a/src/proto_018_Proxford/lib_delegate/baking_pow.ml +++ b/src/proto_018_Proxford/lib_delegate/baking_pow.ml @@ -108,8 +108,8 @@ let mine ~proof_of_work_threshold shell builder = else ( Bytes.blit_string (Z.to_bits z) 0 block_header offset z_len ; (if Hacl_star.AutoConfig2.(has_feature VEC256) then - Hacl_star.Hacl.Blake2b_256.Noalloc.hash - else Hacl_star.Hacl.Blake2b_32.Noalloc.hash) + Hacl_star.Hacl.Blake2b_256.Noalloc.hash + else Hacl_star.Hacl.Blake2b_32.Noalloc.hash) ~key:Bytes.empty ~msg:block_header ~digest:block_hash_bytes ; diff --git a/src/proto_018_Proxford/lib_delegate/baking_scheduling.ml b/src/proto_018_Proxford/lib_delegate/baking_scheduling.ml index 7858c7d8a6ac9395d386da3a1f2da76fa77323f7..a22da9410d5f937c1b87ab58b12cedea6f90eae1 100644 --- a/src/proto_018_Proxford/lib_delegate/baking_scheduling.ml +++ b/src/proto_018_Proxford/lib_delegate/baking_scheduling.ml @@ -411,13 +411,13 @@ let compute_next_potential_baking_time_at_next_level state = compute the round from the current timestamp. This possibly means the baker has been late. *) (if Time.Protocol.(now < min_possible_time) then Ok Round.zero - else - Environment.wrap_tzresult - @@ Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~predecessor_round - ~timestamp:now) + else + Environment.wrap_tzresult + @@ Round.round_of_timestamp + round_durations + ~predecessor_timestamp + ~predecessor_round + ~timestamp:now) |> function | Error _ -> return_none | Ok earliest_round -> ( diff --git a/src/proto_018_Proxford/lib_delegate/client_baking_denunciation.ml b/src/proto_018_Proxford/lib_delegate/client_baking_denunciation.ml index 87b99b6fc99a6b3895bbc2d714dfb7a5dd3343cf..325e922712ffcfb2b10f40047f751c68d7bec8ef 100644 --- a/src/proto_018_Proxford/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_018_Proxford/lib_delegate/client_baking_denunciation.ml @@ -334,7 +334,7 @@ let process_operations (cctxt : #Protocol_client_context.full) state match protocol_data with | Operation_data ({contents = Single (Preattestation {round; slot; level; _}); _} as - protocol_data) -> + protocol_data) -> let new_preattestation : Kind.preattestation Alpha_context.operation = {shell; protocol_data} in @@ -349,7 +349,7 @@ let process_operations (cctxt : #Protocol_client_context.full) state slot | Operation_data ({contents = Single (Attestation {round; slot; level; _}); _} as - protocol_data) -> + protocol_data) -> let new_attestation : Kind.attestation Alpha_context.operation = {shell; protocol_data} in diff --git a/src/proto_018_Proxford/lib_delegate/operation_pool.ml b/src/proto_018_Proxford/lib_delegate/operation_pool.ml index 7d9ca75987de45da86e69ec8e9f30049660ba412..dd164bdf89e79d8d5b36e3a55b566a1cd88d18f1 100644 --- a/src/proto_018_Proxford/lib_delegate/operation_pool.ml +++ b/src/proto_018_Proxford/lib_delegate/operation_pool.ml @@ -181,8 +181,8 @@ let classify op = | None -> `Bad | Some pass -> let open Operation_repr in - if pass = consensus_pass then `Consensus - (* TODO filter outdated consensus ops ? *) + if pass = consensus_pass then + `Consensus (* TODO filter outdated consensus ops ? *) else if pass = voting_pass then `Votes else if pass = anonymous_pass then `Anonymous else if pass = manager_pass then `Managers diff --git a/src/proto_018_Proxford/lib_delegate/test/mockup_simulator/mockup_simulator.ml b/src/proto_018_Proxford/lib_delegate/test/mockup_simulator/mockup_simulator.ml index 8b8dc691dc41655bbd712085952c0e88c82a25ec..ca213f90e6beaf971074d7ea922ac13958ce35c9 100644 --- a/src/proto_018_Proxford/lib_delegate/test/mockup_simulator/mockup_simulator.ml +++ b/src/proto_018_Proxford/lib_delegate/test/mockup_simulator/mockup_simulator.ml @@ -321,13 +321,13 @@ let make_mocked_services_hooks (state : state) (user_hooks : (module Hooks)) : { current_protocol = (if - Block_hash.equal hash genesis_block_hash - || is_predecessor_of_genesis - then Protocol_hash.zero - else Protocol.hash); + Block_hash.equal hash genesis_block_hash + || is_predecessor_of_genesis + then Protocol_hash.zero + else Protocol.hash); next_protocol = (if is_predecessor_of_genesis then Protocol_hash.zero - else Protocol.hash); + else Protocol.hash); } let may_lie_on_proto_level block x = @@ -762,12 +762,13 @@ let rec listener ~(user_hooks : (module Hooks)) ~state ~broadcast_pipe = Lwt_pipe.Unbounded.pop broadcast_pipe >>= function | Broadcast_op (operation_hash, packed_operation) -> (if - List.mem_assoc ~equal:Operation_hash.equal operation_hash state.mempool - then return_unit - else ( - state.mempool <- (operation_hash, packed_operation) :: state.mempool ; - state.operations_stream_push (Some [(operation_hash, packed_operation)]) ; - User_hooks.check_mempool_after_processing ~mempool:state.mempool)) + List.mem_assoc ~equal:Operation_hash.equal operation_hash state.mempool + then return_unit + else ( + state.mempool <- (operation_hash, packed_operation) :: state.mempool ; + state.operations_stream_push + (Some [(operation_hash, packed_operation)]) ; + User_hooks.check_mempool_after_processing ~mempool:state.mempool)) >>=? fun () -> listener ~user_hooks ~state ~broadcast_pipe | Broadcast_block (block_hash, block_header, operations) -> get_block_level block_header >>=? fun level -> @@ -1215,7 +1216,7 @@ let run ?(config = default_config) bakers_spec = In particular, it seems that when logging is enabled the baker process can get cancelled without executing its Lwt finalizer. *) (if config.debug then Tezos_base_unix.Internal_event_unix.init () - else Lwt.return_unit) + else Lwt.return_unit) >>= fun () -> let total_bakers = List.length bakers_spec in (List.init ~when_negative_length:() total_bakers (fun _ -> diff --git a/src/proto_018_Proxford/lib_parameters/default_parameters.ml b/src/proto_018_Proxford/lib_parameters/default_parameters.ml index 13628838245f36f1ef8edd12542af2a8942f4eb9..421cdb3a5a35c2943be41d5eaa0e8839052a808e 100644 --- a/src/proto_018_Proxford/lib_parameters/default_parameters.ml +++ b/src/proto_018_Proxford/lib_parameters/default_parameters.ml @@ -233,15 +233,15 @@ let constants_mainnet = metadata = Raw_level.root; dal_page = (if default_dal.feature_enable then Raw_level.root - else - (* Deactivate the reveal if the dal is not enabled. *) - (* https://gitlab.com/tezos/tezos/-/issues/5968 - Encoding error with Raw_level - - We set the activation level to [pred max_int] to deactivate - the feature. The [pred] is needed to not trigger an encoding - exception with the value [Int32.int_min] (see tezt/tests/mockup.ml). *) - Raw_level.of_int32_exn Int32.(pred max_int)); + else + (* Deactivate the reveal if the dal is not enabled. *) + (* https://gitlab.com/tezos/tezos/-/issues/5968 + Encoding error with Raw_level + + We set the activation level to [pred max_int] to deactivate + the feature. The [pred] is needed to not trigger an encoding + exception with the value [Int32.int_min] (see tezt/tests/mockup.ml). *) + Raw_level.of_int32_exn Int32.(pred max_int)); }; }; zk_rollup = diff --git a/src/proto_018_Proxford/lib_plugin/RPC.ml b/src/proto_018_Proxford/lib_plugin/RPC.ml index 6bff9bb765fd5b211b4c643cafcead086217496f..9fe320c3c56b4f71d3cbdb4994c98e12d493ddb9 100644 --- a/src/proto_018_Proxford/lib_plugin/RPC.ml +++ b/src/proto_018_Proxford/lib_plugin/RPC.ml @@ -3385,7 +3385,7 @@ module Attestation_rights = struct (req "first_slot" Slot.encoding) (req (if use_legacy_attestation_name then "endorsing_power" - else "attestation_power") + else "attestation_power") uint16) (req "consensus_key" Signature.Public_key_hash.encoding)) diff --git a/src/proto_018_Proxford/lib_plugin/mempool.ml b/src/proto_018_Proxford/lib_plugin/mempool.ml index 5b9cf6f28efddfeae1efe64c6f50a48e4e892868..e7963beace1131476998cb664d8f7b58fcb6385c 100644 --- a/src/proto_018_Proxford/lib_plugin/mempool.ml +++ b/src/proto_018_Proxford/lib_plugin/mempool.ml @@ -651,25 +651,25 @@ let fee_needed_to_replace_by_fee config ~op_to_replace ~candidate_op = if is_manager_operation candidate_op && is_manager_operation op_to_replace then (let open Result_syntax in - let* _fee, candidate_gas = compute_fee_and_gas_limit candidate_op in - let* old_fee, old_gas = compute_fee_and_gas_limit op_to_replace in - if Gas.Arith.(old_gas = zero || candidate_gas = zero) then - (* This should not happen when both operations are valid. *) - Result.return_none - else - let candidate_gas = gas_as_q candidate_gas in - let bumped_old_fee, bumped_old_ratio = - bumped_fee_and_ratio_as_q config old_fee old_gas - in - (* The new operation needs to exceed both the bumped fee and the - bumped ratio to make {!better_fees_and_ratio} return [true]. - (Having fee or ratio equal to its bumped counterpart is ok too, - hence the [ceil] in [int64_ceil_of_q].) *) - let fee_needed_for_fee = int64_ceil_of_q bumped_old_fee in - let fee_needed_for_ratio = - int64_ceil_of_q Q.(bumped_old_ratio * candidate_gas) - in - Result.return_some (max fee_needed_for_fee fee_needed_for_ratio)) + let* _fee, candidate_gas = compute_fee_and_gas_limit candidate_op in + let* old_fee, old_gas = compute_fee_and_gas_limit op_to_replace in + if Gas.Arith.(old_gas = zero || candidate_gas = zero) then + (* This should not happen when both operations are valid. *) + Result.return_none + else + let candidate_gas = gas_as_q candidate_gas in + let bumped_old_fee, bumped_old_ratio = + bumped_fee_and_ratio_as_q config old_fee old_gas + in + (* The new operation needs to exceed both the bumped fee and the + bumped ratio to make {!better_fees_and_ratio} return [true]. + (Having fee or ratio equal to its bumped counterpart is ok too, + hence the [ceil] in [int64_ceil_of_q].) *) + let fee_needed_for_fee = int64_ceil_of_q bumped_old_fee in + let fee_needed_for_ratio = + int64_ceil_of_q Q.(bumped_old_ratio * candidate_gas) + in + Result.return_some (max fee_needed_for_fee fee_needed_for_ratio)) |> Option.of_result |> Option.join else None @@ -747,23 +747,25 @@ let fee_needed_to_overtake ~op_to_overtake ~candidate_op = if is_manager_operation candidate_op && is_manager_operation op_to_overtake then (let open Result_syntax in - let* _fee, candidate_gas = compute_fee_and_gas_limit candidate_op in - let* target_fee, target_gas = compute_fee_and_gas_limit op_to_overtake in - if Gas.Arith.(target_gas = zero || candidate_gas = zero) then - (* This should not happen when both operations are valid. *) - Result.return_none - else - (* Compute the target ratio as in {!Operation_repr.weight_manager}. - We purposefully don't use {!fee_and_ratio_as_q} because the code - here needs to stay in sync with {!Operation_repr.weight_manager} - rather than {!better_fees_and_ratio}. *) - let target_fee = Q.of_int64 (Tez.to_mutez target_fee) in - let target_gas = Q.of_bigint (Gas.Arith.integral_to_z target_gas) in - let target_ratio = Q.(target_fee / target_gas) in - (* Compute the minimal fee needed to have a strictly greater ratio. *) - let candidate_gas = Q.of_bigint (Gas.Arith.integral_to_z candidate_gas) in - Result.return_some - (Int64.succ Q.(to_int64 (target_ratio * candidate_gas)))) + let* _fee, candidate_gas = compute_fee_and_gas_limit candidate_op in + let* target_fee, target_gas = compute_fee_and_gas_limit op_to_overtake in + if Gas.Arith.(target_gas = zero || candidate_gas = zero) then + (* This should not happen when both operations are valid. *) + Result.return_none + else + (* Compute the target ratio as in {!Operation_repr.weight_manager}. + We purposefully don't use {!fee_and_ratio_as_q} because the code + here needs to stay in sync with {!Operation_repr.weight_manager} + rather than {!better_fees_and_ratio}. *) + let target_fee = Q.of_int64 (Tez.to_mutez target_fee) in + let target_gas = Q.of_bigint (Gas.Arith.integral_to_z target_gas) in + let target_ratio = Q.(target_fee / target_gas) in + (* Compute the minimal fee needed to have a strictly greater ratio. *) + let candidate_gas = + Q.of_bigint (Gas.Arith.integral_to_z candidate_gas) + in + Result.return_some + (Int64.succ Q.(to_int64 (target_ratio * candidate_gas)))) |> Option.of_result |> Option.join else None diff --git a/src/proto_018_Proxford/lib_plugin/script_interpreter_logging.ml b/src/proto_018_Proxford/lib_plugin/script_interpreter_logging.ml index 6244eaf730fc1d765cf9288b7679b63f5bc57860..d9120f03b3ad6f308918a0e07516e176aaf6a0a6 100644 --- a/src/proto_018_Proxford/lib_plugin/script_interpreter_logging.ml +++ b/src/proto_018_Proxford/lib_plugin/script_interpreter_logging.ml @@ -2292,7 +2292,7 @@ module Logger (Base : Logger_base) = struct accu stack | _ -> (step [@ocaml.tailcall]) g gas k ks accu stack - [@@inline] + [@@inline] let klog : type a s r f. @@ -2405,7 +2405,7 @@ module Logger (Base : Logger_base) = struct (* This case should never happen. *) (next [@ocaml.tailcall]) g gas k accu stack | KNil as k -> (next [@ocaml.tailcall]) g gas k accu stack - [@@inline] + [@@inline] end let make (module Base : Logger_base) = diff --git a/src/proto_018_Proxford/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml b/src/proto_018_Proxford/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml index acd420fe74e264f199da609b490b85c1bc1b1447..19ba5a5848c44d563ebcb15ddeaf7cea34dbdc98 100644 --- a/src/proto_018_Proxford/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml +++ b/src/proto_018_Proxford/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml @@ -95,24 +95,24 @@ let test_manager_ops config (op_to_replace, fee_r, gas_r) (fst candidate_op, Helpers.set_fee fee (snd candidate_op)) in (if fee_needed > 0L then - let fee_smaller = Int64.pred fee_needed in - match - Plugin.Mempool.conflict_handler - config - ~existing_operation:op_to_replace - ~new_operation:(with_fee fee_smaller) - with - | `Keep -> () - | `Replace -> - Test.fail - ~__LOC__ - "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee smaller than \ - fee_needed should not be allowed to replace op_to_replace: \ - {fee=%dmutez; gas=%d}" - fee_smaller - gas_c - fee_r - gas_r) ; + let fee_smaller = Int64.pred fee_needed in + match + Plugin.Mempool.conflict_handler + config + ~existing_operation:op_to_replace + ~new_operation:(with_fee fee_smaller) + with + | `Keep -> () + | `Replace -> + Test.fail + ~__LOC__ + "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee smaller \ + than fee_needed should not be allowed to replace op_to_replace: \ + {fee=%dmutez; gas=%d}" + fee_smaller + gas_c + fee_r + gas_r) ; match Plugin.Mempool.conflict_handler config diff --git a/src/proto_018_Proxford/lib_protocol/test/helpers/block.ml b/src/proto_018_Proxford/lib_protocol/test/helpers/block.ml index d984eaa3f848cafeeab002c9420014f73b956f48..d7f425d7cb5ede6ce017af23d2eb546a7363fafc 100644 --- a/src/proto_018_Proxford/lib_protocol/test/helpers/block.ml +++ b/src/proto_018_Proxford/lib_protocol/test/helpers/block.ml @@ -785,19 +785,19 @@ let apply_with_metadata ?(policy = By_round 0) ?(check_size = true) ~baking_mode List.fold_left_es (fun vstate op -> (if check_size then - let operation_size = - Data_encoding.Binary.length - Operation.encoding_with_legacy_attestation_name - op - in - if operation_size > Constants_repr.max_operation_data_length then - raise - (invalid_arg - (Format.sprintf - "The operation size is %d, it exceeds the constant maximum \ - size %d" - operation_size - Constants_repr.max_operation_data_length))) ; + let operation_size = + Data_encoding.Binary.length + Operation.encoding_with_legacy_attestation_name + op + in + if operation_size > Constants_repr.max_operation_data_length then + raise + (invalid_arg + (Format.sprintf + "The operation size is %d, it exceeds the constant \ + maximum size %d" + operation_size + Constants_repr.max_operation_data_length))) ; validate_and_apply_operation vstate op >>=? fun (state, result) -> if allow_manager_failures then return state else diff --git a/src/proto_018_Proxford/lib_protocol/test/helpers/dummy_zk_rollup.ml b/src/proto_018_Proxford/lib_protocol/test/helpers/dummy_zk_rollup.ml index d02f6f5c5c43ebaa16fa005e84a7778b20e9e88c..03875ec112fd0ee9dcd40b0ff3889fe42d665cb9 100644 --- a/src/proto_018_Proxford/lib_protocol/test/helpers/dummy_zk_rollup.ml +++ b/src/proto_018_Proxford/lib_protocol/test/helpers/dummy_zk_rollup.ml @@ -380,7 +380,7 @@ end = struct let lazy_srs = lazy (let open Octez_bls12_381_polynomial in - (Srs.generate_insecure 9 1, Srs.generate_insecure 1 1)) + (Srs.generate_insecure 9 1, Srs.generate_insecure 1 1)) let dummy_l1_dst = Hex.to_bytes_exn (`Hex "0002298c03ed7d454a101eb7022bc95f7e5f41ac78") diff --git a/src/proto_018_Proxford/lib_protocol/test/helpers/liquidity_baking_machine.ml b/src/proto_018_Proxford/lib_protocol/test/helpers/liquidity_baking_machine.ml index 46f0fcf200e24216cfaa1fe47b5608b6a9972b37..b78550fe581f4991b293b3af2f3ddf196d2e3f93 100644 --- a/src/proto_018_Proxford/lib_protocol/test/helpers/liquidity_baking_machine.ml +++ b/src/proto_018_Proxford/lib_protocol/test/helpers/liquidity_baking_machine.ml @@ -649,7 +649,7 @@ module MachineBuilder = struct fun ?(invariant = fun _ _ -> pure true) ?(subsidy = default_subsidy) ({cpmm_min_xtz_balance; accounts_balances; cpmm_min_tzbtc_balance} as - specs) -> + specs) -> let accounts_balances_with_extra = predict_initial_balances accounts_balances subsidy in @@ -684,13 +684,14 @@ module MachineBuilder = struct >>= fun current_cpmm_tzbtc_balance -> let tzbtc_missing = cpmm_min_tzbtc_balance - current_cpmm_tzbtc_balance in (if 0 < tzbtc_missing then - (* 4.1. Provide the tokens to the [bootstrap1] account, as a - temporary holder for CPMM missing tzBTC balance *) - mint_tzbtc ~invariant env.holder tzbtc_missing env state >>= fun state -> - (* 4.1. Make [bootstrap1] buy some xtz against the appropriate - amount of tzbtc *) - sell_tzbtc ~invariant env.holder env.holder tzbtc_missing env state - else pure state) + (* 4.1. Provide the tokens to the [bootstrap1] account, as a + temporary holder for CPMM missing tzBTC balance *) + mint_tzbtc ~invariant env.holder tzbtc_missing env state + >>= fun state -> + (* 4.1. Make [bootstrap1] buy some xtz against the appropriate + amount of tzbtc *) + sell_tzbtc ~invariant env.holder env.holder tzbtc_missing env state + else pure state) >>= fun state -> (* 5. Provide any missing xtz tokens to [cpmm_contract], if necessary *) get_xtz_balance env.cpmm_contract state @@ -699,9 +700,9 @@ module MachineBuilder = struct Int64.sub cpmm_min_xtz_balance current_cpmm_xtz_balance in (if 0L < xtz_missing then - transaction ~src:env.holder env.cpmm_contract xtz_missing state - >>= fun op -> bake ~invariant ~baker:env.holder [op] env state - else pure state) + transaction ~src:env.holder env.cpmm_contract xtz_missing state + >>= fun op -> bake ~invariant ~baker:env.holder [op] env state + else pure state) >>= fun state -> check_state_satisfies_specs env state specs >>= fun () -> pure (state, env) end diff --git a/src/proto_018_Proxford/lib_protocol/test/helpers/op.ml b/src/proto_018_Proxford/lib_protocol/test/helpers/op.ml index adca2dd339015d5c80ed990ec25bda843759d3fc..ab86eca0c354399c96e3b5cc7bd4b8862c932129 100644 --- a/src/proto_018_Proxford/lib_protocol/test/helpers/op.ml +++ b/src/proto_018_Proxford/lib_protocol/test/helpers/op.ml @@ -183,20 +183,20 @@ let batch_operations ?(recompute_counters = false) ~source ctxt |> List.flatten in (if recompute_counters then - Context.Contract.counter ctxt source >>=? fun counter -> - (* Update counters and transform into a contents_list *) - let _, rev_operations = - List.fold_left - (fun (counter, acc) -> function - | Contents (Manager_operation m) -> - ( Manager_counter.succ counter, - Contents (Manager_operation {m with counter}) :: acc ) - | x -> (counter, x :: acc)) - (Manager_counter.succ counter, []) - operations - in - return (List.rev rev_operations) - else return operations) + Context.Contract.counter ctxt source >>=? fun counter -> + (* Update counters and transform into a contents_list *) + let _, rev_operations = + List.fold_left + (fun (counter, acc) -> function + | Contents (Manager_operation m) -> + ( Manager_counter.succ counter, + Contents (Manager_operation {m with counter}) :: acc ) + | x -> (counter, x :: acc)) + (Manager_counter.succ counter, []) + operations + in + return (List.rev rev_operations) + else return operations) >>=? fun operations -> Context.Contract.manager ctxt source >>=? fun account -> Environment.wrap_tzresult @@ Operation.of_list operations diff --git a/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_baking.ml b/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_baking.ml index 610bda7b6c6a8f898944ee8e7e9b8b5c40de1213..4b1c6dedb1eda489d5541867074c9c3a02083740 100644 --- a/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_baking.ml +++ b/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_baking.ml @@ -224,8 +224,8 @@ let test_rewards_block_and_payload_producer () = Context.get_baking_reward_fixed_portion (B b2) >>=? fun baking_reward -> Context.get_bonus_reward (B b2) ~attesting_power >>=? fun bonus_reward -> (if Signature.Public_key_hash.equal baker_b2 baker_b1 then - Context.get_baking_reward_fixed_portion (B b1) - else return Tez.zero) + Context.get_baking_reward_fixed_portion (B b1) + else return Tez.zero) >>=? fun reward_for_b1 -> (* we are in the first scenario where the payload producer is the same as the block producer, in our case, [baker_b2]. [baker_b2] gets the baking reward diff --git a/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_consensus_key.ml b/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_consensus_key.ml index 410f371499a0ea9579940420e36545d265dfc57a..b54a42def393f7658f6f602ecdd47c3529ce0cef 100644 --- a/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_consensus_key.ml +++ b/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_consensus_key.ml @@ -132,18 +132,23 @@ let test_drain_delegate ~low_balance ~exclude_ck ~ck_delegates () = else Block.By_account delegate in (if ck_delegates then - may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> - delegate_stake blk consensus_pkh delegate - else return blk) + may_reveal_manager_key blk (consensus_pkh, consensus_pk) + >>=? fun blk -> delegate_stake blk consensus_pkh delegate + else return blk) >>=? fun blk -> Context.Contract.balance (B blk) (Contract.Implicit delegate) >>=? fun delegate_balance -> (if low_balance then - transfer_tokens blk delegate consensus_pkh delegate_balance - >>=? fun blk -> - may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> - transfer_tokens blk consensus_pkh delegate Tez.(of_mutez_exn 1_000_000L) - else return blk) + transfer_tokens blk delegate consensus_pkh delegate_balance + >>=? fun blk -> + may_reveal_manager_key blk (consensus_pkh, consensus_pk) + >>=? fun blk -> + transfer_tokens + blk + consensus_pkh + delegate + Tez.(of_mutez_exn 1_000_000L) + else return blk) >>=? fun blk -> Context.Contract.balance (B blk) (Contract.Implicit delegate) >>=? fun delegate_balance -> diff --git a/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_double_attestation.ml b/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_double_attestation.ml index 226e1b8b0d9a7c4be2f702987587a1f40ebfeef0..60446158fa12eb2b7f095e0bae933146a612fd7e 100644 --- a/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_double_attestation.ml +++ b/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_double_attestation.ml @@ -352,8 +352,8 @@ let test_freeze_more_with_low_balance = | [d1; d2] -> return (if Signature.Public_key_hash.equal account d1.delegate then d1 - else if Signature.Public_key_hash.equal account d2.delegate then d2 - else assert false) + else if Signature.Public_key_hash.equal account d2.delegate then d2 + else assert false) .slots | _ -> assert false (* there are exactly two attesters for this test. *) diff --git a/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_seed.ml b/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_seed.ml index 59b1fddb3cb93d93cea56eb75d23cac09f434c3e..a2bacae10bda307054cdc3e2d4631f49c14b0f47 100644 --- a/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_seed.ml +++ b/src/proto_018_Proxford/lib_protocol/test/integration/consensus/test_seed.ml @@ -65,14 +65,14 @@ let test_seed_no_commitment () = let* s = Context.get_seed (B b) in let seed_bytes = Data_encoding.Binary.to_bytes_exn Seed.seed_encoding s in (if expected_seed <> seed_bytes then - let seed_pp = - Hex.show - (Hex.of_string - (Data_encoding.Binary.to_string_exn Seed.seed_encoding s)) - in - let expected_seed_pp = Hex.show (Hex.of_bytes expected_seed) in - Stdlib.failwith - (Format.sprintf "Seed: %s\nExpected: %s\n\n" seed_pp expected_seed_pp)) ; + let seed_pp = + Hex.show + (Hex.of_string + (Data_encoding.Binary.to_string_exn Seed.seed_encoding s)) + in + let expected_seed_pp = Hex.show (Hex.of_bytes expected_seed) in + Stdlib.failwith + (Format.sprintf "Seed: %s\nExpected: %s\n\n" seed_pp expected_seed_pp)) ; return b in let rec bake_and_check_seed b = function diff --git a/src/proto_018_Proxford/lib_protocol/test/integration/gas/test_gas_levels.ml b/src/proto_018_Proxford/lib_protocol/test/integration/gas/test_gas_levels.ml index 02d74ec3543a2599282a036d7fab612718495dfe..e25c1fd53f61b4da24a6bd32bb706d8bd996c745 100644 --- a/src/proto_018_Proxford/lib_protocol/test/integration/gas/test_gas_levels.ml +++ b/src/proto_018_Proxford/lib_protocol/test/integration/gas/test_gas_levels.ml @@ -216,20 +216,20 @@ let finalize_validation_and_application (validation_state, application_state) let apply_with_gas header ?(operations = []) (pred : Block.t) = let open Alpha_context in (let open Environment.Error_monad in - begin_validation_and_application - pred.context - Chain_id.zero - (Application header) - ~predecessor:pred.header.shell - >>=? fun vstate -> - List.fold_left_es - (fun vstate op -> - validate_and_apply_operation vstate op >|=? fun (state, _result) -> state) - vstate - operations - >>=? fun vstate -> - finalize_validation_and_application vstate (Some header.shell) - >|=? fun (validation, result) -> (validation.context, result.consumed_gas)) + begin_validation_and_application + pred.context + Chain_id.zero + (Application header) + ~predecessor:pred.header.shell + >>=? fun vstate -> + List.fold_left_es + (fun vstate op -> + validate_and_apply_operation vstate op >|=? fun (state, _result) -> state) + vstate + operations + >>=? fun vstate -> + finalize_validation_and_application vstate (Some header.shell) + >|=? fun (validation, result) -> (validation.context, result.consumed_gas)) >|= Environment.wrap_tzresult >|=? fun (context, consumed_gas) -> let hash = Block_header.hash header in diff --git a/src/proto_018_Proxford/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_018_Proxford/lib_protocol/test/integration/michelson/test_typechecking.ml index 5b5d229c630ed9ede2cf72de2eaa3255404e5581..883323364b57ba4595cde358f56225753fa3d493 100644 --- a/src/proto_018_Proxford/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_018_Proxford/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -582,8 +582,8 @@ let test_unparse_data loc ctxt ty x ~expected_readable ~expected_optimized = ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Readable ty x >>=? fun (actual_readable, ctxt) -> (if actual_readable = Micheline.strip_locations expected_readable then - return ctxt - else Alcotest.failf "Error in readable unparsing: %s" loc) + return ctxt + else Alcotest.failf "Error in readable unparsing: %s" loc) >>=? fun ctxt -> Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty x >>=? fun (actual_optimized, ctxt) -> diff --git a/src/proto_018_Proxford/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_018_Proxford/lib_protocol/test/integration/operations/test_sc_rollup.ml index cb33ec227cc1011891be046ec5a59449bfa532de..6e7f6f45b6c002fcfe8d2687008d119a2cabedaa 100644 --- a/src/proto_018_Proxford/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_018_Proxford/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -431,16 +431,16 @@ let verify_execute_outbox_message_operations incr rollup ~loc ~operations let*? ctxt = Environment.wrap_tzresult (let open Result_syntax in - let* eq, ctxt = - Gas_monad.run - ctxt - (Script_ir_translator.ty_eq - ~error_details:(Informative (-1)) - script_parameters_ty - parameters_ty) - in - let+ Eq = eq in - ctxt) + let* eq, ctxt = + Gas_monad.run + ctxt + (Script_ir_translator.ty_eq + ~error_details:(Informative (-1)) + script_parameters_ty + parameters_ty) + in + let+ Eq = eq in + ctxt) in return (ctxt, (destination, entrypoint, unparsed_parameters)) | _ -> @@ -656,8 +656,8 @@ let execute_outbox_message_without_proof_validation incr rollup let*@ res, ctxt = Sc_rollup_operations.Internal_for_tests.execute_outbox_message (Incremental.alpha_ctxt incr) - ~validate_and_decode_output_proof: - (fun ctxt ~cemented_commitment:_ _rollup ~output_proof:_ -> + ~validate_and_decode_output_proof:(fun + ctxt ~cemented_commitment:_ _rollup ~output_proof:_ -> return (outbox_message, ctxt)) rollup ~cemented_commitment @@ -3458,7 +3458,7 @@ let test_start_game_on_cemented_commitment () = let expect_apply_failure = function | Environment.Ecoproto_error (Sc_rollup_errors.Sc_rollup_wrong_staker_for_conflict_commitment _ - as e) + as e) :: _ -> Assert.test_error_encodings e ; return_unit diff --git a/src/proto_018_Proxford/lib_protocol/test/integration/operations/test_voting.ml b/src/proto_018_Proxford/lib_protocol/test/integration/operations/test_voting.ml index c34f1d6fd7a694c2aa605f212af30f0c5601f359..2ac4165abdf109f4587c894fdb2b18d400cd8558 100644 --- a/src/proto_018_Proxford/lib_protocol/test/integration/operations/test_voting.ml +++ b/src/proto_018_Proxford/lib_protocol/test/integration/operations/test_voting.ml @@ -456,7 +456,7 @@ let test_successful_vote num_delegates () = (* no proposals at the beginning of proposal period *) Context.Vote.get_proposals (B b) >>=? fun ps -> (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) + else failwith "%s - Unexpected proposals" __LOC__) >>=? fun () -> (* no current proposal during proposal period *) (Context.Vote.get_current_proposal (B b) >>=? function @@ -545,7 +545,7 @@ let test_successful_vote num_delegates () = (* no proposals during exploration period *) Context.Vote.get_proposals (B b) >>=? fun ps -> (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) + else failwith "%s - Unexpected proposals" __LOC__) >>=? fun () -> (* current proposal must be set during exploration period *) (Context.Vote.get_current_proposal (B b) >>=? function @@ -623,7 +623,7 @@ let test_successful_vote num_delegates () = (* no proposals during promotion period *) Context.Vote.get_proposals (B b) >>=? fun ps -> (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) + else failwith "%s - Unexpected proposals" __LOC__) >>=? fun () -> (* current proposal must be set during promotion period *) (Context.Vote.get_current_proposal (B b) >>=? function @@ -878,9 +878,9 @@ let test_supermajority_in_proposal there_is_a_winner () = minimal_stake >>=? fun op2 -> (if there_is_a_winner then Test_tez.( *? ) minimal_stake 3L - else - Test_tez.( *? ) minimal_stake 2L - >>? Test_tez.( +? ) (Test_tez.of_mutez_exn initial_balance)) + else + Test_tez.( *? ) minimal_stake 2L + >>? Test_tez.( +? ) (Test_tez.of_mutez_exn initial_balance)) >>?= fun bal3 -> Op.transaction (B b) @@ -905,7 +905,7 @@ let test_supermajority_in_proposal there_is_a_winner () = (* we remain in the proposal period when there is no winner, otherwise we move to the exploration period *) (if there_is_a_winner then assert_period ~expected_kind:Exploration b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) + else assert_period ~expected_kind:Proposal b __LOC__) >>=? fun () -> return_unit (** After one voting period, if [has_quorum] then the period kind must @@ -941,7 +941,7 @@ let test_quorum_in_proposal has_quorum () = (* we remain in the proposal period when there is no quorum, otherwise we move to the cooldown vote period *) (if has_quorum then assert_period ~expected_kind:Exploration b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) + else assert_period ~expected_kind:Proposal b __LOC__) >>=? fun () -> return_unit (** If a supermajority is reached, then the voting period must be @@ -985,7 +985,7 @@ let test_supermajority_in_exploration supermajority () = Block.bake ~operations b >>=? fun b -> bake_until_first_block_of_next_period b >>=? fun b -> (if supermajority then assert_period ~expected_kind:Cooldown b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) + else assert_period ~expected_kind:Proposal b __LOC__) >>=? fun () -> return_unit (** Test also how the selection scales: all delegates propose max diff --git a/src/proto_018_Proxford/lib_protocol/test/pbt/test_bytes_conversion.ml b/src/proto_018_Proxford/lib_protocol/test/pbt/test_bytes_conversion.ml index 3481e7b026290a7658acfbff0153e8d8f851b670..263e5a8cc9cd41532eee2eedb478598ffecfdda0 100644 --- a/src/proto_018_Proxford/lib_protocol/test/pbt/test_bytes_conversion.ml +++ b/src/proto_018_Proxford/lib_protocol/test/pbt/test_bytes_conversion.ml @@ -161,9 +161,9 @@ let test_bytes_of_int_random () = (* [bytes_of_int] must return the shortest encoding: at most 1 char of zero or '\255's at the head. *) (if Bytes.length bytes >= 2 then - match (Bytes.get bytes 0, Bytes.get bytes 1) with - | '\000', '\000' | '\255', '\255' -> assert false - | _ -> ()) ; + match (Bytes.get bytes 0, Bytes.get bytes 1) with + | '\000', '\000' | '\255', '\255' -> assert false + | _ -> ()) ; (* [int_of_bytes @@ bytes_of_int z = z] *) (let z' = to_zint @@ int_of_bytes_be bytes in Z.Compare.(z = z')) diff --git a/src/proto_018_Proxford/lib_protocol/test/pbt/test_carbonated_map.ml b/src/proto_018_Proxford/lib_protocol/test/pbt/test_carbonated_map.ml index f08a3a432c051c99a5cb752d0152b51a45e5a114..4cf0060249a2d51fd6a945e6fea3e15d54e8a006 100644 --- a/src/proto_018_Proxford/lib_protocol/test/pbt/test_carbonated_map.ml +++ b/src/proto_018_Proxford/lib_protocol/test/pbt/test_carbonated_map.ml @@ -79,9 +79,9 @@ let pp_int_map fmt map = in Lwt_main.run (let open Lwt_result_syntax in - let* ctxt = new_ctxt () in - let*?@ kvs, _ = CM.to_list ctxt map in - return kvs) + let* ctxt = new_ctxt () in + let*?@ kvs, _ = CM.to_list ctxt map in + return kvs) |> Result.value_f ~default:(fun () -> assert false) |> Format.fprintf fmt "%a" pp diff --git a/src/proto_018_Proxford/lib_protocol/test/pbt/test_gas_properties.ml b/src/proto_018_Proxford/lib_protocol/test/pbt/test_gas_properties.ml index 279f5dd8dd8323a7196a196d09042b1c4b6563bf..4d9388d63970ad2e10d8ae2edda6ad7747eac640 100644 --- a/src/proto_018_Proxford/lib_protocol/test/pbt/test_gas_properties.ml +++ b/src/proto_018_Proxford/lib_protocol/test/pbt/test_gas_properties.ml @@ -46,33 +46,33 @@ let test_free_neutral (start, any_cost) = let open Alpha_context in extract_qcheck_result (let open Result_syntax in - let* free_first = Gas.consume start Gas.free in - let* branch1 = Gas.consume free_first any_cost in - let* cost_first = Gas.consume start any_cost in - let+ branch2 = Gas.consume cost_first Gas.free in - let equal_consumption_from_start t1 t2 = - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:t1) - (Gas.consumed ~since:start ~until:t2)) - in - equal_consumption_from_start branch1 branch2 - && equal_consumption_from_start branch1 cost_first) + let* free_first = Gas.consume start Gas.free in + let* branch1 = Gas.consume free_first any_cost in + let* cost_first = Gas.consume start any_cost in + let+ branch2 = Gas.consume cost_first Gas.free in + let equal_consumption_from_start t1 t2 = + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:t1) + (Gas.consumed ~since:start ~until:t2)) + in + equal_consumption_from_start branch1 branch2 + && equal_consumption_from_start branch1 cost_first) (** Consuming [Gas.free] is equivalent to consuming nothing. *) let test_free_consumption start = let open Alpha_context in extract_qcheck_result (let open Result_syntax in - let+ after_empty_consumption = Gas.consume start Gas.free in - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:after_empty_consumption) - zero)) + let+ after_empty_consumption = Gas.consume start Gas.free in + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:after_empty_consumption) + zero)) (** Consuming [cost1] then [cost2] is equivalent to consuming [Gas.(cost1 +@ cost2)]. *) @@ -80,26 +80,26 @@ let test_consume_commutes (start, cost1, cost2) = let open Alpha_context in extract_qcheck_result (let open Result_syntax in - let* after_cost1 = Gas.consume start cost1 in - let* branch1 = Gas.consume after_cost1 cost2 in - let+ branch2 = Gas.consume start Gas.(cost1 +@ cost2) in - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:branch1) - (Gas.consumed ~since:start ~until:branch2))) + let* after_cost1 = Gas.consume start cost1 in + let* branch1 = Gas.consume after_cost1 cost2 in + let+ branch2 = Gas.consume start Gas.(cost1 +@ cost2) in + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:branch1) + (Gas.consumed ~since:start ~until:branch2))) (** Arbitrary context with a gas limit of 100_000_000. *) let context_gen : Alpha_context.t QCheck2.Gen.t = QCheck2.Gen.return (Lwt_main.run (let open Lwt_result_syntax in - let* b, _contract = Context.init1 () in - let+ inc = Incremental.begin_construction b in - Alpha_context.Gas.set_limit - (Incremental.alpha_ctxt inc) - Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000))) + let* b, _contract = Context.init1 () in + let+ inc = Incremental.begin_construction b in + Alpha_context.Gas.set_limit + (Incremental.alpha_ctxt inc) + Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000))) |> function | Ok a -> a | Error _ -> assert false) diff --git a/src/proto_018_Proxford/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_018_Proxford/lib_protocol/test/pbt/test_refutation_game.ml index 14662cd40ddb127589b6f69bc7d345b56eced9c8..af4c5d2b4c6db0c8312b7a1efdcd405491ec6bfa 100644 --- a/src/proto_018_Proxford/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_018_Proxford/lib_protocol/test/pbt/test_refutation_game.ml @@ -489,8 +489,8 @@ module Dissection = struct ~name:"gen_dissection produces a valid dissection" ~print ~gen - (fun (dissection, new_dissection, default_number_of_sections, our_states) - -> + (fun + (dissection, new_dissection, default_number_of_sections, our_states) -> let open Lwt_syntax in match new_dissection with | None -> return (final_dissection ~our_states dissection) @@ -539,16 +539,17 @@ module Dissection = struct "distance < nb_of_sections => (len dissection = succ (dist dissection))" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = 3 -- (number_of_sections - 1) in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_hash, stop_hash = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_hash, stop_hash, number_of_sections, ticks)) + let* number_of_sections = gen_num_sections in + let* ticks = 3 -- (number_of_sections - 1) in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_hash, stop_hash = + gen_dissection ~number_of_sections ~our_states dissection + in + return + (new_dissection, start_hash, stop_hash, number_of_sections, ticks)) (fun ( dissection, start_chunk, stop_chunk, @@ -572,16 +573,16 @@ module Dissection = struct ~name:"distance >= nb_of_sections => (len dissection = nb_of_sections" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = number_of_sections -- 1_000 in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) + let* number_of_sections = gen_num_sections in + let* ticks = number_of_sections -- 1_000 in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return (new_dissection, start_chunk, stop_chunk, number_of_sections)) (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> truncate_and_check_error dissection @@ -599,22 +600,22 @@ module Dissection = struct ~name:"dissection.start_chunk can not change" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - let* new_state_hash = gen_random_hash in - return - ( new_dissection, - start_chunk, - stop_chunk, - number_of_sections, - new_state_hash )) + let* number_of_sections = gen_num_sections in + let* ticks = gen_nonfinal_initial_dissection_ticks in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + let* new_state_hash = gen_random_hash in + return + ( new_dissection, + start_chunk, + stop_chunk, + number_of_sections, + new_state_hash )) (fun ( dissection, start_chunk, stop_chunk, @@ -646,16 +647,16 @@ module Dissection = struct ~name:"dissection.stop_chunk must change" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) + let* number_of_sections = gen_num_sections in + let* ticks = gen_nonfinal_initial_dissection_ticks in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return (new_dissection, start_chunk, stop_chunk, number_of_sections)) (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> let open Lwt_syntax in let check_failure_on_same_stop_hash stop_hash = @@ -691,16 +692,16 @@ module Dissection = struct "start_chunk.tick and stop_chunk.tick can not change in the dissection" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) + let* number_of_sections = gen_num_sections in + let* ticks = gen_nonfinal_initial_dissection_ticks in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return (new_dissection, start_chunk, stop_chunk, number_of_sections)) (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> let open Lwt_syntax in let expected_error dissection = @@ -748,29 +749,29 @@ module Dissection = struct ~name:"dissection must be well distributed" ~gen: (let open Gen in - (* The test is not general enough to support all kind of number of - sections. *) - let number_of_sections = - Tezos_protocol_018_Proxford_parameters.Default_parameters - .constants_mainnet - .sc_rollup - .number_of_sections_in_dissection - in - let* picked_section = 0 -- (number_of_sections - 2) in - let* ticks = 100 -- 1_000 in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return - ( new_dissection, - start_chunk, - stop_chunk, - number_of_sections, - picked_section )) + (* The test is not general enough to support all kind of number of + sections. *) + let number_of_sections = + Tezos_protocol_018_Proxford_parameters.Default_parameters + .constants_mainnet + .sc_rollup + .number_of_sections_in_dissection + in + let* picked_section = 0 -- (number_of_sections - 2) in + let* ticks = 100 -- 1_000 in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return + ( new_dissection, + start_chunk, + stop_chunk, + number_of_sections, + picked_section )) (fun ( dissection, start_chunk, stop_chunk, @@ -1494,15 +1495,16 @@ let test_game ?(count = 10) ~p1_strategy ~p2_strategy () = p2_strategy in qcheck_make_lwt_res - ~print: - (fun ( _block, - _rollup, - _commitment_level, - _lcc, - p1_client, - p2_client, - p1_start, - _payloads_per_levels ) -> + ~print:(fun + ( _block, + _rollup, + _commitment_level, + _lcc, + p1_client, + p2_client, + p1_start, + _payloads_per_levels ) + -> Format.asprintf "@[@,@[p1:@,%a@]@,@[p2:@,%a@]@,%s@,@]" pp_player_client diff --git a/src/proto_018_Proxford/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_018_Proxford/lib_protocol/test/pbt/test_script_comparison.ml index 258efa74ad9e3d58a517e3d048e985b271663720..95919d370dea61cf0d10e7b62decd60d152af655 100644 --- a/src/proto_018_Proxford/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_018_Proxford/lib_protocol/test/pbt/test_script_comparison.ml @@ -193,9 +193,9 @@ let assert_return x = assert_ok (Lwt_main.run x) let ctxt = assert_return (let open Lwt_result_syntax in - let* b, _cs = Context.init3 () in - let* v = Incremental.begin_construction b in - return (Incremental.alpha_ctxt v)) + let* b, _cs = Context.init3 () in + let* v = Incremental.begin_construction b in + return (Incremental.alpha_ctxt v)) let unparse_comparable_ty ty = Micheline.strip_locations diff --git a/src/proto_018_Proxford/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml b/src/proto_018_Proxford/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml index 9db176a9c9322ccf0c9fedfe40286638e637363d..0ab23367c8eb9f04d56e883622ccfa39c8475f80 100644 --- a/src/proto_018_Proxford/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml +++ b/src/proto_018_Proxford/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml @@ -137,9 +137,9 @@ let test_encode_decode_internal_inbox_message_transfer () = let*? (Script_typed_ir.Ty_ex_c pair_nat_ticket_string_ty) = Environment.wrap_tzresult (let open Result_syntax in - let open Script_typed_ir in - let* ticket_t = ticket_t (-1) string_t in - pair_t (-1) nat_t ticket_t) + let open Script_typed_ir in + let* ticket_t = ticket_t (-1) string_t in + pair_t (-1) nat_t ticket_t) in let payload = ( Script_int.(abs @@ of_int 42), diff --git a/src/proto_018_Proxford/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_018_Proxford/lib_protocol/test/unit/test_sc_rollup_storage.ml index 3909cdbd74b13de45457692028ecb00f995fd85d..6152fb8e8ecfa52c6855d820695790ac9014404b 100644 --- a/src/proto_018_Proxford/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_018_Proxford/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -1164,12 +1164,12 @@ module Stake_storage_tests = struct ~loc:__LOC__ (cement_commitment ctxt rollup commitment) (let open Sc_rollup_errors in - function - | Sc_rollup_disputed | Sc_rollup_parent_not_lcc - | Raw_context.Storage_error (Missing_key _) (* missing commitment *) - -> - true - | _ -> false)) + function + | Sc_rollup_disputed | Sc_rollup_parent_not_lcc + | Raw_context.Storage_error (Missing_key _) + (* missing commitment *) -> + true + | _ -> false)) in let* () = cant_cement ctxt honest_commitments in let* () = cant_cement ctxt dishonest_commitments in diff --git a/src/proto_018_Proxford/lib_sc_rollup/game_helpers.ml b/src/proto_018_Proxford/lib_sc_rollup/game_helpers.ml index b3ddddc305e12c4da450b9f45af89f5b29257023..80237a59d1c56be495ecbec0511c418923cbc1ac 100644 --- a/src/proto_018_Proxford/lib_sc_rollup/game_helpers.ml +++ b/src/proto_018_Proxford/lib_sc_rollup/game_helpers.ml @@ -104,7 +104,7 @@ module Wasm = struct (* If [is_stop_chunk_aligned] is false, we allocate one sections for the surplus. *) (if is_stop_chunk_aligned then default_number_of_sections - else default_number_of_sections - 1)) + else default_number_of_sections - 1)) max_number_of_sections in diff --git a/src/proto_018_Proxford/lib_sc_rollup_client/configuration.ml b/src/proto_018_Proxford/lib_sc_rollup_client/configuration.ml index 556750448844159ede5078025555fb84f081c32f..ed3d3a5c4ce956b38623c111b1d97064215a5ae5 100644 --- a/src/proto_018_Proxford/lib_sc_rollup_client/configuration.ml +++ b/src/proto_018_Proxford/lib_sc_rollup_client/configuration.ml @@ -85,12 +85,11 @@ let parse argv = in return (make opts, argv) -class type sc_client_context = - object - inherit Base.Client_context.io_wallet +class type sc_client_context = object + inherit Base.Client_context.io_wallet - inherit Tezos_rpc.Context.generic - end + inherit Tezos_rpc.Context.generic +end class unix_sc_client_context ~base_dir ~password_filename ~rpc_config : sc_client_context = diff --git a/src/proto_018_Proxford/lib_sc_rollup_client/configuration.mli b/src/proto_018_Proxford/lib_sc_rollup_client/configuration.mli index 56028f3da1439b653868644d57e7a5a0a7c593ec..3b54217a7486a6a90c8fcd40cdb05df1cdff463a 100644 --- a/src/proto_018_Proxford/lib_sc_rollup_client/configuration.mli +++ b/src/proto_018_Proxford/lib_sc_rollup_client/configuration.mli @@ -45,20 +45,18 @@ val global_options : (** Instance of [Tezos_client_base.Client_context] that only handles IOs and RPCs. Can be used for keys and RPCs related commands. *) -class type sc_client_context = - object - inherit Tezos_client_base.Client_context.io_wallet +class type sc_client_context = object + inherit Tezos_client_base.Client_context.io_wallet - inherit Tezos_rpc.Context.generic - end + inherit Tezos_rpc.Context.generic +end (** Instance of [sc_client_context] for linux systems. Relies on [Tezos_rpc_http_client_unix]. *) -class unix_sc_client_context : - base_dir:string - -> password_filename:string option - -> rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config - -> sc_client_context +class unix_sc_client_context : base_dir:string -> + password_filename:string option -> + rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config -> + sc_client_context (** [make_unix_client_context config] generates a unix_sc_client_context from the client configuration. *) diff --git a/src/proto_alpha/lib_benchmark/autocomp.ml b/src/proto_alpha/lib_benchmark/autocomp.ml index 0b3f0d8b62debbb1bc48a95a505df191e45ccaf4..18c9685b4c6a71b3c78570b57b2f9ca70073c060 100644 --- a/src/proto_alpha/lib_benchmark/autocomp.ml +++ b/src/proto_alpha/lib_benchmark/autocomp.ml @@ -143,11 +143,11 @@ module SM = struct fun m f rng_state s -> let x, s = m rng_state s in f x rng_state s - [@@inline] + [@@inline] let sample : 'a sampler -> 'a Inference.M.t sampler = fun x rng_state st -> (x rng_state, st) - [@@inline] + [@@inline] let deterministic : 'a Inference.M.t -> 'a t = fun x _rng_state -> x diff --git a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/inference.ml b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/inference.ml index d8c47801dca357ac1905cd72a3dd51d9c2cd7ad1..65ec8932a5e671bf1c46a9bde101e5d7b45f2a43 100644 --- a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/inference.ml +++ b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/inference.ml @@ -249,7 +249,7 @@ module M = struct let ( >>= ) m f s = let x, s = m s in f x s - [@@inline] + [@@inline] let return x s = (x, s) @@ -259,25 +259,25 @@ module M = struct fun computation state -> let res, uf = computation state.uf in (res, {state with uf}) - [@@inline] + [@@inline] let repr_lift : 'a Repr_sm.t -> 'a t = fun computation state -> let res, repr = computation state.repr in (res, {state with repr}) - [@@inline] + [@@inline] let annot_instr_lift : 'a Annot_instr_sm.t -> 'a t = fun computation state -> let res, annot_instr = computation state.annot_instr in (res, {state with annot_instr}) - [@@inline] + [@@inline] let annot_data_lift : 'a Annot_data_sm.t -> 'a t = fun computation state -> let res, annot_data = computation state.annot_data in (res, {state with annot_data}) - [@@inline] + [@@inline] let set_repr k v = repr_lift (Repr_sm.set k v) [@@inline] @@ -285,7 +285,7 @@ module M = struct repr_lift (Repr_sm.get k) >>= function | None -> Stdlib.failwith "get_repr_exn" | Some res -> return res - [@@inline] + [@@inline] let set_instr_annot k v = annot_instr_lift (Annot_instr_sm.set k v) [@@inline] @@ -400,8 +400,8 @@ and unify_base (x : Type.Base.t) (y : Type.Base.t) : unit M.t = let open M in let unify_single_var v x = (if List.mem v (Type.Base.vars x) then - raise (Ill_typed_script Cyclic_base_type) - else return ()) + raise (Ill_typed_script Cyclic_base_type) + else return ()) >>= fun () -> M.uf_lift (UF.find v) >>= fun root -> get_repr_exn root >>= fun repr -> diff --git a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml index 4b702dd05667a8ab593401e650ca5f4a203d962d..29a59f6fc4bfcec068d382e67c16cdd540bf4a50 100644 --- a/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml +++ b/src/proto_alpha/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml @@ -142,33 +142,33 @@ module Test3 = struct try ignore ((let open Inference in - let open M in - M.uf_lift Uf.UF.show >>= fun uf_state -> - Inference.M.repr_lift (fun s -> (Inference.Repr_store.to_string s, s)) - >>= fun repr_state -> - Printf.printf "uf_state:\n%s\n" uf_state ; - Printf.printf "repr_state:\n%s\n" repr_state ; - let path = - Path.(at_index 2 (at_index 0 (at_index 0 (at_index 3 root)))) - in - let subterm = Rewriter.get_subterm ~term:program ~path in - Format.printf - "subterm at path %s:\n%a\n" - (Path.to_string path) - Mikhailsky.pp - subterm ; - Inference.M.annot_instr_lift (Inference.Annot_instr_sm.get path) - >>= fun typ -> - (match typ with - | None -> assert false - | Some {bef; aft} -> - Inference.instantiate bef >>= fun bef -> - Inference.instantiate aft >>= fun aft -> - Format.printf "Type of subterm:\n" ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - return ()) - >>= fun () -> return ()) + let open M in + M.uf_lift Uf.UF.show >>= fun uf_state -> + Inference.M.repr_lift (fun s -> (Inference.Repr_store.to_string s, s)) + >>= fun repr_state -> + Printf.printf "uf_state:\n%s\n" uf_state ; + Printf.printf "repr_state:\n%s\n" repr_state ; + let path = + Path.(at_index 2 (at_index 0 (at_index 0 (at_index 3 root)))) + in + let subterm = Rewriter.get_subterm ~term:program ~path in + Format.printf + "subterm at path %s:\n%a\n" + (Path.to_string path) + Mikhailsky.pp + subterm ; + Inference.M.annot_instr_lift (Inference.Annot_instr_sm.get path) + >>= fun typ -> + (match typ with + | None -> assert false + | Some {bef; aft} -> + Inference.instantiate bef >>= fun bef -> + Inference.instantiate aft >>= fun aft -> + Format.printf "Type of subterm:\n" ; + Format.printf "bef: %a@." Type.Stack.pp bef ; + Format.printf "aft: %a@." Type.Stack.pp aft ; + return ()) + >>= fun () -> return ()) state) with Inference.Ill_typed_script error -> let s = Mikhailsky.to_string program in diff --git a/src/proto_alpha/lib_benchmark/michelson_mcmc_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_mcmc_samplers.ml index a5b66c0f53afcd95e260889a9ef43d0b66504b78..0515479b29f642d6cecb4403f85a3a54a2c6de2a 100644 --- a/src/proto_alpha/lib_benchmark/michelson_mcmc_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_mcmc_samplers.ml @@ -211,7 +211,8 @@ end module Make_code_sampler (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) (X : sig + (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) + (X : sig val rng_state : Random.State.t val target_size : int @@ -270,7 +271,8 @@ end module Make_data_sampler (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) (X : sig + (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) + (X : sig val rng_state : Random.State.t val target_size : int diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index a70a7d79e49523f1e923655f4e1fa2a20a8d6f4f..b32d512ce70f55c9896fd459453c85139f80885a 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -258,10 +258,11 @@ exception SamplingError of string let fail_sampling error = raise (SamplingError error) -module Make (P : sig - val parameters : parameters -end) -(Crypto_samplers : Crypto_samplers.Finite_key_pool_S) : S = struct +module Make + (P : sig + val parameters : parameters + end) + (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) : S = struct module Michelson_base = Michelson_samplers_base.Make (struct let parameters = P.parameters.base_parameters end) diff --git a/src/proto_alpha/lib_benchmark/sampling_helpers.ml b/src/proto_alpha/lib_benchmark/sampling_helpers.ml index 8b36fc09e0bf983a58e280dd2eed654cbd151b67..b371a6aa1e1e37a7a35c65936ac8d2f212358ba7 100644 --- a/src/proto_alpha/lib_benchmark/sampling_helpers.ml +++ b/src/proto_alpha/lib_benchmark/sampling_helpers.ml @@ -33,7 +33,7 @@ module M = struct fun sampler f rng_state -> let x = sampler rng_state in f x rng_state - [@@inline] + [@@inline] let bind = ( let* ) diff --git a/src/proto_alpha/lib_client/client_proto_args.ml b/src/proto_alpha/lib_client/client_proto_args.ml index e05cb8860f8c729a89cb7b0c7131dd4b9ca6ccd9..9ad8ebe8309ebe40a1014dd8d63e3676a9220701 100644 --- a/src/proto_alpha/lib_client/client_proto_args.ml +++ b/src/proto_alpha/lib_client/client_proto_args.ml @@ -989,14 +989,15 @@ let fee_parameter_args = | None -> cctxt#error "Bad burn cap")) in Tezos_clic.map_arg - ~f: - (fun _cctxt - ( minimal_fees, - minimal_nanotez_per_byte, - minimal_nanotez_per_gas_unit, - force_low_fee, - fee_cap, - burn_cap ) -> + ~f:(fun + _cctxt + ( minimal_fees, + minimal_nanotez_per_byte, + minimal_nanotez_per_gas_unit, + force_low_fee, + fee_cap, + burn_cap ) + -> return { Injection.minimal_fees; diff --git a/src/proto_alpha/lib_client/michelson_v1_macros.ml b/src/proto_alpha/lib_client/michelson_v1_macros.ml index 2577ffa223d89e4e22a46cb7bd23191839292992..4e59be7406da922244e77d6eb002d6bb645265c9 100644 --- a/src/proto_alpha/lib_client/michelson_v1_macros.ml +++ b/src/proto_alpha/lib_client/michelson_v1_macros.ml @@ -605,7 +605,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), args, [] ) -> tzfail (Invalid_arity (str, List.length args, 2)) @@ -613,7 +613,7 @@ let expand_compare original = ( _, (( "IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" ) as - str), + str), [], _ :: _ ) -> tzfail (Unexpected_macro_annotation str) diff --git a/src/proto_alpha/lib_client/protocol_client_context.ml b/src/proto_alpha/lib_client/protocol_client_context.ml index 18f0d9b8ea46897686ca6ff00788479ea3023e2a..8d8099ae0b5f2358984d0b00fbf022973c04f74b 100644 --- a/src/proto_alpha/lib_client/protocol_client_context.ml +++ b/src/proto_alpha/lib_client/protocol_client_context.ml @@ -27,14 +27,12 @@ module Alpha_block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) (** Client RPC context *) -class type rpc_context = - object - inherit Tezos_rpc.Context.generic +class type rpc_context = object + inherit Tezos_rpc.Context.generic - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end (** The class [wrap_rpc_context] is a wrapper class used by the proxy mode clients. From a general-purpose Tezos_rpc.Context.generic [t], the @@ -80,24 +78,22 @@ class wrap_rpc_context (t : Tezos_rpc.Context.generic) : rpc_context = usage, the type may be coerced into one of its following ascendants to serve for explicit operations on blocks, chain or daemon for instance. *) -class type full = - object - (** The class Client_context.full provides I/O services for the +class type full = object + (** The class Client_context.full provides I/O services for the client, the wallet, etc. *) - inherit Client_context.full + inherit Client_context.full - (** Base interface provided to call RPCs, i.e., communication + (** Base interface provided to call RPCs, i.e., communication with the node. A client context is defined by mapping all RPCs protocol-generic to a specific protocol. *) - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple - (** Protocol RPCs exposed through the environment (using + (** Protocol RPCs exposed through the environment (using an additional chainpath). *) - inherit - [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context - end + inherit + [Shell_services.chain, Shell_services.block] Environment.proto_rpc_context +end (** From a [Client_context.full], the class allows to call RPCs from the node and those defined by the protocol. *) diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index f627a058119a828ad1af7013e0726bf6acaff786..3edaa24a1cdce227d4d3a84d0471dc56e6cd16e0 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -737,9 +737,12 @@ let commands_ro () = (Tez.of_mutez_exn w) Operation_result.tez_sym (if - List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) + List.mem + ~equal:Protocol_hash.equal + p + known_protos + then "" + else "not ")) ranks ; pp_close_box ppf ()) else cctxt#message "The proposals have already been cleared." @@ -2531,8 +2534,8 @@ let commands_rw () = error "There %s: %a." (if Compare.List_length_with.(dups = 1) then - "is a duplicate proposal" - else "are duplicate proposals") + "is a duplicate proposal" + else "are duplicate proposals") Format.( pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf ", ") @@ -2559,7 +2562,7 @@ let commands_rw () = cctxt#message "There %s with the submission:%t" (if Compare.List_length_with.(!errors = 1) then "is an issue" - else "are issues") + else "are issues") Format.( fun ppf -> pp_print_cut ppf () ; diff --git a/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml index b1e114f7f075bf01a90140868456dbe8d3b31af5..a3c73baee6bf76835ffc2647b4be9fe304d649c7 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml @@ -745,8 +745,8 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = included). Note that the operations injected during the last block \ are ignored because they should not be currently included." (if Int.equal injected_ops_count 0 then "N/A" - else - Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + else + Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) injected_ops_count included_ops_count in diff --git a/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml b/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml index 347de5bbe0b1f848dd00b766510f9a397809d8df..523dbe55fd2325f2cfbc29862c9ca29819566ab5 100644 --- a/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml @@ -397,19 +397,19 @@ let forge_shielded_cmd = let file = Option.value ~default:sapling_transaction_file file in let*! () = cctxt#message "Writing transaction to %s@." file in (if use_json_format then - save_json_to_file - (Data_encoding.Json.construct UTXO.transaction_encoding transaction) - file - else - let bytes = - Hex.of_bytes - (Data_encoding.Binary.to_bytes_exn - UTXO.transaction_encoding - transaction) - in - let file = open_out_bin file in - Printf.fprintf file "0x%s" (Hex.show bytes) ; - close_out file) ; + save_json_to_file + (Data_encoding.Json.construct UTXO.transaction_encoding transaction) + file + else + let bytes = + Hex.of_bytes + (Data_encoding.Binary.to_bytes_exn + UTXO.transaction_encoding + transaction) + in + let file = open_out_bin file in + Printf.fprintf file "0x%s" (Hex.show bytes) ; + close_out file) ; return_unit) let submit_shielded_cmd = diff --git a/src/proto_alpha/lib_delegate/baking_commands.ml b/src/proto_alpha/lib_delegate/baking_commands.ml index d76316d25dfbb5b4465db777bc129cc482e71a46..80b69770799ecd6d64362ce60ad47f0af064bbb1 100644 --- a/src/proto_alpha/lib_delegate/baking_commands.ml +++ b/src/proto_alpha/lib_delegate/baking_commands.ml @@ -151,14 +151,15 @@ let per_block_vote_parameter = Tezos_clic.parameter ~autocomplete:(fun _ctxt -> return ["on"; "off"; "pass"]) (let open Protocol.Alpha_context.Per_block_votes in - fun _ctxt -> function - | "on" -> return Per_block_vote_on - | "off" -> return Per_block_vote_off - | "pass" -> return Per_block_vote_pass - | s -> - failwith - "unexpected vote: %s, expected either \"on\", \"off\", or \"pass\"." - s) + fun _ctxt -> function + | "on" -> return Per_block_vote_on + | "off" -> return Per_block_vote_off + | "pass" -> return Per_block_vote_pass + | s -> + failwith + "unexpected vote: %s, expected either \"on\", \"off\", or \ + \"pass\"." + s) let liquidity_baking_toggle_vote_arg = Tezos_clic.arg diff --git a/src/proto_alpha/lib_delegate/baking_highwatermarks.ml b/src/proto_alpha/lib_delegate/baking_highwatermarks.ml index d4e3201795c8e1c6d6b3a1c5fd3cc36d7a0aec33..337feaa1466ad85e8a5006f4da04cda1d5402715 100644 --- a/src/proto_alpha/lib_delegate/baking_highwatermarks.ml +++ b/src/proto_alpha/lib_delegate/baking_highwatermarks.ml @@ -134,11 +134,11 @@ let encoding ~use_legacy_attestation_name = (req "blocks" highwatermark_delegate_map_encoding) (req (if use_legacy_attestation_name then "preendorsements" - else "preattestations") + else "preattestations") highwatermark_delegate_map_encoding) (req (if use_legacy_attestation_name then "endorsements" - else "attestations") + else "attestations") highwatermark_delegate_map_encoding)) let load_encoding = diff --git a/src/proto_alpha/lib_delegate/baking_pow.ml b/src/proto_alpha/lib_delegate/baking_pow.ml index 5a7306a3e31c6f464c2aa9715fa9e7086c9ee66c..a0b690886bfb09b52976d7db142a12a301d70f6c 100644 --- a/src/proto_alpha/lib_delegate/baking_pow.ml +++ b/src/proto_alpha/lib_delegate/baking_pow.ml @@ -108,8 +108,8 @@ let mine ~proof_of_work_threshold shell builder = else ( Bytes.blit_string (Z.to_bits z) 0 block_header offset z_len ; (if Hacl_star.AutoConfig2.(has_feature VEC256) then - Hacl_star.Hacl.Blake2b_256.Noalloc.hash - else Hacl_star.Hacl.Blake2b_32.Noalloc.hash) + Hacl_star.Hacl.Blake2b_256.Noalloc.hash + else Hacl_star.Hacl.Blake2b_32.Noalloc.hash) ~key:Bytes.empty ~msg:block_header ~digest:block_hash_bytes ; diff --git a/src/proto_alpha/lib_delegate/baking_scheduling.ml b/src/proto_alpha/lib_delegate/baking_scheduling.ml index 7858c7d8a6ac9395d386da3a1f2da76fa77323f7..a22da9410d5f937c1b87ab58b12cedea6f90eae1 100644 --- a/src/proto_alpha/lib_delegate/baking_scheduling.ml +++ b/src/proto_alpha/lib_delegate/baking_scheduling.ml @@ -411,13 +411,13 @@ let compute_next_potential_baking_time_at_next_level state = compute the round from the current timestamp. This possibly means the baker has been late. *) (if Time.Protocol.(now < min_possible_time) then Ok Round.zero - else - Environment.wrap_tzresult - @@ Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~predecessor_round - ~timestamp:now) + else + Environment.wrap_tzresult + @@ Round.round_of_timestamp + round_durations + ~predecessor_timestamp + ~predecessor_round + ~timestamp:now) |> function | Error _ -> return_none | Ok earliest_round -> ( diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml index 87b99b6fc99a6b3895bbc2d714dfb7a5dd3343cf..325e922712ffcfb2b10f40047f751c68d7bec8ef 100644 --- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml @@ -334,7 +334,7 @@ let process_operations (cctxt : #Protocol_client_context.full) state match protocol_data with | Operation_data ({contents = Single (Preattestation {round; slot; level; _}); _} as - protocol_data) -> + protocol_data) -> let new_preattestation : Kind.preattestation Alpha_context.operation = {shell; protocol_data} in @@ -349,7 +349,7 @@ let process_operations (cctxt : #Protocol_client_context.full) state slot | Operation_data ({contents = Single (Attestation {round; slot; level; _}); _} as - protocol_data) -> + protocol_data) -> let new_attestation : Kind.attestation Alpha_context.operation = {shell; protocol_data} in diff --git a/src/proto_alpha/lib_delegate/operation_pool.ml b/src/proto_alpha/lib_delegate/operation_pool.ml index 7d9ca75987de45da86e69ec8e9f30049660ba412..dd164bdf89e79d8d5b36e3a55b566a1cd88d18f1 100644 --- a/src/proto_alpha/lib_delegate/operation_pool.ml +++ b/src/proto_alpha/lib_delegate/operation_pool.ml @@ -181,8 +181,8 @@ let classify op = | None -> `Bad | Some pass -> let open Operation_repr in - if pass = consensus_pass then `Consensus - (* TODO filter outdated consensus ops ? *) + if pass = consensus_pass then + `Consensus (* TODO filter outdated consensus ops ? *) else if pass = voting_pass then `Votes else if pass = anonymous_pass then `Anonymous else if pass = manager_pass then `Managers diff --git a/src/proto_alpha/lib_delegate/test/mockup_simulator/mockup_simulator.ml b/src/proto_alpha/lib_delegate/test/mockup_simulator/mockup_simulator.ml index 8b8dc691dc41655bbd712085952c0e88c82a25ec..ca213f90e6beaf971074d7ea922ac13958ce35c9 100644 --- a/src/proto_alpha/lib_delegate/test/mockup_simulator/mockup_simulator.ml +++ b/src/proto_alpha/lib_delegate/test/mockup_simulator/mockup_simulator.ml @@ -321,13 +321,13 @@ let make_mocked_services_hooks (state : state) (user_hooks : (module Hooks)) : { current_protocol = (if - Block_hash.equal hash genesis_block_hash - || is_predecessor_of_genesis - then Protocol_hash.zero - else Protocol.hash); + Block_hash.equal hash genesis_block_hash + || is_predecessor_of_genesis + then Protocol_hash.zero + else Protocol.hash); next_protocol = (if is_predecessor_of_genesis then Protocol_hash.zero - else Protocol.hash); + else Protocol.hash); } let may_lie_on_proto_level block x = @@ -762,12 +762,13 @@ let rec listener ~(user_hooks : (module Hooks)) ~state ~broadcast_pipe = Lwt_pipe.Unbounded.pop broadcast_pipe >>= function | Broadcast_op (operation_hash, packed_operation) -> (if - List.mem_assoc ~equal:Operation_hash.equal operation_hash state.mempool - then return_unit - else ( - state.mempool <- (operation_hash, packed_operation) :: state.mempool ; - state.operations_stream_push (Some [(operation_hash, packed_operation)]) ; - User_hooks.check_mempool_after_processing ~mempool:state.mempool)) + List.mem_assoc ~equal:Operation_hash.equal operation_hash state.mempool + then return_unit + else ( + state.mempool <- (operation_hash, packed_operation) :: state.mempool ; + state.operations_stream_push + (Some [(operation_hash, packed_operation)]) ; + User_hooks.check_mempool_after_processing ~mempool:state.mempool)) >>=? fun () -> listener ~user_hooks ~state ~broadcast_pipe | Broadcast_block (block_hash, block_header, operations) -> get_block_level block_header >>=? fun level -> @@ -1215,7 +1216,7 @@ let run ?(config = default_config) bakers_spec = In particular, it seems that when logging is enabled the baker process can get cancelled without executing its Lwt finalizer. *) (if config.debug then Tezos_base_unix.Internal_event_unix.init () - else Lwt.return_unit) + else Lwt.return_unit) >>= fun () -> let total_bakers = List.length bakers_spec in (List.init ~when_negative_length:() total_bakers (fun _ -> diff --git a/src/proto_alpha/lib_parameters/default_parameters.ml b/src/proto_alpha/lib_parameters/default_parameters.ml index 55ff1df2e8cc7a55a73bf15466b2761f86561846..de37f4a516096f93fab3ac74614f9cb5fe6b25ca 100644 --- a/src/proto_alpha/lib_parameters/default_parameters.ml +++ b/src/proto_alpha/lib_parameters/default_parameters.ml @@ -233,15 +233,15 @@ let constants_mainnet = metadata = Raw_level.root; dal_page = (if default_dal.feature_enable then Raw_level.root - else - (* Deactivate the reveal if the dal is not enabled. *) - (* https://gitlab.com/tezos/tezos/-/issues/5968 - Encoding error with Raw_level - - We set the activation level to [pred max_int] to deactivate - the feature. The [pred] is needed to not trigger an encoding - exception with the value [Int32.int_min] (see tezt/tests/mockup.ml). *) - Raw_level.of_int32_exn Int32.(pred max_int)); + else + (* Deactivate the reveal if the dal is not enabled. *) + (* https://gitlab.com/tezos/tezos/-/issues/5968 + Encoding error with Raw_level + + We set the activation level to [pred max_int] to deactivate + the feature. The [pred] is needed to not trigger an encoding + exception with the value [Int32.int_min] (see tezt/tests/mockup.ml). *) + Raw_level.of_int32_exn Int32.(pred max_int)); }; private_enable = false; }; diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index f68aa41c113eb57c2be4dccc200dff871766c24f..155c6cf1165e5fa54342f5bce2b1f1b93e88f09c 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -3488,7 +3488,7 @@ module Attestation_rights = struct (req "first_slot" Slot.encoding) (req (if use_legacy_attestation_name then "endorsing_power" - else "attestation_power") + else "attestation_power") uint16) (req "consensus_key" Signature.Public_key_hash.encoding)) diff --git a/src/proto_alpha/lib_plugin/script_interpreter_logging.ml b/src/proto_alpha/lib_plugin/script_interpreter_logging.ml index 6244eaf730fc1d765cf9288b7679b63f5bc57860..d9120f03b3ad6f308918a0e07516e176aaf6a0a6 100644 --- a/src/proto_alpha/lib_plugin/script_interpreter_logging.ml +++ b/src/proto_alpha/lib_plugin/script_interpreter_logging.ml @@ -2292,7 +2292,7 @@ module Logger (Base : Logger_base) = struct accu stack | _ -> (step [@ocaml.tailcall]) g gas k ks accu stack - [@@inline] + [@@inline] let klog : type a s r f. @@ -2405,7 +2405,7 @@ module Logger (Base : Logger_base) = struct (* This case should never happen. *) (next [@ocaml.tailcall]) g gas k accu stack | KNil as k -> (next [@ocaml.tailcall]) g gas k accu stack - [@@inline] + [@@inline] end let make (module Base : Logger_base) = diff --git a/src/proto_alpha/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml b/src/proto_alpha/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml index bca8f9d15b09d00425de5a5f3d42197afb3d6a05..fac73e3fcc811502835306e00d7d6bf1bd9acbb8 100644 --- a/src/proto_alpha/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml +++ b/src/proto_alpha/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml @@ -95,24 +95,24 @@ let test_manager_ops config (op_to_replace, fee_r, gas_r) (fst candidate_op, Helpers.set_fee fee (snd candidate_op)) in (if fee_needed > 0L then - let fee_smaller = Int64.pred fee_needed in - match - Plugin.Mempool.conflict_handler - config - ~existing_operation:op_to_replace - ~new_operation:(with_fee fee_smaller) - with - | `Keep -> () - | `Replace -> - Test.fail - ~__LOC__ - "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee smaller than \ - fee_needed should not be allowed to replace op_to_replace: \ - {fee=%dmutez; gas=%d}" - fee_smaller - gas_c - fee_r - gas_r) ; + let fee_smaller = Int64.pred fee_needed in + match + Plugin.Mempool.conflict_handler + config + ~existing_operation:op_to_replace + ~new_operation:(with_fee fee_smaller) + with + | `Keep -> () + | `Replace -> + Test.fail + ~__LOC__ + "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee smaller \ + than fee_needed should not be allowed to replace op_to_replace: \ + {fee=%dmutez; gas=%d}" + fee_smaller + gas_c + fee_r + gas_r) ; match Plugin.Mempool.conflict_handler config diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 36012a622ab7a2352efd562f721af0428fe58c1d..d2a068e5a8860694e9db989cb767b76b64e34860 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -99,8 +99,8 @@ module Sc_rollup = struct add_all_messages ~protocol_migration_message: (if first_block then - Some Inbox_message.protocol_migration_internal_message - else None) + Some Inbox_message.protocol_migration_internal_message + else None) module Internal_for_tests = struct include Sc_rollup_inbox_repr.Internal_for_tests diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 97bdd0f4a05c38caa5e87733e78d48f1a840fc04..edc39551486bb9846bda119906be69da32c4bfbc 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1451,16 +1451,16 @@ let apply_internal_operations ctxt ~payer ~chain_id ops = | Script_typed_ir.Internal_operation ({sender; operation; nonce} as op) :: rest -> ( (if internal_nonce_already_recorded ctxt nonce then - let op_res = Apply_internal_results.internal_operation op in - tzfail (Internal_operation_replay (Internal_operation op_res)) - else - let ctxt = record_internal_nonce ctxt nonce in - apply_internal_operation_contents - ctxt - ~sender - ~payer - ~chain_id - operation) + let op_res = Apply_internal_results.internal_operation op in + tzfail (Internal_operation_replay (Internal_operation op_res)) + else + let ctxt = record_internal_nonce ctxt nonce in + apply_internal_operation_contents + ctxt + ~sender + ~payer + ~chain_id + operation) >>= function | Error errors -> let result = @@ -1492,8 +1492,8 @@ let burn_transaction_storage_fees ctxt trr ~storage_limit ~payer = Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed >>=? fun (ctxt, storage_limit, storage_bus) -> (if payload.allocated_destination_contract then - Fees.burn_origination_fees ctxt ~storage_limit ~payer - else return (ctxt, storage_limit, [])) + Fees.burn_origination_fees ctxt ~storage_limit ~payer + else return (ctxt, storage_limit, [])) >>=? fun (ctxt, storage_limit, origination_bus) -> let balance_updates = storage_bus @ payload.balance_updates @ origination_bus diff --git a/src/proto_alpha/lib_protocol/apply_internal_results.ml b/src/proto_alpha/lib_protocol/apply_internal_results.ml index 3c188af0d33c54e76be66b2f25f906608a19e534..3228be4a69e2ef9915388a2f2c6de00fdf2d5477 100644 --- a/src/proto_alpha/lib_protocol/apply_internal_results.ml +++ b/src/proto_alpha/lib_protocol/apply_internal_results.ml @@ -606,13 +606,14 @@ module Internal_operation_result = struct paid_storage_size_diff, lazy_storage_diff )) ~kind:Kind.Origination_manager_kind - ~inj: - (fun ( balance_updates, - originated_contracts, - consumed_gas, - storage_size, - paid_storage_size_diff, - lazy_storage_diff ) -> + ~inj:(fun + ( balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + lazy_storage_diff ) + -> IOrigination_result { lazy_storage_diff; diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index e9f997bcbf1e9bea9ae9a64a5311066286f2909a..27f2dbf750828c5ab79073467bfcec1eb5c53372 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -404,13 +404,14 @@ module Manager_result = struct paid_storage_size_diff, lazy_storage_diff )) ~kind:Kind.Origination_manager_kind - ~inj: - (fun ( balance_updates, - originated_contracts, - consumed_gas, - storage_size, - paid_storage_size_diff, - lazy_storage_diff ) -> + ~inj:(fun + ( balance_updates, + originated_contracts, + consumed_gas, + storage_size, + paid_storage_size_diff, + lazy_storage_diff ) + -> Origination_result { lazy_storage_diff; @@ -443,8 +444,8 @@ module Manager_result = struct {balance_updates; consumed_gas; size_of_constant; global_address} -> (balance_updates, consumed_gas, size_of_constant, global_address)) ~kind:Kind.Register_global_constant_manager_kind - ~inj: - (fun (balance_updates, consumed_gas, size_of_constant, global_address) -> + ~inj:(fun + (balance_updates, consumed_gas, size_of_constant, global_address) -> Register_global_constant_result {balance_updates; consumed_gas; size_of_constant; global_address}) @@ -534,11 +535,9 @@ module Manager_result = struct ticket_receipt, consumed_gas, paid_storage_size_diff )) - ~inj: - (fun ( balance_updates, - ticket_receipt, - consumed_gas, - paid_storage_size_diff ) -> + ~inj:(fun + (balance_updates, ticket_receipt, consumed_gas, paid_storage_size_diff) + -> Transfer_ticket_result { balance_updates; @@ -588,8 +587,8 @@ module Manager_result = struct {balance_updates; originated_zk_rollup; consumed_gas; storage_size} -> (balance_updates, originated_zk_rollup, consumed_gas, storage_size)) - ~inj: - (fun (balance_updates, originated_zk_rollup, consumed_gas, storage_size) -> + ~inj:(fun + (balance_updates, originated_zk_rollup, consumed_gas, storage_size) -> Zk_rollup_origination_result {balance_updates; originated_zk_rollup; consumed_gas; storage_size}) @@ -671,12 +670,9 @@ module Manager_result = struct consumed_gas, size )) ~kind:Kind.Sc_rollup_originate_manager_kind - ~inj: - (fun ( balance_updates, - address, - genesis_commitment_hash, - consumed_gas, - size ) -> + ~inj:(fun + (balance_updates, address, genesis_commitment_hash, consumed_gas, size) + -> Sc_rollup_originate_result { balance_updates; @@ -739,8 +735,8 @@ module Manager_result = struct {consumed_gas; staked_hash; published_at_level; balance_updates} -> (consumed_gas, staked_hash, published_at_level, balance_updates)) ~kind:Kind.Sc_rollup_publish_manager_kind - ~inj: - (fun (consumed_gas, staked_hash, published_at_level, balance_updates) -> + ~inj:(fun + (consumed_gas, staked_hash, published_at_level, balance_updates) -> Sc_rollup_publish_result {consumed_gas; staked_hash; published_at_level; balance_updates}) @@ -820,11 +816,9 @@ module Manager_result = struct ticket_receipt, consumed_gas, paid_storage_size_diff )) - ~inj: - (fun ( balance_updates, - ticket_receipt, - consumed_gas, - paid_storage_size_diff ) -> + ~inj:(fun + (balance_updates, ticket_receipt, consumed_gas, paid_storage_size_diff) + -> Sc_rollup_execute_outbox_message_result { balance_updates; @@ -1565,7 +1559,7 @@ module Encoding = struct (function | Contents_and_result ( (Manager_operation {operation = Register_global_constant _; _} as - op), + op), res ) -> Some (op, res) | _ -> None) @@ -1598,8 +1592,7 @@ module Encoding = struct Manager_result.dal_publish_slot_header_case (function | Contents_and_result - ( (Manager_operation {operation = Dal_publish_slot_header _; _} as - op), + ( (Manager_operation {operation = Dal_publish_slot_header _; _} as op), res ) -> Some (op, res) | _ -> None) @@ -2685,8 +2678,8 @@ let block_metadata_encoding ~use_legacy_attestation_name = let open Data_encoding in def (if use_legacy_attestation_name then - "block_header.alpha.metadata_with_legacy_attestation_name" - else "block_header.alpha.metadata") + "block_header.alpha.metadata_with_legacy_attestation_name" + else "block_header.alpha.metadata") @@ conv (fun { proposer = @@ -2760,8 +2753,8 @@ let block_metadata_encoding ~use_legacy_attestation_name = (dft "balance_updates" (if use_legacy_attestation_name then - Receipt.balance_updates_encoding_with_legacy_attestation_name - else Receipt.balance_updates_encoding) + Receipt.balance_updates_encoding_with_legacy_attestation_name + else Receipt.balance_updates_encoding) []) (req "liquidity_baking_toggle_ema" diff --git a/src/proto_alpha/lib_protocol/cache_memory_helpers.ml b/src/proto_alpha/lib_protocol/cache_memory_helpers.ml index 137f19977931b5f69d09ab3c9cfad8aeac6d7bd4..aa4fd91ef3108e0956771d1c1ed9d73cebefb0e3 100644 --- a/src/proto_alpha/lib_protocol/cache_memory_helpers.ml +++ b/src/proto_alpha/lib_protocol/cache_memory_helpers.ml @@ -147,7 +147,7 @@ let option_size_vec some x = Option.fold ~none:zero ~some x let list_cell_size elt_size = header_size +! word_size +! word_size +! elt_size - [@@ocaml.inline always] +[@@ocaml.inline always] let list_fold_size elt_size list = List.fold_left @@ -156,7 +156,7 @@ let list_fold_size elt_size list = list let boxed_tup2 x y = header_size +! word_size +! word_size +! x +! y - [@@ocaml.inline always] +[@@ocaml.inline always] let node_size = let open Micheline in diff --git a/src/proto_alpha/lib_protocol/constants_repr.ml b/src/proto_alpha/lib_protocol/constants_repr.ml index 3d1dc9e80362a603addb6776c4bc7a7aaeac67a8..a31676144f151c8285320d4c379fabd90b087417 100644 --- a/src/proto_alpha/lib_protocol/constants_repr.ml +++ b/src/proto_alpha/lib_protocol/constants_repr.ml @@ -379,13 +379,13 @@ module Generated = struct baking_reward_fixed_portion_weight = (* 1/4 or 1/2 *) (if Compare.Int.(bonus_committee_size <= 0) then - (* a fortiori, consensus_committee_size < 4 *) - reward_parts_half - else reward_parts_quarter); + (* a fortiori, consensus_committee_size < 4 *) + reward_parts_half + else reward_parts_quarter); baking_reward_bonus_weight = (* 1/4 or 0 *) (if Compare.Int.(bonus_committee_size <= 0) then 0 - else reward_parts_quarter); + else reward_parts_quarter); attesting_reward_weight = reward_parts_half; (* 1/2 *) (* All block (baking + attesting)rewards sum to 1 ( *256*80 ) *) diff --git a/src/proto_alpha/lib_protocol/contract_repr.ml b/src/proto_alpha/lib_protocol/contract_repr.ml index 30f1c2f403d2beeec97b598afd1399736f44c776..2bcb84d70a4d6cdc945b33f525a869e718e881ce 100644 --- a/src/proto_alpha/lib_protocol/contract_repr.ml +++ b/src/proto_alpha/lib_protocol/contract_repr.ml @@ -182,7 +182,7 @@ let originated_contracts Origination_nonce.{origination_index = first; operation_hash = first_hash} ~until: (Origination_nonce.{origination_index = last; operation_hash = last_hash} - as origination_nonce) = + as origination_nonce) = assert (Operation_hash.equal first_hash last_hash) ; let rec contracts acc origination_index = if Compare.Int32.(origination_index < first) then acc diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index acde2c9ef8823f248a98d742afb6723b9b118651..a49bc799deb2545ab2df9916a32e2546905eeab3 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -573,11 +573,11 @@ let register () = (Script_typed_ir.Ex_ty ty, original_type_expr) (acc, ctxt) -> (if normalize_types then - Script_ir_unparser.unparse_ty ~loc:() ctxt ty - >|? fun (ty_node, ctxt) -> - (Micheline.strip_locations ty_node, ctxt) - else - ok (Micheline.strip_locations original_type_expr, ctxt)) + Script_ir_unparser.unparse_ty ~loc:() ctxt ty + >|? fun (ty_node, ctxt) -> + (Micheline.strip_locations ty_node, ctxt) + else + ok (Micheline.strip_locations original_type_expr, ctxt)) >|? fun (ty_expr, ctxt) -> ((Entrypoint.to_string entry, ty_expr) :: acc, ctxt)) map diff --git a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml index f916a29849fbefc78ad765d1d8d9733fc053e44e..49a78d5c171de6c03619c8fcf96b8da61b28592c 100644 --- a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml +++ b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml @@ -104,34 +104,34 @@ let timestamp (tstamp : Script_timestamp.t) : t = let rec size_of_comparable_value : type a. a Script_typed_ir.comparable_ty -> a -> t = - fun (type a) (wit : a Script_typed_ir.comparable_ty) (v : a) -> - match wit with - | Never_t -> ( match v with _ -> .) - | Unit_t -> unit - | Int_t -> integer v - | Nat_t -> integer v - | String_t -> script_string v - | Bytes_t -> bytes v - | Mutez_t -> mutez v - | Bool_t -> bool v - | Key_hash_t -> key_hash v - | Timestamp_t -> timestamp v - | Address_t -> address v - | Pair_t (leaf, node, _, YesYes) -> - let lv, rv = v in - let size = - size_of_comparable_value leaf lv + size_of_comparable_value node rv - in - size + 1 - | Or_t (left, right, _, YesYes) -> - let size = - match v with - | L v -> size_of_comparable_value left v - | R v -> size_of_comparable_value right v - in - size + 1 - | Option_t (ty, _, Yes) -> ( - match v with None -> 1 | Some x -> size_of_comparable_value ty x + 1) - | Signature_t -> signature v - | Key_t -> public_key v - | Chain_id_t -> chain_id v + fun (type a) (wit : a Script_typed_ir.comparable_ty) (v : a) -> + match wit with + | Never_t -> ( match v with _ -> .) + | Unit_t -> unit + | Int_t -> integer v + | Nat_t -> integer v + | String_t -> script_string v + | Bytes_t -> bytes v + | Mutez_t -> mutez v + | Bool_t -> bool v + | Key_hash_t -> key_hash v + | Timestamp_t -> timestamp v + | Address_t -> address v + | Pair_t (leaf, node, _, YesYes) -> + let lv, rv = v in + let size = + size_of_comparable_value leaf lv + size_of_comparable_value node rv + in + size + 1 + | Or_t (left, right, _, YesYes) -> + let size = + match v with + | L v -> size_of_comparable_value left v + | R v -> size_of_comparable_value right v + in + size + 1 + | Option_t (ty, _, Yes) -> ( + match v with None -> 1 | Some x -> size_of_comparable_value ty x + 1) + | Signature_t -> signature v + | Key_t -> public_key v + | Chain_id_t -> chain_id v diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 3597f4bfa47f62d3619f22c944300c827337813d..daf416575411b96d60309fcca67604c5368a6952 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -42,20 +42,20 @@ let return_unit = return () (* Inlined [Option.bind] for performance. *) let ( >>?? ) m f = match m with None -> None | Some x -> f x - [@@ocaml.inline always] +[@@ocaml.inline always] let bind m f gas = m gas >>?? fun (res, gas) -> match res with Ok y -> f y gas | Error _ as err -> of_result err gas - [@@ocaml.inline always] +[@@ocaml.inline always] let map f m gas = m gas >>?? fun (x, gas) -> of_result (x >|? f) gas - [@@ocaml.inline always] +[@@ocaml.inline always] let bind_result m f = bind (of_result m) f [@@ocaml.inline always] let bind_recover m f gas = m gas >>?? fun (x, gas) -> f x gas - [@@ocaml.inline always] +[@@ocaml.inline always] let consume_gas cost gas = match Local_gas_counter.consume_opt gas cost with diff --git a/src/proto_alpha/lib_protocol/local_gas_counter.ml b/src/proto_alpha/lib_protocol/local_gas_counter.ml index 868ee3abd6ef0b4d0a5d0b5a5a1bfcc3d77f6aeb..7703d60508bd66b7343630220af9c51cc1962bda 100644 --- a/src/proto_alpha/lib_protocol/local_gas_counter.ml +++ b/src/proto_alpha/lib_protocol/local_gas_counter.ml @@ -67,29 +67,29 @@ let outdated_context ctxt = Outdated_context ctxt [@@ocaml.inline always] let update_context (Local_gas_counter gas_counter) (Outdated_context ctxt) = Gas.update_remaining_operation_gas ctxt (Gas.fp_of_milligas_int gas_counter) - [@@ocaml.inline always] +[@@ocaml.inline always] let local_gas_counter ctxt = Local_gas_counter (Gas.remaining_operation_gas ctxt :> int) - [@@ocaml.inline always] +[@@ocaml.inline always] let local_gas_counter_and_outdated_context ctxt = (local_gas_counter ctxt, outdated_context ctxt) - [@@ocaml.inline always] +[@@ocaml.inline always] let use_gas_counter_in_context ctxt gas_counter f = let ctxt = update_context gas_counter ctxt in f ctxt >|=? fun (y, ctxt) -> (y, outdated_context ctxt, local_gas_counter ctxt) - [@@ocaml.inline always] +[@@ocaml.inline always] let consume_opt (Local_gas_counter gas_counter) (cost : Gas.cost) = let gas_counter = gas_counter - (cost :> int) in if Compare.Int.(gas_counter < 0) then None else Some (Local_gas_counter gas_counter) - [@@ocaml.inline always] +[@@ocaml.inline always] let consume local_gas_counter cost = match consume_opt local_gas_counter cost with | None -> error Gas.Operation_quota_exceeded | Some local_gas_counter -> Ok local_gas_counter - [@@ocaml.inline always] +[@@ocaml.inline always] diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index 62fb3d3162dae9e519dcf76cae3cb4fbb1b00e43..21ee9918d5aad6978dcda5c2e436bd46905ec6c4 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -90,12 +90,13 @@ module type T = sig end end -module Make (El : sig - type t +module Make + (El : sig + type t - val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t = struct + val to_bytes : t -> bytes + end) + (H : S.HASH) : T with type elt = El.t and type h = H.t = struct type h = H.t type elt = El.t diff --git a/src/proto_alpha/lib_protocol/merkle_list.mli b/src/proto_alpha/lib_protocol/merkle_list.mli index dceb20f2b347d1ab33814cabab9830658b6e71d3..09590b9deef337ebb390748115f26a9017cde06a 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.mli +++ b/src/proto_alpha/lib_protocol/merkle_list.mli @@ -110,9 +110,10 @@ module type T = sig end end -module Make (El : sig - type t +module Make + (El : sig + type t - val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t + val to_bytes : t -> bytes + end) + (H : S.HASH) : T with type elt = El.t and type h = H.t diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index d2a7b1b8d3a8caecd7cd13267533746861a78855..4c03ae89c8df4c3cd95bd39c514b149083b0df91 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -956,20 +956,20 @@ let prepare_first_block ~level ~timestamp chain_id ctxt = metadata = c.sc_rollup.reveal_activation_level.metadata; dal_page = (if c.dal.feature_enable then - c.sc_rollup.reveal_activation_level.dal_page - else if dal.feature_enable then - (* First level of the protocol with dal activated. *) - Raw_level_repr.of_int32_exn (Int32.succ level) - else - (* Deactivate the reveal if the dal is not enabled. - - assert (not (c.dal.feature_enable || dal.feature_enable)) - - We set the activation level to [pred max_int] to deactivate - the feature. The [pred] is needed to not trigger an encoding - exception with the value [Int32.int_min] (see - tezt/tests/mockup.ml). *) - Raw_level_repr.of_int32_exn Int32.(pred max_int)); + c.sc_rollup.reveal_activation_level.dal_page + else if dal.feature_enable then + (* First level of the protocol with dal activated. *) + Raw_level_repr.of_int32_exn (Int32.succ level) + else + (* Deactivate the reveal if the dal is not enabled. + + assert (not (c.dal.feature_enable || dal.feature_enable)) + + We set the activation level to [pred max_int] to deactivate + the feature. The [pred] is needed to not trigger an encoding + exception with the value [Int32.int_min] (see + tezt/tests/mockup.ml). *) + Raw_level_repr.of_int32_exn Int32.(pred max_int)); } in let sc_rollup = diff --git a/src/proto_alpha/lib_protocol/receipt_repr.ml b/src/proto_alpha/lib_protocol/receipt_repr.ml index 640b9dbdc956fef5e007b30fa214cdafdf8ce053..a696d95ea9accaeedf47849b2548734a73094b5d 100644 --- a/src/proto_alpha/lib_protocol/receipt_repr.ml +++ b/src/proto_alpha/lib_protocol/receipt_repr.ml @@ -65,8 +65,8 @@ let balance_encoding ~use_legacy_attestation_name = in def (if use_legacy_attestation_name then - "operation_metadata_with_legacy_attestation_name.alpha.balance" - else "operation_metadata.alpha.balance") + "operation_metadata_with_legacy_attestation_name.alpha.balance" + else "operation_metadata.alpha.balance") @@ union [ case @@ -108,14 +108,14 @@ let balance_encoding ~use_legacy_attestation_name = (Tag 7) ~title: (if use_legacy_attestation_name then "Endorsing_rewards" - else "Attesting_rewards") + else "Attesting_rewards") (obj2 (req "kind" (constant "minted")) (req "category" (constant (if use_legacy_attestation_name then "endorsing rewards" - else "attesting rewards")))) + else "attesting rewards")))) (function Attesting_rewards -> Some ((), ()) | _ -> None) (fun ((), ()) -> Attesting_rewards); case @@ -154,15 +154,15 @@ let balance_encoding ~use_legacy_attestation_name = (Tag 13) ~title: (if use_legacy_attestation_name then "Lost_endorsing_rewards" - else "Lost_attesting_rewards") + else "Lost_attesting_rewards") (obj5 (req "kind" (constant "burned")) (req "category" (constant (if use_legacy_attestation_name then - "lost endorsing rewards" - else "lost attesting rewards"))) + "lost endorsing rewards" + else "lost attesting rewards"))) (req "delegate" Signature.Public_key_hash.encoding) (req "participation" Data_encoding.bool) (req "revelation" Data_encoding.bool)) diff --git a/src/proto_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml index 4f8c5c7b20eec2f0e55ad77ac757c9848a27e19b..bc15e630aa7d2bb495258ad5f3c88cec359ec1b8 100644 --- a/src/proto_alpha/lib_protocol/round_repr.ml +++ b/src/proto_alpha/lib_protocol/round_repr.ml @@ -77,7 +77,7 @@ let () = let of_int32 i = if i >= 0l then Ok i else error (Negative_round (Int32.to_int i)) - [@@inline] +[@@inline] let pred r = let p = Int32.pred r in diff --git a/src/proto_alpha/lib_protocol/sapling_storage.ml b/src/proto_alpha/lib_protocol/sapling_storage.ml index 1deae40db03d219e107d36383076416fd6ad799c..558bea8e2509a9da5112d937711ee1dd212af28f 100644 --- a/src/proto_alpha/lib_protocol/sapling_storage.ml +++ b/src/proto_alpha/lib_protocol/sapling_storage.ml @@ -163,16 +163,17 @@ module Commitments : COMMITMENTS = struct | _ -> let height = height - 1 in (if Compare.Int64.(pos < pow2 height) then - let at = Int64.(sub (pow2 height) pos) in - let cml, cmr = split_at at cms in - insert ctx id (left node) height pos cml >>=? fun (ctx, size_l, hl) -> - insert ctx id (right node) height 0L cmr >|=? fun (ctx, size_r, hr) -> - (ctx, size_l + size_r, hl, hr) - else - get_root_height ctx id (left node) height >>=? fun (ctx, hl) -> - let pos = Int64.(sub pos (pow2 height)) in - insert ctx id (right node) height pos cms - >|=? fun (ctx, size_r, hr) -> (ctx, size_r, hl, hr)) + let at = Int64.(sub (pow2 height) pos) in + let cml, cmr = split_at at cms in + insert ctx id (left node) height pos cml + >>=? fun (ctx, size_l, hl) -> + insert ctx id (right node) height 0L cmr + >|=? fun (ctx, size_r, hr) -> (ctx, size_l + size_r, hl, hr) + else + get_root_height ctx id (left node) height >>=? fun (ctx, hl) -> + let pos = Int64.(sub pos (pow2 height)) in + insert ctx id (right node) height pos cms + >|=? fun (ctx, size_r, hr) -> (ctx, size_r, hl, hr)) >>=? fun (ctx, size_children, hl, hr) -> let h = H.merkle_hash ~height hl hr in Storage.Sapling.Commitments.add (ctx, id) node h diff --git a/src/proto_alpha/lib_protocol/sc_rollup_dissection_chunk_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_dissection_chunk_repr.ml index 534ce8fb6016102337ce082bbbf2c380b3c36654..5bce25876fa0b5f331361bda27856d7e4eabc053 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_dissection_chunk_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_dissection_chunk_repr.ml @@ -241,12 +241,13 @@ let () = ~id:"smart_rollup_dissection_edge_ticks_mismatch" ~title:description ~description - ~pp: - (fun ppf - ( dissection_start_tick, - dissection_stop_tick, - chunk_start_tick, - chunk_stop_tick ) -> + ~pp:(fun + ppf + ( dissection_start_tick, + dissection_stop_tick, + chunk_start_tick, + chunk_stop_tick ) + -> Sc_rollup_tick_repr.( Format.fprintf ppf 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 99f1c3a029f767632ab39850d52b31f5adf666c5..6f1b6c39880e3a58886dd29fbbb96aef3544aa83 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -727,11 +727,11 @@ let check_proof_stop_state ~pvm ~stop_state input_given (let b = Option.equal State_hash.equal stop_state stop_proof in if validate then b else not b) (if validate then - Proof_stop_state_hash_failed_to_validate - {stop_state_hash = stop_state; stop_proof} - else - Proof_stop_state_hash_failed_to_refute - {stop_state_hash = stop_state; stop_proof}) + Proof_stop_state_hash_failed_to_validate + {stop_state_hash = stop_state; stop_proof} + else + Proof_stop_state_hash_failed_to_refute + {stop_state_hash = stop_state; stop_proof}) (** Check the proof validates the stop state. *) let check_proof_validate_stop_state ~stop_state input input_request proof = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml index 9a287dfcd17a48225857f6a5edb03a8af13ed22d..472b4b1b96655b05998dfe247315924ec3c985bc 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml @@ -131,32 +131,31 @@ let () = ~id:"smart_rollup_outdated_whitelist_update" ~title:description ~description - ~pp: - (fun ppf -> function - | Outdated_message_index {given; last_update} -> - Format.fprintf - ppf - "%s: got message index %a at outbox level %a, while the lastest \ - whitelist update occurred with message index %a." - description - Z.pp_print - given - Z.pp_print - last_update.message_index - Raw_level.pp - last_update.outbox_level - | Outdated_outbox_level {given; last_update} -> - Format.fprintf - ppf - "%s: got outbox level %a, while the current outbox level is %a \ - with message index %a." - description - Raw_level.pp - given - Raw_level.pp - last_update.outbox_level - Z.pp_print - last_update.message_index) + ~pp:(fun ppf -> function + | Outdated_message_index {given; last_update} -> + Format.fprintf + ppf + "%s: got message index %a at outbox level %a, while the lastest \ + whitelist update occurred with message index %a." + description + Z.pp_print + given + Z.pp_print + last_update.message_index + Raw_level.pp + last_update.outbox_level + | Outdated_outbox_level {given; last_update} -> + Format.fprintf + ppf + "%s: got outbox level %a, while the current outbox level is %a \ + with message index %a." + description + Raw_level.pp + given + Raw_level.pp + last_update.outbox_level + Z.pp_print + last_update.message_index) outdated_whitelist_update_encoding (function Sc_rollup_outdated_whitelist_update e -> Some e | _ -> None) (fun e -> Sc_rollup_outdated_whitelist_update e) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index 0db364a8383c03e855d2f59e1c7b5ced83373690..7e27f1ec3d7b3594930259adaa037194c9d4789c 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -573,7 +573,7 @@ module V2_0_0 = struct Compare.Z.min (Z.of_int default_number_of_sections) (if is_stop_chunk_aligned then max_number_of_sections - else Z.succ max_number_of_sections) + else Z.succ max_number_of_sections) in let given = Z.of_int number_of_sections in error_unless diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index add9a6e0a8f8bbf982c1d8ab2b81b131a9a6d669..2918871fcaef6804253d9e208dd5670f7450ff3c 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -260,7 +260,7 @@ module Raw = struct let ks = instrument @@ KMap_enter_body (body, xs, ys, ty, ks) in let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack - [@@inline] + [@@inline] and kmap_enter : type a b c d f i j k. (a, b, c, d, f, i, j, k) kmap_enter_type = @@ -272,7 +272,7 @@ module Raw = struct let res = (xk, xv) in let stack = (accu, stack) in (step [@ocaml.tailcall]) g gas body ks res stack - [@@inline] + [@@inline] and klist_exit : type a b c d e i j. (a, b, c, d, e, i, j) klist_exit_type = fun instrument g gas body xs ys ty len ks accu stack -> @@ -280,7 +280,7 @@ module Raw = struct let ks = instrument @@ KList_enter_body (body, xs, ys, ty, len, ks) in let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack - [@@inline] + [@@inline] and klist_enter : type a b c d e f j. (a, b, c, d, e, f, j) klist_enter_type = fun instrument g gas body xs ys ty len ks' accu stack -> @@ -291,7 +291,7 @@ module Raw = struct | x :: xs -> let ks = instrument @@ KList_exit_body (body, xs, ys, ty, len, ks') in (step [@ocaml.tailcall]) g gas body ks x (accu, stack) - [@@inline] + [@@inline] and kloop_in_left : type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type = @@ -299,14 +299,14 @@ module Raw = struct match accu with | L v -> (step [@ocaml.tailcall]) g gas ki ks0 v stack | R v -> (next [@ocaml.tailcall]) g gas ks' v stack - [@@inline] + [@@inline] and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = fun g gas ks0 ki ks' accu stack -> let accu', stack' = stack in if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' else (next [@ocaml.tailcall]) g gas ks' accu' stack' - [@@inline] + [@@inline] and kiter : type a b s r f c. (a, b, s, r, f, c) kiter_type = fun instrument g gas body ty xs ks accu stack -> @@ -315,7 +315,7 @@ module Raw = struct | x :: xs -> let ks = instrument @@ KIter (body, ty, xs, ks) in (step [@ocaml.tailcall]) g gas body ks x (accu, stack) - [@@inline] + [@@inline] and next : type a s r f. @@ -413,7 +413,7 @@ module Raw = struct in let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack - [@@inline] + [@@inline] and ilist_iter : type a b c d e f g cmp. (a, b, c, d, e, f, g, cmp) ilist_iter_type = @@ -422,7 +422,7 @@ module Raw = struct let ks = instrument @@ KIter (body, ty, xs, KCons (k, ks)) in let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack - [@@inline] + [@@inline] and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = fun instrument g gas body ty k ks accu stack -> @@ -431,7 +431,7 @@ module Raw = struct let ks = instrument @@ KIter (body, ty, l, KCons (k, ks)) in let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack - [@@inline] + [@@inline] and imap_map : type a b c d e f g h i j. (a, b, c, d, e, f, g, h, i, j) imap_map_type = @@ -442,7 +442,7 @@ module Raw = struct let ks = instrument @@ KMap_enter_body (body, xs, ys, ty, KCons (k, ks)) in let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack - [@@inline] + [@@inline] and imap_iter : type a b c d e f g h cmp. (a, b, c, d, e, f, g, h, cmp) imap_iter_type = @@ -452,7 +452,7 @@ module Raw = struct let ks = instrument @@ KIter (body, ty, l, KCons (k, ks)) in let accu, stack = stack in (next [@ocaml.tailcall]) g gas ks accu stack - [@@inline] + [@@inline] and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = fun logger g gas loc k ks accu stack -> @@ -1666,8 +1666,8 @@ let step_descr ~log_now logger (ctxt, sc) descr accu stack = | None -> step (outdated_ctxt, sc) gas descr.kinstr KNil accu stack | Some logger -> (if log_now then - let loc = kinstr_location descr.kinstr in - logger.log_interp descr.kinstr ctxt loc descr.kbef (accu, stack)) ; + let loc = kinstr_location descr.kinstr in + logger.log_interp descr.kinstr ctxt loc descr.kbef (accu, stack)) ; let log = ILog ( kinstr_location descr.kinstr, diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index df8d30eba2e9959c760a04b9f978ef1a70720564..9100034c1f04242b136ee320c6ab11b7d4afd09e 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -403,7 +403,7 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = Interp_costs.open_chest ~chest ~time:(Script_int.to_zint time) | IEmit _ -> Interp_costs.emit | ILog _ -> Gas.free - [@@ocaml.inline always] +[@@ocaml.inline always] let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = fun ks -> @@ -439,17 +439,17 @@ let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = let consume_instr local_gas_counter k accu stack = let cost = cost_of_instr k accu stack in consume_opt local_gas_counter cost - [@@ocaml.inline always] +[@@ocaml.inline always] let consume_control local_gas_counter ks = let cost = cost_of_control ks in consume_opt local_gas_counter cost - [@@ocaml.inline always] +[@@ocaml.inline always] let get_log = function | None -> Lwt.return (Ok None) | Some logger -> logger.get_log () - [@@ocaml.inline always] +[@@ocaml.inline always] (* diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 83f56d2afff88884c2453f8f4d873ec20816bfde..b96c3d063d854400631558c0a797163ed6b992a1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1323,13 +1323,13 @@ let well_formed_entrypoints (type full fullc) (full : (full, fullc) ty) | None -> ok ( (if reachable then acc - else - match ty with - | Or_t _ -> acc - | _ -> ( - match first_unreachable with - | None -> (Some (List.rev path), all) - | Some _ -> acc)), + else + match ty with + | Or_t _ -> acc + | _ -> ( + match first_unreachable with + | None -> (Some (List.rev path), all) + | Some _ -> acc)), reachable ) | Some {name; original_type_expr = _} -> if Entrypoint.Set.mem name all then error (Duplicate_entrypoint name) @@ -1391,8 +1391,8 @@ let parse_parameter_ty_and_entrypoints : >>? fun (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt) -> (if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit - else well_formed_entrypoints arg_type entrypoints) + Result.return_unit + else well_formed_entrypoints arg_type entrypoints) >|? fun () -> let entrypoints = {root = entrypoints; original_type_expr = node} in (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) @@ -1429,8 +1429,8 @@ let opened_ticket_type loc ty = comparable_pair_3_t loc address_t ty nat_t let parse_unit ctxt ~legacy = function | Prim (loc, D_Unit, [], annot) -> (if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit - else error_unexpected_annot loc annot) + Result.return_unit + else error_unexpected_annot loc annot) >>? fun () -> Gas.consume ctxt Typecheck_costs.unit >|? fun ctxt -> ((), ctxt) | Prim (loc, D_Unit, l, _) -> @@ -1440,14 +1440,14 @@ let parse_unit ctxt ~legacy = function let parse_bool ctxt ~legacy = function | Prim (loc, D_True, [], annot) -> (if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit - else error_unexpected_annot loc annot) + Result.return_unit + else error_unexpected_annot loc annot) >>? fun () -> Gas.consume ctxt Typecheck_costs.bool >|? fun ctxt -> (true, ctxt) | Prim (loc, D_False, [], annot) -> (if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit - else error_unexpected_annot loc annot) + Result.return_unit + else error_unexpected_annot loc annot) >>? fun () -> Gas.consume ctxt Typecheck_costs.bool >|? fun ctxt -> (false, ctxt) | Prim (loc, ((D_True | D_False) as c), l, _) -> @@ -1673,8 +1673,8 @@ let parse_pair (type r) parse_l parse_r ctxt ~legacy match expr with | Prim (loc, D_Pair, l :: rs, annot) -> (if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit - else error_unexpected_annot loc annot) + Result.return_unit + else error_unexpected_annot loc annot) >>?= fun () -> parse_comb loc l rs | Prim (loc, D_Pair, l, _) -> tzfail @@ Invalid_arity (loc, D_Pair, 2, List.length l) @@ -1686,16 +1686,16 @@ let parse_pair (type r) parse_l parse_r ctxt ~legacy let parse_or parse_l parse_r ctxt ~legacy = function | Prim (loc, D_Left, [v], annot) -> (if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit - else error_unexpected_annot loc annot) + Result.return_unit + else error_unexpected_annot loc annot) >>?= fun () -> parse_l ctxt v >|=? fun (v, ctxt) -> (L v, ctxt) | Prim (loc, D_Left, l, _) -> tzfail @@ Invalid_arity (loc, D_Left, 1, List.length l) | Prim (loc, D_Right, [v], annot) -> (if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit - else error_unexpected_annot loc annot) + Result.return_unit + else error_unexpected_annot loc annot) >>?= fun () -> parse_r ctxt v >|=? fun (v, ctxt) -> (R v, ctxt) | Prim (loc, D_Right, l, _) -> @@ -1705,8 +1705,8 @@ let parse_or parse_l parse_r ctxt ~legacy = function let parse_option parse_v ctxt ~legacy = function | Prim (loc, D_Some, [v], annot) -> (if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit - else error_unexpected_annot loc annot) + Result.return_unit + else error_unexpected_annot loc annot) >>?= fun () -> parse_v ctxt v >|=? fun (v, ctxt) -> (Some v, ctxt) | Prim (loc, D_Some, l, _) -> @@ -1714,8 +1714,8 @@ let parse_option parse_v ctxt ~legacy = function | Prim (loc, D_None, [], annot) -> Lwt.return ( (if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit - else error_unexpected_annot loc annot) + Result.return_unit + else error_unexpected_annot loc annot) >|? fun () -> (None, ctxt) ) | Prim (loc, D_None, l, _) -> tzfail @@ Invalid_arity (loc, D_None, 0, List.length l) @@ -1883,8 +1883,8 @@ let rec parse_data : match item with | Prim (loc, D_Elt, [k; v], annot) -> (if elab_conf.legacy (* Legacy check introduced before Ithaca. *) - then Result.return_unit - else error_unexpected_annot loc annot) + then Result.return_unit + else error_unexpected_annot loc annot) >>?= fun () -> non_terminal_recursion ctxt key_type k >>=? fun (k, ctxt) -> non_terminal_recursion ctxt value_type v >>=? fun (v, ctxt) -> @@ -1932,8 +1932,8 @@ let rec parse_data : match item with | Prim (loc, D_Elt, [k; v], annot) -> (if elab_conf.legacy (* Legacy check introduced before Ithaca. *) - then Result.return_unit - else error_unexpected_annot loc annot) + then Result.return_unit + else error_unexpected_annot loc annot) >>?= fun () -> non_terminal_recursion ctxt key_type k >>=? fun (k, ctxt) -> hash_comparable_data ctxt key_type k >>=? fun (key_hash, ctxt) -> @@ -3128,13 +3128,13 @@ and parse_instr : (typed ctxt loc instr (Item_t (bool_t, rest)) : ((a, s) judgement * context) tzresult Lwt.t) | Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Map_t (k, elt, _), rest)) - -> + -> ( check_item_ty ctxt vk k loc I_GET 1 2 >>?= fun (Eq, ctxt) -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun k -> IMap_get (loc, k))} in option_t loc elt >>?= fun ty : ((a, s) judgement * context) tzresult Lwt.t -> - typed ctxt loc instr (Item_t (ty, rest)) + typed ctxt loc instr (Item_t (ty, rest))) | ( Prim (loc, I_UPDATE, [], annot), Item_t ( vk, @@ -3201,7 +3201,7 @@ and parse_instr : Item_t ( vk, (Item_t (Option_t (vv, _, _), Item_t (Big_map_t (k, v, _), _)) as - stack) ) ) -> + stack) ) ) -> check_item_ty ctxt vk k loc I_GET_AND_UPDATE 1 3 >>?= fun (Eq, ctxt) -> check_item_ty ctxt vv v loc I_GET_AND_UPDATE 2 3 >>?= fun (Eq, ctxt) -> check_var_annot loc annot >>?= fun () -> @@ -4921,17 +4921,17 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) match entrypoints.at_node with | None -> ( (if reachable then acc - else - match ty with - | Or_t _ -> acc - | _ -> (List.rev path :: unreachables, all)), + else + match ty with + | Or_t _ -> acc + | _ -> (List.rev path :: unreachables, all)), reachable ) | Some {name; original_type_expr} -> ( (if Entrypoint.Map.mem name all then - (List.rev path :: unreachables, all) - else - ( unreachables, - Entrypoint.Map.add name (Ex_ty ty, original_type_expr) all )), + (List.rev path :: unreachables, all) + else + ( unreachables, + Entrypoint.Map.add name (Ex_ty ty, original_type_expr) all )), true ) in let rec fold_tree : @@ -5009,21 +5009,21 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage >>=? fun (storage, ctxt) -> let loc = Micheline.dummy_location in (if normalize_types then - unparse_parameter_ty ~loc ctxt arg_type ~entrypoints - >>?= fun (arg_type, ctxt) -> - unparse_ty ~loc ctxt storage_type >>?= fun (storage_type, ctxt) -> - Script_map.map_es_in_context - (fun ctxt - _name - (Typed_view {input_ty; output_ty; kinstr = _; original_code_expr}) -> - Lwt.return - ( unparse_ty ~loc ctxt input_ty >>? fun (input_ty, ctxt) -> - unparse_ty ~loc ctxt output_ty >|? fun (output_ty, ctxt) -> - ({input_ty; output_ty; view_code = original_code_expr}, ctxt) )) - ctxt - typed_views - >|=? fun (views, ctxt) -> (arg_type, storage_type, views, ctxt) - else return (original_arg_type_expr, original_storage_type_expr, views, ctxt)) + unparse_parameter_ty ~loc ctxt arg_type ~entrypoints + >>?= fun (arg_type, ctxt) -> + unparse_ty ~loc ctxt storage_type >>?= fun (storage_type, ctxt) -> + Script_map.map_es_in_context + (fun ctxt + _name + (Typed_view {input_ty; output_ty; kinstr = _; original_code_expr}) -> + Lwt.return + ( unparse_ty ~loc ctxt input_ty >>? fun (input_ty, ctxt) -> + unparse_ty ~loc ctxt output_ty >|? fun (output_ty, ctxt) -> + ({input_ty; output_ty; view_code = original_code_expr}, ctxt) )) + ctxt + typed_views + >|=? fun (views, ctxt) -> (arg_type, storage_type, views, ctxt) + else return (original_arg_type_expr, original_storage_type_expr, views, ctxt)) >>=? fun (arg_type, storage_type, views, ctxt) -> Script_map.map_es_in_context (fun ctxt _name {input_ty; output_ty; view_code} -> @@ -5324,9 +5324,7 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = end in ( ctxt, Script_map.make - (module M : Boxed_map - with type key = M.key - and type value = M.value), + (module M : Boxed_map with type key = M.key and type value = M.value), ids_to_copy, acc ) | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc) diff --git a/src/proto_alpha/lib_protocol/script_list.ml b/src/proto_alpha/lib_protocol/script_list.ml index 66d97bdbffbcddb011adcf86e1b5a37824d32818..9b9abddd37af0dba55926e6ac30fede312da854e 100644 --- a/src/proto_alpha/lib_protocol/script_list.ml +++ b/src/proto_alpha/lib_protocol/script_list.ml @@ -44,4 +44,4 @@ let uncons = function Some (hd, {elements = tl; length = length - 1}) let rev {elements; length} = {elements = List.rev elements; length} - [@@inline always] +[@@inline always] diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 4ae6863b929f6b28ce4dcd9e226ef50fabdaba41..0a72f127302e916681ef8e0ddb5cf796c6280793 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1758,7 +1758,8 @@ module Sc_rollup = struct (Make_index (Sc_rollup_repr.Index)) module Make_versioned - (Versioned_value : Sc_rollup_data_version_sig.S) (Data_storage : sig + (Versioned_value : Sc_rollup_data_version_sig.S) + (Data_storage : sig type context type key diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index a7903bb7805a23cf12a84686458e48b1ced032f9..e95ebb2cf2d9a88ea6a660e806968c1b5c0ba631 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -793,19 +793,19 @@ let apply_with_metadata ?(policy = By_round 0) ?(check_size = true) ~baking_mode List.fold_left_es (fun vstate op -> (if check_size then - let operation_size = - Data_encoding.Binary.length - Operation.encoding_with_legacy_attestation_name - op - in - if operation_size > Constants_repr.max_operation_data_length then - raise - (invalid_arg - (Format.sprintf - "The operation size is %d, it exceeds the constant maximum \ - size %d" - operation_size - Constants_repr.max_operation_data_length))) ; + let operation_size = + Data_encoding.Binary.length + Operation.encoding_with_legacy_attestation_name + op + in + if operation_size > Constants_repr.max_operation_data_length then + raise + (invalid_arg + (Format.sprintf + "The operation size is %d, it exceeds the constant \ + maximum size %d" + operation_size + Constants_repr.max_operation_data_length))) ; validate_and_apply_operation vstate op >>=? fun (state, result) -> if allow_manager_failures then return state else diff --git a/src/proto_alpha/lib_protocol/test/helpers/dummy_zk_rollup.ml b/src/proto_alpha/lib_protocol/test/helpers/dummy_zk_rollup.ml index d02f6f5c5c43ebaa16fa005e84a7778b20e9e88c..03875ec112fd0ee9dcd40b0ff3889fe42d665cb9 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/dummy_zk_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/dummy_zk_rollup.ml @@ -380,7 +380,7 @@ end = struct let lazy_srs = lazy (let open Octez_bls12_381_polynomial in - (Srs.generate_insecure 9 1, Srs.generate_insecure 1 1)) + (Srs.generate_insecure 9 1, Srs.generate_insecure 1 1)) let dummy_l1_dst = Hex.to_bytes_exn (`Hex "0002298c03ed7d454a101eb7022bc95f7e5f41ac78") diff --git a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml index c0aa67a2e76ef43d5c7b7d0cd9968886122e568a..0c59fcd26cae92a3d323b32b2bb9d536b650d34d 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_machine.ml @@ -649,7 +649,7 @@ module MachineBuilder = struct fun ?(invariant = fun _ _ -> pure true) ?(subsidy = default_subsidy) ({cpmm_min_xtz_balance; accounts_balances; cpmm_min_tzbtc_balance} as - specs) -> + specs) -> let accounts_balances_with_extra = predict_initial_balances accounts_balances subsidy in @@ -684,13 +684,14 @@ module MachineBuilder = struct >>= fun current_cpmm_tzbtc_balance -> let tzbtc_missing = cpmm_min_tzbtc_balance - current_cpmm_tzbtc_balance in (if 0 < tzbtc_missing then - (* 4.1. Provide the tokens to the [bootstrap1] account, as a - temporary holder for CPMM missing tzBTC balance *) - mint_tzbtc ~invariant env.holder tzbtc_missing env state >>= fun state -> - (* 4.1. Make [bootstrap1] buy some xtz against the appropriate - amount of tzbtc *) - sell_tzbtc ~invariant env.holder env.holder tzbtc_missing env state - else pure state) + (* 4.1. Provide the tokens to the [bootstrap1] account, as a + temporary holder for CPMM missing tzBTC balance *) + mint_tzbtc ~invariant env.holder tzbtc_missing env state + >>= fun state -> + (* 4.1. Make [bootstrap1] buy some xtz against the appropriate + amount of tzbtc *) + sell_tzbtc ~invariant env.holder env.holder tzbtc_missing env state + else pure state) >>= fun state -> (* 5. Provide any missing xtz tokens to [cpmm_contract], if necessary *) get_xtz_balance env.cpmm_contract state @@ -699,9 +700,9 @@ module MachineBuilder = struct Int64.sub cpmm_min_xtz_balance current_cpmm_xtz_balance in (if 0L < xtz_missing then - transaction ~src:env.holder env.cpmm_contract xtz_missing state - >>= fun op -> bake ~invariant ~baker:env.holder [op] env state - else pure state) + transaction ~src:env.holder env.cpmm_contract xtz_missing state + >>= fun op -> bake ~invariant ~baker:env.holder [op] env state + else pure state) >>= fun state -> check_state_satisfies_specs env state specs >>= fun () -> pure (state, env) end diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index 32ab48673e719a18a72819694757867a7bb1175b..e45e8b758310c14841a9103bf7ee963e332e3ba9 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -183,20 +183,20 @@ let batch_operations ?(recompute_counters = false) ~source ctxt |> List.flatten in (if recompute_counters then - Context.Contract.counter ctxt source >>=? fun counter -> - (* Update counters and transform into a contents_list *) - let _, rev_operations = - List.fold_left - (fun (counter, acc) -> function - | Contents (Manager_operation m) -> - ( Manager_counter.succ counter, - Contents (Manager_operation {m with counter}) :: acc ) - | x -> (counter, x :: acc)) - (Manager_counter.succ counter, []) - operations - in - return (List.rev rev_operations) - else return operations) + Context.Contract.counter ctxt source >>=? fun counter -> + (* Update counters and transform into a contents_list *) + let _, rev_operations = + List.fold_left + (fun (counter, acc) -> function + | Contents (Manager_operation m) -> + ( Manager_counter.succ counter, + Contents (Manager_operation {m with counter}) :: acc ) + | x -> (counter, x :: acc)) + (Manager_counter.succ counter, []) + operations + in + return (List.rev rev_operations) + else return operations) >>=? fun operations -> Context.Contract.manager ctxt source >>=? fun account -> Environment.wrap_tzresult @@ Operation.of_list operations diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml index 0de0cdda0c8d1e170445e8795fa3a39c553e34b8..7eb122520de1ed7ca493cfb2b89668929e71a9cb 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml @@ -224,8 +224,8 @@ let test_rewards_block_and_payload_producer () = Context.get_baking_reward_fixed_portion (B b2) >>=? fun baking_reward -> Context.get_bonus_reward (B b2) ~attesting_power >>=? fun bonus_reward -> (if Signature.Public_key_hash.equal baker_b2 baker_b1 then - Context.get_baking_reward_fixed_portion (B b1) - else return Tez.zero) + Context.get_baking_reward_fixed_portion (B b1) + else return Tez.zero) >>=? fun reward_for_b1 -> (* we are in the first scenario where the payload producer is the same as the block producer, in our case, [baker_b2]. [baker_b2] gets the baking reward diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_consensus_key.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_consensus_key.ml index 583cee9b049edcbb00777b2dd7a884e25642d64d..74c9e0db95dcc0eeaeeee0a0eb7b2c64e057974c 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_consensus_key.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_consensus_key.ml @@ -132,18 +132,23 @@ let test_drain_delegate ~low_balance ~exclude_ck ~ck_delegates () = else Block.By_account delegate in (if ck_delegates then - may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> - delegate_stake blk consensus_pkh delegate - else return blk) + may_reveal_manager_key blk (consensus_pkh, consensus_pk) + >>=? fun blk -> delegate_stake blk consensus_pkh delegate + else return blk) >>=? fun blk -> Context.Contract.balance (B blk) (Contract.Implicit delegate) >>=? fun delegate_balance -> (if low_balance then - transfer_tokens blk delegate consensus_pkh delegate_balance - >>=? fun blk -> - may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> - transfer_tokens blk consensus_pkh delegate Tez.(of_mutez_exn 1_000_000L) - else return blk) + transfer_tokens blk delegate consensus_pkh delegate_balance + >>=? fun blk -> + may_reveal_manager_key blk (consensus_pkh, consensus_pk) + >>=? fun blk -> + transfer_tokens + blk + consensus_pkh + delegate + Tez.(of_mutez_exn 1_000_000L) + else return blk) >>=? fun blk -> Context.Contract.balance (B blk) (Contract.Implicit delegate) >>=? fun delegate_balance -> diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_attestation.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_attestation.ml index 6a8e626661f8ebe539a28efda9602874c2394fe6..8ddd5feeedf25efa24ac7d564f16e260705013de 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_attestation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_double_attestation.ml @@ -382,8 +382,8 @@ let test_freeze_more_with_low_balance = | [d1; d2] -> return (if Signature.Public_key_hash.equal account d1.delegate then d1 - else if Signature.Public_key_hash.equal account d2.delegate then d2 - else assert false) + else if Signature.Public_key_hash.equal account d2.delegate then d2 + else assert false) .slots | _ -> assert false (* there are exactly two attesters for this test. *) diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_seed.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_seed.ml index 7c5da4d70f56d95d56b1e0c3834c18a6990e094c..5d3a8bcfbe46d15e75d959c87e8b8fdcc331bdb8 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_seed.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_seed.ml @@ -65,14 +65,14 @@ let test_seed_no_commitment () = let* s = Context.get_seed (B b) in let seed_bytes = Data_encoding.Binary.to_bytes_exn Seed.seed_encoding s in (if expected_seed <> seed_bytes then - let seed_pp = - Hex.show - (Hex.of_string - (Data_encoding.Binary.to_string_exn Seed.seed_encoding s)) - in - let expected_seed_pp = Hex.show (Hex.of_bytes expected_seed) in - Stdlib.failwith - (Format.sprintf "Seed: %s\nExpected: %s\n\n" seed_pp expected_seed_pp)) ; + let seed_pp = + Hex.show + (Hex.of_string + (Data_encoding.Binary.to_string_exn Seed.seed_encoding s)) + in + let expected_seed_pp = Hex.show (Hex.of_bytes expected_seed) in + Stdlib.failwith + (Format.sprintf "Seed: %s\nExpected: %s\n\n" seed_pp expected_seed_pp)) ; return b in let rec bake_and_check_seed b = function diff --git a/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_levels.ml b/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_levels.ml index 6356b38a423b58b675f8fff596e61b25602727b9..2292d98b2e641444c36e4c880c9b1fc9fd81776d 100644 --- a/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_levels.ml +++ b/src/proto_alpha/lib_protocol/test/integration/gas/test_gas_levels.ml @@ -216,20 +216,20 @@ let finalize_validation_and_application (validation_state, application_state) let apply_with_gas header ?(operations = []) (pred : Block.t) = let open Alpha_context in (let open Environment.Error_monad in - begin_validation_and_application - pred.context - Chain_id.zero - (Application header) - ~predecessor:pred.header.shell - >>=? fun vstate -> - List.fold_left_es - (fun vstate op -> - validate_and_apply_operation vstate op >|=? fun (state, _result) -> state) - vstate - operations - >>=? fun vstate -> - finalize_validation_and_application vstate (Some header.shell) - >|=? fun (validation, result) -> (validation.context, result.consumed_gas)) + begin_validation_and_application + pred.context + Chain_id.zero + (Application header) + ~predecessor:pred.header.shell + >>=? fun vstate -> + List.fold_left_es + (fun vstate op -> + validate_and_apply_operation vstate op >|=? fun (state, _result) -> state) + vstate + operations + >>=? fun vstate -> + finalize_validation_and_application vstate (Some header.shell) + >|=? fun (validation, result) -> (validation.context, result.consumed_gas)) >|= Environment.wrap_tzresult >|=? fun (context, consumed_gas) -> let hash = Block_header.hash header in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index e8dcc3b533e9f84da9fb37054e3e75e65a8b4117..70c3587528c431cfde65f10bab2eb752b473d622 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -582,8 +582,8 @@ let test_unparse_data loc ctxt ty x ~expected_readable ~expected_optimized = ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Readable ty x >>=? fun (actual_readable, ctxt) -> (if actual_readable = Micheline.strip_locations expected_readable then - return ctxt - else Alcotest.failf "Error in readable unparsing: %s" loc) + return ctxt + else Alcotest.failf "Error in readable unparsing: %s" loc) >>=? fun ctxt -> Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty x >>=? fun (actual_optimized, ctxt) -> diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index 9e8acf860daaef850e8076c81fae57746962b1aa..dd111c6b13b518873fa6b04a38f1a9c6df712a9d 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -447,16 +447,16 @@ let verify_execute_outbox_message_operations ctxt rollup ~loc ~operations let*? ctxt = Environment.wrap_tzresult (let open Result_syntax in - let* eq, ctxt = - Gas_monad.run - ctxt - (Script_ir_translator.ty_eq - ~error_details:(Informative (-1)) - script_parameters_ty - parameters_ty) - in - let+ Eq = eq in - ctxt) + let* eq, ctxt = + Gas_monad.run + ctxt + (Script_ir_translator.ty_eq + ~error_details:(Informative (-1)) + script_parameters_ty + parameters_ty) + in + let+ Eq = eq in + ctxt) in return (ctxt, (destination, entrypoint, unparsed_parameters)) | _ -> @@ -666,8 +666,8 @@ let execute_outbox_message_without_proof_validation block rollup let*@ res, alpha_ctxt = Sc_rollup_operations.Internal_for_tests.execute_outbox_message (Incremental.alpha_ctxt incr) - ~validate_and_decode_output_proof: - (fun ctxt ~cemented_commitment:_ _rollup ~output_proof:_ -> + ~validate_and_decode_output_proof:(fun + ctxt ~cemented_commitment:_ _rollup ~output_proof:_ -> return (outbox_message, ctxt)) rollup ~cemented_commitment diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_voting.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_voting.ml index f1e184ad9e442392a3f6186630d91cb1d520825a..8f08ccdc30552d9ae3dd4ad704f9c328676b7f9d 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_voting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_voting.ml @@ -456,7 +456,7 @@ let test_successful_vote num_delegates () = (* no proposals at the beginning of proposal period *) Context.Vote.get_proposals (B b) >>=? fun ps -> (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) + else failwith "%s - Unexpected proposals" __LOC__) >>=? fun () -> (* no current proposal during proposal period *) (Context.Vote.get_current_proposal (B b) >>=? function @@ -545,7 +545,7 @@ let test_successful_vote num_delegates () = (* no proposals during exploration period *) Context.Vote.get_proposals (B b) >>=? fun ps -> (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) + else failwith "%s - Unexpected proposals" __LOC__) >>=? fun () -> (* current proposal must be set during exploration period *) (Context.Vote.get_current_proposal (B b) >>=? function @@ -623,7 +623,7 @@ let test_successful_vote num_delegates () = (* no proposals during promotion period *) Context.Vote.get_proposals (B b) >>=? fun ps -> (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) + else failwith "%s - Unexpected proposals" __LOC__) >>=? fun () -> (* current proposal must be set during promotion period *) (Context.Vote.get_current_proposal (B b) >>=? function @@ -878,9 +878,9 @@ let test_supermajority_in_proposal there_is_a_winner () = minimal_stake >>=? fun op2 -> (if there_is_a_winner then Test_tez.( *? ) minimal_stake 3L - else - Test_tez.( *? ) minimal_stake 2L - >>? Test_tez.( +? ) (Test_tez.of_mutez_exn initial_balance)) + else + Test_tez.( *? ) minimal_stake 2L + >>? Test_tez.( +? ) (Test_tez.of_mutez_exn initial_balance)) >>?= fun bal3 -> Op.transaction (B b) @@ -905,7 +905,7 @@ let test_supermajority_in_proposal there_is_a_winner () = (* we remain in the proposal period when there is no winner, otherwise we move to the exploration period *) (if there_is_a_winner then assert_period ~expected_kind:Exploration b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) + else assert_period ~expected_kind:Proposal b __LOC__) >>=? fun () -> return_unit (** After one voting period, if [has_quorum] then the period kind must @@ -941,7 +941,7 @@ let test_quorum_in_proposal has_quorum () = (* we remain in the proposal period when there is no quorum, otherwise we move to the cooldown vote period *) (if has_quorum then assert_period ~expected_kind:Exploration b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) + else assert_period ~expected_kind:Proposal b __LOC__) >>=? fun () -> return_unit (** If a supermajority is reached, then the voting period must be @@ -985,7 +985,7 @@ let test_supermajority_in_exploration supermajority () = Block.bake ~operations b >>=? fun b -> bake_until_first_block_of_next_period b >>=? fun b -> (if supermajority then assert_period ~expected_kind:Cooldown b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) + else assert_period ~expected_kind:Proposal b __LOC__) >>=? fun () -> return_unit (** Test also how the selection scales: all delegates propose max diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_bytes_conversion.ml b/src/proto_alpha/lib_protocol/test/pbt/test_bytes_conversion.ml index 59ebebfd7b771f10c57fb87ecb00d486427cf66c..40e479d0066d421836471d910c31dcd505a03d52 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_bytes_conversion.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_bytes_conversion.ml @@ -161,9 +161,9 @@ let test_bytes_of_int_random () = (* [bytes_of_int] must return the shortest encoding: at most 1 char of zero or '\255's at the head. *) (if Bytes.length bytes >= 2 then - match (Bytes.get bytes 0, Bytes.get bytes 1) with - | '\000', '\000' | '\255', '\255' -> assert false - | _ -> ()) ; + match (Bytes.get bytes 0, Bytes.get bytes 1) with + | '\000', '\000' | '\255', '\255' -> assert false + | _ -> ()) ; (* [int_of_bytes @@ bytes_of_int z = z] *) (let z' = to_zint @@ int_of_bytes_be bytes in Z.Compare.(z = z')) diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml b/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml index 718d442daa97bc6e09fe4f07d1b434eab288c515..ebbe19f387a555a3816802936068063ca8694e5d 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml @@ -79,9 +79,9 @@ let pp_int_map fmt map = in Lwt_main.run (let open Lwt_result_syntax in - let* ctxt = new_ctxt () in - let*?@ kvs, _ = CM.to_list ctxt map in - return kvs) + let* ctxt = new_ctxt () in + let*?@ kvs, _ = CM.to_list ctxt map in + return kvs) |> Result.value_f ~default:(fun () -> assert false) |> Format.fprintf fmt "%a" pp diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_gas_properties.ml b/src/proto_alpha/lib_protocol/test/pbt/test_gas_properties.ml index 53e28d23bf7b5821da895b51859ff4a1eda89f24..f34e8d392af8eb5f6edcdf5f604c015bbef76e77 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_gas_properties.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_gas_properties.ml @@ -46,33 +46,33 @@ let test_free_neutral (start, any_cost) = let open Alpha_context in extract_qcheck_result (let open Result_syntax in - let* free_first = Gas.consume start Gas.free in - let* branch1 = Gas.consume free_first any_cost in - let* cost_first = Gas.consume start any_cost in - let+ branch2 = Gas.consume cost_first Gas.free in - let equal_consumption_from_start t1 t2 = - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:t1) - (Gas.consumed ~since:start ~until:t2)) - in - equal_consumption_from_start branch1 branch2 - && equal_consumption_from_start branch1 cost_first) + let* free_first = Gas.consume start Gas.free in + let* branch1 = Gas.consume free_first any_cost in + let* cost_first = Gas.consume start any_cost in + let+ branch2 = Gas.consume cost_first Gas.free in + let equal_consumption_from_start t1 t2 = + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:t1) + (Gas.consumed ~since:start ~until:t2)) + in + equal_consumption_from_start branch1 branch2 + && equal_consumption_from_start branch1 cost_first) (** Consuming [Gas.free] is equivalent to consuming nothing. *) let test_free_consumption start = let open Alpha_context in extract_qcheck_result (let open Result_syntax in - let+ after_empty_consumption = Gas.consume start Gas.free in - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:after_empty_consumption) - zero)) + let+ after_empty_consumption = Gas.consume start Gas.free in + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:after_empty_consumption) + zero)) (** Consuming [cost1] then [cost2] is equivalent to consuming [Gas.(cost1 +@ cost2)]. *) @@ -80,26 +80,26 @@ let test_consume_commutes (start, cost1, cost2) = let open Alpha_context in extract_qcheck_result (let open Result_syntax in - let* after_cost1 = Gas.consume start cost1 in - let* branch1 = Gas.consume after_cost1 cost2 in - let+ branch2 = Gas.consume start Gas.(cost1 +@ cost2) in - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:branch1) - (Gas.consumed ~since:start ~until:branch2))) + let* after_cost1 = Gas.consume start cost1 in + let* branch1 = Gas.consume after_cost1 cost2 in + let+ branch2 = Gas.consume start Gas.(cost1 +@ cost2) in + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:branch1) + (Gas.consumed ~since:start ~until:branch2))) (** Arbitrary context with a gas limit of 100_000_000. *) let context_gen : Alpha_context.t QCheck2.Gen.t = QCheck2.Gen.return (Lwt_main.run (let open Lwt_result_syntax in - let* b, _contract = Context.init1 () in - let+ inc = Incremental.begin_construction b in - Alpha_context.Gas.set_limit - (Incremental.alpha_ctxt inc) - Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000))) + let* b, _contract = Context.init1 () in + let+ inc = Incremental.begin_construction b in + Alpha_context.Gas.set_limit + (Incremental.alpha_ctxt inc) + Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000))) |> function | Ok a -> a | Error _ -> assert false) diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml index 9d7c3e29ee620fdfc577d92f3540f4449a4102a0..c69c82c1c969b5961bf322ed51b8edb80c45c4a4 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml @@ -489,8 +489,8 @@ module Dissection = struct ~name:"gen_dissection produces a valid dissection" ~print ~gen - (fun (dissection, new_dissection, default_number_of_sections, our_states) - -> + (fun + (dissection, new_dissection, default_number_of_sections, our_states) -> let open Lwt_syntax in match new_dissection with | None -> return (final_dissection ~our_states dissection) @@ -539,16 +539,17 @@ module Dissection = struct "distance < nb_of_sections => (len dissection = succ (dist dissection))" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = 3 -- (number_of_sections - 1) in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_hash, stop_hash = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_hash, stop_hash, number_of_sections, ticks)) + let* number_of_sections = gen_num_sections in + let* ticks = 3 -- (number_of_sections - 1) in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_hash, stop_hash = + gen_dissection ~number_of_sections ~our_states dissection + in + return + (new_dissection, start_hash, stop_hash, number_of_sections, ticks)) (fun ( dissection, start_chunk, stop_chunk, @@ -572,16 +573,16 @@ module Dissection = struct ~name:"distance >= nb_of_sections => (len dissection = nb_of_sections" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = number_of_sections -- 1_000 in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) + let* number_of_sections = gen_num_sections in + let* ticks = number_of_sections -- 1_000 in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return (new_dissection, start_chunk, stop_chunk, number_of_sections)) (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> truncate_and_check_error dissection @@ -599,22 +600,22 @@ module Dissection = struct ~name:"dissection.start_chunk can not change" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - let* new_state_hash = gen_random_hash in - return - ( new_dissection, - start_chunk, - stop_chunk, - number_of_sections, - new_state_hash )) + let* number_of_sections = gen_num_sections in + let* ticks = gen_nonfinal_initial_dissection_ticks in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + let* new_state_hash = gen_random_hash in + return + ( new_dissection, + start_chunk, + stop_chunk, + number_of_sections, + new_state_hash )) (fun ( dissection, start_chunk, stop_chunk, @@ -646,16 +647,16 @@ module Dissection = struct ~name:"dissection.stop_chunk must change" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) + let* number_of_sections = gen_num_sections in + let* ticks = gen_nonfinal_initial_dissection_ticks in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return (new_dissection, start_chunk, stop_chunk, number_of_sections)) (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> let open Lwt_syntax in let check_failure_on_same_stop_hash stop_hash = @@ -691,16 +692,16 @@ module Dissection = struct "start_chunk.tick and stop_chunk.tick can not change in the dissection" ~gen: (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) + let* number_of_sections = gen_num_sections in + let* ticks = gen_nonfinal_initial_dissection_ticks in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return (new_dissection, start_chunk, stop_chunk, number_of_sections)) (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> let open Lwt_syntax in let expected_error dissection = @@ -748,28 +749,28 @@ module Dissection = struct ~name:"dissection must be well distributed" ~gen: (let open Gen in - (* The test is not general enough to support all kind of number of - sections. *) - let number_of_sections = - Tezos_protocol_alpha_parameters.Default_parameters.constants_mainnet - .sc_rollup - .number_of_sections_in_dissection - in - let* picked_section = 0 -- (number_of_sections - 2) in - let* ticks = 100 -- 1_000 in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return - ( new_dissection, - start_chunk, - stop_chunk, - number_of_sections, - picked_section )) + (* The test is not general enough to support all kind of number of + sections. *) + let number_of_sections = + Tezos_protocol_alpha_parameters.Default_parameters.constants_mainnet + .sc_rollup + .number_of_sections_in_dissection + in + let* picked_section = 0 -- (number_of_sections - 2) in + let* ticks = 100 -- 1_000 in + let* dissection = gen_initial_dissection ~ticks () in + let* our_states = + gen_our_states (initial_of_dissection dissection) (succ ticks) + in + let* new_dissection, start_chunk, stop_chunk = + gen_dissection ~number_of_sections ~our_states dissection + in + return + ( new_dissection, + start_chunk, + stop_chunk, + number_of_sections, + picked_section )) (fun ( dissection, start_chunk, stop_chunk, @@ -1493,15 +1494,16 @@ let test_game ?(count = 10) ~p1_strategy ~p2_strategy () = p2_strategy in qcheck_make_lwt_res - ~print: - (fun ( _block, - _rollup, - _commitment_level, - _lcc, - p1_client, - p2_client, - p1_start, - _payloads_per_levels ) -> + ~print:(fun + ( _block, + _rollup, + _commitment_level, + _lcc, + p1_client, + p2_client, + p1_start, + _payloads_per_levels ) + -> Format.asprintf "@[@,@[p1:@,%a@]@,@[p2:@,%a@]@,%s@,@]" pp_player_client diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml index 90d0b24f8d1db445db52235661e2d77b41c4709b..0b30815b89feda06677763142ca1afdb88a2315e 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml @@ -193,9 +193,9 @@ let assert_return x = assert_ok (Lwt_main.run x) let ctxt = assert_return (let open Lwt_result_syntax in - let* b, _cs = Context.init3 () in - let* v = Incremental.begin_construction b in - return (Incremental.alpha_ctxt v)) + let* b, _cs = Context.init3 () in + let* v = Incremental.begin_construction b in + return (Incremental.alpha_ctxt v)) let unparse_comparable_ty ty = Micheline.strip_locations diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml index 68943e4aeba9865b4a86efd0409b764c4d711f2c..4864db09ec339ee9a3717a93972280068b45090e 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml @@ -143,9 +143,9 @@ let test_encode_decode_internal_inbox_message_transfer () = let*? (Script_typed_ir.Ty_ex_c pair_nat_ticket_string_ty) = Environment.wrap_tzresult (let open Result_syntax in - let open Script_typed_ir in - let* ticket_t = ticket_t (-1) string_t in - pair_t (-1) nat_t ticket_t) + let open Script_typed_ir in + let* ticket_t = ticket_t (-1) string_t in + pair_t (-1) nat_t ticket_t) in let payload = ( Script_int.(abs @@ of_int 42), diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml index a3a9d6ee25fd561ee9158a564669eeb9b6247273..c34ae23173e8c9eec60f6a5be96dc26fdf92b4ae 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -1164,12 +1164,12 @@ module Stake_storage_tests = struct ~loc:__LOC__ (cement_commitment ctxt rollup commitment) (let open Sc_rollup_errors in - function - | Sc_rollup_disputed | Sc_rollup_parent_not_lcc - | Raw_context.Storage_error (Missing_key _) (* missing commitment *) - -> - true - | _ -> false)) + function + | Sc_rollup_disputed | Sc_rollup_parent_not_lcc + | Raw_context.Storage_error (Missing_key _) + (* missing commitment *) -> + true + | _ -> false)) in let* () = cant_cement ctxt honest_commitments in let* () = cant_cement ctxt dishonest_commitments in diff --git a/src/proto_alpha/lib_sc_rollup/game_helpers.ml b/src/proto_alpha/lib_sc_rollup/game_helpers.ml index b3ddddc305e12c4da450b9f45af89f5b29257023..80237a59d1c56be495ecbec0511c418923cbc1ac 100644 --- a/src/proto_alpha/lib_sc_rollup/game_helpers.ml +++ b/src/proto_alpha/lib_sc_rollup/game_helpers.ml @@ -104,7 +104,7 @@ module Wasm = struct (* If [is_stop_chunk_aligned] is false, we allocate one sections for the surplus. *) (if is_stop_chunk_aligned then default_number_of_sections - else default_number_of_sections - 1)) + else default_number_of_sections - 1)) max_number_of_sections in diff --git a/src/proto_alpha/lib_sc_rollup_client/configuration.ml b/src/proto_alpha/lib_sc_rollup_client/configuration.ml index 556750448844159ede5078025555fb84f081c32f..ed3d3a5c4ce956b38623c111b1d97064215a5ae5 100644 --- a/src/proto_alpha/lib_sc_rollup_client/configuration.ml +++ b/src/proto_alpha/lib_sc_rollup_client/configuration.ml @@ -85,12 +85,11 @@ let parse argv = in return (make opts, argv) -class type sc_client_context = - object - inherit Base.Client_context.io_wallet +class type sc_client_context = object + inherit Base.Client_context.io_wallet - inherit Tezos_rpc.Context.generic - end + inherit Tezos_rpc.Context.generic +end class unix_sc_client_context ~base_dir ~password_filename ~rpc_config : sc_client_context = diff --git a/src/proto_alpha/lib_sc_rollup_client/configuration.mli b/src/proto_alpha/lib_sc_rollup_client/configuration.mli index 56028f3da1439b653868644d57e7a5a0a7c593ec..3b54217a7486a6a90c8fcd40cdb05df1cdff463a 100644 --- a/src/proto_alpha/lib_sc_rollup_client/configuration.mli +++ b/src/proto_alpha/lib_sc_rollup_client/configuration.mli @@ -45,20 +45,18 @@ val global_options : (** Instance of [Tezos_client_base.Client_context] that only handles IOs and RPCs. Can be used for keys and RPCs related commands. *) -class type sc_client_context = - object - inherit Tezos_client_base.Client_context.io_wallet +class type sc_client_context = object + inherit Tezos_client_base.Client_context.io_wallet - inherit Tezos_rpc.Context.generic - end + inherit Tezos_rpc.Context.generic +end (** Instance of [sc_client_context] for linux systems. Relies on [Tezos_rpc_http_client_unix]. *) -class unix_sc_client_context : - base_dir:string - -> password_filename:string option - -> rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config - -> sc_client_context +class unix_sc_client_context : base_dir:string -> + password_filename:string option -> + rpc_config:Tezos_rpc_http_client_unix.RPC_client_unix.config -> + sc_client_context (** [make_unix_client_context config] generates a unix_sc_client_context from the client configuration. *) diff --git a/src/proto_demo_counter/lib_client/protocol_client_context.ml b/src/proto_demo_counter/lib_client/protocol_client_context.ml index 2c53e65e5c9f8fc5ed8d3655bd38659a5e985187..16a81aacf1d2fd2434ec2b48c5e44d6e3dae5abe 100644 --- a/src/proto_demo_counter/lib_client/protocol_client_context.ml +++ b/src/proto_demo_counter/lib_client/protocol_client_context.ml @@ -23,14 +23,12 @@ (* *) (*****************************************************************************) -class type full = - object - inherit Client_context.full +class type full = object + inherit Client_context.full - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end class wrap_full (t : Client_context.full) : full = object diff --git a/src/proto_demo_counter/lib_client/protocol_client_context.mli b/src/proto_demo_counter/lib_client/protocol_client_context.mli index 70b26388e57d5673fb3fa3e0e799d5bad96a30bc..237ef1af0c268ab02f4610a3a370bf66dd80e65c 100644 --- a/src/proto_demo_counter/lib_client/protocol_client_context.mli +++ b/src/proto_demo_counter/lib_client/protocol_client_context.mli @@ -23,13 +23,11 @@ (* *) (*****************************************************************************) -class type full = - object - inherit Client_context.full +class type full = object + inherit Client_context.full - inherit - [Shell_services.chain * Shell_services.block] Environment.RPC_context - .simple - end + inherit + [Shell_services.chain * Shell_services.block] Environment.RPC_context.simple +end class wrap_full : Client_context.full -> full diff --git a/tezt/lib_performance_regression/long_test.ml b/tezt/lib_performance_regression/long_test.ml index 792e58b5196d53a8b73eec2e47c8e8847610443b..9f811909accd10adc6cf0f6c6ba07db4cc7a4155 100644 --- a/tezt/lib_performance_regression/long_test.ml +++ b/tezt/lib_performance_regression/long_test.ml @@ -558,42 +558,42 @@ module Stats = struct fun (a, (b, c)) -> (a, b, c) ) let rec functions : 'a. 'a t -> _ = - fun (type a) (stats : a t) -> - match stats with - | Int func | Float func -> [func] - | Pair (a, b) -> functions a @ functions b - | Convert (stats, _, _) -> functions stats + fun (type a) (stats : a t) -> + match stats with + | Int func | Float func -> [func] + | Pair (a, b) -> functions a @ functions b + | Convert (stats, _, _) -> functions stats let rec get : 'a. _ -> 'a t -> 'a = - fun (type a) result_data_point (stats : a t) -> - let result : a = - match stats with - | Int func -> - InfluxDB.get - (InfluxDB.column_name_of_func func) - JSON.as_int - result_data_point - | Float func -> - InfluxDB.get - (InfluxDB.column_name_of_func func) - JSON.as_float - result_data_point - | Pair (a, b) -> (get result_data_point a, get result_data_point b) - | Convert (stats, _, decode) -> decode (get result_data_point stats) - in - result + fun (type a) result_data_point (stats : a t) -> + let result : a = + match stats with + | Int func -> + InfluxDB.get + (InfluxDB.column_name_of_func func) + JSON.as_int + result_data_point + | Float func -> + InfluxDB.get + (InfluxDB.column_name_of_func func) + JSON.as_float + result_data_point + | Pair (a, b) -> (get result_data_point a, get result_data_point b) + | Convert (stats, _, decode) -> decode (get result_data_point stats) + in + result let show stats values = let rec gather : 'a. 'a t -> 'a -> _ = - fun (type a) (stats : a t) (values : a) -> - match stats with - | Int func -> [(InfluxDB.column_name_of_func func, string_of_int values)] - | Float func -> - [(InfluxDB.column_name_of_func func, string_of_float values)] - | Pair (a, b) -> - let v, w = values in - gather a v @ gather b w - | Convert (stats, encode, _) -> gather stats (encode values) + fun (type a) (stats : a t) (values : a) -> + match stats with + | Int func -> [(InfluxDB.column_name_of_func func, string_of_int values)] + | Float func -> + [(InfluxDB.column_name_of_func func, string_of_float values)] + | Pair (a, b) -> + let v, w = values in + gather a v @ gather b w + | Convert (stats, encode, _) -> gather stats (encode values) in gather stats values |> List.map (fun (name, value) -> sf "%s = %s" name value) diff --git a/tezt/lib_tezos/protocol.ml b/tezt/lib_tezos/protocol.ml index 5742796255a30d94e107f41dba3ebdd5157110c0..4909ccbb71235c594151cd2e7e50b374c8f178b8 100644 --- a/tezt/lib_tezos/protocol.ml +++ b/tezt/lib_tezos/protocol.ml @@ -227,7 +227,7 @@ let write_parameter_file : [ `String (if is_revealed then account.public_key - else account.public_key_hash); + else account.public_key_hash); `String (string_of_int (Option.value ~default:4000000000000 default_balance)); diff --git a/tezt/lib_tezos/sc_rollup_helpers.ml b/tezt/lib_tezos/sc_rollup_helpers.ml index ba34e85d4ff0f8103f160914cc0dab3b3e9be32a..8e2e9b606e1a031eb54c3d367e4cbb89e461e794 100644 --- a/tezt/lib_tezos/sc_rollup_helpers.ml +++ b/tezt/lib_tezos/sc_rollup_helpers.ml @@ -184,8 +184,8 @@ let setup_l1 ?bootstrap_smart_rollups ?bootstrap_contracts ?commitment_period @ make_parameter "smart_rollup_challenge_window_in_blocks" challenge_window @ make_parameter "smart_rollup_timeout_period_in_blocks" timeout @ (if Protocol.number protocol >= 19 then - make_bool_parameter "smart_rollup_private_enable" whitelist_enable - else []) + make_bool_parameter "smart_rollup_private_enable" whitelist_enable + else []) @ [(["smart_rollup_arith_pvm_enable"], `Bool true)] in let base = Either.right (protocol, None) in diff --git a/tezt/manual_tests/baker_test.ml b/tezt/manual_tests/baker_test.ml index fc84d623c225a5ac67fe107188c100ac8c29d649..21461512b61f38911f45145e19207614e16d058c 100644 --- a/tezt/manual_tests/baker_test.ml +++ b/tezt/manual_tests/baker_test.ml @@ -483,11 +483,11 @@ let baker_early_preattestation_test = "%s have proposed, both baker have pre-attested for their delegates%s" (Baker.name baker1) (if preattestation_should_be_validated then - " and the pqc is reached. Ensure that the pre-attestations are injected \ - in the nodes as validated operation" - else - ". Ensure that the pre-attestations are injected in the nodes as \ - branch_delayed operation") ; + " and the pqc is reached. Ensure that the pre-attestations are injected \ + in the nodes as validated operation" + else + ". Ensure that the pre-attestations are injected in the nodes as \ + branch_delayed operation") ; let expected_preattestations status_a status_b = List.of_seq diff --git a/tezt/tests/dal.ml b/tezt/tests/dal.ml index 2c124e01b29d7d7d69c56048479ddced2932637b..09c8fb3d36088239533fa758f6a5c59f56848fc3 100644 --- a/tezt/tests/dal.ml +++ b/tezt/tests/dal.ml @@ -2089,21 +2089,22 @@ let test_attestor_with_daemon protocol parameters cryptobox node client dal_node int ~error_msg:"Expected index %L (got %R)") ; (if - level < intermediary_level || level >= first_not_attested_published_level - then - (* We cannot know for sure the status of a slot between - [intermediary_level] and - [first_not_attested_published_level]. Before - [intermediary_level], it should be [attested], and above - [first_not_attested_published_level], it should be - [unattested]. *) - let expected_status = - if level < intermediary_level then "attested" else "unattested" - in - Check.( - (expected_status = status) - string - ~error_msg:"Expected status %L (got %R)")) ; + level < intermediary_level + || level >= first_not_attested_published_level + then + (* We cannot know for sure the status of a slot between + [intermediary_level] and + [first_not_attested_published_level]. Before + [intermediary_level], it should be [attested], and above + [first_not_attested_published_level], it should be + [unattested]. *) + let expected_status = + if level < intermediary_level then "attested" else "unattested" + in + Check.( + (expected_status = status) + string + ~error_msg:"Expected status %L (got %R)")) ; check_attestations (level + 1) in check_attestations first_level diff --git a/tezt/tests/evm_rollup.ml b/tezt/tests/evm_rollup.ml index 0cdb60311679af804a1db1586f39b872ad051125..0b22cf4f6188f2b66c7aea59b4fb07362b6adda1 100644 --- a/tezt/tests/evm_rollup.ml +++ b/tezt/tests/evm_rollup.ml @@ -843,7 +843,7 @@ let test_l2_deploy_erc20 = @@ fun protocol -> (* setup *) let* ({sc_rollup_client; evm_proxy_server; node; client; sc_rollup_node; _} as - evm_setup) = + evm_setup) = setup_past_genesis ~deposit_admin:None protocol in let endpoint = Evm_proxy_server.endpoint evm_proxy_server in @@ -1603,7 +1603,7 @@ let test_eth_call_storage_contract_eth_cli = (fun protocol -> (* setup *) let* ({evm_proxy_server; endpoint; sc_rollup_node; client; node; _} as - evm_setup) = + evm_setup) = setup_past_genesis ~deposit_admin:None protocol in diff --git a/tezt/tests/main.ml b/tezt/tests/main.ml index a1c4bac5d21c63c9b8646ef53ebe9d3d212e7ed9..076fbb83e103450296a3e9e880a3a2080c37b0f8 100644 --- a/tezt/tests/main.ml +++ b/tezt/tests/main.ml @@ -68,12 +68,12 @@ let register_protocol_migration_tests () = Protocol_table_update.register ~migrate_from ~migrate_to ; User_activated_upgrade.register ~migrate_from ~migrate_to ; (if alpha_can_stitch_from_its_predecessor then - Protocol.previous_protocol Alpha - |> Option.iter @@ fun from_protocol -> - Voting.register - ~from_protocol - ~to_protocol:(Known Alpha) - ~loser_protocols:[]) ; + Protocol.previous_protocol Alpha + |> Option.iter @@ fun from_protocol -> + Voting.register + ~from_protocol + ~to_protocol:(Known Alpha) + ~loser_protocols:[]) ; Voting.register ~from_protocol:migrate_to ~to_protocol:Injected_test diff --git a/tezt/tests/mockup.ml b/tezt/tests/mockup.ml index 1bc36f4737adb44f0b35f615786c9cc9c702b31a..6e13794401aa36414aec0582e0a418d1fe75a5f8 100644 --- a/tezt/tests/mockup.ml +++ b/tezt/tests/mockup.ml @@ -459,8 +459,8 @@ let test_migration_transfer ?migration_spec () = in let* () = Client.transfer ~amount ~giver ~receiver client in return (giver_balance_before, receiver_balance_before)) - ~post_migration: - (fun client (giver_balance_before, receiver_balance_before) -> + ~post_migration:(fun + client (giver_balance_before, receiver_balance_before) -> let* giver_balance_after = Client.get_balance_for ~account:giver client in let* receiver_balance_after = Client.get_balance_for ~account:receiver client diff --git a/tezt/tests/multiple_transfers.ml b/tezt/tests/multiple_transfers.ml index bccc3378f0821bfdf73fb325b0673af0e028ee42..b77d1721a3d6f1f7cd87f263d76a82ff36142bda 100644 --- a/tezt/tests/multiple_transfers.ml +++ b/tezt/tests/multiple_transfers.ml @@ -107,12 +107,12 @@ let test_transfer_json_to_entrypoint_with_args = let* new_balance_source = Client.get_balance_for ~account:source client in let* new_balance_payer = Client.get_balance_for ~account:payer client in (if payer <> source then - Check.( - (balance_source = new_balance_source) - Tez.typ - ~__LOC__ - ~error_msg: - "Expected source's balance to be unchanged from %R, but got %L")) ; + Check.( + (balance_source = new_balance_source) + Tez.typ + ~__LOC__ + ~error_msg: + "Expected source's balance to be unchanged from %R, but got %L")) ; Check.( (Tez.(balance_payer - fee) = new_balance_payer) Tez.typ diff --git a/tezt/tests/operation_validation.ml b/tezt/tests/operation_validation.ml index ad2fa8d6c84a07fb436cd53b87133933059a849a..a8bb573038047533489f0f207fd9bc9deae0ebde 100644 --- a/tezt/tests/operation_validation.ml +++ b/tezt/tests/operation_validation.ml @@ -49,8 +49,8 @@ let check_validate_1m_restriction_node = Client.init_with_protocol ~nodes_args: ((if disable_operations_precheck then - [Node.Disable_operations_precheck] - else []) + [Node.Disable_operations_precheck] + else []) @ [Synchronisation_threshold 0]) ~protocol `Client diff --git a/tezt/tests/script_annotations.ml b/tezt/tests/script_annotations.ml index 75ad5b46288551febd524a61b9225f792d84e17a..889b5f5d69cb962ad9be4d38977ec9139edef18c 100644 --- a/tezt/tests/script_annotations.ml +++ b/tezt/tests/script_annotations.ml @@ -108,8 +108,8 @@ let register = typecheck_script ?res: (if Protocol.(number protocol > number Nairobi) then - Some (rex "unexpected annotation") - else None) + Some (rex "unexpected annotation") + else None) ~legacy:true ~script:"parameter %r unit; storage unit; code { FAILWITH }" client @@ -120,8 +120,8 @@ let register = typecheck_script ?res: (if Protocol.(number protocol > number Nairobi) then - Some (rex "unexpected annotation") - else None) + Some (rex "unexpected annotation") + else None) ~legacy:true ~script:"parameter %1 unit; storage unit; code { FAILWITH }" client diff --git a/tezt/tests/vdf_test.ml b/tezt/tests/vdf_test.ml index ab94327b2f313bf6e42266c147b1984003596d2e..311de3b9f2b7581858638eb831a3fe28f99fe75f 100644 --- a/tezt/tests/vdf_test.ml +++ b/tezt/tests/vdf_test.ml @@ -66,21 +66,21 @@ let assert_computation_status ?(info = false) ?(assert_is_not = false) in let* current_status = get_seed_computation_status ~info client level.level in (if current_status = Nonce_revelation_stage then - (* For levels in the nonce revelation stage, we also check the consistency - * of [Vdf.Helpers.is_in_nonce_revelation_stage] with - * the [Seed_computation] RPC. *) - let nonce_revelation_threshold = Int32.of_int nonce_revelation_threshold in - if - not - (Vdf.Helpers.is_in_nonce_revelation_stage - ~nonce_revelation_threshold - ~level) - then - failwith - (Printf.sprintf - "Vdf.Helpers.is_in_nonce_revelation_stage is inconsistent with the \ - Seed_computation RPC: returned false on level %d" - level.level)) ; + (* For levels in the nonce revelation stage, we also check the consistency + * of [Vdf.Helpers.is_in_nonce_revelation_stage] with + * the [Seed_computation] RPC. *) + let nonce_revelation_threshold = Int32.of_int nonce_revelation_threshold in + if + not + (Vdf.Helpers.is_in_nonce_revelation_stage + ~nonce_revelation_threshold + ~level) + then + failwith + (Printf.sprintf + "Vdf.Helpers.is_in_nonce_revelation_stage is inconsistent with the \ + Seed_computation RPC: returned false on level %d" + level.level)) ; return @@ assert (comp current_status status) let assert_not_computation_status = diff --git a/tezt/tests/voting.ml b/tezt/tests/voting.ml index 376c899f1ed84ba99624eebf43ecfa711131cb14..64e5d2ffd5ac076fcba7e6ca2793ac6ebba9fe89 100644 --- a/tezt/tests/voting.ml +++ b/tezt/tests/voting.ml @@ -263,7 +263,7 @@ let test_voting ~from_protocol ~(to_protocol : target_protocol) ~loser_protocols (Protocol.tag from_protocol) (target_protocol_tag to_protocol) (if loser_protocols = [] then "none" - else String.concat ", " (List.map Protocol.tag loser_protocols))) + else String.concat ", " (List.map Protocol.tag loser_protocols))) ~tags: ("amendment" :: ("from_" ^ Protocol.tag from_protocol) diff --git a/tezt/vesting_contract_test/state.ml b/tezt/vesting_contract_test/state.ml index edadd6d1785f4e1347bea1fbbed7470e7beb839a..0087fda5ea2d00670931a3272b98a74ae8119f82 100644 --- a/tezt/vesting_contract_test/state.ml +++ b/tezt/vesting_contract_test/state.ml @@ -53,10 +53,11 @@ module type MONAD = sig val bind : 'a t -> ('a -> 'b t) -> 'b t end -module Monad (State : sig - type t -end) -(M : MONAD) = +module Monad + (State : sig + type t + end) + (M : MONAD) = struct type nonrec 'a t = State.t -> ('a * State.t) M.t diff --git a/tezt/vesting_contract_test/vesting_test.ml b/tezt/vesting_contract_test/vesting_test.ml index abbec026d18ca29b6bd320644805054477f3298c..10f3a78bb897e242f873e41c871b1707a6336286 100644 --- a/tezt/vesting_contract_test/vesting_test.ml +++ b/tezt/vesting_contract_test/vesting_test.ml @@ -380,7 +380,7 @@ let vest ?(expect_failure = false) ?(amount = Tez.zero) vesting_contract = in assert_updated_storage (if expect_failure then [] - else Contract_storage.[increment_vested_balance; next_payout]) + else Contract_storage.[increment_vested_balance; next_payout]) vesting_contract let sign_transfer ?(expect_failure = false) ?data ~contract ~replay ~receiver @@ -588,7 +588,7 @@ let set_keys ?(expect_failure = false) ~signers ~key_groups ~overall_threshold let* () = assert_balance contract in assert_updated_storage (if expect_failure then [] - else Contract_storage.[update_keys key_groups overall_threshold]) + else Contract_storage.[update_keys key_groups overall_threshold]) contract let transfer_and_pour_happy_path =