diff --git a/docs/doc_gen/rpc_doc.ml b/docs/doc_gen/rpc_doc.ml index c770d812fbc2a7936ce64e2c052113be633144e9..7e58dff2b8b6592ae3b561b78180644963c99526 100644 --- a/docs/doc_gen/rpc_doc.ml +++ b/docs/doc_gen/rpc_doc.ml @@ -381,9 +381,10 @@ let main node = in let dirs = ("shell", "Shell", [""], shell_dir) :: protocol_dirs in let (_version, name, path, dir) = - List.find - (fun (version, _name, _path, _dir) -> version = required_version) - dirs + Option.get + @@ List.find + (fun (version, _name, _path, _dir) -> version = required_version) + dirs in RPC_directory.describe_directory ~recurse:true ~arg:() dir >>= fun dir -> diff --git a/src/bin_client/client_protocols_commands.ml b/src/bin_client/client_protocols_commands.ml index e2ea6a48f3990b152f7a3005735671db74cab496..9c23a87c82e8a3f45980537bdaef758fc762c4cc 100644 --- a/src/bin_client/client_protocols_commands.ml +++ b/src/bin_client/client_protocols_commands.ml @@ -48,9 +48,7 @@ let commands () = (fun () (cctxt : #Client_context.full) -> Shell_services.Protocol.list cctxt >>=? fun protos -> - Lwt_list.iter_s - (fun ph -> cctxt#message "%a" Protocol_hash.pp ph) - protos + List.iter_s (fun ph -> cctxt#message "%a" Protocol_hash.pp ph) protos >>= fun () -> return_unit); command ~group diff --git a/src/bin_client/client_rpc_commands.ml b/src/bin_client/client_rpc_commands.ml index 6fc432ffc3b8e297020d92cbef2ab44f9dbc0163..c8fc74cb4136160e54fca75dcf584e0229040068 100644 --- a/src/bin_client/client_rpc_commands.ml +++ b/src/bin_client/client_rpc_commands.ml @@ -77,7 +77,7 @@ let fill_in ?(show_optionals = true) input schema = | Combine ((One_of | Any_of), elts) -> let nb = List.length elts in input.int 0 (nb - 1) (Some "Select the schema to follow") path - >>= fun n -> element path (List.nth elts n) + >>= fun n -> element path (Option.get @@ List.nth elts n) | Combine ((All_of | Not), _) -> Lwt.fail Unsupported_construct | Def_ref name -> @@ -85,29 +85,23 @@ let fill_in ?(show_optionals = true) input schema = | Id_ref _ | Ext_ref _ -> Lwt.fail Unsupported_construct | Array (elts, _) -> - let rec fill_loop acc n ls = - match ls with - | [] -> - Lwt.return acc - | elt :: elts -> - element (string_of_int n :: path) elt - >>= fun json -> fill_loop (json :: acc) (succ n) elts - in - fill_loop [] 0 elts >>= fun acc -> Lwt.return (`A (List.rev acc)) + List.mapi_s (fun n elt -> element (string_of_int n :: path) elt) elts + >|= fun a -> `A a | Object {properties; _} -> - let properties = - if show_optionals then properties - else List.filter (fun (_, _, b, _) -> b) properties - in - let rec fill_loop acc ls = - match ls with - | [] -> - Lwt.return acc - | (n, elt, _, _) :: elts -> - element (n :: path) elt - >>= fun json -> fill_loop ((n, json) :: acc) elts - in - fill_loop [] properties >>= fun acc -> Lwt.return (`O (List.rev acc)) + if show_optionals then + List.map_s + (fun (n, elt, _, _) -> + element (n :: path) elt >|= fun json -> (n, json)) + properties + >|= fun o -> `O o + else + List.filter_map_s + (fun (n, elt, optional, _) -> + if optional then + element (n :: path) elt >|= fun json -> Some (n, json) + else Lwt.return_none) + properties + >|= fun o -> `O o | Monomorphic_array (elt, specs) -> let rec fill_loop acc min n max = if n > max then Lwt.return acc diff --git a/src/bin_node/node_config_file.ml b/src/bin_node/node_config_file.ml index 77a2e92f2863099f6bda7891d1fa11030171c4e2..297a519be98554d10924101c8478eb9cdcaf7c5a 100644 --- a/src/bin_node/node_config_file.ml +++ b/src/bin_node/node_config_file.ml @@ -1233,7 +1233,7 @@ let to_ipv4 ipv6_l = | Some ipv4 -> Lwt.return_some (ipv4, port) in - Lwt_list.filter_map_s convert_or_warn ipv6_l + List.filter_map_s convert_or_warn ipv6_l let resolve_addr ~default_addr ?default_port ?(passive = false) peer = let (addr, port) = P2p_point.Id.parse_addr_port peer in @@ -1250,7 +1250,7 @@ let resolve_addr ~default_addr ?default_port ?(passive = false) peer = Lwt_utils_unix.getaddrinfo ~passive ~node ~service let resolve_addrs ~default_addr ?default_port ?passive peers = - Lwt_list.fold_left_s + List.fold_left_s (fun a peer -> resolve_addr ~default_addr ?default_port ?passive peer >>= fun points -> Lwt.return (List.rev_append points a)) @@ -1321,7 +1321,7 @@ let check_discovery_addr config = Lwt.fail exn) let check_rpc_listening_addr config = - Lwt_list.iter_p + List.iter_p (fun addr -> Lwt.catch (fun () -> @@ -1365,7 +1365,7 @@ let bootstrap_peers config = peers let check_bootstrap_peers config = - Lwt_list.iter_p check_bootstrap_peer (bootstrap_peers config) + List.iter_p check_bootstrap_peer (bootstrap_peers config) let fail fmt = Format.kasprintf (fun s -> prerr_endline s ; exit 1) fmt diff --git a/src/bin_node/node_run_command.ml b/src/bin_node/node_run_command.ml index e2e90fa8f5e6f2935956d426588c45a40afde245..aad362781024bc0a833ec00ca4e8ea3ae552c4b8 100644 --- a/src/bin_node/node_run_command.ml +++ b/src/bin_node/node_run_command.ml @@ -341,14 +341,14 @@ let launch_rpc_server (config : Node_config_file.t) node (addr, port) = Lwt.return (error_exn exn)) let init_rpc (config : Node_config_file.t) node = - fold_right_s + List.fold_right_es (fun addr acc -> Node_config_file.resolve_rpc_listening_addrs addr >>= function | [] -> failwith "Cannot resolve listening address: %S" addr | addrs -> - fold_right_s + List.fold_right_es (fun x a -> launch_rpc_server config node x >>=? fun o -> return (o :: a)) addrs @@ -412,7 +412,7 @@ let run ?verbosity ?sandbox ?checkpoint ~singleprocess ~after:[node_downer] (fun _ -> Event.(emit shutting_down_rpc_server) () - >>= fun () -> Lwt_list.iter_p RPC_server.shutdown rpc) + >>= fun () -> List.iter_p RPC_server.shutdown rpc) in Event.(emit node_is_ready) () >>= fun () -> @@ -463,7 +463,7 @@ let process sandbox verbosity checkpoint singleprocess args = (fun () -> run ?sandbox ?verbosity ?checkpoint ~singleprocess config) (function | Unix.Unix_error (Unix.EADDRINUSE, "bind", "") -> - Lwt_list.fold_right_s + List.fold_right_s (fun addr acc -> Node_config_file.resolve_rpc_listening_addrs addr >>= fun x -> Lwt.return (x @ acc)) diff --git a/src/bin_signer/handler.ml b/src/bin_signer/handler.ml index e4fa1c94bcaf7d6ace274890bfb9e405881bc830..55f8c5673f968bb6caecb43103f8da994dc6cda9 100644 --- a/src/bin_signer/handler.ml +++ b/src/bin_signer/handler.ml @@ -151,9 +151,8 @@ let check_authorization cctxt pkh data require_auth signature = Authorized_key.load cctxt >>=? fun keys -> if - List.fold_left - (fun acc (_, key) -> acc || Signature.check key signature to_sign) - false + List.exists + (fun (_, key) -> Signature.check key signature to_sign) keys then return_unit else failwith "invalid authentication signature" diff --git a/src/bin_signer/socket_daemon.ml b/src/bin_signer/socket_daemon.ml index 66e41a463e8bf3c2cd03e4b95d60aae23784a5ff..37ef3b73be405593f844cdc6b736961b0edb6174 100644 --- a/src/bin_signer/socket_daemon.ml +++ b/src/bin_signer/socket_daemon.ml @@ -149,4 +149,4 @@ let run ?magic_bytes ?timeout ~check_high_watermark ~require_auth >>= fun _ -> Lwt.return_unit) ; loop fd in - Lwt_list.map_p loop fds >>= return + List.map_p loop fds >>= return diff --git a/src/bin_snoop/display.ml b/src/bin_snoop/display.ml index 71efa13c9237ac91e72b9534e7add6e2c4542786..62bbd426054810a3c65afe1236b95596519219e1 100644 --- a/src/bin_snoop/display.ml +++ b/src/bin_snoop/display.ml @@ -167,7 +167,11 @@ let empirical_data (workload_data : (Sparse_vec.String.t * float) list) = Matrix.set timings i 0 qty) samples ; let columns = Array.to_list columns in - let named_columns = List.combine vars columns in + let named_columns = + List.combine ~when_different_lengths:() vars columns + |> (* [columns = Array.to_list (Array.init (List.length vars))] *) + Result.get_ok + in Ok (named_columns, timings) let column_is_constant (m : Matrix.t) = @@ -189,10 +193,12 @@ let prune_problem problem : (Free_variable.t * Matrix.t) list * Matrix.t = | Inference.Non_degenerate {input; output; nmap; _} -> let (_, cols) = Matrix.shape input in let named_columns = - List.init cols (fun c -> + List.init ~when_negative_length:() cols (fun c -> let name = Inference.NMap.nth_exn nmap c in let col = Matrix.column input c in (name, col)) + |> (* column count cannot be negative *) + Result.get_ok in let columns = List.filter @@ -241,12 +247,12 @@ let validator (problem : Inference.problem) (solution : Inference.solution) = let empirical (workload_data : (Sparse_vec.String.t * float) list) : (int * (col:int -> unit Plot.t), string) result = - Result.bind (empirical_data workload_data) - @@ fun (columns, timings) -> - Result.bind (plot_scatter "Empirical" columns [timings]) - @@ fun plots -> + empirical_data workload_data + >>? fun (columns, timings) -> + plot_scatter "Empirical" columns [timings] + >>? fun plots -> let nrows = List.length plots in - Result.ok (nrows, fun ~col -> plot_stacked 0 col plots) + Ok (nrows, fun ~col -> plot_stacked 0 col plots) let eval_mset (mset : Free_variable.Sparse_vec.t) (eval : Free_variable.t -> float) = @@ -262,7 +268,7 @@ let validator_empirical workload_data (problem : Inference.problem) (solution : Inference.solution) : (int * (col:int -> unit Plot.t), string) result = let {Inference.mapping; _} = solution in - let valuation name = List.assoc name mapping in + let valuation name = Option.get @@ List.assoc name mapping in let predicted = match problem with | Inference.Degenerate {predicted; _} -> diff --git a/src/bin_snoop/report.ml b/src/bin_snoop/report.ml index be573f5fd0b383ca59cdcea7593f31d11e5840b0..2ce86226a1a21943a2fcaf951bdae3f64794676e 100644 --- a/src/bin_snoop/report.ml +++ b/src/bin_snoop/report.ml @@ -248,8 +248,12 @@ let inferred_params_table (solution : Inference.solution) = | [] | [[]] -> assert false | column_names :: lines -> - let dim = List.length column_names in - let spec = splice Syntax.Vbar (List.init dim (fun _i -> Syntax.L)) in + let spec_data = + (* we do not actually care about the content of the column_names, + just matching things one-to-one for equal length. *) + List.rev_map (fun _ -> Syntax.L) column_names + in + let spec = splice Syntax.Vbar spec_data in let hdr = Syntax.Row (List.map (fun x -> [normal_text x]) column_names) in diff --git a/src/lib_base/tzPervasives.ml b/src/lib_base/tzPervasives.ml index 55c2ba6a919f42f57860857b9f3790a519b41050..1d43a44b04b613e9235b12a545630a97b7cf43fe 100644 --- a/src/lib_base/tzPervasives.ml +++ b/src/lib_base/tzPervasives.ml @@ -41,8 +41,8 @@ module Option = struct end module List = struct - include List include Tezos_stdlib.TzList + include Tezos_lwt_result_stdlib.Lwtreslib.List end module String = struct diff --git a/src/lib_base/tzPervasives.mli b/src/lib_base/tzPervasives.mli index 76629784611a35d709be744c155fb06da7ad07fc..5060203ff6639d5f3872a6b5c0b7c7ddc2238cac 100644 --- a/src/lib_base/tzPervasives.mli +++ b/src/lib_base/tzPervasives.mli @@ -50,9 +50,9 @@ module Option : sig end module List : sig - include module type of List - include module type of Tezos_stdlib.TzList + + include module type of Tezos_lwt_result_stdlib.Lwtreslib.List end module String : sig diff --git a/src/lib_base/unix/socket.ml b/src/lib_base/unix/socket.ml index 54472eead5f7dbe651c4e2d0e61af32aae9f6127..518f4cd0b717bb2ae64d1cbc42bc674a526f2ef7 100644 --- a/src/lib_base/unix/socket.ml +++ b/src/lib_base/unix/socket.ml @@ -108,7 +108,7 @@ let bind ?(backlog = 10) = function Lwt_unix.listen sock backlog ; return sock in - map_s do_bind addrs ) + Tezos_lwt_result_stdlib.Lwtreslib.List.map_es do_bind addrs ) (* To get the encoding/decoding errors into scope. *) open Data_encoding_wrapper diff --git a/src/lib_benchmark/base_samplers.ml b/src/lib_benchmark/base_samplers.ml index 1565f5c3e2dd32e44726589a3ac725a8a8212d1f..fab45244d36ae9b884adcb6d2db3c10848536f48 100644 --- a/src/lib_benchmark/base_samplers.ml +++ b/src/lib_benchmark/base_samplers.ml @@ -117,7 +117,11 @@ module Adversarial = struct assert (n > 0) ; let common_prefix = string state ~range in let rand_suffix () = if Random.bool () then "\x00" else "\x01" in - let elements = List.init n (fun _ -> common_prefix ^ rand_suffix ()) in + let elements = + List.init ~when_negative_length:() n (fun _ -> + common_prefix ^ rand_suffix ()) + |> (* see [assert] above *) Result.get_ok + in (common_prefix, elements) (* Adversarial bytes *) diff --git a/src/lib_benchmark/csv.ml b/src/lib_benchmark/csv.ml index f5ac2cf5ea8158c4fb35c6a3f1d396b8b1094dc4..f11a91f769e727f094b6cc61532aa905ffb381bf 100644 --- a/src/lib_benchmark/csv.ml +++ b/src/lib_benchmark/csv.ml @@ -46,7 +46,13 @@ let concat (csv1 : csv) (csv2 : csv) : csv = else if not (all_equal lengths2) then let msg = "Csv.concat: first argument has uneven # of lines" in Stdlib.failwith msg - else List.map2 (fun line1 line2 -> line1 @ line2) csv1 csv2 + else + List.map2 + ~when_different_lengths:() + (fun line1 line2 -> line1 @ line2) + csv1 + csv2 + |> (* see top if condition *) Result.get_ok let export ~filename ?(separator = ',') ?(linebreak = '\n') (data : csv) = Format.eprintf "Exporting to %s@." filename ; @@ -104,8 +110,7 @@ let append_columns ~filename ?(separator = ',') ?(linebreak = '\n') with Sys_error _ | Empty_csv_file -> (* If the target file does not exist or is empty, we create a dummy CSV matrix with the expected dimensions. *) - let length_data = List.length data in - List.init length_data (fun _ -> []) + List.map (fun _ -> []) data in let csv_data = concat file_data data in export ~filename ~separator ~linebreak csv_data diff --git a/src/lib_benchmark/example/blake2b.ml b/src/lib_benchmark/example/blake2b.ml index a1f73d92b1ec1712b309bc6511d85e04b78f682f..36b7046573beb22afe70d16b81585bbf920844fd 100644 --- a/src/lib_benchmark/example/blake2b.ml +++ b/src/lib_benchmark/example/blake2b.ml @@ -102,4 +102,4 @@ let () = Registration.register (module Blake2b_bench) let () = Registration.register_for_codegen "blake2b_codegen" - (Model.For_codegen (List.assoc "blake2b" Blake2b_bench.models)) + (Model.For_codegen (Option.get @@ List.assoc "blake2b" Blake2b_bench.models)) diff --git a/src/lib_benchmark/fixed_point_transform.ml b/src/lib_benchmark/fixed_point_transform.ml index a92d51eea806c8ce42fb8893fd5a671ccdba8943..22121ca3522e8061b2f22f0ed9d5af982b19f45f 100644 --- a/src/lib_benchmark/fixed_point_transform.ml +++ b/src/lib_benchmark/fixed_point_transform.ml @@ -218,7 +218,8 @@ module Fixed_point_arithmetic (Lang : Fixed_point_lang_sig) = struct (* All bits of a float: all_bits x = [sign] @ exponent @ mantissa *) let all_bits (x : float) : int64 list = - List.init 64 (fun i -> bit x i) |> List.rev + List.init ~when_negative_length:() 64 (fun i -> bit x i) + |> (* 64 >= 0 *) Result.get_ok |> List.rev (* take n first elements from a list *) let take n l = diff --git a/src/lib_benchmark/inference.ml b/src/lib_benchmark/inference.ml index ca56b253af3b0e918b95a68f8a60349f89aad7df..d437898e12a4f8bc37ccc98469f04ae3fbce4182 100644 --- a/src/lib_benchmark/inference.ml +++ b/src/lib_benchmark/inference.ml @@ -242,11 +242,15 @@ let fv_to_string fv = Format.asprintf "%a" Free_variable.pp fv let to_list_of_rows (m : Scikit.Matrix.t) : float list list = let (lines, cols) = Scikit.Matrix.shape m in - List.init lines (fun l -> List.init cols (fun c -> Scikit.Matrix.get m l c)) + let init n f = + List.init ~when_negative_length:() n f + |> (* lines/column count cannot be negative *) Result.get_ok + in + init lines (fun l -> init cols (fun c -> Scikit.Matrix.get m l c)) let of_list_of_rows (m : float list list) : Scikit.Matrix.t = let lines = List.length m in - let cols = List.length (List.hd m) in + let cols = List.length (Option.get @@ List.hd m) in let mat = Scikit.Matrix.create ~lines ~cols in List.iteri (fun l row -> List.iteri (fun c elt -> Scikit.Matrix.set mat l c elt) row) @@ -255,7 +259,11 @@ let of_list_of_rows (m : float list list) : Scikit.Matrix.t = let model_matrix_to_csv (m : Scikit.Matrix.t) (nmap : NMap.t) : Csv.csv = let (_, cols) = Scikit.Matrix.shape m in - let names = List.init cols (fun i -> fv_to_string (NMap.nth_exn nmap i)) in + let names = + List.init ~when_negative_length:() cols (fun i -> + fv_to_string (NMap.nth_exn nmap i)) + |> (* number of column cannot be negative *) Result.get_ok + in let rows = to_list_of_rows m in let rows = List.map (List.map string_of_float) rows in names :: rows diff --git a/src/lib_benchmark/override.ml b/src/lib_benchmark/override.ml index 3acb9348b5e4ee8c091bcc293370b3ba38fb4af8..9a2e16e029875ee788ac83b0677698819e1a25c7 100644 --- a/src/lib_benchmark/override.ml +++ b/src/lib_benchmark/override.ml @@ -46,6 +46,7 @@ let load_file ~filename map = (header, overrides) in List.fold_left2 + ~when_different_lengths:() (fun map name coeff -> let coeff_float = try float_of_string coeff @@ -56,6 +57,7 @@ let load_file ~filename map = map header values + |> (* {!Csv.import} fails before this can *) Result.get_ok let load ~filenames : t = List.fold_left diff --git a/src/lib_benchmark/test/test_costlang.ml b/src/lib_benchmark/test/test_costlang.ml index c39f2bdcb5f829095a2e00dffa08100be7bfe818..1e2a247b64a609ec7388971e30393db23673f573 100644 --- a/src/lib_benchmark/test/test_costlang.ml +++ b/src/lib_benchmark/test/test_costlang.ml @@ -78,10 +78,12 @@ let test_eval1 () = Subst (struct let subst x = - try List.assoc x [(fv_v1, 88.); (fv_v2, 4.); (fv_const, -10.)] - with e -> - Format.eprintf "failed to get %a@." Free_variable.pp x ; - raise e + match List.assoc x [(fv_v1, 88.); (fv_v2, 4.); (fv_const, -10.)] with + | Some v -> + v + | None -> + Format.eprintf "failed to get %a@." Free_variable.pp x ; + raise Not_found end) (Eval) in @@ -93,7 +95,13 @@ let test_eval2 () = let module Subst = Subst (struct - let subst x = List.assoc x [(fv_v1, 2.); (fv_v2, 4.); (fv_const, -10.)] + let subst x = + match List.assoc x [(fv_v1, 2.); (fv_v2, 4.); (fv_const, -10.)] with + | Some v -> + v + | None -> + Format.eprintf "failed to get %a@." Free_variable.pp x ; + raise Not_found end) (Eval) in diff --git a/src/lib_clic/clic.ml b/src/lib_clic/clic.ml index 2831a586df7502f07d5076879a7346daf6b7e081..819c5d00d51ccbe026d1420f60c775e3a53b4d85 100644 --- a/src/lib_clic/clic.ml +++ b/src/lib_clic/clic.ml @@ -1884,11 +1884,12 @@ let find_command tree initial_arguments = return (cmd, empty_args_dict, initial_arguments) | (TPrefix {stop = None; prefix}, ([] | ("-h" | "--help") :: _)) -> fail (Unterminated_command (initial_arguments, gather_assoc prefix)) - | (TPrefix {prefix; _}, hd_arg :: tl) -> - ( try return (List.assoc hd_arg prefix) - with Not_found -> - fail (Command_not_found (List.rev acc, gather_assoc prefix)) ) - >>=? fun tree' -> traverse tree' tl (hd_arg :: acc) + | (TPrefix {prefix; _}, hd_arg :: tl) -> ( + match List.assoc hd_arg prefix with + | None -> + fail (Command_not_found (List.rev acc, gather_assoc prefix)) + | Some tree' -> + traverse tree' tl (hd_arg :: acc) ) | (TParam {stop = None; _}, ([] | ("-h" | "--help") :: _)) -> fail (Unterminated_command (initial_arguments, gather_commands tree)) | (TParam {stop = Some c; _}, []) -> @@ -2013,7 +2014,7 @@ let complete_next_tree cctxt = function >|=? fun completions -> completions @ list_command_args command | TNonTerminalSeq {autocomplete; suffix; _} -> complete_func autocomplete cctxt - >|=? fun completions -> completions @ [List.hd suffix] + >|=? fun completions -> completions @ [Option.get @@ List.hd suffix] | TParam {autocomplete; _} -> complete_func autocomplete cctxt | TStop command -> @@ -2059,8 +2060,11 @@ let complete_tree cctxt tree index args = | _ -> complete_next_tree cctxt this_tree ) | (TPrefix {prefix; _}, hd :: tl) -> ( - try help (List.assoc hd prefix) tl (ind - 1) - with Not_found -> return_nil ) + match List.assoc hd prefix with + | None -> + return_nil + | Some p -> + help p tl (ind - 1) ) | (TParam {tree; _}, _ :: tl) -> help tree tl (ind - 1) | (TStop (Command {options = Argument {spec; _}; conv; _}), args) -> diff --git a/src/lib_clic/dune b/src/lib_clic/dune index 22f96d5f10bd33eb890887ef2b72ef105b61d689..5108619e722668e7d4ff0149abe24554740febc1 100644 --- a/src/lib_clic/dune +++ b/src/lib_clic/dune @@ -2,11 +2,15 @@ (name tezos_clic) (public_name tezos-clic) (flags (:standard -open Tezos_stdlib - -open Tezos_error_monad)) + -open Tezos_error_monad + -open Tezos_lwt_result_stdlib.Lwtreslib + )) (libraries tezos-stdlib lwt re - tezos-error-monad)) + tezos-error-monad + tezos-lwt-result-stdlib + )) (rule (alias runtest_lint) diff --git a/src/lib_clic/tezos-clic.opam b/src/lib_clic/tezos-clic.opam index 22d9ee257abe8dd8337dc1453c3c869be8ba399a..0279a87816839f619630e1982a7c6a583b1376d1 100644 --- a/src/lib_clic/tezos-clic.opam +++ b/src/lib_clic/tezos-clic.opam @@ -12,7 +12,7 @@ depends: [ "tezos-stdlib" "tezos-stdlib-unix" "tezos-error-monad" - "alcotest-lwt" { with-test & >= "1.1.0" } + "tezos-lwt-result-stdlib" ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/lib_clic/unix/dune b/src/lib_clic/unix/dune index 346992e4bff209b3ff176196933811073679baaa..8d472a1c8dd46ee78f31d0bc8a16c8bf015420ea 100644 --- a/src/lib_clic/unix/dune +++ b/src/lib_clic/unix/dune @@ -3,10 +3,14 @@ (public_name tezos-clic.unix) (flags (:standard -open Tezos_stdlib -open Tezos_clic - -open Tezos_error_monad)) + -open Tezos_error_monad + -open Tezos_lwt_result_stdlib.Lwtreslib + )) (libraries tezos-clic tezos-stdlib-unix - tezos-error-monad)) + tezos-error-monad + tezos-lwt-result-stdlib + )) (rule (alias runtest_lint) diff --git a/src/lib_clic/unix/scriptable.ml b/src/lib_clic/unix/scriptable.ml index 618ce6d5a2d3f0c4377472be4955ad641db62fe1..2dfe4c5e95061b65f75d07c3d193676a4884428b 100644 --- a/src/lib_clic/unix/scriptable.ml +++ b/src/lib_clic/unix/scriptable.ml @@ -37,7 +37,7 @@ let output ?(channel = Lwt_io.stdout) how_option ~for_human ~for_script = for_human () | Some (Rows {separator; escape}) -> let open Format in - iter_s + List.iter_es (fun row -> fprintf_lwt channel diff --git a/src/lib_client_base/client_aliases.ml b/src/lib_client_base/client_aliases.ml index acffe8e6cb5179cc44d4827f60b113a98090d88b..80d26cefe2f305a315e8468e5013e800811e6ef5 100644 --- a/src/lib_client_base/client_aliases.ml +++ b/src/lib_client_base/client_aliases.ml @@ -129,12 +129,12 @@ module Alias (Entity : Entity) = struct | Error _ -> return_nil | Ok list -> return (List.map fst list) let find_opt (wallet : #wallet) name = - load wallet >|=? fun list -> List.assoc_opt name list + load wallet >|=? fun list -> List.assoc name list let find (wallet : #wallet) name = load wallet >>=? fun list -> - match List.assoc_opt name list with + match List.assoc name list with | Some v -> return v | None -> @@ -142,8 +142,7 @@ module Alias (Entity : Entity) = struct let rev_find (wallet : #wallet) v = load wallet - >|=? fun list -> - Option.map fst @@ List.find_opt (fun (_, v') -> v = v') list + >|=? fun list -> Option.map fst @@ List.find (fun (_, v') -> v = v') list let rev_find_all (wallet : #wallet) v = load wallet @@ -160,7 +159,7 @@ module Alias (Entity : Entity) = struct >>=? fun list -> ( if force then return_unit else - iter_s + List.iter_es (fun (n, v) -> if n = name && v = value then ( keep := true ; @@ -215,7 +214,7 @@ module Alias (Entity : Entity) = struct >>=? fun list -> ( if force then return_unit else - iter_s + List.iter_es (fun (n, v) -> if n = s then Entity.to_source v diff --git a/src/lib_client_base/client_keys.ml b/src/lib_client_base/client_keys.ml index 4baa21380b10f148c532770e9a72574ec96d3df0..853225e58f2c60453b959fcb1333fa2f48925584 100644 --- a/src/lib_client_base/client_keys.ml +++ b/src/lib_client_base/client_keys.ml @@ -386,7 +386,7 @@ let join_keys keys1_opt keys2 = let raw_get_key (cctxt : #Client_context.wallet) pkh = Public_key_hash.rev_find_all cctxt pkh >>=? (fun names -> - fold_left_s + List.fold_left_es (fun keys_opt n -> Secret_key.find_opt cctxt n >>=? fun sk_uri -> @@ -448,7 +448,7 @@ let get_public_key cctxt pkh = let get_keys (cctxt : #Client_context.wallet) = Secret_key.load cctxt >>=? fun sks -> - Lwt_list.filter_map_s + List.filter_map_s (fun (name, sk_uri) -> Public_key_hash.find cctxt name >>=? (fun pkh -> @@ -469,7 +469,7 @@ let get_keys (cctxt : #Client_context.wallet) = let list_keys cctxt = Public_key_hash.load cctxt >>=? fun l -> - map_s + List.map_es (fun (name, pkh) -> raw_get_key cctxt pkh >>= function diff --git a/src/lib_client_commands/client_admin_commands.ml b/src/lib_client_commands/client_admin_commands.ml index d988d9ac1bcaafd466d3c20f1e4cae39c4bbdf98..a6ddc4681026c73e8b436c2c1a496f72ac76c715 100644 --- a/src/lib_client_commands/client_admin_commands.ml +++ b/src/lib_client_commands/client_admin_commands.ml @@ -48,7 +48,7 @@ let commands () = ~name:"block" ~desc:"blocks to remove from invalid list") ) (fun () blocks (cctxt : #Client_context.full) -> - iter_s + List.iter_es (fun block -> Shell_services.Invalid_blocks.delete cctxt block >>=? fun () -> @@ -66,7 +66,7 @@ let commands () = (fun () (cctxt : #Client_context.full) -> Shell_services.Invalid_blocks.list cctxt () >>=? fun invalid_blocks -> - iter_s + List.iter_es (fun {Chain_services.hash; _} -> Shell_services.Invalid_blocks.delete cctxt hash >>=? fun () -> diff --git a/src/lib_client_commands/client_keys_commands.ml b/src/lib_client_commands/client_keys_commands.ml index 245d8b1f21c8150a0e68afae8dd7f62214d759f5..4371ebdb70393275bdf75fbd6220dc0a0b2e590a 100644 --- a/src/lib_client_commands/client_keys_commands.ml +++ b/src/lib_client_commands/client_keys_commands.ml @@ -268,7 +268,7 @@ let commands network : Client_context.full Clic.command list = (fun (ka, _) (kb, _) -> String.compare ka kb) (registered_signers ()) in - Lwt_list.iter_s + List.iter_s (fun (n, (module S : SIGNER)) -> cctxt#message "@[Scheme `%s`: %s@,@[%a@]@]" @@ -479,7 +479,7 @@ let commands network : Client_context.full Clic.command list = (fun () (cctxt : #Client_context.full) -> list_keys cctxt >>=? fun l -> - iter_s + List.iter_es (fun (name, pkh, pk, sk) -> Public_key_hash.to_source pkh >>=? fun v -> diff --git a/src/lib_client_commands/client_p2p_commands.ml b/src/lib_client_commands/client_p2p_commands.ml index 7d455183e6787182b8be7cb5ce76ae8fc4f3000f..67c04d7b0ad24d4a6a2ed795dda40c50887efb31 100644 --- a/src/lib_client_commands/client_p2p_commands.ml +++ b/src/lib_client_commands/client_p2p_commands.ml @@ -72,17 +72,17 @@ let commands () = let (incoming, outgoing) = List.partition (fun c -> c.P2p_connection.Info.incoming) conns in - Lwt_list.iter_s + List.iter_s (fun conn -> cctxt#message " %a" pp_connection_info conn) incoming >>= fun () -> - Lwt_list.iter_s + List.iter_s (fun conn -> cctxt#message " %a" pp_connection_info conn) outgoing >>= fun () -> cctxt#message "KNOWN PEERS" >>= fun () -> - Lwt_list.iter_s + List.iter_s (fun (p, pi) -> cctxt#message " %a %.0f %a %a %s" @@ -98,7 +98,7 @@ let commands () = >>= fun () -> cctxt#message "KNOWN POINTS" >>= fun () -> - Lwt_list.iter_s + List.iter_s (fun (p, pi) -> match pi.P2p_point.Info.state with | Running peer_id -> diff --git a/src/lib_crypto/blake2B.ml b/src/lib_crypto/blake2B.ml index 70cac2bd886ad7b640086ee6e5015b871efafa2f..4d4ac3faa85bd5972a3a7bffb03de7cad37abd75 100644 --- a/src/lib_crypto/blake2B.ml +++ b/src/lib_crypto/blake2B.ml @@ -255,8 +255,8 @@ struct H.empty | [x] -> H.leaf x - | _ :: _ :: _ -> - let last = TzList.last_exn xs in + | _ :: one :: rest -> + let last = List.last one rest in let n = List.length xs in let a = Array.make (n + 1) (H.leaf last) in List.iteri (fun i x -> a.(i) <- H.leaf x) xs ; @@ -285,8 +285,8 @@ struct invalid_arg "compute_path" | [_] -> Op - | _ :: _ :: _ -> - let last = TzList.last_exn xs in + | _ :: one :: rest -> + let last = List.last one rest in let n = List.length xs in if i < 0 || n <= i then invalid_arg "compute_path" ; let a = Array.make (n + 1) (H.leaf last) in diff --git a/src/lib_crypto/pvss.ml b/src/lib_crypto/pvss.ml index ba01b111fb877151c909d83648f57a8d2bb49454..e9ba83a2a638baa9d4b25daf3c072bf11f38aea1 100644 --- a/src/lib_crypto/pvss.ml +++ b/src/lib_crypto/pvss.ml @@ -23,6 +23,9 @@ (* *) (*****************************************************************************) +(* We reshadow the List module with Stdlib's because there are many safe uses of + double-list traversors *) +module List = Stdlib.List module H = Blake2B (** Polynomial ring (ℤ/qℤ)[X] *) diff --git a/src/lib_crypto/test/dune b/src/lib_crypto/test/dune index b614a71f62b463f3c190be0194023a748cfe0067..626aa892567668e41314dd4011b7d30a325a74b7 100644 --- a/src/lib_crypto/test/dune +++ b/src/lib_crypto/test/dune @@ -16,6 +16,7 @@ alcotest-lwt) (flags (:standard -open Tezos_stdlib -open Tezos_crypto + -open Tezos_lwt_result_stdlib.Lwtreslib -open Data_encoding))) (rule diff --git a/src/lib_crypto/test/test_hacl.ml b/src/lib_crypto/test/test_hacl.ml index 2932fa18e96323f644dcbcfec996c06d27e92bd7..22a1295a10c2b5ecd92b66ecc164fd13e6f919f6 100644 --- a/src/lib_crypto/test/test_hacl.ml +++ b/src/lib_crypto/test/test_hacl.ml @@ -407,9 +407,11 @@ let test_vectors_p256 () = block) Vectors_p256.sigs in - List.iter2 + List.iter2_e + ~when_different_lengths:() (fun (sk, pk) sigs -> List.iter2 + ~when_different_lengths:() (fun msg s -> assert (verify ~pk ~msg ~signature:s) ; let signature = sign ~sk ~msg in @@ -418,6 +420,11 @@ let test_vectors_p256 () = sigs) keys expected_sigs + |> function + | Ok () -> + () + | Error () -> + failwith "unequal number of keys, messages, and signatures" let p256 = [ ("export", `Quick, test_export_p256); diff --git a/src/lib_crypto/test/test_pvss.ml b/src/lib_crypto/test/test_pvss.ml index 93d6916c24e1e831e134c6ff375ddaafb3a269fc..5f35153896dd93df283c67a6082fd0cf3bc8bcee 100644 --- a/src/lib_crypto/test/test_pvss.ml +++ b/src/lib_crypto/test/test_pvss.ml @@ -30,6 +30,9 @@ Subject: On Publicly Verifiable Secret Sharing [Schoenmakers, 1999] *) +(* We reshadow the List module with Stdlib's because there are many safe uses of + double-list traversors *) +module List = Stdlib.List module Pvss = Pvss_secp256k1 module Sp = Secp256k1_group diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index 42a7a6605c8f60af38943b495f0ce7336277e3d9..98c3aabe3ccfcdb6393e9b9d5739976a7b860935 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -75,286 +75,6 @@ module Make (Trace : Sig.TRACE) : let ( >|? ) v f = v >>? fun v -> Ok (f v) - let rec map f l = - match l with - | [] -> - ok_nil - | h :: t -> - f h >>? fun rh -> map f t >>? fun rt -> Ok (rh :: rt) - - let mapi f l = - let rec mapi f i l = - match l with - | [] -> - ok_nil - | h :: t -> - f i h >>? fun rh -> mapi f (i + 1) t >>? fun rt -> Ok (rh :: rt) - in - mapi f 0 l - - let rec map_s f l = - match l with - | [] -> - return_nil - | h :: t -> - f h >>=? fun rh -> map_s f t >>=? fun rt -> return (rh :: rt) - - let mapi_s f l = - let rec mapi_s f i l = - match l with - | [] -> - return_nil - | h :: t -> - f i h - >>=? fun rh -> mapi_s f (i + 1) t >>=? fun rt -> return (rh :: rt) - in - mapi_s f 0 l - - let rec rev_map_append_s acc f = function - | [] -> - return acc - | hd :: tl -> - f hd >>=? fun v -> rev_map_append_s (v :: acc) f tl - - let rev_map_s f l = rev_map_append_s [] f l - - let rec map_p f l = - match l with - | [] -> - return_nil - | x :: l -> ( - let tx = f x and tl = map_p f l in - tx - >>= fun x -> - tl - >>= fun l -> - match (x, l) with - | (Ok x, Ok l) -> - Lwt.return_ok (x :: l) - | (Error trace1, Error trace2) -> - Lwt.return_error (Trace.conp trace1 trace2) - | (Ok _, Error trace) | (Error trace, Ok _) -> - Lwt.return_error trace ) - - let mapi_p f l = - let rec mapi_p f i l = - match l with - | [] -> - return_nil - | x :: l -> ( - let tx = f i x and tl = mapi_p f (i + 1) l in - tx - >>= fun x -> - tl - >>= fun l -> - match (x, l) with - | (Ok x, Ok l) -> - Lwt.return_ok (x :: l) - | (Error trace1, Error trace2) -> - Lwt.return_error (Trace.conp trace1 trace2) - | (Ok _, Error trace) | (Error trace, Ok _) -> - Lwt.return_error trace ) - in - mapi_p f 0 l - - let rec map2_s f l1 l2 = - match (l1, l2) with - | ([], []) -> - return_nil - | (_ :: _, []) | ([], _ :: _) -> - invalid_arg "Error_monad.map2_s" - | (h1 :: t1, h2 :: t2) -> - f h1 h2 >>=? fun rh -> map2_s f t1 t2 >>=? fun rt -> return (rh :: rt) - - let mapi2_s f l1 l2 = - let rec mapi2_s i f l1 l2 = - match (l1, l2) with - | ([], []) -> - return_nil - | (_ :: _, []) | ([], _ :: _) -> - invalid_arg "Error_monad.mapi2_s" - | (h1 :: t1, h2 :: t2) -> - f i h1 h2 - >>=? fun rh -> - mapi2_s (i + 1) f t1 t2 >>=? fun rt -> return (rh :: rt) - in - mapi2_s 0 f l1 l2 - - let rec map2 f l1 l2 = - match (l1, l2) with - | ([], []) -> - ok_nil - | (_ :: _, []) | ([], _ :: _) -> - invalid_arg "Error_monad.map2" - | (h1 :: t1, h2 :: t2) -> - f h1 h2 >>? fun rh -> map2 f t1 t2 >>? fun rt -> Ok (rh :: rt) - - let mapi2 f l1 l2 = - let rec mapi2 i f l1 l2 = - match (l1, l2) with - | ([], []) -> - ok_nil - | (_ :: _, []) | ([], _ :: _) -> - invalid_arg "Error_monad.mapi2" - | (h1 :: t1, h2 :: t2) -> - f i h1 h2 - >>? fun rh -> mapi2 (i + 1) f t1 t2 >>? fun rt -> Ok (rh :: rt) - in - mapi2 0 f l1 l2 - - let rec filter_map_s f l = - match l with - | [] -> - return_nil - | h :: t -> ( - f h - >>=? function - | None -> - filter_map_s f t - | Some rh -> - filter_map_s f t >>=? fun rt -> return (rh :: rt) ) - - let rec filter_map_p f l = - match l with - | [] -> - return_nil - | h :: t -> ( - let th = f h and tt = filter_map_p f t in - th - >>=? function - | None -> tt | Some rh -> tt >>=? fun rt -> return (rh :: rt) ) - - let rec filter f l = - match l with - | [] -> - ok_nil - | h :: t -> ( - f h - >>? function - | true -> filter f t >>? fun t -> Ok (h :: t) | false -> filter f t ) - - let rec filter_s f l = - match l with - | [] -> - return_nil - | h :: t -> ( - f h - >>=? function - | false -> - filter_s f t - | true -> - filter_s f t >>=? fun t -> return (h :: t) ) - - let rec filter_p f l = - match l with - | [] -> - return_nil - | h :: t -> ( - let jh = f h and t = filter_p f t in - jh >>=? function false -> t | true -> t >>=? fun t -> return (h :: t) ) - - let rec iter f l = - match l with [] -> ok_unit | h :: t -> f h >>? fun () -> iter f t - - let rec iter_s f l = - match l with [] -> return_unit | h :: t -> f h >>=? fun () -> iter_s f t - - let rec iter_p f l = - match l with - | [] -> - return_unit - | x :: l -> ( - let tx = f x and tl = iter_p f l in - tx - >>= fun tx_res -> - tl - >>= fun tl_res -> - match (tx_res, tl_res) with - | (Ok (), Ok ()) -> - Lwt.return_ok () - | (Error trace1, Error trace2) -> - Lwt.return_error (Trace.conp trace1 trace2) - | (Ok (), Error trace) | (Error trace, Ok ()) -> - Lwt.return_error trace ) - - let iteri_p f l = - let rec iteri_p i f l = - match l with - | [] -> - return_unit - | x :: l -> ( - let tx = f i x and tl = iteri_p (i + 1) f l in - tx - >>= fun tx_res -> - tl - >>= fun tl_res -> - match (tx_res, tl_res) with - | (Ok (), Ok ()) -> - Lwt.return ok_unit - | (Error trace1, Error trace2) -> - Lwt.return_error (Trace.conp trace1 trace2) - | (Ok (), Error trace) | (Error trace, Ok ()) -> - Lwt.return_error trace ) - in - iteri_p 0 f l - - let rec iter2_p f l1 l2 = - match (l1, l2) with - | ([], []) -> - return_unit - | ([], _) | (_, []) -> - invalid_arg "Error_monad.iter2_p" - | (x1 :: l1, x2 :: l2) -> ( - let tx = f x1 x2 and tl = iter2_p f l1 l2 in - tx - >>= fun tx_res -> - tl - >>= fun tl_res -> - match (tx_res, tl_res) with - | (Ok (), Ok ()) -> - Lwt.return_ok () - | (Error trace1, Error trace2) -> - Lwt.return_error (Trace.conp trace1 trace2) - | (Ok (), Error trace) | (Error trace, Ok ()) -> - Lwt.return_error trace ) - - let iteri2_p f l1 l2 = - let rec iteri2_p i f l1 l2 = - match (l1, l2) with - | ([], []) -> - return_unit - | ([], _) | (_, []) -> - invalid_arg "Error_monad.iteri2_p" - | (x1 :: l1, x2 :: l2) -> ( - let tx = f i x1 x2 and tl = iteri2_p (i + 1) f l1 l2 in - tx - >>= fun tx_res -> - tl - >>= fun tl_res -> - match (tx_res, tl_res) with - | (Ok (), Ok ()) -> - Lwt.return_ok () - | (Error trace1, Error trace2) -> - Lwt.return_error (Trace.conp trace1 trace2) - | (Ok (), Error trace) | (Error trace, Ok ()) -> - Lwt.return_error trace ) - in - iteri2_p 0 f l1 l2 - - let rec fold_left_s f init l = - match l with - | [] -> - return init - | h :: t -> - f init h >>=? fun acc -> fold_left_s f acc t - - let rec fold_right_s f l init = - match l with - | [] -> - return init - | h :: t -> - fold_right_s f t init >>=? fun acc -> f h acc - let join_p = Lwt.join let all_p = Lwt.all diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index 70e0af8672623b2336f2651a188edf49b623fa9e..c4e68def9fd18a8f849405f17f5eb33f4de59865 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -368,140 +368,6 @@ module type MONAD = sig (unit -> (unit, 'trace) result Lwt.t) -> unit - (** {2 In-monad list iterators} *) - - (** A {!List.iter} in the monad *) - val iter : ('a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result - - val iter_s : - ('a -> (unit, 'trace) result Lwt.t) -> - 'a list -> - (unit, 'trace) result Lwt.t - - val iter_p : - ('a -> (unit, 'err trace) result Lwt.t) -> - 'a list -> - (unit, 'err trace) result Lwt.t - - val iteri_p : - (int -> 'a -> (unit, 'err trace) result Lwt.t) -> - 'a list -> - (unit, 'err trace) result Lwt.t - - (** @raise [Invalid_argument] if provided two lists of different lengths. *) - val iter2_p : - ('a -> 'b -> (unit, 'err trace) result Lwt.t) -> - 'a list -> - 'b list -> - (unit, 'err trace) result Lwt.t - - (** @raise [Invalid_argument] if provided two lists of different lengths. *) - val iteri2_p : - (int -> 'a -> 'b -> (unit, 'err trace) result Lwt.t) -> - 'a list -> - 'b list -> - (unit, 'err trace) result Lwt.t - - (** A {!List.map} in the monad *) - val map : ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result - - val mapi : - (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result - - val map_s : - ('a -> ('b, 'trace) result Lwt.t) -> - 'a list -> - ('b list, 'trace) result Lwt.t - - val rev_map_s : - ('a -> ('b, 'trace) result Lwt.t) -> - 'a list -> - ('b list, 'trace) result Lwt.t - - val map_p : - ('a -> ('b, 'err trace) result Lwt.t) -> - 'a list -> - ('b list, 'err trace) result Lwt.t - - val mapi_s : - (int -> 'a -> ('b, 'trace) result Lwt.t) -> - 'a list -> - ('b list, 'trace) result Lwt.t - - val mapi_p : - (int -> 'a -> ('b, 'err trace) result Lwt.t) -> - 'a list -> - ('b list, 'err trace) result Lwt.t - - (** A {!List.map2} in the monad. - - @raise [Invalid_argument] if provided two lists of different lengths. *) - val map2 : - ('a -> 'b -> ('c, 'trace) result) -> - 'a list -> - 'b list -> - ('c list, 'trace) result - - (** @raise [Invalid_argument] if provided two lists of different lengths. *) - val mapi2 : - (int -> 'a -> 'b -> ('c, 'trace) result) -> - 'a list -> - 'b list -> - ('c list, 'trace) result - - (** @raise [Invalid_argument] if provided two lists of different lengths. *) - val map2_s : - ('a -> 'b -> ('c, 'trace) result Lwt.t) -> - 'a list -> - 'b list -> - ('c list, 'trace) result Lwt.t - - (** @raise [Invalid_argument] if provided two lists of different lengths. *) - val mapi2_s : - (int -> 'a -> 'b -> ('c, 'trace) result Lwt.t) -> - 'a list -> - 'b list -> - ('c list, 'trace) result Lwt.t - - (** A {!List.filter_map} in the monad *) - val filter_map_s : - ('a -> ('b option, 'trace) result Lwt.t) -> - 'a list -> - ('b list, 'trace) result Lwt.t - - val filter_map_p : - ('a -> ('b option, 'err trace) result Lwt.t) -> - 'a list -> - ('b list, 'err trace) result Lwt.t - - (** A {!List.filter} in the monad *) - val filter : - ('a -> (bool, 'trace) result) -> 'a list -> ('a list, 'trace) result - - val filter_s : - ('a -> (bool, 'trace) result Lwt.t) -> - 'a list -> - ('a list, 'trace) result Lwt.t - - val filter_p : - ('a -> (bool, 'err trace) result Lwt.t) -> - 'a list -> - ('a list, 'err trace) result Lwt.t - - (** A {!List.fold_left} in the monad *) - val fold_left_s : - ('a -> 'b -> ('a, 'trace) result Lwt.t) -> - 'a -> - 'b list -> - ('a, 'trace) result Lwt.t - - (** A {!List.fold_right} in the monad *) - val fold_right_s : - ('a -> 'b -> ('b, 'trace) result Lwt.t) -> - 'a list -> - 'b -> - ('b, 'trace) result Lwt.t - (** A few aliases for Lwt functions *) val join_p : unit Lwt.t list -> unit Lwt.t diff --git a/src/lib_event_logging/dune b/src/lib_event_logging/dune index a0057aa9fa0e3f3783a211204b666dfc1820cff0..53b5bd298993feec7e358df7fdaf0808454d6c4f 100644 --- a/src/lib_event_logging/dune +++ b/src/lib_event_logging/dune @@ -4,10 +4,12 @@ (flags (:standard -open Tezos_stdlib -open Data_encoding -open Tezos_error_monad + -open Tezos_lwt_result_stdlib.Lwtreslib )) (libraries tezos-stdlib data-encoding tezos-error-monad + tezos-lwt-result-stdlib lwt_log.core)) (rule diff --git a/src/lib_event_logging/internal_event.ml b/src/lib_event_logging/internal_event.ml index 66333bbedce727e7899e420f421c90e7833f4565..9f9c6fae831ef1bfafa793781bd42455aa42186d 100644 --- a/src/lib_event_logging/internal_event.ml +++ b/src/lib_event_logging/internal_event.ml @@ -203,18 +203,18 @@ module All_sinks = struct let active : active list ref = ref [] - let find_registered_exn scheme_to_find = + let find_registered scheme_to_find = List.find (function Registered {scheme; _} -> String.equal scheme scheme_to_find) !registered let register (type a) m = let module S = (val m : SINK with type t = a) in - match find_registered_exn S.uri_scheme with - | exception _ -> + match find_registered S.uri_scheme with + | None -> registered := Registered {scheme = S.uri_scheme; definition = m} :: !registered - | _ -> + | Some _ -> (* This should be considered a programming error: *) Printf.ksprintf Stdlib.invalid_arg @@ -270,10 +270,10 @@ module All_sinks = struct >>=? fun sink -> return (Active {scheme; configuration = uri; definition; sink}) in - ( match find_registered_exn scheme_to_activate with - | Registered {scheme; definition} -> + ( match find_registered scheme_to_activate with + | Some (Registered {scheme; definition}) -> activate scheme definition - | exception _ -> + | None -> fail (Activation_error (Uri_scheme_not_registered (Uri.to_string uri))) ) @@ -286,7 +286,7 @@ module All_sinks = struct let module S = (val definition : SINK with type t = a) in S.close sink in - iter_s + List.iter_es (fun (Active {sink; definition; _}) -> close_one sink definition) !active @@ -295,7 +295,7 @@ module All_sinks = struct let module S = (val definition : SINK with type t = a) in S.handle ?section sink def v in - iter_s + List.iter_es (function Active {sink; definition; _} -> handle sink definition) !active @@ -384,9 +384,9 @@ module All_definitions = struct let add (type a) ev = let module E = (val ev : EVENT_DEFINITION with type t = a) in match List.find (function Definition (n, _) -> E.name = n) !all with - | _ -> + | Some _ -> raise (registration_exn "duplicate Event name: %S" E.name) - | exception _ -> + | None -> check_name_exn E.name (registration_exn "invalid event name: %S contains '%c'") ; @@ -395,11 +395,7 @@ module All_definitions = struct let get () = !all let find match_name = - match List.find (function Definition (n, _) -> match_name n) !all with - | s -> - Some s - | exception _ -> - None + List.find (function Definition (n, _) -> match_name n) !all end module Make (E : EVENT_DEFINITION) : EVENT with type t = E.t = struct @@ -553,7 +549,7 @@ module Simple = struct | Padded (encoding, _) -> pp_human_readable ~never_empty encoding fmt value | String_enum (table, _) -> ( - match Hashtbl.find_opt table value with + match Stdlib.Hashtbl.find_opt table value with | None -> if never_empty then Format.pp_print_string fmt "N/A" | Some (name, _) -> diff --git a/src/lib_event_logging/tezos-event-logging.opam b/src/lib_event_logging/tezos-event-logging.opam index 90f4ddb22d04bf071bc49bd6117980653218975b..6b60d6bd8cf7e051f9fbb5f19daaaaec1167b056 100644 --- a/src/lib_event_logging/tezos-event-logging.opam +++ b/src/lib_event_logging/tezos-event-logging.opam @@ -10,6 +10,7 @@ depends: [ "tezos-tooling" { with-test } "dune" { >= "2.0" } "tezos-stdlib" + "tezos-lwt-result-stdlib" "data-encoding" { = "0.2" } "tezos-error-monad" "lwt_log" diff --git a/src/lib_lwt_result_stdlib/functors/list.ml b/src/lib_lwt_result_stdlib/functors/list.ml new file mode 100644 index 0000000000000000000000000000000000000000..d015e5a1e8ec368f2c8e14cce28bc613f8f01e2c --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/list.ml @@ -0,0 +1,1176 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Make (Monad : Sigs.Monad.S) : + Sigs.List.S with type 'error trace := 'error Monad.trace = struct + open Lwt.Infix + open Monad + module Legacy = Stdlib.List + include Legacy + + let nil = [] + + let nil_e = Ok [] + + let nil_s = Lwt.return_nil + + let nil_es = Lwt.return nil_e + + let hd = function x :: _ -> Some x | [] -> None + + let tl = function _ :: xs -> Some xs | [] -> None + + let nth xs n = + if n < 0 then None + else + let rec aux xs n = + match (xs, n) with + | ([], _) -> + None + | (x :: _, 0) -> + Some x + | (_ :: xs, n) -> + (aux [@ocaml.tailcall]) xs (n - 1) + in + aux xs n + + let rec last hd = function + | [] -> + hd + | [last] -> + last + | hd :: (_ :: _ as tl) -> + (last [@ocaml.tailcall]) hd tl + + let last_opt = function [] -> None | hd :: tl -> Some (last hd tl) + + let find = find_opt + + let rec iter2 ~when_different_lengths f xs ys = + (* NOTE: We could do the following but we would need to assume [f] does not + raise [Invalid_argument] + [try + Ok (iter2 f xs ys) + with Invalid_argument _ -> + Error when_different_lengths] + The same remark applies to the other 2-list iterators. + *) + match (xs, ys) with + | ([], []) -> + ok_unit + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + f x y ; + (iter2 [@ocaml.tailcall]) ~when_different_lengths f xs ys + + let rev_map2 ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Ok zs + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + let z = f x y in + (aux [@ocaml.tailcall]) (z :: zs) xs ys + in + aux [] xs ys + + let map2 ~when_different_lengths f xs ys = + rev_map2 ~when_different_lengths f xs ys >|? rev + + let fold_left2 ~when_different_lengths f a xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Ok acc + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + let acc = f acc x y in + (aux [@ocaml.tailcall]) acc xs ys + in + aux a xs ys + + let fold_right2 ~when_different_lengths f xs ys a = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok a + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + aux xs ys >|? fun acc -> f x y acc + in + aux xs ys + + let for_all2 ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok true + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> ( + match f x y with + | true -> + (aux [@ocaml.tailcall]) xs ys + | false -> + Ok false ) + in + aux xs ys + + let exists2 ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok false + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> ( + match f x y with + | true -> + Ok true + | false -> + (aux [@ocaml.tailcall]) xs ys ) + in + aux xs ys + + let assoc = assoc_opt + + let assq = assq_opt + + let init ~when_negative_length l f = + if l < 0 then Error when_negative_length + else if l = 0 then nil_e + else Ok (Legacy.init l f) + + let init_e ~when_negative_length l f = + let rec aux acc i = + if i >= l then Ok (rev acc) + else f i >>? fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) + in + if l < 0 then Error when_negative_length + else if l = 0 then nil_e + else aux [] 0 + + let init_s ~when_negative_length l f = + let rec aux acc i = + if i >= l then Lwt.return (Ok (rev acc)) + else f i >>= fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error when_negative_length) + else if l = 0 then nil_es + else Lwt.apply f 0 >>= fun v -> aux [v] 1 + + let init_es ~when_negative_length l f = + let rec aux acc i = + if i >= l then Lwt.return (Ok (rev acc)) + else f i >>=? fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error when_negative_length) + else if l = 0 then nil_es + else Lwt.apply f 0 >>=? fun v -> aux [v] 1 + + let init_p ~when_negative_length l f = + let rec aux acc i = + if i >= l then all_p (rev acc) >>= fun xs -> Lwt.return (Ok xs) + else (aux [@ocaml.tailcall]) (Lwt.apply f i :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error when_negative_length) + else if l = 0 then nil_es + else aux [] 0 + + let init_ep ~when_negative_length l f = + let rec aux acc i = + if i >= l then all_ep (rev acc) + else (aux [@ocaml.tailcall]) (Lwt.apply f i :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error (Monad.make when_negative_length)) + else if l = 0 then nil_es + else aux [] 0 + + let rec find_e f = function + | [] -> + ok_none + | x :: xs -> ( + f x + >>? function + | true -> Ok (Some x) | false -> (find_e [@ocaml.tailcall]) f xs ) + + let rec find_s f = function + | [] -> + Lwt.return_none + | x :: xs -> ( + f x + >>= function + | true -> + Lwt.return (Some x) + | false -> + (find_s [@ocaml.tailcall]) f xs ) + + let find_s f = function + | [] -> + Lwt.return_none + | x :: xs -> ( + Lwt.apply f x + >>= function + | true -> + Lwt.return (Some x) + | false -> + (find_s [@ocaml.tailcall]) f xs ) + + let rec find_es f = function + | [] -> + return_none + | x :: xs -> ( + f x + >>=? function + | true -> + Lwt.return (Ok (Some x)) + | false -> + (find_es [@ocaml.tailcall]) f xs ) + + let find_es f = function + | [] -> + return_none + | x :: xs -> ( + Lwt.apply f x + >>=? function + | true -> + Lwt.return (Ok (Some x)) + | false -> + (find_es [@ocaml.tailcall]) f xs ) + + let rev_filter f xs = + fold_left (fun rev_xs x -> if f x then x :: rev_xs else rev_xs) [] xs + + let rev_filter_e f xs = + let rec aux acc = function + | [] -> + Ok acc + | x :: xs -> ( + f x + >>? function + | true -> + (aux [@ocaml.tailcall]) (x :: acc) xs + | false -> + (aux [@ocaml.tailcall]) acc xs ) + in + aux [] xs + + let rev_filter_some oxs = + let rec aux xs = function + | [] -> + xs + | Some x :: oxs -> + (aux [@ocaml.tailcall]) (x :: xs) oxs + | None :: oxs -> + (aux [@ocaml.tailcall]) xs oxs + in + aux [] oxs + + let filter_some oxs = rev_filter_some oxs |> rev + + let rev_filter_ok rxs = + let rec aux xs = function + | [] -> + xs + | Ok x :: rxs -> + (aux [@ocaml.tailcall]) (x :: xs) rxs + | Error _ :: rxs -> + (aux [@ocaml.tailcall]) xs rxs + in + aux [] rxs + + let filter_ok rxs = rev_filter_ok rxs |> rev + + let rev_filter_error rxs = + let rec aux xs = function + | [] -> + xs + | Error x :: rxs -> + (aux [@ocaml.tailcall]) (x :: xs) rxs + | Ok _ :: rxs -> + (aux [@ocaml.tailcall]) xs rxs + in + aux [] rxs + + let filter_error rxs = rev_filter_error rxs |> rev + + let filter_e f xs = rev_filter_e f xs >|? rev + + let rev_filter_s f xs = + let rec aux acc = function + | [] -> + Lwt.return acc + | x :: xs -> ( + f x + >>= function + | true -> + (aux [@ocaml.tailcall]) (x :: acc) xs + | false -> + (aux [@ocaml.tailcall]) acc xs ) + in + match xs with + | [] -> + Lwt.return [] + | x :: xs -> ( + Lwt.apply f x + >>= function + | true -> + (aux [@ocaml.tailcall]) [x] xs + | false -> + (aux [@ocaml.tailcall]) [] xs ) + + let filter_s f xs = rev_filter_s f xs >|= rev + + let rev_filter_es f xs = + let rec aux acc = function + | [] -> + Lwt.return (Ok acc) + | x :: xs -> ( + f x + >>=? function + | true -> + (aux [@ocaml.tailcall]) (x :: acc) xs + | false -> + (aux [@ocaml.tailcall]) acc xs ) + in + match xs with + | [] -> + Lwt.return (Ok []) + | x :: xs -> ( + Lwt.apply f x >>=? function true -> aux [x] xs | false -> aux [] xs ) + + let filter_es f xs = rev_filter_es f xs >|=? rev + + let rec iter_e f = function + | [] -> + ok_unit + | h :: t -> + f h >>? fun () -> (iter_e [@ocaml.tailcall]) f t + + let rec iter_s f = function + | [] -> + Lwt.return_unit + | h :: t -> + f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t + + let iter_s f = function + | [] -> + Lwt.return_unit + | h :: t -> + Lwt.apply f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t + + let rec iter_es f = function + | [] -> + return_unit + | h :: t -> + f h >>=? fun () -> (iter_es [@ocaml.tailcall]) f t + + let iter_es f = function + | [] -> + return_unit + | h :: t -> + Lwt.apply f h >>=? fun () -> (iter_es [@ocaml.tailcall]) f t + + let iter_p f l = join_p (rev_map (Lwt.apply f) l) + + let iter_ep f l = join_ep (rev_map (Lwt.apply f) l) + + let iteri_e f l = + let rec aux i = function + | [] -> + ok_unit + | x :: xs -> + f i x >>? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs + in + aux 0 l + + let lwt_apply2 f x y = try f x y with exc -> Lwt.fail exc + + let iteri_s f l = + let rec aux i = function + | [] -> + Lwt.return_unit + | x :: xs -> + f i x >>= fun () -> (aux [@ocaml.tailcall]) (i + 1) xs + in + match l with + | [] -> + Lwt.return_unit + | x :: xs -> + lwt_apply2 f 0 x >>= fun () -> aux 1 xs + + let iteri_es f l = + let rec aux i = function + | [] -> + return_unit + | x :: xs -> + f i x >>=? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs + in + match l with + | [] -> + return_unit + | x :: xs -> + lwt_apply2 f 0 x >>=? fun () -> aux 1 xs + + let iteri_p f l = join_p (mapi (lwt_apply2 f) l) + + let iteri_ep f l = join_ep (mapi (lwt_apply2 f) l) + + let rev_map_e f l = + let rec aux ys = function + | [] -> + Ok ys + | x :: xs -> + f x >>? fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs + in + aux [] l + + let map_e f l = rev_map_e f l >|? rev + + let rev_map_s f l = + let rec aux ys = function + | [] -> + Lwt.return ys + | x :: xs -> + f x >>= fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs + in + match l with + | [] -> + Lwt.return [] + | x :: xs -> + Lwt.apply f x >>= fun y -> aux [y] xs + + let map_s f l = rev_map_s f l >|= rev + + let rev_map_es f l = + let rec aux ys = function + | [] -> + return ys + | x :: xs -> + f x >>=? fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs + in + match l with + | [] -> + return [] + | x :: xs -> + Lwt.apply f x >>=? fun y -> aux [y] xs + + let map_es f l = rev_map_es f l >|=? rev + + let rev_map_p f l = all_p @@ rev_map (Lwt.apply f) l + + let map_p f l = rev_map_p f l >|= rev + + let rev_map_ep f l = all_ep @@ rev_map (Lwt.apply f) l + + let map_ep f l = rev_map_ep f l >|=? rev + + let rev_mapi_e f l = + let rec aux i ys = function + | [] -> + Ok ys + | x :: xs -> + f i x >>? fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs + in + aux 0 [] l + + let mapi_e f l = rev_mapi_e f l >|? rev + + let rev_mapi_s f l = + let rec aux i ys = function + | [] -> + Lwt.return ys + | x :: xs -> + f i x >>= fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs + in + match l with + | [] -> + Lwt.return [] + | x :: xs -> + lwt_apply2 f 0 x >>= fun y -> aux 1 [y] xs + + let mapi_s f l = rev_mapi_s f l >|= rev + + let rev_mapi_es f l = + let rec aux i ys = function + | [] -> + return ys + | x :: xs -> + f i x >>=? fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs + in + match l with + | [] -> + return [] + | x :: xs -> + lwt_apply2 f 0 x >>=? fun y -> aux 1 [y] xs + + let mapi_es f l = rev_mapi_es f l >|=? rev + + let rev_mapi f l = + let rec aux i ys = function + | [] -> + ys + | x :: xs -> + (aux [@ocaml.tailcall]) (i + 1) (f i x :: ys) xs + in + aux 0 [] l + + let rev_mapi_p f l = all_p @@ rev_mapi f l + + let mapi_p f l = rev_mapi_p f l >|= rev + + let rev_mapi_ep f l = all_ep @@ rev_mapi f l + + let mapi_ep f l = rev_mapi_ep f l >|=? rev + + let rec fold_left_e f acc = function + | [] -> + Ok acc + | x :: xs -> + f acc x >>? fun acc -> (fold_left_e [@ocaml.tailcall]) f acc xs + + let rec fold_left_s f acc = function + | [] -> + Lwt.return acc + | x :: xs -> + f acc x >>= fun acc -> (fold_left_s [@ocaml.tailcall]) f acc xs + + let fold_left_s f acc = function + | [] -> + Lwt.return acc + | x :: xs -> + lwt_apply2 f acc x >>= fun acc -> fold_left_s f acc xs + + let rec fold_left_es f acc = function + | [] -> + return acc + | x :: xs -> + f acc x >>=? fun acc -> (fold_left_es [@ocaml.tailcall]) f acc xs + + let fold_left_es f acc = function + | [] -> + return acc + | x :: xs -> + lwt_apply2 f acc x >>=? fun acc -> fold_left_es f acc xs + + let filter_p f l = + rev_map_p (fun x -> f x >|= fun b -> if b then Some x else None) l + >|= rev_filter_some + + let filter_ep f l = + rev_map_ep (fun x -> f x >|=? fun b -> if b then Some x else None) l + >|=? rev_filter_some + + let rev_filter_map f l = + fold_left + (fun acc x -> match f x with None -> acc | Some y -> y :: acc) + [] + l + + let filter_map f l = rev_filter_map f l |> rev + + let rev_filter_map_e f l = + fold_left_e + (fun acc x -> f x >|? function None -> acc | Some y -> y :: acc) + [] + l + + let filter_map_e f l = rev_filter_map_e f l >|? rev + + let rev_filter_map_s f l = + fold_left_s + (fun acc x -> f x >|= function None -> acc | Some y -> y :: acc) + [] + l + + let filter_map_s f l = rev_filter_map_s f l >|= rev + + let rev_filter_map_es f l = + fold_left_es + (fun acc x -> f x >|=? function None -> acc | Some y -> y :: acc) + [] + l + + let filter_map_es f l = rev_filter_map_es f l >|=? rev + + let filter_map_p f l = rev_map_p f l >|= rev_filter_some + + let filter_map_ep f l = rev_map_ep f l >|=? rev_filter_some + + let rec fold_right_e f l acc = + match l with + | [] -> + Ok acc + | x :: xs -> + fold_right_e f xs acc >>? fun acc -> f x acc + + let rec fold_right_s f l acc = + match l with + | [] -> + Lwt.return acc + | x :: xs -> + fold_right_s f xs acc >>= fun acc -> f x acc + + let rec fold_right_es f l acc = + match l with + | [] -> + return acc + | x :: xs -> + fold_right_es f xs acc >>=? fun acc -> f x acc + + let rev_map2_e ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Ok zs + | (x :: xs, y :: ys) -> + f x y >>? fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux [] xs ys + + let rev_map2_s ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok zs) + | (x :: xs, y :: ys) -> + f x y >>= fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok []) + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>= fun z -> aux [z] xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let rev_map2_es ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok zs) + | (x :: xs, y :: ys) -> + f x y >>=? fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok []) + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>=? fun z -> aux [z] xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let map2_e ~when_different_lengths f xs ys = + rev_map2_e ~when_different_lengths f xs ys >|? rev + + let map2_s ~when_different_lengths f xs ys = + rev_map2_s ~when_different_lengths f xs ys >|=? rev + + let map2_es ~when_different_lengths f xs ys = + rev_map2_es ~when_different_lengths f xs ys >|=? rev + + let iter2_e ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Monad.ok_unit + | (x :: xs, y :: ys) -> + f x y >>? fun () -> (aux [@ocaml.tailcall]) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux xs ys + + let iter2_s ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok ()) + | (x :: xs, y :: ys) -> + f x y >>= fun () -> (aux [@ocaml.tailcall]) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok ()) + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>= fun () -> aux xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let iter2_es ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Monad.return_unit + | (x :: xs, y :: ys) -> + f x y >>=? fun () -> (aux [@ocaml.tailcall]) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Monad.return_unit + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>=? fun () -> aux xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let fold_left2_e ~when_different_lengths f init xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Ok acc + | (x :: xs, y :: ys) -> + f acc x y >>? fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux init xs ys + + let lwt_apply3 f a x y = try f a x y with exc -> Lwt.fail exc + + let fold_left2_s ~when_different_lengths f init xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok acc) + | (x :: xs, y :: ys) -> + f acc x y >>= fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + lwt_apply3 f init x y >>= fun acc -> aux acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let fold_left2_es ~when_different_lengths f init xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok acc) + | (x :: xs, y :: ys) -> + f acc x y >>=? fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + lwt_apply3 f init x y >>=? fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + + let fold_right2_e ~when_different_lengths f xs ys init = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok init + | (x :: xs, y :: ys) -> + aux xs ys >>? fun acc -> f x y acc + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux xs ys + + let fold_right2_s ~when_different_lengths f xs ys init = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + (* We could use a specific operator for that. It'd need the following type + ('a, 'err) result Lwt.t -> ('a -> 'b Lwt.t) -> ('b, 'err) result Lwt.t + *) + aux xs ys >>=? fun acc -> f x y acc >|= ok + in + aux xs ys + + let fold_right2_es ~when_different_lengths f xs ys init = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + aux xs ys >>=? fun acc -> f x y acc + in + aux xs ys + + let rec for_all_e f = function + | [] -> + Monad.ok_true + | x :: xs -> ( + f x + >>? function + | true -> (for_all_e [@ocaml.tailcall]) f xs | false -> Monad.ok_false + ) + + let rec for_all_s f = function + | [] -> + Lwt.return_true + | x :: xs -> ( + f x + >>= function + | true -> + (for_all_s [@ocaml.tailcall]) f xs + | false -> + Lwt.return_false ) + + let for_all_s f = function + | [] -> + Lwt.return_true + | x :: xs -> ( + Lwt.apply f x + >>= function + | true -> + (for_all_s [@ocaml.tailcall]) f xs + | false -> + Lwt.return_false ) + + let rec for_all_es f = function + | [] -> + Monad.return_true + | x :: xs -> ( + f x + >>=? function + | true -> + (for_all_es [@ocaml.tailcall]) f xs + | false -> + Monad.return_false ) + + let for_all_es f = function + | [] -> + Monad.return_true + | x :: xs -> ( + Lwt.apply f x + >>=? function + | true -> + (for_all_es [@ocaml.tailcall]) f xs + | false -> + Monad.return_false ) + + let for_all_p f l = rev_map_p f l >|= for_all Fun.id + + let for_all_ep f l = rev_map_ep f l >|=? for_all Fun.id + + let rec exists_e f = function + | [] -> + Monad.ok_false + | x :: xs -> ( + f x + >>? function + | false -> (exists_e [@ocaml.tailcall]) f xs | true -> Monad.ok_true ) + + let rec exists_s f = function + | [] -> + Lwt.return_false + | x :: xs -> ( + f x + >>= function + | false -> (exists_s [@ocaml.tailcall]) f xs | true -> Lwt.return_true + ) + + let exists_s f = function + | [] -> + Lwt.return_false + | x :: xs -> ( + Lwt.apply f x + >>= function false -> exists_s f xs | true -> Lwt.return_true ) + + let rec exists_es f = function + | [] -> + Monad.return_false + | x :: xs -> ( + f x + >>=? function + | false -> + (exists_es [@ocaml.tailcall]) f xs + | true -> + Monad.return_true ) + + let exists_es f = function + | [] -> + Monad.return_false + | x :: xs -> ( + Lwt.apply f x + >>=? function false -> exists_es f xs | true -> Monad.return_true ) + + let exists_p f l = rev_map_p f l >|= exists Fun.id + + let exists_ep f l = rev_map_ep f l >|=? exists Fun.id + + let for_all2_e ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | ([], []) -> + Monad.ok_true + | (x :: xs, y :: ys) -> ( + f x y + >>? function + | true -> (aux [@ocaml.tailcall]) xs ys | false -> Monad.ok_false ) + in + aux xs ys + + let for_all2_s ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_true + | (x :: xs, y :: ys) -> ( + f x y + >>= function + | true -> (aux [@ocaml.tailcall]) xs ys | false -> Monad.return_false + ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_true + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y + >>= function true -> aux xs ys | false -> Monad.return_false ) + + let for_all2_es ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_true + | (x :: xs, y :: ys) -> ( + f x y + >>=? function + | true -> (aux [@ocaml.tailcall]) xs ys | false -> Monad.return_false + ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_true + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y + >>=? function true -> aux xs ys | false -> Monad.return_false ) + + let exists2_e ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | ([], []) -> + Monad.ok_false + | (x :: xs, y :: ys) -> ( + f x y + >>? function + | false -> (aux [@ocaml.tailcall]) xs ys | true -> Monad.ok_true ) + in + aux xs ys + + let exists2_s ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_false + | (x :: xs, y :: ys) -> ( + f x y + >>= function + | false -> (aux [@ocaml.tailcall]) xs ys | true -> Monad.return_true + ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_false + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y + >>= function false -> aux xs ys | true -> Monad.return_true ) + + let exists2_es ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_false + | (x :: xs, y :: ys) -> ( + f x y + >>=? function + | false -> (aux [@ocaml.tailcall]) xs ys | true -> Monad.return_true + ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Lwt.return_error when_different_lengths + | ([], []) -> + Monad.return_false + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y + >>=? function false -> aux xs ys | true -> Monad.return_true ) + + let rev_partition_result xs = + let rec aux oks errors = function + | [] -> + (oks, errors) + | Ok ok :: xs -> + (aux [@ocaml.tailcall]) (ok :: oks) errors xs + | Error error :: xs -> + (aux [@ocaml.tailcall]) oks (error :: errors) xs + in + aux [] [] xs + + let partition_result xs = + let (rev_oks, rev_errors) = rev_partition_result xs in + (rev rev_oks, rev rev_errors) + + let rev_partition_e f l = + let rec aux trues falses = function + | [] -> + Ok (trues, falses) + | x :: xs -> + f x + >>? fun b -> + if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + aux [] [] l + + let partition_e f l = + rev_partition_e f l >|? fun (trues, falses) -> (rev trues, rev falses) + + let rev_partition_s f l = + let rec aux trues falses = function + | [] -> + Lwt.return (trues, falses) + | x :: xs -> + f x + >>= fun b -> + if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + match l with + | [] -> + Lwt.return ([], []) + | x :: xs -> + Lwt.apply f x >>= fun b -> if b then aux [x] [] xs else aux [] [x] xs + + let partition_s f l = + rev_partition_s f l >|= fun (trues, falses) -> (rev trues, rev falses) + + let rev_partition_es f l = + let rec aux trues falses = function + | [] -> + Lwt.return_ok (trues, falses) + | x :: xs -> + f x + >>=? fun b -> + if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + match l with + | [] -> + Lwt.return_ok ([], []) + | x :: xs -> + Lwt.apply f x >>=? fun b -> if b then aux [x] [] xs else aux [] [x] xs + + let partition_es f l = + rev_partition_es f l >|=? fun (trues, falses) -> (rev trues, rev falses) + + let partition_p f l = + rev_map_p (fun x -> f x >|= fun b -> (b, x)) l + >|= fun bxs -> + fold_left + (fun (trues, falses) (b, x) -> + if b then (x :: trues, falses) else (trues, x :: falses)) + ([], []) + bxs + + let partition_ep f l = + rev_map_ep (fun x -> f x >|=? fun b -> (b, x)) l + >|=? fun bxs -> + fold_left + (fun (trues, falses) (b, x) -> + if b then (x :: trues, falses) else (trues, x :: falses)) + ([], []) + bxs + + let combine ~when_different_lengths xs ys = + map2 ~when_different_lengths (fun x y -> (x, y)) xs ys + + let rev_combine ~when_different_lengths xs ys = + rev_map2 ~when_different_lengths (fun x y -> (x, y)) xs ys + + let combine_with_leftovers xs ys = + let rec aux rev_combined xs ys = + match (xs, ys) with + | ([], []) -> + (rev rev_combined, None) + | ((_ :: _ as left), []) -> + (rev rev_combined, Some (`Left left)) + | ([], (_ :: _ as right)) -> + (rev rev_combined, Some (`Right right)) + | (x :: xs, y :: ys) -> + (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys + in + aux [] xs ys + + let combine_drop xs ys = + let rec aux rev_combined xs ys = + match (xs, ys) with + | (x :: xs, y :: ys) -> + (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys + | ([], []) | (_ :: _, []) | ([], _ :: _) -> + rev rev_combined + in + aux [] xs ys +end diff --git a/src/lib_lwt_result_stdlib/functors/list.mli b/src/lib_lwt_result_stdlib/functors/list.mli new file mode 100644 index 0000000000000000000000000000000000000000..d1230ce4576c64913a60a9b2f1fc164b9471f227 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/list.mli @@ -0,0 +1,27 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Make (Monad : Sigs.Monad.S) : + Sigs.List.S with type 'error trace := 'error Monad.trace diff --git a/src/lib_lwt_result_stdlib/lib/list.ml b/src/lib_lwt_result_stdlib/lib/list.ml new file mode 100644 index 0000000000000000000000000000000000000000..a6dac7678449342c9c211fa0f2f26ab4e6ae98b8 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/list.ml @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Functors.List.Make (Seq.Monad) diff --git a/src/lib_lwt_result_stdlib/lib/list.mli b/src/lib_lwt_result_stdlib/lib/list.mli new file mode 100644 index 0000000000000000000000000000000000000000..e686712c35bd21d57dbd431a917c26a2f1fcfc7c --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/list.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Sigs.List.S with type 'error trace := 'error Error_monad.trace diff --git a/src/lib_lwt_result_stdlib/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml index a40eb489f321b197f2df4b162e9a0ee62c44b9f7..3128b884eed26c47fca5c2e63621f0f7286097dd 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.ml +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -27,3 +27,4 @@ module Seq = Lib.Seq module Set = Lib.Set module Map = Lib.Map module Hashtbl = Lib.Hashtbl +module List = Lib.List diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index 4f2865c1862c0f6b5bdf0f46b159051490fd96c1..155975a8c99333b7025baaf483d86e199c9b61b5 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -52,3 +52,5 @@ module Set : module type of Lib.Set module Map : module type of Lib.Map module Hashtbl : module type of Lib.Hashtbl + +module List : module type of Lib.List diff --git a/src/lib_lwt_result_stdlib/sigs/list.ml b/src/lib_lwt_result_stdlib/sigs/list.ml new file mode 100644 index 0000000000000000000000000000000000000000..11ba967312e54436354e08a4ba87933284c8fbcb --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/list.ml @@ -0,0 +1,787 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** {1 List} + + A wrapper around {!Stdlib.List} that includes lwt-, error- and + lwt-error-aware traversal functions. + + Supersedes {!Stdlib.List} and {!Lwt_list} both. + +*) + +(** + {2 Basics} + + This follows the design principles and semantic described in {!Sigs.Seq}. In + a nutshell: + - Stdlib functions that raise exceptions are replaced by safe variants + (typically returning [option]). + - The [_e] suffix is for error-aware traversors, [_s] and [_p] are for + lwt-aware, and [_es] and [_ep] are for lwt-error-aware. + - [_e], [_s], and [_es] traversors are {i fail-early}: they stop traversal + as soon as a failure ([Error] or [Fail]) occurs; [_p] and [_ep] + traversors are {i best-effort}: they only resolve once all of the + intermediate promises have even if a failure occurs. + +*) + +(** + + {2 Double-traversal and combine} + + Note that double-list traversors ([iter2], [map2], etc., and also [combine]) + take an additional [when_different_lengths] parameter. This is to control + the error that is returned when the two lists passed as arguments have + different lengths. + + Note that, as per the fail-early behaviour mentioned above, [_e], [_s], and + [_es] traversors will have already processed the common-prefix before the + error is returned. + + Because the best-effort behaviour of [_p] and [_ep] is unsatisfying for this + failure case, double parallel traversors are omitted from this library. + (Specifically, it is not obvious whether nor how the + [when_different_lengths] error should be composed with the other errors, + what shape the trace should have.) + + To obtain a different behaviour for sequential traversors, or to process + two lists in parallel, you can use {!combine} or any of the alternative that + handles the error differently: {!combine_drop}, {!combine_with_leftovers}. + Finally, the {!rev_combine} is provided to allow to avoid + multiple-reversing. + + {3 Special considerations} + + Because they traverse the list from right-to-left, the {!fold_right2} + function and all its variants fail with [when_different_lengths] before any + of the processing starts. Whilst this is still within the fail-early + behaviour, it may be surprising enough that it requires mentioning here. + + Because they return early, {!for_all2} and {!exists2} and all their variants + may return [Ok _] even tough the arguments have different lengths. + + +*) + +(** {2 S} *) +module type S = sig + (** {3 Boilerplate} *) + + (** For substituting based on the {!Sigs.Trace} type. *) + type 'error trace + + (** Include the legacy list. Unsafe functions are shadowed below. *) + include + module type of Stdlib.List with type 'a t = 'a Stdlib.List.t + + (** {3 Trivial values} *) + + (** in-monad, preallocated nil *) + + (** [nil] is [[]] *) + val nil : 'a list + + (** [nil] is [Ok []] *) + val nil_e : ('a list, 'trace) result + + (** [nil] is [Lwt.return_nil] *) + val nil_s : 'a list Lwt.t + + (** [nil] is [Lwt.return (Ok [])] *) + val nil_es : ('a list, 'trace) result Lwt.t + + (** {3 Safe wrappers} + + Shadowing unsafe functions to avoid all exceptions. *) + + (** {4 Safe lookups, scans, retrievals} + + Return option rather than raise [Not_found] or [Invalid_argument _] *) + + (** [hd xs] is the head (first element) of the list or [None] if the list is + empty. *) + val hd : 'a list -> 'a option + + (** [tl xs] is the tail of the list (the whole list except the first element) + or [None] if the list is empty. *) + val tl : 'a list -> 'a list option + + (** [nth xs n] is the [n]th element of the list or [None] if the list has + fewer than [n] elements. + + [nth xs 0 = tl xs] *) + val nth : 'a list -> int -> 'a option + + (** [last x xs] is the last element of the list [xs] or [x] if [xs] is empty. + + The primary intended use for [last] is after destructing a list: + [match l with | None -> … | Some x :: xs -> last x xs] + but it can also be used for a default value: + [last default_value_if_empty xs]. *) + val last : 'a -> 'a list -> 'a + + (** [last_opt xs] is the last element of the list [xs] or [None] if the list + [xs] is empty. *) + val last_opt : 'a list -> 'a option + + (** [find predicate xs] is the first element [x] of the list [xs] such that + [predicate x] is [true] or [None] if the list [xs] has no such element. *) + val find : ('a -> bool) -> 'a list -> 'a option + + (** [assoc k kvs] is [v] such that [(k', v)] is the first pair in the list + such that [k' = k] (uses the polymorphic equality) or [None] if the list + contains no such pair. *) + val assoc : 'a -> ('a * 'b) list -> 'b option + + (** [assq k kvs] is the same as [assoc k kvs] but it uses the physical + equality. *) + val assq : 'a -> ('a * 'b) list -> 'b option + + (** {4 Initialisation} *) + + (** [init ~when_negative_length n f] is [Error when_negative_length] if [n] is + strictly negative and + [Ok] {!Stdlib.List.init n f} otherwise. *) + val init : + when_negative_length:'trace -> + int -> + (int -> 'a) -> + ('a list, 'trace) result + + (** {4 Double-list traversals} + + These safe-wrappers take an explicit value to handle the case of lists of + unequal length. + *) + + (** [combine ~when_different_lengths l1 l2] is either + - [Error when_different_lengths] if [List.length l1 <> List.length l2] + - a list of pairs of elements from [l1] and [l2] + + E.g., [combine ~when_different_lengths [] [] = Ok []] + + E.g., [combine ~when_different_lengths [1; 2] ['a'; 'b'] = Ok [(1,'a'); (2, 'b')]] + + E.g., [combine ~when_different_lengths:() [1] [] = Error ()] + + Note: [combine ~when_different_lengths l1 l2] is equivalent to + [try Ok (Stdlib.List.combine l1 l2) + with Invalid_argument _ -> when_different_lengths] + + The same equivalence almost holds for the other double traversors below. + The notable difference is if the functions passed as argument to the + traversors raise the [Invalid_argument _] exception. *) + val combine : + when_different_lengths:'trace -> + 'a list -> + 'b list -> + (('a * 'b) list, 'trace) result + + (** [rev_combine ~when_different_lengths xs ys] is + [rev (combine ~when_different_lengths xs ys)] but more efficient. *) + val rev_combine : + when_different_lengths:'trace -> + 'a list -> + 'b list -> + (('a * 'b) list, 'trace) result + + val iter2 : + when_different_lengths:'trace -> + ('a -> 'b -> unit) -> + 'a list -> + 'b list -> + (unit, 'trace) result + + val map2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + + val rev_map2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + + val fold_left2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'a) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result + + (** This function is not tail-recursive *) + val fold_right2 : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'c) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result + + val for_all2 : + when_different_lengths:'trace -> + ('a -> 'b -> bool) -> + 'a list -> + 'b list -> + (bool, 'trace) result + + val exists2 : + when_different_lengths:'trace -> + ('a -> 'b -> bool) -> + 'a list -> + 'b list -> + (bool, 'trace) result + + (** {3 Monad-aware variants} + + The functions below are strict extensions of the standard {!Stdlib.List} + module. It is for error-, lwt- and lwt-error-aware variants. The meaning + of the suffix is as described above and in {!Sigs.Seq}. *) + + (** {4 Initialisation variants} + + Note that for asynchronous variants ([_s], [_es], [_p], and [_ep]), if the + length parameter is negative, then the promise is returned already + fulfilled with [Error when_different_lengths]. *) + + val init_e : + when_negative_length:'trace -> + int -> + (int -> ('a, 'trace) result) -> + ('a list, 'trace) result + + val init_s : + when_negative_length:'trace -> + int -> + (int -> 'a Lwt.t) -> + ('a list, 'trace) result Lwt.t + + val init_es : + when_negative_length:'trace -> + int -> + (int -> ('a, 'trace) result Lwt.t) -> + ('a list, 'trace) result Lwt.t + + val init_p : + when_negative_length:'trace -> + int -> + (int -> 'a Lwt.t) -> + ('a list, 'trace) result Lwt.t + + val init_ep : + when_negative_length:'error -> + int -> + (int -> ('a, 'error trace) result Lwt.t) -> + ('a list, 'error trace) result Lwt.t + + (** {4 Query variants} *) + + val find_e : + ('a -> (bool, 'trace) result) -> 'a list -> ('a option, 'trace) result + + val find_s : ('a -> bool Lwt.t) -> 'a list -> 'a option Lwt.t + + val find_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a option, 'trace) result Lwt.t + + (** [rev_filter f l] is [rev (filter f l)] but more efficient. *) + val rev_filter : ('a -> bool) -> 'a list -> 'a list + + val rev_filter_some : 'a option list -> 'a list + + val filter_some : 'a option list -> 'a list + + val rev_filter_ok : ('a, 'b) result list -> 'a list + + val filter_ok : ('a, 'b) result list -> 'a list + + val rev_filter_error : ('a, 'b) result list -> 'b list + + val filter_error : ('a, 'b) result list -> 'b list + + val rev_filter_e : + ('a -> (bool, 'trace) result) -> 'a list -> ('a list, 'trace) result + + val filter_e : + ('a -> (bool, 'trace) result) -> 'a list -> ('a list, 'trace) result + + val rev_filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + + val filter_s : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + + val rev_filter_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list, 'trace) result Lwt.t + + val filter_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list, 'trace) result Lwt.t + + val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t + + val filter_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + ('a list, 'error trace) result Lwt.t + + val rev_partition_result : ('a, 'b) result list -> 'a list * 'b list + + val partition_result : ('a, 'b) result list -> 'a list * 'b list + + val rev_partition_e : + ('a -> (bool, 'trace) result) -> + 'a list -> + ('a list * 'a list, 'trace) result + + val partition_e : + ('a -> (bool, 'trace) result) -> + 'a list -> + ('a list * 'a list, 'trace) result + + val rev_partition_s : + ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t + + val partition_s : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t + + val rev_partition_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'trace) result Lwt.t + + val partition_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'trace) result Lwt.t + + val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t + + val partition_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'error trace) result Lwt.t + + (** {4 Traversal variants} *) + + val iter_e : + ('a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result + + val iter_s : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + + val iter_es : + ('a -> (unit, 'trace) result Lwt.t) -> + 'a list -> + (unit, 'trace) result Lwt.t + + val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t + + val iter_ep : + ('a -> (unit, 'error trace) result Lwt.t) -> + 'a list -> + (unit, 'error trace) result Lwt.t + + val iteri_e : + (int -> 'a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result + + val iteri_s : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t + + val iteri_es : + (int -> 'a -> (unit, 'trace) result Lwt.t) -> + 'a list -> + (unit, 'trace) result Lwt.t + + val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t + + val iteri_ep : + (int -> 'a -> (unit, 'error trace) result Lwt.t) -> + 'a list -> + (unit, 'error trace) result Lwt.t + + val map_e : + ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val map_es : + ('a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val map_ep : + ('a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val mapi_e : + (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val mapi_es : + (int -> 'a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val mapi_ep : + (int -> 'a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + + val rev_map_e : + ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val rev_map_s : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_map_es : + ('a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_map_ep : + ('a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val rev_mapi_e : + (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val rev_mapi_s : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_mapi_es : + (int -> 'a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val rev_mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_mapi_ep : + (int -> 'a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val rev_filter_map : ('a -> 'b option) -> 'a list -> 'b list + + val rev_filter_map_e : + ('a -> ('b option, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val filter_map_e : + ('a -> ('b option, 'trace) result) -> 'a list -> ('b list, 'trace) result + + val rev_filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + + val filter_map_s : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + + val rev_filter_map_es : + ('a -> ('b option, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val filter_map_es : + ('a -> ('b option, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t + + val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t + + val filter_map_ep : + ('a -> ('b option, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val fold_left_e : + ('a -> 'b -> ('a, 'trace) result) -> 'a -> 'b list -> ('a, 'trace) result + + val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b list -> 'a Lwt.t + + val fold_left_es : + ('a -> 'b -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b list -> + ('a, 'trace) result Lwt.t + + (** This function is not tail-recursive *) + val fold_right_e : + ('a -> 'b -> ('b, 'trace) result) -> 'a list -> 'b -> ('b, 'trace) result + + (** This function is not tail-recursive *) + val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t + + (** This function is not tail-recursive *) + val fold_right_es : + ('a -> 'b -> ('b, 'trace) result Lwt.t) -> + 'a list -> + 'b -> + ('b, 'trace) result Lwt.t + + (** {4 Double-traversal variants} + + As mentioned above, there are no [_p] and [_ep] double-traversors. Use + {!combine} (and variants) to circumvent this. *) + + val iter2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (unit, 'trace) result) -> + 'a list -> + 'b list -> + (unit, 'trace) result + + val iter2_s : + when_different_lengths:'trace -> + ('a -> 'b -> unit Lwt.t) -> + 'a list -> + 'b list -> + (unit, 'trace) result Lwt.t + + val iter2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (unit, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + (unit, 'trace) result Lwt.t + + val map2_e : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + + val map2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + + val map2_es : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + + val rev_map2_e : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + ('c list, 'trace) result + + val rev_map2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + + val rev_map2_es : + when_different_lengths:'trace -> + ('a -> 'b -> ('c, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + ('c list, 'trace) result Lwt.t + + val fold_left2_e : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('a, 'trace) result) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result + + val fold_left2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'a Lwt.t) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result Lwt.t + + val fold_left2_es : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b list -> + 'c list -> + ('a, 'trace) result Lwt.t + + (** This function is not tail-recursive *) + val fold_right2_e : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result + + (** This function is not tail-recursive *) + val fold_right2_s : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> 'c Lwt.t) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result Lwt.t + + (** This function is not tail-recursive *) + val fold_right2_es : + when_different_lengths:'trace -> + ('a -> 'b -> 'c -> ('c, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + 'c -> + ('c, 'trace) result Lwt.t + + (** {4 Scanning variants} *) + + val for_all_e : + ('a -> (bool, 'trace) result) -> 'a list -> (bool, 'trace) result + + val for_all_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + + val for_all_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + (bool, 'trace) result Lwt.t + + val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + + val for_all_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + (bool, 'error trace) result Lwt.t + + val exists_e : + ('a -> (bool, 'trace) result) -> 'a list -> (bool, 'trace) result + + val exists_s : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + + val exists_es : + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + (bool, 'trace) result Lwt.t + + val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t + + val exists_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + (bool, 'error trace) result Lwt.t + + (** {4 Double-scanning variants} + + As mentioned above, there are no [_p] and [_ep] double-scanners. Use + {!combine} (and variants) to circumvent this. *) + + val for_all2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result) -> + 'a list -> + 'b list -> + (bool, 'trace) result + + val for_all2_s : + when_different_lengths:'trace -> + ('a -> 'b -> bool Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + + val for_all2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + + val exists2_e : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result) -> + 'a list -> + 'b list -> + (bool, 'trace) result + + val exists2_s : + when_different_lengths:'trace -> + ('a -> 'b -> bool Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + + val exists2_es : + when_different_lengths:'trace -> + ('a -> 'b -> (bool, 'trace) result Lwt.t) -> + 'a list -> + 'b list -> + (bool, 'trace) result Lwt.t + + (** {3 Combine variants} + + These are primarily intended to be used for preprocessing before applying + a traversor to the resulting list of pairs. They give alternatives to the + [when_different_lengths] mechanism of the immediate double-traversors + above. + + In case the semantic of, say, [map2_es] was unsatisfying, one can use + [map_es] on a [combine]-preprocessed pair of lists. The different variants + of [combine] give different approaches to different-length handling. *) + + (** [combine_drop ll lr] is a list [l] of pairs of elements taken from the + common-length prefix of [ll] and [lr]. The suffix of whichever list is + longer (if any) is dropped. + + More formally [nth l n] is: + - [None] if [n >= min (length ll) (length lr)] + - [Some (Option.get @@ nth ll n, Option.get @@ nth lr n)] otherwise + *) + val combine_drop : 'a list -> 'b list -> ('a * 'b) list + + (** [combine_with_leftovers ll lr] is a tuple [(combined, leftover)] + where [combined] is [combine_drop ll lr] + and [leftover] is either [`Left lsuffix] or [`Right rsuffix] depending on + which of [ll] or [lr] is longer. [leftover] is [None] if the two lists + have the same length. *) + val combine_with_leftovers : + 'a list -> + 'b list -> + ('a * 'b) list * [`Left of 'a list | `Right of 'b list] option +end diff --git a/src/lib_lwt_result_stdlib/test/dune b/src/lib_lwt_result_stdlib/test/dune index bef7149d741c985749f7b8e7489db037b272cf25..4201e90450424b3b50cc27e81aa7f1a11486bfe0 100644 --- a/src/lib_lwt_result_stdlib/test/dune +++ b/src/lib_lwt_result_stdlib/test/dune @@ -1,8 +1,10 @@ (executables (names test_hashtbl + test_list_basic test_generic test_fuzzing_seq + test_fuzzing_list test_fuzzing_set ) (libraries tezos-lwt-result-stdlib @@ -17,7 +19,9 @@ (deps test_hashtbl.exe test_generic.exe + test_list_basic.exe test_fuzzing_seq.exe + test_fuzzing_list.exe test_fuzzing_set.exe )) @@ -27,9 +31,15 @@ (rule (alias runtest_generic) (action (run %{exe:test_generic.exe}))) +(rule + (alias runtest_list_basic) + (action (run %{exe:test_list_basic.exe}))) (rule (alias runtest_fuzzing_seq) (action (run %{exe:test_fuzzing_seq.exe}))) +(rule + (alias runtest_fuzzing_list) + (action (run %{exe:test_fuzzing_list.exe}))) (rule (alias runtest_fuzzing_set) (action (run %{exe:test_fuzzing_set.exe}))) @@ -40,7 +50,9 @@ (deps (alias runtest_hashtbl) (alias runtest_generic) + (alias runtest_list_basic) (alias runtest_fuzzing_seq) + (alias runtest_fuzzing_list) (alias runtest_fuzzing_set) ) (action (progn)) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml index bb8f9a90dae3364c5d41148d92103e5fcd592290..64decbaca7ded4fbc02bca4d2dc31092dd3be0a4 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml @@ -91,6 +91,10 @@ module IterOf = struct let fn r fn y = r := fn !r y end +module IteriOf = struct + let fn r fn i y = r := fn !r (fn i y) +end + module Iter2Of = struct let fn r fn x y = r := fn !r (fn x y) end @@ -121,6 +125,14 @@ module IterEOf = struct let fn_e r fn y = fn !r y >|? fun t -> r := t end +module IteriEOf = struct + let fn r fn i y = + r := fn !r (fn i y) ; + Ok () + + let fn_e r fn i y = fn i y >>? fun z -> fn !r z >|? fun t -> r := t +end + module Iter2EOf = struct let fn r fn x y = r := fn x y ; @@ -183,6 +195,14 @@ module IterSOf = struct let fn_s r fn y = fn !r y >|= fun t -> r := t end +module IteriSOf = struct + let fn r fn i y = + r := fn !r (fn i y) ; + Lwt.return_unit + + let fn_s r fn i y = fn i y >>= fun z -> fn !r z >|= fun t -> r := t +end + module Iter2SOf = struct let fn r fn x y = r := fn x y ; @@ -253,6 +273,26 @@ module IterESOf = struct let fn_es r fn y = fn !r y >|=? fun t -> r := t end +module IteriESOf = struct + let fn r fn i y = + r := fn !r (fn i y) ; + return_unit + + let fn_e r fn i y = + Lwt.return @@ fn i y + >>=? fun z -> Lwt.return @@ fn !r z >|=? fun t -> r := t + + let fn_s r fn i y = + fn i y + >>= fun z -> + fn !r z + >|= fun t -> + r := t ; + Ok () + + let fn_es r fn i y = fn i y >>=? fun z -> fn !r z >|=? fun t -> r := t +end + module Iter2ESOf = struct let fn r fn x y = r := fn x y ; diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml new file mode 100644 index 0000000000000000000000000000000000000000..46b6ed5f9f1f79e6221572ce04cd6eefd595b214 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml @@ -0,0 +1,59 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Test_fuzzing_tests + +module ListWithBase = struct + type 'a elt = 'a + + include Lwtreslib.List + + let of_list = Fun.id + + let to_list = Fun.id + + let name = "List" +end + +(* Internal consistency *) +module IterFold = TestIterFold (ListWithBase) +module RevMapRevMap = TestRevMapRevMap (ListWithBase) + +(* consistency w.r.t. Stdlib *) +module ExistForall = TestExistForallAgainstStdlibList (ListWithBase) +module Filter = TestFilterAgainstStdlibList (ListWithBase) +module Filterp = TestFilterpAgainstStdlibList (ListWithBase) +module Filtermap = TestFiltermapAgainstStdlibList (ListWithBase) +module Filtermapp = TestFiltermappAgainstStdlibList (ListWithBase) +module Fold = TestFoldAgainstStdlibList (ListWithBase) +module FoldRight = TestFoldRightAgainstStdlibList (ListWithBase) +module Iter = TestIterAgainstStdlibList (ListWithBase) +module Iteri = TestIteriAgainstStdlibList (ListWithBase) +module Iterp = TestIterMonotoneAgainstStdlibList (ListWithBase) +module Map = TestMapAgainstStdlibList (ListWithBase) +module Mapp = TestMappAgainstStdlibList (ListWithBase) +module Find = TestFindStdlibList (ListWithBase) +module Partition = TestPartitionStdlibList (ListWithBase) +module Double = TestDoubleTraversorsStdlibList (ListWithBase) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml index a70023eb9270fba46525e0f9670e7f0aa05b6380..f512c627e7628f9618ce28dbece7dded1a08a47a 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml @@ -213,6 +213,61 @@ struct (Lwt.return_ok @@ with_stdlib_iter fn init input)) end +module TestIteriAgainstStdlibList (M : sig + include BASE with type 'a elt := int + + include + Traits.ITERI_SEQUENTIAL with type 'a elt := int and type 'a t := int t +end) = +struct + let with_stdlib_iteri fn init input = + let acc = ref init in + Stdlib.List.iteri (IteriOf.fn acc fn) input ; + !acc + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iteri, Stdlib.List.iteri" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq + (let acc = ref init in + M.iteri (IteriOf.fn acc fn) (M.of_list input) ; + !acc) + (with_stdlib_iteri fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iteri_e, Stdlib.List.iteri" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_e + (let acc = ref init in + M.iteri_e (IteriEOf.fn acc fn) (M.of_list input) >|? fun () -> !acc) + (Ok (with_stdlib_iteri fn init input))) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iteri_s, Stdlib.List.iteri" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_s + (let acc = ref init in + M.iteri_s (IteriSOf.fn acc fn) (M.of_list input) >|= fun () -> !acc) + (Lwt.return @@ with_stdlib_iteri fn init input)) + + let () = + Crowbar.add_test + ~name:(Format.asprintf "%s.iteri_es, Stdlib.List.iteri" M.name) + [Fn.arith; one; many] + (fun fn init input -> + eq_es + (let acc = ref init in + M.iteri_es (IteriESOf.fn acc fn) (M.of_list input) + >|=? fun () -> !acc) + (Lwt.return_ok @@ with_stdlib_iteri fn init input)) +end + module TestIterMonotoneAgainstStdlibList (M : sig include BASE with type 'a elt := int diff --git a/src/lib_lwt_result_stdlib/test/test_generic.ml b/src/lib_lwt_result_stdlib/test/test_generic.ml index 49fd33c579ea03045fd9487bc1ae9dc8f853e217..87054a1508796a9dac8405f5dd58a7e4a7f7164b 100644 --- a/src/lib_lwt_result_stdlib/test/test_generic.ml +++ b/src/lib_lwt_result_stdlib/test/test_generic.ml @@ -45,6 +45,16 @@ module SeqGen = struct let up n = up n 0 end +module ListGen = struct + include Lwtreslib.List + + let rec down n : int t = if n < 0 then [] else n :: down (pred n) + + let rec up n i : int t = if i > n then [] else i :: up n (succ i) + + let up n = up n 0 +end + module Testing = struct exception Nope of int @@ -208,6 +218,7 @@ struct end module SeqIterTest = MakeItererTest (SeqGen) +module ListIterTest = MakeItererTest (ListGen) module MakeFolderTest (M : sig include GEN @@ -243,6 +254,7 @@ struct end module SeqFoldTest = MakeFolderTest (SeqGen) +module ListFoldTest = MakeFolderTest (ListGen) module MakeMapperTest (M : sig include GEN @@ -277,11 +289,15 @@ struct end module SeqMapTest = MakeMapperTest (SeqGen) +module ListMapTest = MakeMapperTest (ListGen) let () = Alcotest_lwt.run "traversor-generic" [ ("seq-iter", SeqIterTest.tests); ("seq-fold", SeqFoldTest.tests); - ("seq-map", SeqMapTest.tests) ] + ("seq-map", SeqMapTest.tests); + ("list-iter", ListIterTest.tests); + ("list-fold", ListFoldTest.tests); + ("list-map", ListMapTest.tests) ] |> Lwt_main.run diff --git a/src/lib_lwt_result_stdlib/test/test_list_basic.ml b/src/lib_lwt_result_stdlib/test/test_list_basic.ml new file mode 100644 index 0000000000000000000000000000000000000000..26557886c24f2bf634db832677fbcc43596aaaaf --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/test_list_basic.ml @@ -0,0 +1,298 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Lwtreslib.Seq.Monad + +let assert_eq_s pa pb = + let open Lwt.Infix in + pa + >>= fun a -> + pb + >>= fun b -> + assert (a = b) ; + Lwt.return_unit + +let assert_err e = e = Error () + +let assert_err_s e = + let open Lwt.Infix in + e + >>= fun e -> + assert (e = Error ()) ; + Lwt.return_unit + +let assert_err_p e = + let open Lwt.Infix in + e + >>= fun e -> + assert (e = Error (make ())) ; + Lwt.return_unit + +module ListGen = struct + include Lwtreslib.List + + let rec down n : int t = if n < 0 then [] else n :: down (pred n) + + let rec up n i : int t = if i > n then [] else i :: up n (succ i) + + let up n = up n 0 +end + +open ListGen + +module Nth = struct + let nth _ = + assert (nth (up 10) 0 = Some 0) ; + assert (nth (up 10) 1 = Some 1) ; + assert (nth (up 10) 7 = Some 7) ; + assert (nth (up 10) 10 = Some 10) ; + assert (nth (up 10) 11 = None) ; + assert (nth (up 10) 12 = None) ; + assert (nth [] 0 = None) ; + assert (nth [] 1 = None) ; + assert (nth (up 104) max_int = None) ; + assert (nth (up 104) (-1) = None) ; + assert (nth (up 1) (-100) = None) ; + assert (nth (up 0) (-100) = None) ; + () + + let tests = [Alcotest_lwt.test_case_sync "nth" `Quick nth] +end + +module Last = struct + let last _ = + assert (last (-1) [] = -1) ; + assert (last (-1) (up 0) = 0) ; + assert (last (-1) (up 10) = 10) ; + () + + let last_opt _ = + assert (last_opt [] = None) ; + assert (last_opt (up 0) = Some 0) ; + assert (last_opt (up 10) = Some 10) ; + () + + let tests = + [ Alcotest_lwt.test_case_sync "last" `Quick last; + Alcotest_lwt.test_case_sync "last_opt" `Quick last_opt ] +end + +module Init = struct + let init () = + assert (assert_err @@ init ~when_negative_length:() (-10) Fun.id) ; + assert (init ~when_negative_length:() 0 Fun.id = Ok []) ; + assert (init ~when_negative_length:() 11 Fun.id = Ok (up 10)) ; + () + + let init_e () = + assert (assert_err @@ init_e ~when_negative_length:() (-10) ok) ; + assert (init_e ~when_negative_length:() 0 ok = nil_e) ; + assert (init_e ~when_negative_length:() 11 ok = ok @@ up 10) ; + () + + let init_s _ () = + let open Lwt.Infix in + assert_err_s (init_s ~when_negative_length:() (-10) Lwt.return) + >>= fun () -> + assert_eq_s (init_s ~when_negative_length:() 0 Lwt.return) nil_es + >>= fun () -> + assert_eq_s + (init_s ~when_negative_length:() 11 Lwt.return) + (Lwt.return_ok @@ up 10) + >>= fun () -> Lwt.return_unit + + let init_es _ () = + let open Lwt.Infix in + assert_err_s (init_es ~when_negative_length:() (-10) Lwt.return_ok) + >>= fun () -> + assert_eq_s (init_es ~when_negative_length:() 0 Lwt.return_ok) nil_es + >>= fun () -> + assert_eq_s + (init_es ~when_negative_length:() 11 Lwt.return_ok) + (Lwt.return_ok @@ up 10) + >>= fun () -> Lwt.return_unit + + let init_p _ () = + let open Lwt.Infix in + assert_err_s (init_p ~when_negative_length:() (-10) Lwt.return) + >>= fun () -> + assert_eq_s (init_p ~when_negative_length:() 0 Lwt.return) nil_es + >>= fun () -> + assert_eq_s + (init_p ~when_negative_length:() 11 Lwt.return) + (Lwt.return_ok @@ up 10) + >>= fun () -> Lwt.return_unit + + let init_ep _ () = + let open Lwt.Infix in + assert_err_p (init_ep ~when_negative_length:() (-10) Lwt.return_ok) + >>= fun () -> + assert_eq_s (init_ep ~when_negative_length:() 0 Lwt.return_ok) nil_es + >>= fun () -> + assert_eq_s + (init_ep ~when_negative_length:() 11 Lwt.return_ok) + (Lwt.return_ok @@ up 10) + >>= fun () -> Lwt.return_unit + + let tests = + [ Alcotest_lwt.test_case_sync "init" `Quick init; + Alcotest_lwt.test_case_sync "init_e" `Quick init_e; + Alcotest_lwt.test_case "init_s" `Quick init_s; + Alcotest_lwt.test_case "init_es" `Quick init_es; + Alcotest_lwt.test_case "init_p" `Quick init_p; + Alcotest_lwt.test_case "init_ep" `Quick init_ep ] +end + +module FilterSmthg = struct + let cond x = x mod 2 = 0 + + let filter_some () = + assert (filter_some [] = []) ; + assert (filter_some [None] = []) ; + assert (filter_some [Some 0] = [0]) ; + assert ( + let base = up 17 in + let left = base |> filter cond in + let right = + base |> map (fun x -> if cond x then Some x else None) |> filter_some + in + left = right ) ; + () + + let filter_ok () = + assert (filter_ok [] = []) ; + assert (filter_ok [Error 10] = []) ; + assert (filter_ok [Ok 0] = [0]) ; + assert ( + let base = up 17 in + let left = base |> filter cond in + let right = + base + |> map (fun x -> if cond x then Ok x else Error (4 * x)) + |> filter_ok + in + left = right ) ; + () + + let filter_error () = + assert (filter_error [] = []) ; + assert (filter_error [Ok 10] = []) ; + assert (filter_error [Error 0] = [0]) ; + assert ( + let base = up 17 in + let left = base |> filter cond in + let right = + base + |> map (fun x -> if cond x then Error x else Ok (4 * x)) + |> filter_error + in + left = right ) ; + () + + let tests = + [ Alcotest_lwt.test_case_sync "filter_some" `Quick filter_some; + Alcotest_lwt.test_case_sync "filter_ok" `Quick filter_ok; + Alcotest_lwt.test_case_sync "filter_error" `Quick filter_error ] +end + +module Combine = struct + let combine_error () = + assert (combine ~when_different_lengths:() [] [0] = Error ()) ; + assert (combine ~when_different_lengths:() [0] [] = Error ()) ; + assert (combine ~when_different_lengths:() (up 100) (up 99) = Error ()) ; + () + + let combine_ok () = + assert (combine ~when_different_lengths:() [] [] = Ok []) ; + assert (combine ~when_different_lengths:() [0] [1] = Ok [(0, 1)]) ; + assert ( + combine ~when_different_lengths:() (up 100) (down 100) + = init ~when_negative_length:() 101 (fun i -> (i, 100 - i)) ) ; + () + + let combine_drop () = + assert (combine_drop [] [] = []) ; + assert ( + Ok (combine_drop (up 100) (down 100)) + = init ~when_negative_length:() 101 (fun i -> (i, 100 - i)) ) ; + assert (combine_drop [0] [1] = [(0, 1)]) ; + assert (combine_drop [] [0] = []) ; + assert (combine_drop [0] [] = []) ; + assert (combine_drop (up 100) (up 99) = map (fun i -> (i, i)) (up 99)) ; + () + + let combine_with_leftovers () = + assert (combine_with_leftovers [] [] = ([], None)) ; + assert ( + combine_with_leftovers (up 100) (down 100) + = ( Result.get_ok + @@ init ~when_negative_length:() 101 (fun i -> (i, 100 - i)), + None ) ) ; + assert (combine_with_leftovers [0] [1] = ([(0, 1)], None)) ; + assert (combine_with_leftovers [] [0] = ([], Some (`Right [0]))) ; + assert (combine_with_leftovers [0] [] = ([], Some (`Left [0]))) ; + assert ( + combine_with_leftovers (up 100) (up 99) + = (map (fun i -> (i, i)) (up 99), Some (`Left [100])) ) ; + () + + let tests = + [ Alcotest_lwt.test_case_sync "combine-error" `Quick combine_error; + Alcotest_lwt.test_case_sync "combine-ok" `Quick combine_ok; + Alcotest_lwt.test_case_sync "combine_drop" `Quick combine_drop; + Alcotest_lwt.test_case_sync + "combine_with_leftovers" + `Quick + combine_with_leftovers ] +end + +module Partition = struct + let cond x = x mod 2 = 0 + + let partition_result () = + assert (partition_result [] = ([], [])) ; + assert (partition_result [Ok 0] = ([0], [])) ; + assert (partition_result [Error 0] = ([], [0])) ; + assert (partition_result (map ok (up 11)) = (up 11, [])) ; + assert (partition_result (map (fun x -> Error x) (up 11)) = ([], up 11)) ; + assert ( + let input = map (fun x -> if cond x then Ok x else Error x) (up 101) in + partition_result input = (filter_ok input, filter_error input) ) ; + () + + let tests = + [Alcotest_lwt.test_case_sync "partition-result" `Quick partition_result] +end + +let () = + Alcotest_lwt.run + "list-basic" + [ ("nth", Nth.tests); + ("last", Last.tests); + ("init", Init.tests); + ("filter_*", FilterSmthg.tests); + ("combine_*", Combine.tests); + ("partition_*", Partition.tests) ] + |> Lwt_main.run diff --git a/src/lib_lwt_result_stdlib/test/traits.ml b/src/lib_lwt_result_stdlib/test/traits.ml index 09e3700f42470bd86468dde2fdbafa38260e7277..93a1cc883523eb7724367762a3eea89143b121d3 100644 --- a/src/lib_lwt_result_stdlib/test/traits.ml +++ b/src/lib_lwt_result_stdlib/test/traits.ml @@ -70,6 +70,28 @@ module type ITER_PARALLEL = sig (unit, 'error trace) result Lwt.t end +module type ITERI_VANILLA = sig + type 'a elt + + type 'a t + + val iteri : (int -> 'a elt -> unit) -> 'a t -> unit +end + +module type ITERI_SEQUENTIAL = sig + include ITERI_VANILLA + + val iteri_e : + (int -> 'a elt -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result + + val iteri_s : (int -> 'a elt -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iteri_es : + (int -> 'a elt -> (unit, 'trace) result Lwt.t) -> + 'a t -> + (unit, 'trace) result Lwt.t +end + module type MAP_VANILLA = sig type 'a t diff --git a/src/lib_mockup/local_services.ml b/src/lib_mockup/local_services.ml index f9d07d749fae8e9064659dbf973e147c797a0791..b7e6e73108c0fbc3572eeff62329e1936f590314 100644 --- a/src/lib_mockup/local_services.ml +++ b/src/lib_mockup/local_services.ml @@ -298,7 +298,7 @@ module Make (E : MENV) = struct | Error errs -> RPC_answer.fail errs | Ok pooled_operations -> ( - map_s + List.map_es (fun (shell_header, operation_data) -> let op = { @@ -397,8 +397,8 @@ module Make (E : MENV) = struct with_chain chain (fun () -> begin_construction () >>=? (fun validation_state -> - fold_left_s - (fold_left_s simulate_operation) + List.fold_left_es + (List.fold_left_es simulate_operation) (validation_state, []) operations >>=? fun (validation_state, preapply_results) -> @@ -459,7 +459,7 @@ module Make (E : MENV) = struct with_chain chain (fun () -> begin_construction () >>=? (fun state -> - fold_left_s + List.fold_left_es (fun (state, acc) op -> E.Protocol.apply_operation state op >>=? fun (state, result) -> @@ -485,7 +485,7 @@ module Make (E : MENV) = struct let operations = op :: mempool_operations in begin_construction () >>=? fun validation_state -> - fold_left_s + List.fold_left_es (fun rstate (shell, protocol_data) -> simulate_operation rstate E.Protocol.{shell; protocol_data}) (validation_state, []) @@ -591,8 +591,8 @@ module Make (E : MENV) = struct } >>=? fun validation_state -> let i = ref 0 in - fold_left_s - (fold_left_s (fun (validation_state, _results) op -> + List.fold_left_es + (List.fold_left_es (fun (validation_state, _results) op -> incr i ; match Data_encoding.Binary.of_bytes @@ -645,7 +645,7 @@ module Make (E : MENV) = struct >>=? fun () -> Mempool.read () >>=? fun mempool_operations -> - fold_left_s + List.fold_left_es (fun map ((shell_header, operation_data) as v) -> match Data_encoding.Binary.to_bytes diff --git a/src/lib_mockup/mockup_wallet.ml b/src/lib_mockup/mockup_wallet.ml index 8166177a3ae7ef8efcc8b62eb4836ec24efe4967..451a8dee6ce01e58b382983e4c21559357a400f6 100644 --- a/src/lib_mockup/mockup_wallet.ml +++ b/src/lib_mockup/mockup_wallet.ml @@ -36,7 +36,7 @@ let default_bootstrap_accounts = "edsk4QLrcijEffxV31gGdN2HU7UpyJjA8drFoNcmnB28n89YjPNRFm" ] in let basename = "bootstrap" in - Error_monad.mapi_s + List.mapi_es (fun i ukey -> Client_keys.make_sk_uri @@ Uri.of_string ("unencrypted:" ^ ukey) >>=? fun sk_uri -> @@ -93,4 +93,4 @@ let populate (cctxt : #Tezos_client_base.Client_context.io_wallet) failwith "cannot read definitions of bootstrap accounts in %s" accounts_file ) ) - >>=? Tezos_base.TzPervasives.iter_s (add_bootstrap_secret cctxt) + >>=? List.iter_es (add_bootstrap_secret cctxt) diff --git a/src/lib_p2p/p2p_directory.ml b/src/lib_p2p/p2p_directory.ml index c64f2328988ebe4c80a13216e40b1b0917662e03..e5578d8cf3da6ecb3eaf5c42584c7391a27ba84c 100644 --- a/src/lib_p2p/p2p_directory.ml +++ b/src/lib_p2p/p2p_directory.ml @@ -227,11 +227,9 @@ let build_rpc_directory net = | None -> RPC_answer.return [] | Some gi -> - let rev = false and max = max_int in let evts = P2p_peer_state.Info.fold gi ~init:[] ~f:(fun a e -> e :: a) in - let evts = (if rev then List.rev_sub else List.sub) evts max in if not q#monitor then RPC_answer.return evts else let (stream, stopper) = P2p_peer_state.Info.watch gi in @@ -351,11 +349,9 @@ let build_rpc_directory net = | None -> RPC_answer.return [] | Some gi -> - let rev = false and max = max_int in let evts = P2p_point_state.Info.fold gi ~init:[] ~f:(fun a e -> e :: a) in - let evts = (if rev then List.rev_sub else List.sub) evts max in if not q#monitor then RPC_answer.return evts else let (stream, stopper) = P2p_point_state.Info.watch gi in diff --git a/src/lib_p2p/p2p_maintenance.ml b/src/lib_p2p/p2p_maintenance.ml index d158a3d4cd12eeca30bf4485b1de301d369ee3bd..5d7294bb48a49a5c870bcccfeba88f22bf7adbf1 100644 --- a/src/lib_p2p/p2p_maintenance.ml +++ b/src/lib_p2p/p2p_maintenance.ml @@ -109,7 +109,7 @@ let establish t contactable = P2p_connect_handler.connect t.connect_handler point) >|= function Ok _ -> succ count | Error _ -> count in - Lwt_list.fold_left_s try_to_connect 0 contactable + List.fold_left_s try_to_connect 0 contactable (* [connectable t start_time expected seen_points] selects at most [expected] connections candidates from the known points, not in [seen] @@ -268,7 +268,7 @@ and too_many_connections t n_connected = Events.(emit too_many_connections) n >>= fun () -> let connections = random_connections t.pool n in - Lwt_list.iter_p P2p_conn.disconnect connections >>= fun () -> do_maintain t + List.iter_p P2p_conn.disconnect connections >>= fun () -> do_maintain t let rec worker_loop t = (let n_connected = P2p_pool.active_connections t.pool in diff --git a/src/lib_p2p/p2p_pool.ml b/src/lib_p2p/p2p_pool.ml index a59bea6b938d6bdce8aa13478196fa067e945833..04ed3267abd104c8a17b0a54fc7c7ea461e3c9ea 100644 --- a/src/lib_p2p/p2p_pool.ml +++ b/src/lib_p2p/p2p_pool.ml @@ -355,10 +355,13 @@ module Connection = struct let list pool = fold pool ~init:[] ~f:(fun peer_id c acc -> (peer_id, c) :: acc) - let random_elt l = - let n = List.length l in - let r = Random.int n in - List.nth l r + let random_elt = function + | [] -> + None + | _ :: _ as l -> + let n = List.length l in + let r = Random.int n in + List.nth l r let random_addr ?different_than ~no_private pool = let candidates = @@ -376,7 +379,7 @@ module Connection = struct | (addr, Some port) -> ((addr, port), ci.peer_id) :: acc )) in - match candidates with [] -> None | _ -> Some (random_elt candidates) + random_elt candidates (** [random_connection ?conn no_private t] returns a random connection from the pool of connections. It ignores: @@ -395,7 +398,7 @@ module Connection = struct | Some _ | None -> conn :: acc) in - match candidates with [] -> None | _ -> Some (random_elt candidates) + random_elt candidates let propose_swap_request pool = match random_connection ~no_private:true pool with @@ -537,15 +540,23 @@ let add_to_id_points t point = The [best] first elements are taken, then [other] elements are chosen randomly in the rest of the list. Note that it might select fewer elements than [other] if it the same index - close to the end of the list is picked multiple times. *) + close to the end of the list is picked multiple times. + + @raise [Invalid_argument] if either [best] or [other] is strictly negative. + *) let sample best other points = + if best < 0 || other < 0 then raise (Invalid_argument "P2p_pool.sample") ; let l = List.length points in if l <= best + other then points else - let best_indexes = List.init best (fun i -> i) in + (* This is safe because we checked the value of [best] and [other] *) + let list_init n f = + Result.get_ok @@ List.init ~when_negative_length:() n f + in + let best_indexes = list_init best Fun.id in let other_indexes = List.sort compare - @@ List.init other (fun _ -> best + Random.int (l - best)) + @@ list_init other (fun _ -> best + Random.int (l - best)) in let indexes = best_indexes @ other_indexes in (* Note: we are doing a [fold_left_i] by hand, passing [i] manually *) @@ -599,16 +610,20 @@ let compare_known_point_info p1 p2 = compare_last_seen p2 p1 let list_known_points ~ignore_private ?(size = 50) pool = - P2p_point.Table.fold - (fun point_id point_info acc -> - if - (ignore_private && not (P2p_point_state.Info.known_public point_info)) - || Points.banned pool point_id - then acc - else point_info :: acc) - pool.known_points - [] - |> List.sort compare_known_point_info - |> sample (size * 3 / 5) (size * 2 / 5) - |> List.map P2p_point_state.Info.point - |> Lwt.return + if size < 0 then Lwt.fail (Invalid_argument "P2p_pool.list_known_points") + else + let other = size * 2 / 5 in + let best = size - other in + P2p_point.Table.fold + (fun point_id point_info acc -> + if + (ignore_private && not (P2p_point_state.Info.known_public point_info)) + || Points.banned pool point_id + then acc + else point_info :: acc) + pool.known_points + [] + |> List.sort compare_known_point_info + |> sample best other + |> List.map P2p_point_state.Info.point + |> Lwt.return diff --git a/src/lib_p2p/p2p_pool.mli b/src/lib_p2p/p2p_pool.mli index 7021f33abcb0b0ec8dd2b3ade02c4623a97eeac5..6b43872f9f4eb97fab2229c833b21cf8aceb1f85 100644 --- a/src/lib_p2p/p2p_pool.mli +++ b/src/lib_p2p/p2p_pool.mli @@ -317,11 +317,13 @@ val gc_greylist : older_than:Time.System.t -> ('msg, 'peer, 'conn) t -> unit (** [acl_clear pool] clears ACL tables. *) val acl_clear : ('msg, 'peer, 'conn) t -> unit -(** [list_known_points ~ignore_private t] returns a list of point ids, +(** [list_known_points ~ignore_private ?size t] returns a list of point ids, which are not banned, and if [ignore_private] is [true], public. It returns at most [size] point ids (default is 50) based on a - heuristic that selects a mix of 3/5 "good" and 2/5 random points. *) + heuristic that selects a mix of 3/5 "good" and 2/5 random points. + + @raise [Invalid_argument] if [size < 0] *) val list_known_points : ignore_private:bool -> ?size:int -> diff --git a/src/lib_p2p/test/process.ml b/src/lib_p2p/test/process.ml index 82744cc1e4cf418d4a38dd008ad200a3bad9b73c..a574477fd09e2f080ad1508aa02406e4f9887539 100644 --- a/src/lib_p2p/test/process.ml +++ b/src/lib_p2p/test/process.ml @@ -282,45 +282,42 @@ let detach ?(prefix = "") ?canceler ?input_encoding ?output_encoding ~on_error:(fun err -> Lwt_canceler.cancel canceler >>= fun _ -> Lwt.return (Error err)) -let signal_name = - let names = - [ (Sys.sigabrt, "ABRT"); - (Sys.sigalrm, "ALRM"); - (Sys.sigfpe, "FPE"); - (Sys.sighup, "HUP"); - (Sys.sigill, "ILL"); - (Sys.sigint, "INT"); - (Sys.sigkill, "KILL"); - (Sys.sigpipe, "PIPE"); - (Sys.sigquit, "QUIT"); - (Sys.sigsegv, "SEGV"); - (Sys.sigterm, "TERM"); - (Sys.sigusr1, "USR1"); - (Sys.sigusr2, "USR2"); - (Sys.sigchld, "CHLD"); - (Sys.sigcont, "CONT"); - (Sys.sigstop, "STOP"); - (Sys.sigtstp, "TSTP"); - (Sys.sigttin, "TTIN"); - (Sys.sigttou, "TTOU"); - (Sys.sigvtalrm, "VTALRM"); - (Sys.sigprof, "PROF"); - (Sys.sigbus, "BUS"); - (Sys.sigpoll, "POLL"); - (Sys.sigsys, "SYS"); - (Sys.sigtrap, "TRAP"); - (Sys.sigurg, "URG"); - (Sys.sigxcpu, "XCPU"); - (Sys.sigxfsz, "XFSZ") ] - in - fun n -> List.assoc n names +let signal_names = + [ (Sys.sigabrt, "SIGABRT"); + (Sys.sigalrm, "SIGALRM"); + (Sys.sigfpe, "SIGFPE"); + (Sys.sighup, "SIGHUP"); + (Sys.sigill, "SIGILL"); + (Sys.sigint, "SIGINT"); + (Sys.sigkill, "SIGKILL"); + (Sys.sigpipe, "SIGPIPE"); + (Sys.sigquit, "SIGQUIT"); + (Sys.sigsegv, "SIGSEGV"); + (Sys.sigterm, "SIGTERM"); + (Sys.sigusr1, "SIGUSR1"); + (Sys.sigusr2, "SIGUSR2"); + (Sys.sigchld, "SIGCHLD"); + (Sys.sigcont, "SIGCONT"); + (Sys.sigstop, "SIGSTOP"); + (Sys.sigtstp, "SIGTSTP"); + (Sys.sigttin, "SIGTTIN"); + (Sys.sigttou, "SIGTTOU"); + (Sys.sigvtalrm, "SIGVTALRM"); + (Sys.sigprof, "SIGPROF"); + (Sys.sigbus, "SIGBUS"); + (Sys.sigpoll, "SIGPOLL"); + (Sys.sigsys, "SIGSYS"); + (Sys.sigtrap, "SIGTRAP"); + (Sys.sigurg, "SIGURG"); + (Sys.sigxcpu, "SIGXCPU"); + (Sys.sigxfsz, "SIGXFSZ") ] + +let signal_name n = List.assoc n signal_names let print_errors plist = - Lwt_list.partition_p - (fun (_i, _prefix, p) -> - match p with Ok _ -> Lwt.return_true | _ -> Lwt.return_false) - plist - >>= fun (ok_list, errlist) -> + let (ok_list, errlist) = + List.partition (fun (_i, _prefix, p) -> Result.is_ok p) plist + in lwt_log_error "@[Processes @[%a@] finished successfully.@]" (fun ppf -> @@ -334,7 +331,7 @@ let print_errors plist = match p with Error [Exn _] -> true | _ -> false) errlist in - Lwt_list.iter_s + List.iter_s (fun (i, prefix, p) -> let prefix = String.trim prefix in match p with @@ -348,16 +345,16 @@ let print_errors plist = n | Error [Exn (Signaled n)] -> lwt_log_error - "@[Process %d (%s) was killed by a SIG%s !@]" + "@[Process %d (%s) was killed by %s!@]" i prefix - (signal_name n) + (Option.value ~default:"an unknown signal" @@ signal_name n) | Error [Exn (Stopped n)] -> lwt_log_error - "@[Process %d (%s) was stopped by a SIG%s !@]" + "@[Process %d (%s) was stopped by %s!@]" i prefix - (signal_name n) + (Option.value ~default:"an unknown signal" @@ signal_name n) | Error err -> lwt_log_error "@[Process %d (%s) failed with error:@ @[ %a @]@]" @@ -388,7 +385,7 @@ let print_errors plist = Format.fprintf ppf "@ %d(%s)" i (String.trim pref))) canceled_list ) >>= fun () -> - Lwt_list.iter_s + List.iter_s (fun (i, prefix, p) -> let prefix = String.trim prefix in match p with @@ -445,11 +442,8 @@ let () = (function Par lst -> Some lst | _ -> None) (fun lst -> Par lst) -let join (plist : 'a Lwt.t list) = - Lwt_list.map_s (fun (p : 'a Lwt.t) -> p) plist - let join_process (plist : ('a, 'b, 'c) t list) = - Lwt_list.map_p + List.map_p (fun {termination; prefix; _} -> termination >>= fun t -> Lwt.return (prefix, t)) plist @@ -487,7 +481,7 @@ let wait_all_results (processes : ('a, 'b, 'c) t list) = | None -> lwt_log_info "All done!" >>= fun () -> - join terminations + Error_monad.all_p terminations >>= fun terminated -> return @@ List.map (function Ok a -> a | Error _ -> assert false) terminated diff --git a/src/lib_p2p/test/test_p2p_io_scheduler.ml b/src/lib_p2p/test/test_p2p_io_scheduler.ml index bfe6868b04700f89fbda70094c32e8014e89c26d..63f06e80bc3f50164a3dd45c579e21db14b9394b 100644 --- a/src/lib_p2p/test/test_p2p_io_scheduler.ml +++ b/src/lib_p2p/test/test_p2p_io_scheduler.ml @@ -124,9 +124,9 @@ let server ?(display_client_stat = true) ?max_download_speed ?read_queue_size accept_n main_socket n >>=? fun conns -> let conns = List.map (P2p_io_scheduler.register sched) conns in - Lwt_list.iter_p receive conns + List.iter_p receive conns >>= fun () -> - iter_p P2p_io_scheduler.close conns + List.iter_ep P2p_io_scheduler.close conns >>=? fun () -> log_notice "OK %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ; return_unit @@ -202,7 +202,7 @@ let run ?display_client_stat ?max_download_speed ?max_upload_speed >>= fun () -> client ?max_upload_speed ?write_queue_size addr port time n) in - Error_monad.map_s client (1 -- n) + List.map_es client (1 -- n) >>=? fun client_nodes -> Process.wait_all (server_node :: client_nodes) let () = Random.self_init () diff --git a/src/lib_p2p/test/test_p2p_ipv6set.ml b/src/lib_p2p/test/test_p2p_ipv6set.ml index 0733ec24bc57266cc6f214feedec835cb08725f4..d2b0c8b5707bf531c91aff601b9eef70edb2cd77 100644 --- a/src/lib_p2p/test/test_p2p_ipv6set.ml +++ b/src/lib_p2p/test/test_p2p_ipv6set.ml @@ -149,7 +149,13 @@ let print_list ppf l = (** Creating a list from a set preserves the elements of the set. *) let test_to_list _ = let to_list s = P2p_acl.IpSet.fold (fun k _v acc -> k :: acc) s [] in - let list_eq = List.for_all2 (fun x y -> Ipaddr.V6.Prefix.compare x y = 0) in + let list_eq = + List.for_all2 ~when_different_lengths:() (fun x y -> + Ipaddr.V6.Prefix.compare x y = 0) + in + let list_eq l1 l2 = + match list_eq l1 l2 with Ok v -> v | Error () -> false + in let assert_equal_set ~msg a b = let a = List.sort compare a in let b = List.sort compare (to_list b) in diff --git a/src/lib_p2p/test/test_p2p_pool.ml b/src/lib_p2p/test/test_p2p_pool.ml index 89523e47f7228fce819e9c5b3e7bd87e74f7b83b..cc2f1cf6acc4a1412a41aad152c7e1387757e8e2 100644 --- a/src/lib_p2p/test/test_p2p_pool.ml +++ b/src/lib_p2p/test/test_p2p_pool.ml @@ -82,9 +82,10 @@ let sync iteration ch = (** Syncing from the main process everyone until one node fails to sync *) let rec sync_nodes nodes = - Error_monad.iter_p (fun p -> Process.receive p) nodes + List.iter_ep (fun p -> Process.receive p) nodes >>=? fun () -> - iter_p (fun p -> Process.send p ()) nodes >>=? fun () -> sync_nodes nodes + List.iter_ep (fun p -> Process.send p ()) nodes + >>=? fun () -> sync_nodes nodes let sync_nodes nodes = sync_nodes nodes @@ -178,7 +179,7 @@ let detach_node ?(prefix = "") ?timeout ?(min_connections : int option) ~log ~answerer in - Lwt_list.map_p + List.map_p (fun point -> P2p_pool.Points.info pool point |> Option.iter (fun info -> @@ -225,7 +226,7 @@ let detach_nodes ?prefix ?timeout ?min_connections ?max_connections ?max_incoming_connections ?p2p_versions ?msg_config run_node ?(trusted = fun _ points -> points) points = let canceler = Lwt_canceler.create () in - Lwt_list.mapi_s + List.mapi_s (fun n _ -> let prefix = Option.map (fun f -> f n) prefix in let p2p_versions = Option.map (fun f -> f n) p2p_versions in @@ -252,7 +253,7 @@ let detach_nodes ?prefix ?timeout ?min_connections ?max_connections port) points >>= fun nodes -> - Lwt.return @@ Error_monad.map2 (fun p _p -> p) nodes nodes + Lwt.return @@ Error_monad.all_e nodes >>=? fun nodes -> Lwt.ignore_result (sync_nodes nodes) ; Process.wait_all nodes @@ -327,18 +328,20 @@ module Simple = struct Lwt.return res let connect_all ~timeout connect_handler pool points = - map_p (connect ~timeout connect_handler pool) points + List.map_ep (connect ~timeout connect_handler pool) points let write_all conns msg = - iter_p (fun conn -> trace Write @@ P2p_conn.write_sync conn msg) conns + List.iter_ep + (fun conn -> trace Write @@ P2p_conn.write_sync conn msg) + conns let read_all conns = - iter_p + List.iter_ep (fun conn -> trace Read @@ P2p_conn.read conn >>=? fun Ping -> return_unit) conns - let close_all conns = Lwt_list.iter_p P2p_conn.disconnect conns + let close_all conns = List.iter_p P2p_conn.disconnect conns let node iteration channel _stream connect_handler pool points _ = connect_all @@ -405,7 +408,7 @@ module Random_connections = struct let connect_random_all connect_handler pool points n = let total = List.length points in let rem = ref (n * total) in - iter_p + List.iter_ep (fun point -> connect_random connect_handler pool total rem point n) points @@ -439,7 +442,7 @@ module Garbled = struct let write_bad_all conns = let bad_msg = Bytes.of_string (String.make 16 '\000') in - iter_p + List.iter_ep (fun conn -> trace Write @@ P2p_conn.raw_write_sync conn bad_msg) conns @@ -559,7 +562,7 @@ module Overcrowded = struct ~default:0 (P2p_connect_handler.config connect_handler).listening_port in - let target = List.hd trusted_points in + let target = Option.get @@ List.hd trusted_points in connect ~iter_count:0 ~timeout:(Time.System.Span.of_seconds_exn 2.) @@ -712,7 +715,8 @@ module Overcrowded = struct let node_mixed i = if i = 0 then target else client (i mod 2 = 1) - let trusted i points = if i = 0 then points else [List.hd points] + let trusted i points = + if i = 0 then points else [Option.get @@ List.hd points] (** Detaches a number of nodes: one of them is the target (its max_incoming_connections is set to zero), and all the rest are @@ -852,7 +856,7 @@ module No_common_network = struct ~timeout:(Time.System.Span.of_seconds_exn 2.) connect_handler pool - (List.hd trusted_points) + (Option.get @@ List.hd trusted_points) >>= function | Ok conn -> lwt_log_info @@ -891,7 +895,8 @@ module No_common_network = struct let node i = if i = 0 then target else client - let trusted i points = if i = 0 then points else [List.hd points] + let trusted i points = + if i = 0 then points else [Option.get @@ List.hd points] (** Running the target and the clients. All clients should have their pool populated with the list of points. diff --git a/src/lib_p2p/test/test_p2p_socket.ml b/src/lib_p2p/test/test_p2p_socket.ml index 1ed860fde943b0f0e4c2d1a937a49d4cba1cda8a..2cb5a55b7c85c914342a1c47a85bcb0852a112b6 100644 --- a/src/lib_p2p/test/test_p2p_socket.ml +++ b/src/lib_p2p/test/test_p2p_socket.ml @@ -96,9 +96,10 @@ let sync ch = >>=? fun () -> Process.Channel.pop ch >>=? fun () -> return_unit let rec sync_nodes nodes = - iter_p (fun p -> Process.receive p) nodes + List.iter_ep (fun p -> Process.receive p) nodes >>=? fun () -> - iter_p (fun p -> Process.send p ()) nodes >>=? fun () -> sync_nodes nodes + List.iter_ep (fun p -> Process.send p ()) nodes + >>=? fun () -> sync_nodes nodes let sync_nodes nodes = sync_nodes nodes diff --git a/src/lib_protocol_compiler/compiler.ml b/src/lib_protocol_compiler/compiler.ml index 58815b0b66ab5d20537f3346bd65e5548fb79ef2..7dc4af748e6249c1746c64730e083267ff886bc7 100644 --- a/src/lib_protocol_compiler/compiler.ml +++ b/src/lib_protocol_compiler/compiler.ml @@ -172,7 +172,7 @@ let main {compile_ml; pack_objects; link_shared} = in Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ; let source_dir = - match List.rev !anonymous with + match !anonymous with | [protocol_dir] -> protocol_dir | _ -> diff --git a/src/lib_protocol_compiler/main_packer.ml b/src/lib_protocol_compiler/main_packer.ml index 0968a6ab75983e8fd62215d61b8cbce1e0ac0cff..0a20309d6bc5d3bf3e9a63e81d0e2180fb5c7515 100644 --- a/src/lib_protocol_compiler/main_packer.ml +++ b/src/lib_protocol_compiler/main_packer.ml @@ -32,7 +32,7 @@ let () = let usage_msg = Printf.sprintf "Usage: %s [options] " Sys.argv.(0) in Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ; let source_dir = - match List.rev !anonymous with + match !anonymous with | [source_dir] when Filename.basename source_dir = "TEZOS_PROTOCOL" -> Filename.dirname source_dir | [source_dir] -> diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 17ef2feeb04b561077ac3df0b9717ef0b98c0bda..091e01889720231615a4771d9363c9299345d6c5 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -541,6 +541,7 @@ struct include Local_monad include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) (Local_monad) + include Error_monad_traversors let ( >>|? ) = ( >|=? ) (* for backward compatibility *) end diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index 0b1c62d296b42bf885e50459bf401e73ee96d98c..ce77098af1021e59e95a4142767b4464570dc82d 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -726,6 +726,7 @@ struct include Local_monad include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) (Local_monad) + include Error_monad_traversors type 'err trace = 'err TzTrace.trace end diff --git a/src/lib_protocol_environment/structs/dune b/src/lib_protocol_environment/structs/dune index ccc5136f3c0707fec433ce9be1e51a691b868e70..5581d096a3f03e47d9473c36d0f08e834cf5f080 100644 --- a/src/lib_protocol_environment/structs/dune +++ b/src/lib_protocol_environment/structs/dune @@ -6,5 +6,6 @@ (public_name tezos-protocol-environment-structs) (flags :standard) (libraries tezos-stdlib - tezos-crypto) + tezos-crypto + tezos-lwt-result-stdlib) (modules ("V0") ("V1"))) diff --git a/src/lib_protocol_environment/structs/v0.dune.inc b/src/lib_protocol_environment/structs/v0.dune.inc index a550593c5acca1d09bf8547d4a5a9acc9f7d6eeb..0d6c454751bc0fec010468c5d04be9630ad4b103 100644 --- a/src/lib_protocol_environment/structs/v0.dune.inc +++ b/src/lib_protocol_environment/structs/v0.dune.inc @@ -16,6 +16,7 @@ v0/operation_list_list_hash.ml v0/protocol_hash.ml v0/context_hash.ml + v0/error_monad_traversors.ml ) (action (with-stdout-to %{targets} (chdir %{workspace_root}} diff --git a/src/lib_protocol_environment/structs/v0/error_monad_traversors.ml b/src/lib_protocol_environment/structs/v0/error_monad_traversors.ml new file mode 100644 index 0000000000000000000000000000000000000000..ab2f7185eee8fecbcf573e417ce1d884f7ef619a --- /dev/null +++ b/src/lib_protocol_environment/structs/v0/error_monad_traversors.ml @@ -0,0 +1,319 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Lwt.Infix (* >>= >|= *) + +let ( >>? ) v f = match v with Error _ as err -> err | Ok v -> f v + +let ( >>=? ) v f = + v >>= function Error _ as err -> Lwt.return err | Ok v -> f v + +let ok_nil = Ok [] + +let return_nil = Lwt.return ok_nil + +let[@inline] return v = Lwt.return_ok v + +let ok_unit = Ok () + +let return_unit = Lwt.return ok_unit + +let rec map f l = + match l with + | [] -> + ok_nil + | h :: t -> + f h >>? fun rh -> map f t >>? fun rt -> Ok (rh :: rt) + +let mapi f l = + let rec mapi f i l = + match l with + | [] -> + ok_nil + | h :: t -> + f i h >>? fun rh -> mapi f (i + 1) t >>? fun rt -> Ok (rh :: rt) + in + mapi f 0 l + +let rec map_s f l = + match l with + | [] -> + return_nil + | h :: t -> + f h >>=? fun rh -> map_s f t >>=? fun rt -> return (rh :: rt) + +let mapi_s f l = + let rec mapi_s f i l = + match l with + | [] -> + return_nil + | h :: t -> + f i h >>=? fun rh -> mapi_s f (i + 1) t >>=? fun rt -> return (rh :: rt) + in + mapi_s f 0 l + +let rec rev_map_append_s acc f = function + | [] -> + return acc + | hd :: tl -> + f hd >>=? fun v -> rev_map_append_s (v :: acc) f tl + +let rev_map_s f l = rev_map_append_s [] f l + +let rec map_p f l = + match l with + | [] -> + return_nil + | x :: l -> ( + let tx = f x and tl = map_p f l in + tx + >>= fun x -> + tl + >>= fun l -> + match (x, l) with + | (Ok x, Ok l) -> + Lwt.return_ok (x :: l) + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok _, Error trace) | (Error trace, Ok _) -> + Lwt.return_error trace ) + +let mapi_p f l = + let rec mapi_p f i l = + match l with + | [] -> + return_nil + | x :: l -> ( + let tx = f i x and tl = mapi_p f (i + 1) l in + tx + >>= fun x -> + tl + >>= fun l -> + match (x, l) with + | (Ok x, Ok l) -> + Lwt.return_ok (x :: l) + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok _, Error trace) | (Error trace, Ok _) -> + Lwt.return_error trace ) + in + mapi_p f 0 l + +let rec map2_s f l1 l2 = + match (l1, l2) with + | ([], []) -> + return_nil + | (_ :: _, []) | ([], _ :: _) -> + invalid_arg "Error_monad.map2_s" + | (h1 :: t1, h2 :: t2) -> + f h1 h2 >>=? fun rh -> map2_s f t1 t2 >>=? fun rt -> return (rh :: rt) + +let mapi2_s f l1 l2 = + let rec mapi2_s i f l1 l2 = + match (l1, l2) with + | ([], []) -> + return_nil + | (_ :: _, []) | ([], _ :: _) -> + invalid_arg "Error_monad.mapi2_s" + | (h1 :: t1, h2 :: t2) -> + f i h1 h2 + >>=? fun rh -> mapi2_s (i + 1) f t1 t2 >>=? fun rt -> return (rh :: rt) + in + mapi2_s 0 f l1 l2 + +let rec map2 f l1 l2 = + match (l1, l2) with + | ([], []) -> + ok_nil + | (_ :: _, []) | ([], _ :: _) -> + invalid_arg "Error_monad.map2" + | (h1 :: t1, h2 :: t2) -> + f h1 h2 >>? fun rh -> map2 f t1 t2 >>? fun rt -> Ok (rh :: rt) + +let mapi2 f l1 l2 = + let rec mapi2 i f l1 l2 = + match (l1, l2) with + | ([], []) -> + ok_nil + | (_ :: _, []) | ([], _ :: _) -> + invalid_arg "Error_monad.mapi2" + | (h1 :: t1, h2 :: t2) -> + f i h1 h2 + >>? fun rh -> mapi2 (i + 1) f t1 t2 >>? fun rt -> Ok (rh :: rt) + in + mapi2 0 f l1 l2 + +let rec filter_map_s f l = + match l with + | [] -> + return_nil + | h :: t -> ( + f h + >>=? function + | None -> + filter_map_s f t + | Some rh -> + filter_map_s f t >>=? fun rt -> return (rh :: rt) ) + +let rec filter_map_p f l = + match l with + | [] -> + return_nil + | h :: t -> ( + let th = f h and tt = filter_map_p f t in + th + >>=? function + | None -> tt | Some rh -> tt >>=? fun rt -> return (rh :: rt) ) + +let rec filter f l = + match l with + | [] -> + ok_nil + | h :: t -> ( + f h + >>? function + | true -> filter f t >>? fun t -> Ok (h :: t) | false -> filter f t ) + +let rec filter_s f l = + match l with + | [] -> + return_nil + | h :: t -> ( + f h + >>=? function + | false -> + filter_s f t + | true -> + filter_s f t >>=? fun t -> return (h :: t) ) + +let rec filter_p f l = + match l with + | [] -> + return_nil + | h :: t -> ( + let jh = f h and t = filter_p f t in + jh >>=? function false -> t | true -> t >>=? fun t -> return (h :: t) ) + +let rec iter f l = + match l with [] -> ok_unit | h :: t -> f h >>? fun () -> iter f t + +let rec iter_s f l = + match l with [] -> return_unit | h :: t -> f h >>=? fun () -> iter_s f t + +let rec iter_p f l = + match l with + | [] -> + return_unit + | x :: l -> ( + let tx = f x and tl = iter_p f l in + tx + >>= fun tx_res -> + tl + >>= fun tl_res -> + match (tx_res, tl_res) with + | (Ok (), Ok ()) -> + Lwt.return_ok () + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) + +let iteri_p f l = + let rec iteri_p i f l = + match l with + | [] -> + return_unit + | x :: l -> ( + let tx = f i x and tl = iteri_p (i + 1) f l in + tx + >>= fun tx_res -> + tl + >>= fun tl_res -> + match (tx_res, tl_res) with + | (Ok (), Ok ()) -> + Lwt.return ok_unit + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) + in + iteri_p 0 f l + +let rec iter2_p f l1 l2 = + match (l1, l2) with + | ([], []) -> + return_unit + | ([], _) | (_, []) -> + invalid_arg "Error_monad.iter2_p" + | (x1 :: l1, x2 :: l2) -> ( + let tx = f x1 x2 and tl = iter2_p f l1 l2 in + tx + >>= fun tx_res -> + tl + >>= fun tl_res -> + match (tx_res, tl_res) with + | (Ok (), Ok ()) -> + Lwt.return_ok () + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) + +let iteri2_p f l1 l2 = + let rec iteri2_p i f l1 l2 = + match (l1, l2) with + | ([], []) -> + return_unit + | ([], _) | (_, []) -> + invalid_arg "Error_monad.iteri2_p" + | (x1 :: l1, x2 :: l2) -> ( + let tx = f i x1 x2 and tl = iteri2_p (i + 1) f l1 l2 in + tx + >>= fun tx_res -> + tl + >>= fun tl_res -> + match (tx_res, tl_res) with + | (Ok (), Ok ()) -> + Lwt.return_ok () + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) + in + iteri2_p 0 f l1 l2 + +let rec fold_left_s f init l = + match l with + | [] -> + return init + | h :: t -> + f init h >>=? fun acc -> fold_left_s f acc t + +let rec fold_right_s f l init = + match l with + | [] -> + return init + | h :: t -> + fold_right_s f t init >>=? fun acc -> f h acc diff --git a/src/lib_protocol_environment/structs/v1.dune.inc b/src/lib_protocol_environment/structs/v1.dune.inc index 0ba159a5dd2134cd6f1f9d1d9e78ec76ad2847a2..d6ce6f22f1227143ce8ce9806b5511874ed4e276 100644 --- a/src/lib_protocol_environment/structs/v1.dune.inc +++ b/src/lib_protocol_environment/structs/v1.dune.inc @@ -14,6 +14,7 @@ v1/operation_list_list_hash.ml v1/protocol_hash.ml v1/context_hash.ml + v1/error_monad_traversors.ml ) (action (with-stdout-to %{targets} (chdir %{workspace_root}} diff --git a/src/lib_protocol_environment/structs/v1/error_monad_traversors.ml b/src/lib_protocol_environment/structs/v1/error_monad_traversors.ml new file mode 100644 index 0000000000000000000000000000000000000000..ab2f7185eee8fecbcf573e417ce1d884f7ef619a --- /dev/null +++ b/src/lib_protocol_environment/structs/v1/error_monad_traversors.ml @@ -0,0 +1,319 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Lwt.Infix (* >>= >|= *) + +let ( >>? ) v f = match v with Error _ as err -> err | Ok v -> f v + +let ( >>=? ) v f = + v >>= function Error _ as err -> Lwt.return err | Ok v -> f v + +let ok_nil = Ok [] + +let return_nil = Lwt.return ok_nil + +let[@inline] return v = Lwt.return_ok v + +let ok_unit = Ok () + +let return_unit = Lwt.return ok_unit + +let rec map f l = + match l with + | [] -> + ok_nil + | h :: t -> + f h >>? fun rh -> map f t >>? fun rt -> Ok (rh :: rt) + +let mapi f l = + let rec mapi f i l = + match l with + | [] -> + ok_nil + | h :: t -> + f i h >>? fun rh -> mapi f (i + 1) t >>? fun rt -> Ok (rh :: rt) + in + mapi f 0 l + +let rec map_s f l = + match l with + | [] -> + return_nil + | h :: t -> + f h >>=? fun rh -> map_s f t >>=? fun rt -> return (rh :: rt) + +let mapi_s f l = + let rec mapi_s f i l = + match l with + | [] -> + return_nil + | h :: t -> + f i h >>=? fun rh -> mapi_s f (i + 1) t >>=? fun rt -> return (rh :: rt) + in + mapi_s f 0 l + +let rec rev_map_append_s acc f = function + | [] -> + return acc + | hd :: tl -> + f hd >>=? fun v -> rev_map_append_s (v :: acc) f tl + +let rev_map_s f l = rev_map_append_s [] f l + +let rec map_p f l = + match l with + | [] -> + return_nil + | x :: l -> ( + let tx = f x and tl = map_p f l in + tx + >>= fun x -> + tl + >>= fun l -> + match (x, l) with + | (Ok x, Ok l) -> + Lwt.return_ok (x :: l) + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok _, Error trace) | (Error trace, Ok _) -> + Lwt.return_error trace ) + +let mapi_p f l = + let rec mapi_p f i l = + match l with + | [] -> + return_nil + | x :: l -> ( + let tx = f i x and tl = mapi_p f (i + 1) l in + tx + >>= fun x -> + tl + >>= fun l -> + match (x, l) with + | (Ok x, Ok l) -> + Lwt.return_ok (x :: l) + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok _, Error trace) | (Error trace, Ok _) -> + Lwt.return_error trace ) + in + mapi_p f 0 l + +let rec map2_s f l1 l2 = + match (l1, l2) with + | ([], []) -> + return_nil + | (_ :: _, []) | ([], _ :: _) -> + invalid_arg "Error_monad.map2_s" + | (h1 :: t1, h2 :: t2) -> + f h1 h2 >>=? fun rh -> map2_s f t1 t2 >>=? fun rt -> return (rh :: rt) + +let mapi2_s f l1 l2 = + let rec mapi2_s i f l1 l2 = + match (l1, l2) with + | ([], []) -> + return_nil + | (_ :: _, []) | ([], _ :: _) -> + invalid_arg "Error_monad.mapi2_s" + | (h1 :: t1, h2 :: t2) -> + f i h1 h2 + >>=? fun rh -> mapi2_s (i + 1) f t1 t2 >>=? fun rt -> return (rh :: rt) + in + mapi2_s 0 f l1 l2 + +let rec map2 f l1 l2 = + match (l1, l2) with + | ([], []) -> + ok_nil + | (_ :: _, []) | ([], _ :: _) -> + invalid_arg "Error_monad.map2" + | (h1 :: t1, h2 :: t2) -> + f h1 h2 >>? fun rh -> map2 f t1 t2 >>? fun rt -> Ok (rh :: rt) + +let mapi2 f l1 l2 = + let rec mapi2 i f l1 l2 = + match (l1, l2) with + | ([], []) -> + ok_nil + | (_ :: _, []) | ([], _ :: _) -> + invalid_arg "Error_monad.mapi2" + | (h1 :: t1, h2 :: t2) -> + f i h1 h2 + >>? fun rh -> mapi2 (i + 1) f t1 t2 >>? fun rt -> Ok (rh :: rt) + in + mapi2 0 f l1 l2 + +let rec filter_map_s f l = + match l with + | [] -> + return_nil + | h :: t -> ( + f h + >>=? function + | None -> + filter_map_s f t + | Some rh -> + filter_map_s f t >>=? fun rt -> return (rh :: rt) ) + +let rec filter_map_p f l = + match l with + | [] -> + return_nil + | h :: t -> ( + let th = f h and tt = filter_map_p f t in + th + >>=? function + | None -> tt | Some rh -> tt >>=? fun rt -> return (rh :: rt) ) + +let rec filter f l = + match l with + | [] -> + ok_nil + | h :: t -> ( + f h + >>? function + | true -> filter f t >>? fun t -> Ok (h :: t) | false -> filter f t ) + +let rec filter_s f l = + match l with + | [] -> + return_nil + | h :: t -> ( + f h + >>=? function + | false -> + filter_s f t + | true -> + filter_s f t >>=? fun t -> return (h :: t) ) + +let rec filter_p f l = + match l with + | [] -> + return_nil + | h :: t -> ( + let jh = f h and t = filter_p f t in + jh >>=? function false -> t | true -> t >>=? fun t -> return (h :: t) ) + +let rec iter f l = + match l with [] -> ok_unit | h :: t -> f h >>? fun () -> iter f t + +let rec iter_s f l = + match l with [] -> return_unit | h :: t -> f h >>=? fun () -> iter_s f t + +let rec iter_p f l = + match l with + | [] -> + return_unit + | x :: l -> ( + let tx = f x and tl = iter_p f l in + tx + >>= fun tx_res -> + tl + >>= fun tl_res -> + match (tx_res, tl_res) with + | (Ok (), Ok ()) -> + Lwt.return_ok () + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) + +let iteri_p f l = + let rec iteri_p i f l = + match l with + | [] -> + return_unit + | x :: l -> ( + let tx = f i x and tl = iteri_p (i + 1) f l in + tx + >>= fun tx_res -> + tl + >>= fun tl_res -> + match (tx_res, tl_res) with + | (Ok (), Ok ()) -> + Lwt.return ok_unit + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) + in + iteri_p 0 f l + +let rec iter2_p f l1 l2 = + match (l1, l2) with + | ([], []) -> + return_unit + | ([], _) | (_, []) -> + invalid_arg "Error_monad.iter2_p" + | (x1 :: l1, x2 :: l2) -> ( + let tx = f x1 x2 and tl = iter2_p f l1 l2 in + tx + >>= fun tx_res -> + tl + >>= fun tl_res -> + match (tx_res, tl_res) with + | (Ok (), Ok ()) -> + Lwt.return_ok () + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) + +let iteri2_p f l1 l2 = + let rec iteri2_p i f l1 l2 = + match (l1, l2) with + | ([], []) -> + return_unit + | ([], _) | (_, []) -> + invalid_arg "Error_monad.iteri2_p" + | (x1 :: l1, x2 :: l2) -> ( + let tx = f i x1 x2 and tl = iteri2_p (i + 1) f l1 l2 in + tx + >>= fun tx_res -> + tl + >>= fun tl_res -> + match (tx_res, tl_res) with + | (Ok (), Ok ()) -> + Lwt.return_ok () + | (Error trace1, Error trace2) -> + Lwt.return_error (trace1 @ trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) + in + iteri2_p 0 f l1 l2 + +let rec fold_left_s f init l = + match l with + | [] -> + return init + | h :: t -> + f init h >>=? fun acc -> fold_left_s f acc t + +let rec fold_right_s f l init = + match l with + | [] -> + return init + | h :: t -> + fold_right_s f t init >>=? fun acc -> f h acc diff --git a/src/lib_requester/requester.ml b/src/lib_requester/requester.ml index 79f2e315576f52b3fc7fffcc78a089246761959e..e4b6b7a2a7436dee1fed195f4cca0d837ee7bc4d 100644 --- a/src/lib_requester/requester.ml +++ b/src/lib_requester/requester.ml @@ -326,8 +326,7 @@ end = struct state.events >>= fun events -> state.events <- Lwt_pipe.pop_all state.queue ; - Lwt_list.iter_s (process_event state now) events - >>= fun () -> loop state ) + List.iter_s (process_event state now) events >>= fun () -> loop state ) else Events.(emit timeout) () >>= fun () -> @@ -376,7 +375,7 @@ end = struct P2p_peer.Map.iter (Request.send state.param) requests ; P2p_peer.Map.iter_s (fun peer request -> - Lwt_list.iter_s + List.iter_s (fun (key : key) -> Events.(emit requested) (key, peer)) request) requests diff --git a/src/lib_requester/test/test_requester.ml b/src/lib_requester/test/test_requester.ml index 7eca6438e97ed269d28f62033a8bd3fea3d3b577..f44fe3af00de2e1d6f841aa3d636cc83e6a29568 100644 --- a/src/lib_requester/test/test_requester.ml +++ b/src/lib_requester/test/test_requester.ml @@ -335,7 +335,7 @@ let test_full_fetch_issues_request _ () = (tuple3 unit p2p_peer_id (list testable_test_key)) "should have sent a request" ((), P2p_peer.Id.zero, ["baz"]) - (List.hd !Test_request.registered_requests) ; + (Option.get @@ List.hd !Test_request.registered_requests) ; Lwt.cancel f1 ; Lwt.return_unit diff --git a/src/lib_sapling/sapling.opam b/src/lib_sapling/sapling.opam index 36e4f9a224a5cb3363172b057a02ee552d988dfd..b02021cbebedead0bd6a6b3b764d0875b0ce10ec 100644 --- a/src/lib_sapling/sapling.opam +++ b/src/lib_sapling/sapling.opam @@ -17,6 +17,7 @@ depends: [ "tezos-crypto" "tezos-stdlib" "tezos-error-monad" + "tezos-lwt-result-stdlib" { with-test } "alcotest-lwt" { with-test & >= "1.1.0" } ] build: [[ "dune" "build" "-j" jobs "-p" name "@install" ]] diff --git a/src/lib_sapling/test/example.ml b/src/lib_sapling/test/example.ml index e06d1fc9696307d2b1f90539b3d0816a5269a282..fe0a99b132d0250c554316a4b041b050e8da28f9 100644 --- a/src/lib_sapling/test/example.ml +++ b/src/lib_sapling/test/example.ml @@ -21,6 +21,7 @@ * SOFTWARE. *) open Tezos_error_monad.Error_monad +open Tezos_lwt_result_stdlib.Lwtreslib module Client = struct module Core = Core.Client @@ -103,7 +104,7 @@ module Client = struct assert (Int64.add wallet.balance tez >= 0L) ; let rec gather_input to_pay balance inputs unspent_inputs = if to_pay > 0L then - let input_to_add = InputSet.choose unspent_inputs in + let input_to_add = Option.get @@ InputSet.choose unspent_inputs in let amount = Forge.Input.amount input_to_add in gather_input (Int64.sub to_pay amount) @@ -152,7 +153,7 @@ module Client = struct assert (Int64.(add wallet.balance tez) >= amount) ; let rec gather_input to_pay balance inputs unspent_input = if to_pay > 0L then - let input_to_add = InputSet.choose unspent_input in + let input_to_add = Option.get @@ InputSet.choose unspent_input in let amount = Forge.Input.amount input_to_add in gather_input (Int64.sub to_pay amount) @@ -394,7 +395,7 @@ module Validator = struct else Core.Verification.with_verification_ctx (fun ctx -> (* Check all the output ZK proofs *) - iter_s + List.iter_es (fun output -> fail_unless (Core.Verification.check_output ctx output) @@ -402,7 +403,7 @@ module Validator = struct transaction.outputs >>=? fun () -> (* Check all the input Zk proofs and signatures *) - iter_s + List.iter_es (fun input -> if Core.Verification.check_spend ctx input transaction.root key then return_unit @@ -416,7 +417,7 @@ module Validator = struct >>=? fun () -> (* Check that each nullifier is not already present in the state and add it. Important to avoid spending the same input twice in a transaction. *) - fold_left_s + List.fold_left_es (fun state input -> if Storage.mem_nullifier state Core.UTXO.(input.nf) then fail (Input_spent input) diff --git a/src/lib_shell/bench/bench_tool.ml b/src/lib_shell/bench/bench_tool.ml index 1777d50e89a5127c5ba589733e77422f79c81aad..dc09b6059293fefdf118c4c8ce67ac9bcb4cf40d 100644 --- a/src/lib_shell/bench/bench_tool.ml +++ b/src/lib_shell/bench/bench_tool.ml @@ -160,7 +160,7 @@ let get_n_endorsements ctxt n = Context.get_endorsers ctxt >>=? fun endorsing_rights -> let endorsing_rights = List.sub endorsing_rights n in - map_s + List.map_es (fun {Delegate_services.Endorsing_rights.delegate; level; _} -> Op.endorsement ~delegate ~level ctxt ()) endorsing_rights @@ -182,7 +182,7 @@ let generate_and_add_random_endorsements inc = in let endorsements = List.sort_uniq compare endorsements in let endorsements = List.map Operation.pack endorsements in - fold_left_s Incremental.add_operation inc endorsements + List.fold_left_es Incremental.add_operation inc endorsements let regenerate_transfers = ref false @@ -202,16 +202,18 @@ let generate_random_activation ({remaining_activations; _} as gen_state) inc = exception No_transfer_left let rec generate_random_transfer ({remaining_transfers; _} as gen_state) ctxt = - if remaining_transfers = [] then raise No_transfer_left ; - let (a1, a2) = List.hd remaining_transfers in - gen_state.remaining_transfers <- List.tl remaining_transfers ; - let open Account in - let c1 = Alpha_context.Contract.implicit_contract a1.pkh in - let c2 = Alpha_context.Contract.implicit_contract a2.pkh in - Context.Contract.balance ctxt c1 - >>=? fun b1 -> - if Tez.(b1 < Tez.one) then generate_random_transfer gen_state ctxt - else Op.transaction ctxt c1 c2 Tez.one + match remaining_transfers with + | [] -> + raise No_transfer_left + | (a1, a2) :: remaining_transfers -> + gen_state.remaining_transfers <- remaining_transfers ; + let open Account in + let c1 = Alpha_context.Contract.implicit_contract a1.pkh in + let c2 = Alpha_context.Contract.implicit_contract a2.pkh in + Context.Contract.balance ctxt c1 + >>=? fun b1 -> + if Tez.(b1 < Tez.one) then generate_random_transfer gen_state ctxt + else Op.transaction ctxt c1 c2 Tez.one let generate_random_operation (inc : Incremental.t) gen_state = let rnd = Random.int 100 in @@ -262,7 +264,7 @@ let step gen_state blk : Block.t tzresult Lwt.t = "[DEBUG] Generating %d random operations...\n%!" nb_operations) ; (* Generate random operations *) - fold_left_s + List.fold_left_es (fun inc _ -> try generate_random_operation inc gen_state @@ -294,7 +296,7 @@ let step gen_state blk : Block.t tzresult Lwt.t = %!" @@ List.length l) ; gen_state.nonce_to_reveal <- [] ; - (* fold_left_s (fun inc (_, level, nonce) -> *) + (* List.fold_left_es (fun inc (_, level, nonce) -> *) (* Op.seed_nonce_revelation inc level nonce >>=? fun op -> * Incremental.add_operation inc op *) (* return *) @@ -329,7 +331,7 @@ let init () = let new_seed () : Bytes.t = Bytes.(make 32 '\000' |> map (fun _ -> Random.int 0x100 |> char_of_int)) in - map_s + List.map_es (fun _ -> return (Account.new_account ~seed:(new_seed ()) (), initial_amount)) (1 -- args.accounts) @@ -350,7 +352,9 @@ let init () = | x when x < 0 -> return ([], parameters) | x -> - map_s (fun _ -> Account.new_commitment ~seed:(new_seed ()) ()) (1 -- x) + List.map_es + (fun _ -> Account.new_commitment ~seed:(new_seed ()) ()) + (1 -- x) >>=? fun commitments -> return (commitments, {parameters with commitments = List.map snd commitments}) @@ -389,7 +393,7 @@ let init () = Block.genesis_with_parameters parameters >>=? fun genesis -> if_debug_s (fun () -> - iter_s + List.iter_es (let open Account in fun (({pkh; _} as acc), _) -> let contract = Alpha_context.Contract.implicit_contract acc.pkh in diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml index 0a877e536f8d4c0fc102d418b53a2ff7598ac091..3741ce957ffd4d8cc331d37c5c25210c50f27a74 100644 --- a/src/lib_shell/block_directory.ml +++ b/src/lib_shell/block_directory.ml @@ -36,10 +36,13 @@ let rec read_partial_context context path depth = (* try to read as directory *) Context.fold context path ~init:[] ~f:(fun k acc -> match k with - | `Key k | `Dir k -> + | `Key [] | `Dir [] -> + (* This is an invariant of {!Context.fold} *) + assert false + | `Key (khd :: ktl as k) | `Dir (khd :: ktl as k) -> read_partial_context context k (depth - 1) >>= fun v -> - let k = List.nth k (List.length k - 1) in + let k = List.last khd ktl in Lwt.return ((k, v) :: acc)) >>= fun l -> Lwt.return (Block_services.Dir (List.rev l)) @@ -207,12 +210,15 @@ let build_raw_rpc_directory ~user_activated_upgrades Lwt.catch (fun () -> State.Block.all_operations_metadata block - >>= fun ops_metadata -> - return + >|= fun ops_metadata -> + List.map2_e + ~when_different_lengths:() (List.map2 - (List.map2 (convert_with_metadata chain_id)) - ops - ops_metadata)) + ~when_different_lengths:() + (convert_with_metadata chain_id)) + ops + ops_metadata + |> function Ok v -> Ok v | Error () -> raise Not_found) (fun _ -> return (List.map (List.map (convert_without_metadata chain_id)) ops)) in @@ -225,9 +231,13 @@ let build_raw_rpc_directory ~user_activated_upgrades Lwt.catch (fun () -> State.Block.operations_metadata block i - >>= fun ops_metadata -> - return - (List.map2 (convert_with_metadata chain_id) ops ops_metadata)) + >|= fun ops_metadata -> + List.map2 + ~when_different_lengths:() + (convert_with_metadata chain_id) + ops + ops_metadata + |> function Ok v -> Ok v | Error () -> raise Not_found) (fun _ -> return ((List.map (convert_without_metadata chain_id)) ops))) (fun _ -> raise Not_found)) ; @@ -237,12 +247,12 @@ let build_raw_rpc_directory ~user_activated_upgrades (fun () -> State.Block.operations block i >>= fun (ops, _path) -> - let op = List.nth ops j in + let op = Option.get @@ List.nth ops j in Lwt.catch (fun () -> State.Block.operations_metadata block i >>= fun metadata -> - let op_metadata = List.nth metadata j in + let op_metadata = Option.get @@ List.nth metadata j in return (convert_with_metadata chain_id op op_metadata)) (fun _ -> return (convert_without_metadata chain_id op))) (fun _ -> raise Not_found)) ; @@ -257,7 +267,7 @@ let build_raw_rpc_directory ~user_activated_upgrades State.Block.operation_hashes block i >|= fun (ops, _) -> List.nth ops j) (fun _ -> raise Not_found) - >>= fun op -> return op) ; + >>= fail_opt) ; (* operation_metadata_hashes *) register0 S.Operation_metadata_hashes.root (fun block () () -> State.Block.all_operations_metadata_hash block >>= fail_opt) ; @@ -274,7 +284,7 @@ let build_raw_rpc_directory ~user_activated_upgrades (fun block i j () () -> State.Block.operations_metadata_hashes block i >>= fun hashes -> - Lwt.return (Option.map (fun hashes -> List.nth hashes j) hashes) + Lwt.return @@ Option.bind hashes (fun hashes -> List.nth hashes j) >>= fail_opt) ; (* context *) register1 S.Context.read (fun block path q () -> @@ -372,7 +382,7 @@ let build_raw_rpc_directory ~user_activated_upgrades ~timestamp:(Time.System.to_protocol (Systime_os.now ())) () >>=? fun state -> - fold_left_s + List.fold_left_es (fun (state, acc) op -> Next_proto.apply_operation state op >>=? fun (state, result) -> diff --git a/src/lib_shell/bootstrap_pipeline.ml b/src/lib_shell/bootstrap_pipeline.ml index 554c953b7384ef044c584081c17acce6d84c3d3d..c80df48acc7d408615a9669a5ab898a92d67c5fe 100644 --- a/src/lib_shell/bootstrap_pipeline.ml +++ b/src/lib_shell/bootstrap_pipeline.ml @@ -381,13 +381,13 @@ let rec operations_fetch_worker_loop pipeline = protect ~canceler:pipeline.canceler (fun () -> Lwt_pipe.pop pipeline.fetched_headers >>= return) >>=? fun batch -> - map_p + List.map_ep (fun (hash, header) -> Bootstrap_pipeline_event.(emit fetching_operations) (hash, pipeline.peer_id) >>= fun () -> let operations = - map_p + List.map_ep (fun i -> protect ~canceler:pipeline.canceler (fun () -> Distributed_db.Operations.fetch @@ -406,7 +406,7 @@ let rec operations_fetch_worker_loop pipeline = return (hash, header, operations)) batch >>=? fun operationss -> - iter_s + List.iter_es (fun (hash, header, operations) -> protect ~canceler:pipeline.canceler (fun () -> Lwt_pipe.push pipeline.fetched_blocks (hash, header, operations) diff --git a/src/lib_shell/chain.ml b/src/lib_shell/chain.ml index 418ee41e5ad6ec8f2a0d714ea3b5dcbc79355910..3d2186903f89d714bc052c0946ffa3227a75a8b0 100644 --- a/src/lib_shell/chain.ml +++ b/src/lib_shell/chain.ml @@ -34,7 +34,7 @@ let known_heads chain_state = State.read_chain_data chain_state (fun chain_store _data -> Store.Chain_data.Known_heads.elements chain_store) >>= fun hashes -> - Lwt_list.map_p + List.map_p (fun h -> State.Block.read_opt chain_state h >|= Option.unopt_assert ~loc:__POS__) hashes @@ -103,7 +103,7 @@ let locked_set_head chain_store data block live_blocks live_operations = let ancestor = State.Block.hash ancestor in pop_blocks ancestor data.current_head >>= fun () -> - Lwt_list.fold_left_s push_block ancestor path + List.fold_left_s push_block ancestor path >>= fun _ -> Store.Chain_data.Current_head.store chain_store (State.Block.hash block) >>= fun () -> diff --git a/src/lib_shell/chain_directory.ml b/src/lib_shell/chain_directory.ml index b233c75c379e2f96e1d785b7d551c1365785965c..ddca0ea1a196d7de523334d7315794615e6bebbe 100644 --- a/src/lib_shell/chain_directory.ml +++ b/src/lib_shell/chain_directory.ml @@ -94,9 +94,9 @@ let list_blocks chain_state ?(length = 1) ?min_date heads = in Lwt.return (List.map (fun b -> Some b) sorted_heads) | _ :: _ as heads -> - Lwt_list.map_p (State.Block.read_opt chain_state) heads ) + List.map_p (State.Block.read_opt chain_state) heads ) >>= fun requested_heads -> - Lwt_list.fold_left_s + List.fold_left_s (fun (ignored, acc) head -> match head with | None -> diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 7f9d6e833871012422306db20592b3a7b9345a08..26a908d54662907a61a152b4f09e2dec48564c73 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -178,7 +178,7 @@ let notify_new_block w block = let nv = Worker.state w in Option.iter (fun id -> - List.assoc_opt id (Worker.list table) + List.assoc id (Worker.list table) |> Option.iter (fun w -> let nv = Worker.state w in Lwt_watcher.notify nv.valid_block_input block)) @@ -724,7 +724,7 @@ let child w = Option.bind (Worker.state w).child (fun ({parameters = {chain_state; _}; _}, _) -> - List.assoc_opt (State.Chain.id chain_state) (Worker.list table)) + List.assoc (State.Chain.id chain_state) (Worker.list table)) let assert_fitness_increases ?(force = false) w distant_header = let pv = Worker.state w in diff --git a/src/lib_shell/monitor_directory.ml b/src/lib_shell/monitor_directory.ml index 7361e737ae4fc8aa50173e07d107fdcc3c83a4c5..3ce82b98727e6fa4bafd90e25ac0f3e93e42c607 100644 --- a/src/lib_shell/monitor_directory.ml +++ b/src/lib_shell/monitor_directory.ml @@ -68,7 +68,7 @@ let build_rpc_directory validator mainchain_validator = Lwt.return_true | chains -> let that_chain_id = State.Block.chain_id block in - Lwt_list.exists_p + List.exists_p (fun chain -> Chain_directory.get_chain_id_opt state chain >|= function @@ -216,7 +216,7 @@ let build_rpc_directory validator mainchain_validator = in if !first_call then ( first_call := false ; - Lwt_list.map_p + List.map_p (fun c -> convert (c, true)) (Validator.get_active_chains validator) >>= fun l -> Lwt.return_some l ) diff --git a/src/lib_shell/p2p_reader.ml b/src/lib_shell/p2p_reader.ml index ba342a36a4b5d774316eb4005f80c99213ef8c6c..bdea9321e99d324cb2d7f5f7b2d5bd23b070476f 100644 --- a/src/lib_shell/p2p_reader.ml +++ b/src/lib_shell/p2p_reader.ml @@ -198,7 +198,7 @@ let handle_msg state msg = may_handle state chain_id @@ fun chain_db -> let (head, hist) = (locator :> Block_header.t * Block_hash.t list) in - Lwt_list.exists_p + List.exists_p (State.Block.known_invalid chain_db.chain_state) (Block_header.hash head :: hist) >>= fun known_invalid -> @@ -275,7 +275,7 @@ let handle_msg state msg = Lwt.return_unit ) | Get_block_headers hashes -> Peer_metadata.incr meta @@ Received_request Block_header ; - Lwt_list.iter_p + List.iter_p (fun hash -> read_block_header state hash >>= function @@ -305,7 +305,7 @@ let handle_msg state msg = Lwt.return_unit ) | Get_operations hashes -> Peer_metadata.incr meta @@ Received_request Operations ; - Lwt_list.iter_p + List.iter_p (fun hash -> read_operation state hash >>= function @@ -335,7 +335,7 @@ let handle_msg state msg = Lwt.return_unit ) | Get_protocols hashes -> Peer_metadata.incr meta @@ Received_request Protocols ; - Lwt_list.iter_p + List.iter_p (fun hash -> State.Protocol.read_opt state.disk hash >>= function @@ -360,7 +360,7 @@ let handle_msg state msg = Lwt.return_unit | Get_operations_for_blocks blocks -> Peer_metadata.incr meta @@ Received_request Operations_for_block ; - Lwt_list.iter_p + List.iter_p (fun (hash, ofs) -> State.read_block state.disk hash >>= function diff --git a/src/lib_shell/peer_validator.ml b/src/lib_shell/peer_validator.ml index 3a179b81f5ffa6555dacde0f7e4596a6dc44f5cb..475d7e2b315bbbe100cc2e21d92dc58bb7a594dd 100644 --- a/src/lib_shell/peer_validator.ml +++ b/src/lib_shell/peer_validator.ml @@ -161,7 +161,7 @@ let validate_new_head w hash (header : Block_header.t) = let block_received = {Event.peer = pv.peer_id; hash} in Worker.log_event w (Fetching_operations_for_head block_received) >>= fun () -> - map_p + List.map_ep (fun i -> Worker.protect w (fun () -> Distributed_db.Operations.fetch diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index 43d28955511f09da21c8b17a8cf111b87da03d8e..2ad2aae7c00c0d1ec4e0a514692674e3670eb8a4 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -290,12 +290,12 @@ let preapply ~user_activated_upgrades ~user_activated_protocol_overrides in Prevalidation.create ~protocol_data ~predecessor ~timestamp () >>=? fun validation_state -> - Lwt_list.fold_left_s + List.fold_left_s (fun ( acc_validation_passes, acc_validation_result_rev, acc_validation_state ) operations -> - Lwt_list.fold_left_s + List.fold_left_s (fun (acc_validation_result, acc_validation_state) op -> match Prevalidation.parse op with | Error _ -> diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index bc68cff4160c66627e0240c838877d19831f57fd..b741914ac97ac38c777b29abf10068f246bf9d12 100644 --- a/src/lib_shell/prevalidator.ml +++ b/src/lib_shell/prevalidator.ml @@ -215,7 +215,7 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct timestamp = state.timestamp; fetching = state.fetching; pending = domain state.pending; - applied = List.rev (List.map (fun (h, _) -> h) state.applied); + applied = List.rev_map (fun (h, _) -> h) state.applied; delayed = Operation_hash.Set.union (domain state.branch_delays) @@ -263,8 +263,8 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct else State.Block.all_operations block >>= fun operations -> - Lwt_list.fold_left_s - (Lwt_list.fold_left_s (fun mempool op -> + List.fold_left_s + (List.fold_left_s (fun mempool op -> let h = Operation.hash op in Distributed_db.inject_operation chain_db h op >>= fun (_ : bool) -> @@ -294,7 +294,7 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct >>= fun (ancestor, path) -> pop_blocks (State.Block.hash ancestor) from_block old_mempool >>= fun mempool -> - Lwt_list.fold_left_s push_block mempool path + List.fold_left_s push_block mempool path >>= fun new_mempool -> let (new_mempool, outdated) = Operation_hash.Map.partition @@ -644,14 +644,14 @@ module Make (Filter : Prevalidator_filters.FILTER) (Arg : ARG) : T = struct Operation_hash.Map.add oph (res, error) acc in let applied = - List.filter_map + List.rev_filter_map (fun (hash, op) -> match map_op op with | Some op -> Some (hash, op) | None -> None) - (List.rev pv.applied) + pv.applied in let filter f map = Operation_hash.Map.fold f map Operation_hash.Map.empty diff --git a/src/lib_shell/snapshots.ml b/src/lib_shell/snapshots.ml index a72742ed339d1963b2125b0fc2bf449417015136..4a8b1c5b537fcd423bebaf0f07b0d0a0119e4ae6 100644 --- a/src/lib_shell/snapshots.ml +++ b/src/lib_shell/snapshots.ml @@ -275,6 +275,8 @@ type error += | Inconsistent_operation_hashes of (Operation_list_list_hash.t * Operation_list_list_hash.t) +type error += Inconsistent_operation_hashes_lengths + type error += Cannot_reconstruct of History_mode.t type error += Invalid_block_specification of string @@ -382,6 +384,16 @@ let () = | _ -> None) (fun (oph, oph') -> Inconsistent_operation_hashes (oph, oph')) ; + register_error_kind + `Permanent + ~id:"InconsistentOperationHashesLengths" + ~title:"Inconsistent operation hashes lengths" + ~description:"Different number of operations and hashes given." + ~pp:(fun ppf () -> + Format.pp_print_string ppf "Inconsistent operation hashes lengths") + unit + (function Inconsistent_operation_hashes_lengths -> Some () | _ -> None) + (fun () -> Inconsistent_operation_hashes_lengths) ; register_error_kind `Permanent ~id:"CannotReconstruct" @@ -540,7 +552,7 @@ let export ?(export_rolling = false) ~context_root ~store_root ~genesis >>=? fun pred_block_header -> (* Get operation list *) let validations_passes = block_header.shell.validation_passes in - map_s + List.map_es (fun i -> Store.Block.Operations.read (block_store, block_hash) i) (0 -- (validations_passes - 1)) @@ -557,7 +569,7 @@ let export ?(export_rolling = false) ~context_root ~store_root ~genesis | false -> return_none | true -> - map_s + List.map_es (fun i -> Store.Block.Operations_metadata_hashes.read (block_store, pred_block_hash) @@ -592,20 +604,22 @@ let export ?(export_rolling = false) ~context_root ~store_root ~genesis let check_operations_consistency block_header operations operation_hashes = (* Compute operations hashes and compare *) - List.iter2 + List.iter2_e + ~when_different_lengths:Inconsistent_operation_hashes_lengths (fun (_, op) (_, oph) -> let expected_op_hash = List.map Operation.hash op in List.iter2 + ~when_different_lengths:Inconsistent_operation_hashes_lengths (fun expected found -> assert (Operation_hash.equal expected found)) expected_op_hash oph) operations - operation_hashes ; + operation_hashes + |> (function Ok _ as ok -> ok | Error err -> error err) (* To make a trace *) + >>? fun () -> (* Check header hashes based on Merkle tree *) let hashes = - List.map - (fun (_, opl) -> List.map Operation.hash opl) - (List.rev operations) + List.rev_map (fun (_, opl) -> List.map Operation.hash opl) operations in let computed_hash = Operation_list_list_hash.compute @@ -616,11 +630,15 @@ let check_operations_consistency block_header operations operation_hashes = computed_hash block_header.Block_header.shell.operations_hash in - fail_unless + error_unless are_oph_equal (Inconsistent_operation_hashes (computed_hash, block_header.Block_header.shell.operations_hash)) +let check_operations_consistency block_header operations operation_hashes = + Lwt.return + @@ check_operations_consistency block_header operations operation_hashes + let compute_predecessors ~genesis_hash oldest_level block_hashes i = let rec step s d acc = if oldest_level = 1l && i - d = -1 then List.rev ((s, genesis_hash) :: acc) @@ -824,7 +842,7 @@ let reconstruct_storage store context_index chain_id ~user_activated_upgrades State.Block.Header.read (block_store, block_hash) >>=? fun block_header -> let validations_passes = block_header.shell.validation_passes in - map_s + List.map_es (fun i -> Store.Block.Operations.read (block_store, block_hash) i) (0 -- (validations_passes - 1)) @@ -845,7 +863,7 @@ let reconstruct_storage store context_index chain_id ~user_activated_upgrades | false -> return_none | true -> - map_s + List.map_es (fun i -> Store.Block.Operations_metadata_hashes.read (block_store, predecessor_block_hash) @@ -906,7 +924,7 @@ let reconstruct_storage store context_index chain_id ~user_activated_upgrades >>= fun () -> Store.Block.Contents.store st contents >>= fun () -> - Lwt_list.iteri_p + List.iteri_p (fun i ops -> Store.Block.Operation_hashes.store st @@ -914,11 +932,11 @@ let reconstruct_storage store context_index chain_id ~user_activated_upgrades (List.map Operation.hash ops)) operations >>= fun () -> - Lwt_list.iteri_p + List.iteri_p (fun i ops -> Store.Block.Operations.store st i ops) operations >>= fun () -> - Lwt_list.iteri_p + List.iteri_p (fun i ops -> Store.Block.Operations_metadata.store st i ops) ops_metadata >>= fun () -> @@ -1039,13 +1057,13 @@ let import ?(reconstruct = false) ?patch_context ~data_dir (fun () -> let k_store_pruned_blocks data = Store.with_atomic_rw store (fun () -> - Lwt_list.iter_s + List.iter_s (fun (pruned_header_hash, pruned_block) -> Store.Block.Pruned_contents.store (block_store, pruned_header_hash) {header = pruned_block.Context.Pruned_block.block_header} >>= fun () -> - Lwt_list.iter_s + List.iter_s (fun (i, v) -> Store.Block.Operations.store (block_store, pruned_header_hash) @@ -1053,7 +1071,7 @@ let import ?(reconstruct = false) ?patch_context ~data_dir v) pruned_block.operations >>= fun () -> - Lwt_list.iter_s + List.iter_s (fun (i, v) -> Store.Block.Operation_hashes.store (block_store, pruned_header_hash) @@ -1081,9 +1099,9 @@ let import ?(reconstruct = false) ?patch_context ~data_dir let block_hashes_arr = Array.of_list rev_block_hashes in let write_predecessors_table to_write = Store.with_atomic_rw store (fun () -> - Lwt_list.iter_s + List.iter_s (fun (current_hash, predecessors_list) -> - Lwt_list.iter_s + List.iter_s (fun (l, h) -> Store.Block.Predecessors.store (block_store, current_hash) @@ -1102,7 +1120,7 @@ let import ?(reconstruct = false) ?patch_context ~data_dir assert false) to_write) in - Lwt_list.fold_left_s + List.fold_left_s (fun (cpt, to_write) current_hash -> Tezos_stdlib_unix.Utils.display_progress ~refresh_rate:(cpt, 1_000) diff --git a/src/lib_shell/state.ml b/src/lib_shell/state.ml index fe22cc06ccecd03688060afd33b5612eb100dd8c..2f67d43961bb0acca2d60207fdc6b5293060e57d 100644 --- a/src/lib_shell/state.ml +++ b/src/lib_shell/state.ml @@ -396,11 +396,11 @@ let tag_invalid_heads block_store chain_store heads level = | Some header -> tag_invalid_head (Block_header.hash header, header) in - Lwt_list.iter_p + List.iter_p (fun (hash, _header) -> Store.Chain_data.Known_heads.remove chain_store hash) heads - >>= fun () -> Lwt_list.filter_map_s tag_invalid_head heads + >>= fun () -> List.filter_map_s tag_invalid_head heads let prune_block store block_hash = let st = (store, block_hash) in @@ -455,7 +455,7 @@ let cut_alternate_heads block_store chain_store heads = delete_block block_store hash >>= fun () -> cut_alternate_head (Block_header.hash header) header in - Lwt_list.iter_p + List.iter_p (fun (hash, header) -> Store.Chain_data.Known_heads.remove chain_store hash >>= fun () -> cut_alternate_head hash header) @@ -681,7 +681,7 @@ module Chain = struct let locked_read_all global_state data = Store.Chain.list data.global_store >>= fun ids -> - iter_p + List.iter_ep (fun id -> locked_read global_state data id >>=? fun chain -> @@ -734,7 +734,7 @@ module Chain = struct block_hash caboose_level = let do_prune blocks = Store.with_atomic_rw global_store - @@ fun () -> Lwt_list.iter_s (store_header_and_prune_block store) blocks + @@ fun () -> List.iter_s (store_header_and_prune_block store) blocks in let rec loop block_hash (n_blocks, blocks) = ( if n_blocks >= chunk_size then @@ -776,7 +776,7 @@ module Chain = struct let purge_loop_rolling global_store store ~genesis_hash block_hash limit = let do_delete blocks = Store.with_atomic_rw global_store - @@ fun () -> Lwt_list.iter_s (delete_block store) blocks + @@ fun () -> List.iter_s (delete_block store) blocks in let rec prune_loop block_hash limit = if Block_hash.equal genesis_hash block_hash then Lwt.return block_hash @@ -1094,13 +1094,18 @@ module Block = struct (block_header.shell.validation_passes = List.length operations_metadata) (failure "State.Block.store: invalid operations_data length") >>=? fun () -> - fail_unless - (List.for_all2 - (fun l1 l2 -> List.length l1 = List.length l2) - operations - operations_metadata) - (failure "State.Block.store: inconsistent operations and operations_data") - >>=? fun () -> + let inconsistent_failure = + failure "State.Block.store: inconsistent operations and operations_data" + in + List.for_all2 + ~when_different_lengths:inconsistent_failure + (fun l1 l2 -> List.length l1 = List.length l2) + operations + operations_metadata + |> (function Ok _ as ok -> ok | Error err -> error err) + >>?= fun all_have_equal_lengths -> + error_unless all_have_equal_lengths inconsistent_failure + >>?= fun () -> (* let's the validator check the consistency... of fitness, level, ... *) Shared.use chain_state.block_store (fun store -> Store.Block.Invalid_block.known store hash @@ -1158,7 +1163,7 @@ module Block = struct in Store.Block.Contents.store (store, hash) contents >>= fun () -> - Lwt_list.iteri_p + List.iteri_p (fun i ops -> Store.Block.Operation_hashes.store (store, hash) @@ -1166,11 +1171,11 @@ module Block = struct (List.map Operation.hash ops)) operations >>= fun () -> - Lwt_list.iteri_p + List.iteri_p (fun i ops -> Store.Block.Operations.store (store, hash) i ops) operations >>= fun () -> - Lwt_list.iteri_p + List.iteri_p (fun i ops -> Store.Block.Operations_metadata.store (store, hash) i ops) operations_metadata @@ -1288,18 +1293,18 @@ module Block = struct if i < 0 || header.shell.validation_passes <= i then invalid_arg "State.Block.operations" ; Shared.use chain_state.block_store (fun store -> - Lwt_list.map_p + List.map_p (fun n -> Store.Block.Operation_hashes.read_opt (store, hash) n >|= Option.unopt_assert ~loc:__POS__) (0 -- (header.shell.validation_passes - 1)) >>= fun hashes -> let path = compute_operation_path hashes in - Lwt.return (List.nth hashes i, path i)) + Lwt.return (Option.unopt_exn Not_found @@ List.nth hashes i, path i)) let all_operation_hashes {chain_state; hash; header; _} = Shared.use chain_state.block_store (fun store -> - Lwt_list.map_p + List.map_p (fun i -> Store.Block.Operation_hashes.read_opt (store, hash) i >|= Option.unopt_assert ~loc:__POS__) @@ -1309,7 +1314,7 @@ module Block = struct if i < 0 || header.shell.validation_passes <= i then invalid_arg "State.Block.operations" ; Shared.use chain_state.block_store (fun store -> - Lwt_list.map_p + List.map_p (fun n -> Store.Block.Operation_hashes.read_opt (store, hash) n >|= Option.unopt_assert ~loc:__POS__) @@ -1329,7 +1334,7 @@ module Block = struct let all_operations {chain_state; hash; header; _} = Shared.use chain_state.block_store (fun store -> - Lwt_list.map_p + List.map_p (fun i -> Store.Block.Operations.read_opt (store, hash) i >|= Option.unopt_assert ~loc:__POS__) @@ -1337,7 +1342,7 @@ module Block = struct let all_operations_metadata {chain_state; hash; header; _} = Shared.use chain_state.block_store (fun store -> - Lwt_list.map_p + List.map_p (fun i -> Store.Block.Operations_metadata.read_opt (store, hash) i >|= Option.unopt_assert ~loc:__POS__) diff --git a/src/lib_shell/test/test_locator.ml b/src/lib_shell/test/test_locator.ml index 2c28793c3cb8bb634f1efeae50d89eece75a21a0..6482ea7a565a5905b5aa6da71f861c2bbf87519b 100644 --- a/src/lib_shell/test/test_locator.ml +++ b/src/lib_shell/test/test_locator.ml @@ -446,13 +446,14 @@ let test_locator base_dir = let (_, l_exp) = (l_exp : Block_locator.t :> _ * _) in let (_, l_lin) = (l_lin : Block_locator.t :> _ * _) in let _ = Printf.printf "%10i %f %f\n" max_size t_exp t_lin in - List.iter2 - (fun hn ho -> - if not (Block_hash.equal hn ho) then - Assert.fail_msg "Invalid locator %i" max_size) - l_exp - l_lin ; - return_unit + Lwt.return + @@ List.iter2 + ~when_different_lengths:(TzTrace.make @@ Exn (Failure __LOC__)) + (fun hn ho -> + if not (Block_hash.equal hn ho) then + Assert.fail_msg "Invalid locator %i" max_size) + l_exp + l_lin in let stop = locator_limit + 20 in let rec loop size = @@ -466,12 +467,22 @@ let test_protocol_locator base_dir = >>= fun chain -> let chain_length = 200 in let fork_points = [1; 10; 50; 66; 150] in + (* further_points = List.tl fork_points @ [chain_length] *) + let further_points = [10; 50; 66; 150; chain_length] in let fork_points_assoc = List.map2 + ~when_different_lengths:() (fun x y -> (x, y)) fork_points - (List.tl fork_points @ [chain_length]) - |> List.mapi (fun i x -> (i + 1, x)) + further_points + >|? List.mapi (fun i x -> (i + 1, x)) + in + let fork_points_assoc = + match fork_points_assoc with + | Ok fork_points_assoc -> + fork_points_assoc + | Error () -> + assert false in make_multiple_protocol_chain chain ~chain_length ~fork_points >>= fun head_hash -> @@ -489,7 +500,7 @@ let test_protocol_locator base_dir = let open Block_locator in let steps = to_steps seed locator in let has_lower_bound = ref false in - iter_s + List.iter_es (fun {block; predecessor; _} -> State.Block.read chain block >>=? fun block -> @@ -549,7 +560,7 @@ let test_protocol_locator base_dir = >>=? fun pred -> State.Chain.set_checkpoint_then_purge_rolling chain (State.Block.header pred) >>=? fun () -> - iter_s + List.iter_es (fun i -> State.compute_protocol_locator chain ~proto_level:i seed >>= function @@ -569,7 +580,7 @@ let test_protocol_locator base_dir = let has_lower_bound = ref false in let inf = 170 in let sup = 200 in - iter_s + List.iter_es (fun {block; predecessor; _} -> State.Block.read chain block >>=? fun block -> @@ -592,11 +603,11 @@ let test_protocol_locator base_dir = return_unit) steps >>=? fun () -> - let last_hash = (List.hd steps).predecessor in + let last_hash = (Option.get @@ List.hd steps).predecessor in Assert.is_true ~msg:"last block in locator is the checkpoint" (Block_hash.equal last_hash (State.Block.hash pred)) ; - let first_hash = (List.hd (List.rev steps)).block in + let first_hash = (Option.get @@ List.last_opt steps).block in Assert.is_true ~msg:"first block in locator is the head" (Block_hash.equal first_hash head_hash) ; diff --git a/src/lib_shell/test/test_node.ml b/src/lib_shell/test/test_node.ml index 7a16ed017c51a35eae3464cb754e948d7671e7de..f820439afee17e1ec8db9c88bbac33d34b340c80 100644 --- a/src/lib_shell/test/test_node.ml +++ b/src/lib_shell/test/test_node.ml @@ -161,7 +161,7 @@ let node_sandbox_initialization_events sandbox_parameters config _switch () = test_event "Should have an p2p_layer_disabled" (Internal_event.Notice, section, "p2p_layer_disabled") - (List.nth evs 0) ; + (Option.get @@ List.nth evs 0) ; (* End tests *) Node.shutdown n @@ -189,11 +189,11 @@ let node_initialization_events _sandbox_parameters config _switch () = test_event "Should have a p2p bootstrapping event" (Internal_event.Notice, section, "bootstrapping") - (List.nth evs 0) ; + (Option.get @@ List.nth evs 0) ; test_event "Should have a p2p_maintain_started event" (Internal_event.Notice, section, "p2p_maintain_started") - (List.nth evs 1) ; + (Option.get @@ List.nth evs 1) ; (* End tests *) Node.shutdown n diff --git a/src/lib_shell/test/test_state.ml b/src/lib_shell/test/test_state.ml index 7e2824d808e672c2cebe2fad2c28368930a055aa..b97246c679da016d5d0840205f9b4510cdab4e7f 100644 --- a/src/lib_shell/test/test_state.ml +++ b/src/lib_shell/test/test_state.ml @@ -89,7 +89,7 @@ let parsed_block ({shell; protocol_data} : Block_header.t) = let zero = Bytes.create 0 let build_valid_chain state vtbl pred names = - Lwt_list.fold_left_s + List.fold_left_s (fun pred name -> State.Block.context_exn pred >>= fun predecessor_context -> @@ -232,7 +232,7 @@ let test_init (_ : state) = return_unit (** State.Block.read *) let test_read_block (s : state) = - Lwt_list.iter_s + List.iter_s (fun (name, vblock) -> let hash = State.Block.hash vblock in State.Block.read s.chain hash @@ -512,19 +512,23 @@ let test_locator s = State.compute_locator s.chain ~max_size:length (vblock s h1) seed >>= fun l -> let (_, l) = (l : Block_locator.t :> _ * _) in - if List.length l <> List.length expected then - Assert.fail_msg - "Invalid locator length %s (found: %d, expected: %d)" - h1 - (List.length l) - (List.length expected) ; - List.iter2 - (fun h h2 -> - if not (Block_hash.equal h (State.Block.hash @@ vblock s h2)) then - Assert.fail_msg "Invalid locator %s (expected: %s)" h1 h2) - l - expected ; - Lwt.return_unit + match + List.iter2 + ~when_different_lengths:() + (fun h h2 -> + if not (Block_hash.equal h (State.Block.hash @@ vblock s h2)) then + Assert.fail_msg "Invalid locator %s (expected: %s)" h1 h2) + l + expected + with + | Error () -> + Assert.fail_msg + "Invalid locator length %s (found: %d, expected: %d)" + h1 + (List.length l) + (List.length expected) + | Ok () -> + Lwt.return_unit in check_locator 6 "A8" ["A7"; "A6"; "A5"; "A4"; "A3"; "A2"] >>= fun () -> @@ -696,28 +700,32 @@ let test_new_blocks s = head h expected_ancestor ; - if List.length blocks <> List.length expected then - Assert.fail_msg - "Invalid locator length %s (found: %d, expected: %d)" - h - (List.length blocks) - (List.length expected) ; - List.iter2 - (fun h1 h2 -> - if - not - (Block_hash.equal - (State.Block.hash h1) - (State.Block.hash @@ vblock s h2)) - then - Assert.fail_msg - "Invalid new blocks %s -> %s (expected: %s)" - head - h - h2) - blocks - expected ; - Lwt.return_unit + match + List.iter2 + ~when_different_lengths:() + (fun h1 h2 -> + if + not + (Block_hash.equal + (State.Block.hash h1) + (State.Block.hash @@ vblock s h2)) + then + Assert.fail_msg + "Invalid new blocks %s -> %s (expected: %s)" + head + h + h2) + blocks + expected + with + | Error () -> + Assert.fail_msg + "Invalid locator length %s (found: %d, expected: %d)" + h + (List.length blocks) + (List.length expected) + | Ok () -> + Lwt.return_unit in test s "A6" "A6" "A6" [] >>= fun () -> diff --git a/src/lib_shell/test/test_state_checkpoint.ml b/src/lib_shell/test/test_state_checkpoint.ml index da98730de3530c91552137fd5024d6be4e111b03..63e018fca0135e1baceac2152f90c945f79091ad 100644 --- a/src/lib_shell/test/test_state_checkpoint.ml +++ b/src/lib_shell/test/test_state_checkpoint.ml @@ -117,7 +117,7 @@ let block_header_data_encoding = Data_encoding.(obj1 (req "proto_block_header" string)) let build_valid_chain state vtbl pred names = - Lwt_list.fold_left_s + List.fold_left_s (fun pred name -> State.Block.context_exn pred >>= fun predecessor_context -> diff --git a/src/lib_shell/worker_directory.ml b/src/lib_shell/worker_directory.ml index 81205a53a432449b2179e162506df0db5d9f6f6d..76dc6630f3c1609696cc7f4a2ad3e8bc2244293d 100644 --- a/src/lib_shell/worker_directory.ml +++ b/src/lib_shell/worker_directory.ml @@ -56,7 +56,8 @@ let build_rpc_directory state = (* NOTE: it is technically possible to use the Prevalidator interface to * register multiple Prevalidator for a single chain (using distinct * protocols). However, this is never done. *) - List.find (fun (c, _, _) -> Chain_id.equal c chain_id) workers + Option.unopt_exn Not_found + @@ List.find (fun (c, _, _) -> Chain_id.equal c chain_id) workers in let status = Prevalidator.status t in let pending_requests = Prevalidator.pending_requests t in @@ -92,7 +93,8 @@ let build_rpc_directory state = Chain_directory.get_chain_id state chain >>= fun chain_id -> let w = - List.assoc (chain_id, peer_id) (Peer_validator.running_workers ()) + Option.unopt_exn Not_found + @@ List.assoc (chain_id, peer_id) (Peer_validator.running_workers ()) in return { @@ -114,7 +116,10 @@ let build_rpc_directory state = register1 Worker_services.Chain_validators.S.state (fun chain () () -> Chain_directory.get_chain_id state chain >>= fun chain_id -> - let w = List.assoc chain_id (Chain_validator.running_workers ()) in + let w = + Option.unopt_exn Not_found + @@ List.assoc chain_id (Chain_validator.running_workers ()) + in return { Worker_types.status = Chain_validator.status w; @@ -126,6 +131,9 @@ let build_rpc_directory state = register1 Worker_services.Chain_validators.S.ddb_state (fun chain () () -> Chain_directory.get_chain_id state chain >>= fun chain_id -> - let w = List.assoc chain_id (Chain_validator.running_workers ()) in + let w = + Option.unopt_exn Not_found + @@ List.assoc chain_id (Chain_validator.running_workers ()) + in return (Chain_validator.ddb_information w)) ; !dir diff --git a/src/lib_shell_services/block_services.ml b/src/lib_shell_services/block_services.ml index fa2862446d8f491ef0bd34dd75b52358e6b79a8f..250e4e8a6ee25a5b547d2abeb41b8a2d1faee58f 100644 --- a/src/lib_shell_services/block_services.ml +++ b/src/lib_shell_services/block_services.ml @@ -76,7 +76,7 @@ let parse_block s = | 0 -> ([s], ' ') | 1 -> - let delim = List.assoc 1 counts in + let delim = Option.unopt_assert ~loc:__POS__ @@ List.assoc 1 counts in (String.split delim s, delim) | _ -> raise Exit diff --git a/src/lib_signer_backends/encrypted.ml b/src/lib_signer_backends/encrypted.ml index 29cf03e7f5d80e41100e75330d0a883cd40bab08..895f31a5f0441e8c31028ce0ab7e3e23a0e0325c 100644 --- a/src/lib_signer_backends/encrypted.ml +++ b/src/lib_signer_backends/encrypted.ml @@ -211,7 +211,7 @@ let decrypt_all (cctxt : #Client_context.io_wallet) = >>=? fun sks -> password_file_load cctxt >>=? fun () -> - iter_s + List.iter_es (fun (name, sk_uri) -> if Uri.scheme (sk_uri : sk_uri :> Uri.t) <> Some scheme then return_unit else decrypt cctxt ~name sk_uri >>=? fun _ -> return_unit) @@ -222,7 +222,7 @@ let decrypt_list (cctxt : #Client_context.io_wallet) keys = >>=? fun sks -> password_file_load cctxt >>=? fun () -> - iter_s + List.iter_es (fun (name, sk_uri) -> if Uri.scheme (sk_uri : sk_uri :> Uri.t) = Some scheme diff --git a/src/lib_signer_backends/test/dune b/src/lib_signer_backends/test/dune index d3822fac7db402ac29712deeb7c7155a362343f5..bd7dddd4345f0a1017988460f8a1325536a0724c 100644 --- a/src/lib_signer_backends/test/dune +++ b/src/lib_signer_backends/test/dune @@ -4,6 +4,7 @@ alcotest-lwt) (flags (:standard -open Tezos_error_monad -open Tezos_stdlib + -open Tezos_lwt_result_stdlib.Lwtreslib -open Tezos_crypto -open Tezos_client_base -open Tezos_signer_backends))) diff --git a/src/lib_signer_backends/test/test_encrypted.ml b/src/lib_signer_backends/test/test_encrypted.ml index 81200e812d48254f5dc694f7b2f3441eb14248f1..e2aa02d0676951df79aad96a17b8c30ff434627c 100644 --- a/src/lib_signer_backends/test/test_encrypted.ml +++ b/src/lib_signer_backends/test/test_encrypted.ml @@ -68,15 +68,15 @@ let fake_ctx () = match distributed with | false -> distributed <- true ; - return (List.nth passwords 0) + return (Option.get @@ List.nth passwords 0) | true -> i <- (if i = nb_passwds - 1 then 0 else succ i) ; distributed <- false ; - return (List.nth passwords i)) + return (Option.get @@ List.nth passwords i)) end let make_sk_uris = - map_p (fun path -> + List.map_ep (fun path -> Client_keys.make_sk_uri (Uri.make ~scheme:"encrypted" ~path ())) let ed25519_sks = @@ -120,12 +120,12 @@ let sk_testable = let test_vectors () = let open Encrypted in - iter_s + List.iter_es (fun (sks, encrypted_sks) -> let ctx = fake_ctx () in let sks = List.map Signature.Secret_key.of_b58check_exn sks in encrypted_sks - >>=? map_s (decrypt ctx) + >>=? List.map_es (decrypt ctx) >>=? fun decs -> assert (decs = sks) ; return_unit) @@ -157,7 +157,7 @@ let test_random algo = process is repeated 10 times. *) let test_random _switch () = - iter_s test_random Signature.[Ed25519; Secp256k1; P256] + List.iter_es test_random Signature.[Ed25519; Secp256k1; P256] >>= function | Ok _ -> Lwt.return_unit | Error _ -> Lwt.fail_with "test_random" diff --git a/src/lib_stdlib/tzList.ml b/src/lib_stdlib/tzList.ml index 2efce1b22e3e8d0bff00d272b544b1a5c59a3984..483da423f6a7ea327d15834ef7d698f73e1c887d 100644 --- a/src/lib_stdlib/tzList.ml +++ b/src/lib_stdlib/tzList.ml @@ -41,16 +41,6 @@ let rev_sub l n = let sub l n = rev_sub l n |> List.rev -let hd_opt = function [] -> None | h :: _ -> Some h - -let rec last_exn = function - | [] -> - raise Not_found - | [x] -> - x - | _ :: xs -> - last_exn xs - let merge_filter2 ?(finalize = List.rev) ?(compare = compare) ?(f = TzOption.first_some) l1 l2 = let sort = List.sort compare in diff --git a/src/lib_stdlib/tzList.mli b/src/lib_stdlib/tzList.mli index 48ab274dd5dd9ba3aa5c7737c0f44adfb46e532c..6ec405d16b8119515870a80fdf996d9fa41b3889 100644 --- a/src/lib_stdlib/tzList.mli +++ b/src/lib_stdlib/tzList.mli @@ -64,12 +64,6 @@ val rev_sub : 'a list -> int -> 'a list (** [sub l n] is [l] capped to max [n] elements *) val sub : 'a list -> int -> 'a list -(** Like [List.hd], but [Some hd] or [None] if empty *) -val hd_opt : 'a list -> 'a option - -(** Last elt of list, or raise Not_found if empty *) -val last_exn : 'a list -> 'a - (** [merge_filter2 ~compare ~f l1 l2] merges two lists ordered by [compare] and whose items can be merged with [f]. Item is discarded or kept whether [f] returns [Some] or [None] *) diff --git a/src/lib_stdlib_unix/dune b/src/lib_stdlib_unix/dune index bbfbd85a2853474e81197e4d9f4b961caf145104..5dd825cc01d675cc30f0a30296e91fdb799c66f4 100644 --- a/src/lib_stdlib_unix/dune +++ b/src/lib_stdlib_unix/dune @@ -2,11 +2,13 @@ (name tezos_stdlib_unix) (public_name tezos-stdlib-unix) (flags (:standard -open Tezos_error_monad + -open Tezos_lwt_result_stdlib.Lwtreslib -open Tezos_event_logging -open Tezos_stdlib -open Data_encoding)) (libraries data-encoding tezos-error-monad + tezos-lwt-result-stdlib tezos-event-logging tezos-stdlib lwt.unix diff --git a/src/lib_stdlib_unix/file_descriptor_sink.ml b/src/lib_stdlib_unix/file_descriptor_sink.ml index d71ba3b43068a6b6cdd498c540ee24da5ab6519d..4e4acb89e56c4918839c4e683f7e0031da1e6ab8 100644 --- a/src/lib_stdlib_unix/file_descriptor_sink.ml +++ b/src/lib_stdlib_unix/file_descriptor_sink.ml @@ -174,7 +174,7 @@ end) : Internal_event.SINK with type t = t = struct else return_unit let close {lwt_bad_citizen_hack; output; format; _} = - iter_s + List.iter_es (fun event_json -> output_one output format event_json) !lwt_bad_citizen_hack >>=? fun () -> Lwt_unix.close output >>= fun () -> return_unit diff --git a/src/lib_stdlib_unix/file_event_sink.ml b/src/lib_stdlib_unix/file_event_sink.ml index 6c7b0473b3ebc8f79e867839c073a698bccd47e3..eb545bcf33c220156b5a19b7b78494858b2d8ba3 100644 --- a/src/lib_stdlib_unix/file_event_sink.ml +++ b/src/lib_stdlib_unix/file_event_sink.ml @@ -347,12 +347,11 @@ module Sink_implementation : Internal_event.SINK with type t = t = struct return_unit let close {lwt_bad_citizen_hack; _} = - iter_s + List.iter_es (fun (f, j) -> output_json f j ~pp:(fun fmt () -> Format.fprintf fmt "Destacking: %s" f)) !lwt_bad_citizen_hack - >>=? fun () -> return_unit end let () = Internal_event.All_sinks.register (module Sink_implementation) diff --git a/src/lib_stdlib_unix/internal_event_unix.ml b/src/lib_stdlib_unix/internal_event_unix.ml index 0d7d1308c4a324ddcad083e1b9f6f41c29083416..5a4b947b828fe4876933bb0d4b6e2b477c259d2d 100644 --- a/src/lib_stdlib_unix/internal_event_unix.ml +++ b/src/lib_stdlib_unix/internal_event_unix.ml @@ -48,7 +48,8 @@ module Configuration = struct >>=? fun json -> protect (fun () -> return (Data_encoding.Json.destruct encoding json)) - let apply {activate} = iter_s Internal_event.All_sinks.activate activate + let apply {activate} = + List.iter_es Internal_event.All_sinks.activate activate end let env_var_name = "TEZOS_EVENTS_CONFIG" @@ -75,7 +76,7 @@ let init ?lwt_log_sink ?(configuration = Configuration.default) () = |> List.filter (( <> ) "") |> List.map Uri.of_string in - iter_s + List.iter_es (fun uri -> match Uri.scheme uri with | None -> diff --git a/src/lib_stdlib_unix/lwt_exit.ml b/src/lib_stdlib_unix/lwt_exit.ml index b6bf1c6fa494ef0b54689b85a10016d02c8ae513..57ccc252281fb11a256f31379bba685ceb7b1229 100644 --- a/src/lib_stdlib_unix/lwt_exit.ml +++ b/src/lib_stdlib_unix/lwt_exit.ml @@ -76,18 +76,19 @@ let clean_up status = | [] -> Lwt.return_unit | _ :: _ as after -> ( - Callbacks_map.to_seq promises - |> Seq.filter_map (fun (id, (_, p)) -> - if List.mem id after then Some p else None) - |> List.of_seq - |> function - | [] -> - (* This can happen if all after-callbacks were unregistered *) - Lwt.return_unit - | [p] -> - p - | _ :: _ :: _ as ps -> - Lwt.join ps ) + match + Callbacks_map.fold + (fun id (_, p) ps -> if List.mem id after then p :: ps else ps) + promises + [] + with + | [] -> + (* This can happen if all after-callbacks were unregistered *) + Lwt.return_unit + | [p] -> + p + | _ :: _ :: _ as ps -> + Lwt.join ps ) in let promise = pre >>= fun () -> callback status in Lwt.on_failure promise (fun exc -> diff --git a/src/lib_stdlib_unix/tezos-stdlib-unix.opam b/src/lib_stdlib_unix/tezos-stdlib-unix.opam index 5dacf4ca9ae702d593cbf22e1a78681bcc4eead8..148fb1957b5dec1018ffff64ec018531c41ded62 100644 --- a/src/lib_stdlib_unix/tezos-stdlib-unix.opam +++ b/src/lib_stdlib_unix/tezos-stdlib-unix.opam @@ -11,6 +11,7 @@ depends: [ "dune" { >= "2.0" } "data-encoding" { = "0.2" } "tezos-error-monad" + "tezos-lwt-result-stdlib" "tezos-event-logging" "tezos-stdlib" "re" { >= "1.7.2" } diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index dbfc059a6d454ef18fde9a46bd7ba74e1bd4f57b..24514b7a46f40385aec8a9bdcab25019d575a060 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -287,7 +287,7 @@ let unshallow context = Store.Tree.list context.tree [] >>= fun children -> P.Repo.batch context.index.repo (fun x y _ -> - Lwt_list.iter_s + List.iter_s (fun (s, k) -> match k with | `Contents -> @@ -371,7 +371,7 @@ type key_or_dir = [`Key of key | `Dir of key] let fold ctxt key ~init ~f = Store.Tree.list ctxt.tree (data_key key) >>= fun keys -> - Lwt_list.fold_left_s + List.fold_left_s (fun acc (name, kind) -> let key = match kind with @@ -826,7 +826,7 @@ module Dumpable_context = struct >>= fun keys -> keys |> List.sort (fun (a, _) (b, _) -> String.compare a b) - |> Lwt_list.map_s (fun (key, value_kind) -> + |> List.map_s (fun (key, value_kind) -> Store.Tree.get_tree tree [key] >|= fun value -> let value_hash = tree_hash value in @@ -853,7 +853,7 @@ module Dumpable_context = struct let rec aux : type a. tree -> (unit -> a) -> a Lwt.t = fun tree k -> bindings tree - >>= Lwt_list.map_s (fun {key; value; value_hash; value_kind} -> + >>= List.map_s (fun {key; value; value_hash; value_kind} -> let kv = (key, value_hash) in if visited value_hash then Lwt.return kv else diff --git a/src/lib_storage/context_dump.ml b/src/lib_storage/context_dump.ml index e6845f21e74e550fe634477d0fa80f065fbb8eb2..9dda75c84cb5f0ca8dad3c140016e685284fb678 100644 --- a/src/lib_storage/context_dump.ml +++ b/src/lib_storage/context_dump.ml @@ -545,7 +545,7 @@ module Make (I : Dump_interface) = struct aux 0 [] starting_block_header >>=? fun protocol_datas -> (* Dump protocol data *) - Lwt_list.iter_s + List.iter_s (fun proto -> set_loot buf proto ; maybe_flush ()) protocol_datas >>= fun () -> diff --git a/src/lib_storage/raw_store.ml b/src/lib_storage/raw_store.ml index e20cfe724faa6e94d16003f9b7726b7177280ac6..76e07b8b514faf82eb1cc2d5fbb0da597d78a759 100644 --- a/src/lib_storage/raw_store.ml +++ b/src/lib_storage/raw_store.ml @@ -274,12 +274,12 @@ let cursor_at_lwt cursor k acc f = the separator '/', which immediately precedes '0' *) let zero_char_str = String.make 1 (Char.chr (Char.code '/' + 1)) -let next_key_after_subdirs = function +let next_key_after_subdirs l = + match List.rev l with | [] -> [zero_char_str] - | _ :: _ as path -> - List.sub path (List.length path - 1) - @ [List.last_exn path ^ zero_char_str] + | last :: firsts -> + List.rev @@ ((last ^ zero_char_str) :: firsts) module Hashtbl = Hashtbl.MakeSeeded (struct type t = string list diff --git a/src/lib_storage/store_helpers.ml b/src/lib_storage/store_helpers.ml index b72abb7927cce10d7379424e3e8d834290e78a6c..fafe3aa5b7b921f7bf03082c93b602be37f0a1d9 100644 --- a/src/lib_storage/store_helpers.ml +++ b/src/lib_storage/store_helpers.ml @@ -194,7 +194,7 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct | [] -> list t prefix >>= fun prefixes -> - Lwt_list.map_p + List.map_p (function `Key prefix | `Dir prefix -> loop (i + 1) prefix []) prefixes >|= List.flatten @@ -202,22 +202,20 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct if i >= I.path_length then invalid_arg "IO.resolve" ; list t prefix >>= fun prefixes -> - Lwt_list.map_p + List.map_p (function - | `Key prefix | `Dir prefix -> ( - match - String.remove_prefix ~prefix:d (List.hd (List.rev prefix)) - with - | None -> - Lwt.return_nil - | Some _ -> - loop (i + 1) prefix [] )) + | `Key prefix | `Dir prefix -> + let open Option in + bind (List.last_opt prefix) (fun last_prefix -> + String.remove_prefix ~prefix:d last_prefix) + |> fold ~none:Lwt.return_nil ~some:(fun _ -> + loop (i + 1) prefix [])) prefixes >|= List.flatten | "" :: ds -> list t prefix >>= fun prefixes -> - Lwt_list.map_p + List.map_p (function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds) prefixes >|= List.flatten diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index 315d0148b024fda2d3aa3a219bee74b572aef858..7ff703922fdb2fde82fa5693e444c4ae9fa782f8 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -228,8 +228,8 @@ module Make (Proto : Registered_protocol.T) = struct let check_operation_quota block_hash operations = let invalid_block = invalid_block block_hash in - iteri2_p - (fun i ops quota -> + List.iteri_ep + (fun i (ops, quota) -> fail_unless (Option.fold ~none:true @@ -239,7 +239,7 @@ module Make (Proto : Registered_protocol.T) = struct invalid_block (Too_many_operations {pass = i + 1; found = List.length ops; max})) >>=? fun () -> - iter_p + List.iter_ep (fun op -> let size = Data_encoding.Binary.length Operation.encoding op in fail_unless @@ -251,16 +251,23 @@ module Make (Proto : Registered_protocol.T) = struct size; max = Proto.max_operation_data_length; }))) - ops - >>=? fun () -> return_unit) - operations - Proto.validation_passes + ops) + ( match + List.combine + ~when_different_lengths:() + operations + Proto.validation_passes + with + | Ok combined -> + combined + | Error () -> + raise (Invalid_argument "Block_validation.check_operation_quota") ) let parse_operations block_hash operations = let invalid_block = invalid_block block_hash in - mapi_s + List.mapi_es (fun pass -> - map_s (fun op -> + List.map_es (fun op -> let op_hash = Operation.hash op in match Data_encoding.Binary.of_bytes_opt @@ -319,9 +326,9 @@ module Make (Proto : Registered_protocol.T) = struct ~predecessor_fitness:predecessor_block_header.shell.fitness block_header >>=? (fun state -> - fold_left_s + List.fold_left_es (fun (state, acc) ops -> - fold_left_s + List.fold_left_es (fun (state, acc) op -> Proto.apply_operation state op >>=? fun (state, op_metadata) -> diff --git a/src/lib_workers/worker.ml b/src/lib_workers/worker.ml index e4abb0ddd77aa322eae35e2fb1c4fbd61282a704..fd5b70405aec03337b0e33463ba2eedcc2d0bfa8 100644 --- a/src/lib_workers/worker.ml +++ b/src/lib_workers/worker.ml @@ -518,7 +518,8 @@ struct lwt_emit w (Logger.WorkerEvent (evt, Event.level evt)) >>= fun () -> if Event.level evt >= w.limits.backlog_level then - Ringo.Ring.add (List.assoc (Event.level evt) w.event_log) evt ; + List.assoc (Event.level evt) w.event_log + |> Option.iter (fun ring -> Ringo.Ring.add ring evt) ; Lwt.return_unit let record_event w evt = Lwt.ignore_result (log_event w evt) diff --git a/src/proto_001_PtCJ7pwo/lib_client/client_proto_context.ml b/src/proto_001_PtCJ7pwo/lib_client/client_proto_context.ml index 631ed0e26e54be8b898f82212f02baf47f7aa1d5..d9b0ff494b151d0fb2c11825f38f79d2db5b7e41 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/client_proto_context.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/client_proto_context.ml @@ -43,7 +43,7 @@ let get_script (rpc : #Alpha_client_context.rpc_context) ~chain ~block contract let list_contract_labels (cctxt : #Alpha_client_context.full) ~chain ~block = Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> - map_s + List.map_es (fun h -> ( match Contract.is_implicit h with | Some m -> ( diff --git a/src/proto_001_PtCJ7pwo/lib_client/client_proto_contracts.ml b/src/proto_001_PtCJ7pwo/lib_client/client_proto_contracts.ml index 02614530677327e49dcb04d76b336687c15b45c7..57db198aaba2a28920738b1ae18923038cea5b27 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/client_proto_contracts.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/client_proto_contracts.ml @@ -145,12 +145,12 @@ end let list_contracts cctxt = RawContractAlias.load cctxt >>=? fun raw_contracts -> - Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts + List.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts >>= fun contracts -> Client_keys.Public_key_hash.load cctxt >>=? fun keys -> (* List accounts (implicit contracts of identities) *) - map_s + List.map_es (fun (n, v) -> RawContractAlias.mem cctxt n >>=? fun mem -> diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml index 0cf5c95b6df98a4bce026a9c2443827ac168aa34..2b075e6c7e6c2e642e4b088c3465186f441b5680 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_emacs.ml @@ -89,22 +89,23 @@ let print_type_map ppf (parsed, type_map) = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr) items and print_item ppf loc = - try - let ({start = {point = s}; stop = {point = e}}, locs) = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - in - let locs = List.sort compare locs in - let (bef, aft) = List.assoc (List.hd locs) type_map in - Format.fprintf - ppf - "(@[%d %d %a %a@])@," - s - e - print_stack - bef - print_stack - aft - with Not_found -> () + (let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun ({start = {point = s}; stop = {point = e}}, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun hd_loc -> + List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + |> Option.iter (fun (s, e, bef, aft) -> + Format.fprintf + ppf + "(@[%d %d %a %a@])@," + s + e + print_stack + bef + print_stack + aft) in Format.fprintf ppf "(@[%a@])" print_expr_types (root parsed.unexpanded) @@ -151,9 +152,10 @@ let report_errors ppf (parsed, errs) = (fun ppf errs -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in match errs with | top :: errs -> @@ -191,9 +193,10 @@ let report_errors ppf (parsed, errs) = (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in let loc = match err with diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml index 3403e51b3ec2add8944a7a9483ca3eed77a4cf87..4272efc72a2485fd6b3567b32b100541ca9e3d55 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_error_reporter.ml @@ -137,13 +137,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = (Format.asprintf "%a" Micheline_parser.print_location loc)) in let parsed_locations parsed loc = - try - let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table - in - let (ploc, _) = List.assoc oloc parsed.expansion_table in - Some ploc - with Not_found -> None + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + >?? fun oloc -> + List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml index 5a2e5b8d1c1623da260c7d2704279d984bc098a0..fcfc8a3d6fa301194acea9e6d34e833df6266954 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_parser.ml @@ -59,12 +59,19 @@ let expand_all source ast errors = in group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + match + List.map2 + ~when_different_lengths:() + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) + with + | Ok v -> + v + | Error () -> + invalid_arg "Michelson_v1_parser.expand_all" in match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) diff --git a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml index e28a814e941a0a466dca5d550e2b8e5a0728ac78..e31345a9fa8c0bd7101be9a3ce157e76c8245a9e 100644 --- a/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml +++ b/src/proto_001_PtCJ7pwo/lib_client/michelson_v1_printer.ml @@ -91,17 +91,19 @@ let inject_types type_map parsed = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let locs = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - |> snd |> List.sort compare - in - let (bef, aft) = List.assoc (List.hd locs) type_map in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun (_, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun head_loc -> + List.assoc head_loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in inject_expr (root parsed.unexpanded) @@ -126,15 +128,16 @@ let unparse ?type_map parse expanded = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let (bef, aft) = - List.assoc (List.assoc loc unexpansion_table) type_map - in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc unexpansion_table + >?? fun loc -> + List.assoc loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in unexpanded |> root |> inject_expr |> Format.asprintf "%a" Micheline_printer.print_expr 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 14b8fdc7d456533b6ea4a31383ba9e41155b616a..eecd87f82cd0879bbd9269e301e7d1b47dcffa43 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 @@ -76,7 +76,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> list_contract_labels cctxt ~chain:`Main ~block:cctxt#block >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> return_unit); diff --git a/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_contracts_commands.ml index e3e336045807a752eaa5adf28a18c0341b0fbec9..80850975370ceb7a50d0be3c71ad0847c924e85e 100644 --- a/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_contracts_commands.ml @@ -59,7 +59,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> list_contracts cctxt >>=? fun contracts -> - iter_s + List.iter_es (fun (prefix, alias, contract) -> cctxt#message "%s%s: %s" diff --git a/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_programs_commands.ml b/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_programs_commands.ml index 781ea0c79ed6ee4c54e130db9015a040a443d007..633ba37e2cb13af3844a3aaef5188e5509716a97 100644 --- a/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_001_PtCJ7pwo/lib_client_commands/client_proto_programs_commands.ml @@ -118,7 +118,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> Program.load cctxt >>=? fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list + List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return_unit); command ~group diff --git a/src/proto_002_PsYLVpVv/lib_client/client_proto_context.ml b/src/proto_002_PsYLVpVv/lib_client/client_proto_context.ml index 998fdf8777903eeaba557bb9ea92fc02a973d180..206edd5cf662b0b00b1ab9640053fb6c0ca3d5f1 100644 --- a/src/proto_002_PsYLVpVv/lib_client/client_proto_context.ml +++ b/src/proto_002_PsYLVpVv/lib_client/client_proto_context.ml @@ -48,7 +48,7 @@ let get_script (rpc : #Alpha_client_context.rpc_context) ~chain ~block contract let list_contract_labels (cctxt : #Alpha_client_context.full) ~chain ~block = Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> - map_s + List.map_es (fun h -> ( match Contract.is_implicit h with | Some m -> ( diff --git a/src/proto_002_PsYLVpVv/lib_client/client_proto_contracts.ml b/src/proto_002_PsYLVpVv/lib_client/client_proto_contracts.ml index 02614530677327e49dcb04d76b336687c15b45c7..57db198aaba2a28920738b1ae18923038cea5b27 100644 --- a/src/proto_002_PsYLVpVv/lib_client/client_proto_contracts.ml +++ b/src/proto_002_PsYLVpVv/lib_client/client_proto_contracts.ml @@ -145,12 +145,12 @@ end let list_contracts cctxt = RawContractAlias.load cctxt >>=? fun raw_contracts -> - Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts + List.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts >>= fun contracts -> Client_keys.Public_key_hash.load cctxt >>=? fun keys -> (* List accounts (implicit contracts of identities) *) - map_s + List.map_es (fun (n, v) -> RawContractAlias.mem cctxt n >>=? fun mem -> diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml index 0cf5c95b6df98a4bce026a9c2443827ac168aa34..2b075e6c7e6c2e642e4b088c3465186f441b5680 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_emacs.ml @@ -89,22 +89,23 @@ let print_type_map ppf (parsed, type_map) = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr) items and print_item ppf loc = - try - let ({start = {point = s}; stop = {point = e}}, locs) = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - in - let locs = List.sort compare locs in - let (bef, aft) = List.assoc (List.hd locs) type_map in - Format.fprintf - ppf - "(@[%d %d %a %a@])@," - s - e - print_stack - bef - print_stack - aft - with Not_found -> () + (let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun ({start = {point = s}; stop = {point = e}}, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun hd_loc -> + List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + |> Option.iter (fun (s, e, bef, aft) -> + Format.fprintf + ppf + "(@[%d %d %a %a@])@," + s + e + print_stack + bef + print_stack + aft) in Format.fprintf ppf "(@[%a@])" print_expr_types (root parsed.unexpanded) @@ -151,9 +152,10 @@ let report_errors ppf (parsed, errs) = (fun ppf errs -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in match errs with | top :: errs -> @@ -191,9 +193,10 @@ let report_errors ppf (parsed, errs) = (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in let loc = match err with diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml index 3403e51b3ec2add8944a7a9483ca3eed77a4cf87..4272efc72a2485fd6b3567b32b100541ca9e3d55 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_error_reporter.ml @@ -137,13 +137,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = (Format.asprintf "%a" Micheline_parser.print_location loc)) in let parsed_locations parsed loc = - try - let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table - in - let (ploc, _) = List.assoc oloc parsed.expansion_table in - Some ploc - with Not_found -> None + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + >?? fun oloc -> + List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml index 5a2e5b8d1c1623da260c7d2704279d984bc098a0..fcfc8a3d6fa301194acea9e6d34e833df6266954 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_parser.ml @@ -59,12 +59,19 @@ let expand_all source ast errors = in group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + match + List.map2 + ~when_different_lengths:() + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) + with + | Ok v -> + v + | Error () -> + invalid_arg "Michelson_v1_parser.expand_all" in match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) diff --git a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml index e28a814e941a0a466dca5d550e2b8e5a0728ac78..e31345a9fa8c0bd7101be9a3ce157e76c8245a9e 100644 --- a/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml +++ b/src/proto_002_PsYLVpVv/lib_client/michelson_v1_printer.ml @@ -91,17 +91,19 @@ let inject_types type_map parsed = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let locs = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - |> snd |> List.sort compare - in - let (bef, aft) = List.assoc (List.hd locs) type_map in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun (_, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun head_loc -> + List.assoc head_loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in inject_expr (root parsed.unexpanded) @@ -126,15 +128,16 @@ let unparse ?type_map parse expanded = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let (bef, aft) = - List.assoc (List.assoc loc unexpansion_table) type_map - in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc unexpansion_table + >?? fun loc -> + List.assoc loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in unexpanded |> root |> inject_expr |> Format.asprintf "%a" Micheline_printer.print_expr 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 b93b87e971e4e1815615af874b8de0d9c14cae9b..fba38b9875066099ec706904b27396f3bd215d93 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 @@ -89,7 +89,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> list_contract_labels cctxt ~chain:`Main ~block:cctxt#block >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> return_unit); diff --git a/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_contracts_commands.ml index e3e336045807a752eaa5adf28a18c0341b0fbec9..80850975370ceb7a50d0be3c71ad0847c924e85e 100644 --- a/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_002_PsYLVpVv/lib_client_commands/client_proto_contracts_commands.ml @@ -59,7 +59,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> list_contracts cctxt >>=? fun contracts -> - iter_s + List.iter_es (fun (prefix, alias, contract) -> cctxt#message "%s%s: %s" 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 28a3ff1d221ceeb64512142f676c3428a1cd8c17..f6ff94dfb1c3a968dd59320e67df1af6be454073 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 @@ -118,7 +118,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> Program.load cctxt >>=? fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list + List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return_unit); command ~group diff --git a/src/proto_003_PsddFKi3/lib_client/client_proto_context.ml b/src/proto_003_PsddFKi3/lib_client/client_proto_context.ml index 18a91cac75eeea714c7d5435a5775f3cfc4f4f40..964524d96ebba94cb3279b47bfe36b2bed99223b 100644 --- a/src/proto_003_PsddFKi3/lib_client/client_proto_context.ml +++ b/src/proto_003_PsddFKi3/lib_client/client_proto_context.ml @@ -48,7 +48,7 @@ let get_script (rpc : #Alpha_client_context.rpc_context) ~chain ~block contract let list_contract_labels (cctxt : #Alpha_client_context.full) ~chain ~block = Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> - map_s + List.map_es (fun h -> ( match Contract.is_implicit h with | Some m -> ( diff --git a/src/proto_003_PsddFKi3/lib_client/client_proto_contracts.ml b/src/proto_003_PsddFKi3/lib_client/client_proto_contracts.ml index 216a3ff639a875fd6fce44856a9addbd570200bb..ccb3d4f2424c07f6d6a4d08e215cb0c3c0a65168 100644 --- a/src/proto_003_PsddFKi3/lib_client/client_proto_contracts.ml +++ b/src/proto_003_PsddFKi3/lib_client/client_proto_contracts.ml @@ -145,12 +145,12 @@ end let list_contracts cctxt = RawContractAlias.load cctxt >>=? fun raw_contracts -> - Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts + List.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts >>= fun contracts -> Client_keys.Public_key_hash.load cctxt >>=? fun keys -> (* List accounts (implicit contracts of identities) *) - map_s + List.map_es (fun (n, v) -> RawContractAlias.mem cctxt n >>=? fun mem -> diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml index 80a9988157d62dcba6afbff43dc02ff638ade92f..898cfab1f92f0c5c0c5da5a2fe25578183859d19 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_emacs.ml @@ -89,22 +89,23 @@ let print_type_map ppf (parsed, type_map) = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr) items and print_item ppf loc = - try - let ({start = {point = s; _}; stop = {point = e; _}}, locs) = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - in - let locs = List.sort compare locs in - let (bef, aft) = List.assoc (List.hd locs) type_map in - Format.fprintf - ppf - "(@[%d %d %a %a@])@," - s - e - print_stack - bef - print_stack - aft - with Not_found -> () + (let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun hd_loc -> + List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + |> Option.iter (fun (s, e, bef, aft) -> + Format.fprintf + ppf + "(@[%d %d %a %a@])@," + s + e + print_stack + bef + print_stack + aft) in Format.fprintf ppf "(@[%a@])" print_expr_types (root parsed.unexpanded) @@ -151,9 +152,10 @@ let report_errors ppf (parsed, errs) = (fun ppf errs -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in match errs with | top :: errs -> @@ -191,9 +193,10 @@ let report_errors ppf (parsed, errs) = (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in let loc = match err with diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml index 3403e51b3ec2add8944a7a9483ca3eed77a4cf87..4272efc72a2485fd6b3567b32b100541ca9e3d55 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_error_reporter.ml @@ -137,13 +137,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = (Format.asprintf "%a" Micheline_parser.print_location loc)) in let parsed_locations parsed loc = - try - let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table - in - let (ploc, _) = List.assoc oloc parsed.expansion_table in - Some ploc - with Not_found -> None + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + >?? fun oloc -> + List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = 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 4b5bbae81a2cb9cae5d41b4e757b484edc8c6c63..ceb46037d454f330ab267717d7c4f9a6b3ac68ed 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_macros.ml @@ -1010,7 +1010,10 @@ let dxiiivp_roman_of_decimal decimal = let roman = roman_of_decimal decimal in if String.length roman = 1 then (* too short for D*P, fall back to IIIII... *) - String.concat "" (List.init decimal (fun _ -> "I")) + String.concat + "" + ( Result.get_ok + @@ List.init ~when_negative_length:() decimal (fun _ -> "I") ) else roman let unexpand_dxiiivp expanded = diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml index 5a2e5b8d1c1623da260c7d2704279d984bc098a0..fcfc8a3d6fa301194acea9e6d34e833df6266954 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_parser.ml @@ -59,12 +59,19 @@ let expand_all source ast errors = in group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + match + List.map2 + ~when_different_lengths:() + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) + with + | Ok v -> + v + | Error () -> + invalid_arg "Michelson_v1_parser.expand_all" in match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) diff --git a/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml b/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml index e28a814e941a0a466dca5d550e2b8e5a0728ac78..e31345a9fa8c0bd7101be9a3ce157e76c8245a9e 100644 --- a/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml +++ b/src/proto_003_PsddFKi3/lib_client/michelson_v1_printer.ml @@ -91,17 +91,19 @@ let inject_types type_map parsed = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let locs = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - |> snd |> List.sort compare - in - let (bef, aft) = List.assoc (List.hd locs) type_map in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun (_, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun head_loc -> + List.assoc head_loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in inject_expr (root parsed.unexpanded) @@ -126,15 +128,16 @@ let unparse ?type_map parse expanded = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let (bef, aft) = - List.assoc (List.assoc loc unexpansion_table) type_map - in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc unexpansion_table + >?? fun loc -> + List.assoc loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in unexpanded |> root |> inject_expr |> Format.asprintf "%a" Micheline_printer.print_expr 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 d7ddc0461c1b1bd9e14674ba60fe13e3c327a8d3..2bed0384c9b2d90d0fc8fa2a33039527b80ba25a 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 @@ -93,7 +93,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> return_unit); diff --git a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_contracts_commands.ml index e3e336045807a752eaa5adf28a18c0341b0fbec9..80850975370ceb7a50d0be3c71ad0847c924e85e 100644 --- a/src/proto_003_PsddFKi3/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_003_PsddFKi3/lib_client_commands/client_proto_contracts_commands.ml @@ -59,7 +59,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> list_contracts cctxt >>=? fun contracts -> - iter_s + List.iter_es (fun (prefix, alias, contract) -> cctxt#message "%s%s: %s" 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 b820653843a53ad316235f7f37a5827572a9c63b..3731532f42612869ba05a670b8583693a4662bd1 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 @@ -107,7 +107,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> Program.load cctxt >>=? fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list + List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return_unit); command ~group diff --git a/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml b/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml index 5691950cc3622afb347ae4f47fbb75e3d311815d..826edfce9ed28fb0ff0c1d8c648e542a87608f9e 100644 --- a/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml +++ b/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml @@ -48,7 +48,7 @@ let get_script (rpc : #Alpha_client_context.rpc_context) ~chain ~block contract let list_contract_labels (cctxt : #Alpha_client_context.full) ~chain ~block = Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> - rev_map_s + List.rev_map_es (fun h -> ( match Contract.is_implicit h with | Some m -> ( diff --git a/src/proto_004_Pt24m4xi/lib_client/client_proto_contracts.ml b/src/proto_004_Pt24m4xi/lib_client/client_proto_contracts.ml index e9f47f166c4829e56883c859f45a4b0d669409a2..1980f7736ae1d53ed4abc257e4f1c196f8409abc 100644 --- a/src/proto_004_Pt24m4xi/lib_client/client_proto_contracts.ml +++ b/src/proto_004_Pt24m4xi/lib_client/client_proto_contracts.ml @@ -155,12 +155,12 @@ end let list_contracts cctxt = RawContractAlias.load cctxt >>=? fun raw_contracts -> - Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts + List.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts >>= fun contracts -> Client_keys.Public_key_hash.load cctxt >>=? fun keys -> (* List accounts (implicit contracts of identities) *) - map_s + List.map_es (fun (n, v) -> RawContractAlias.mem cctxt n >>=? fun mem -> diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml index 80a9988157d62dcba6afbff43dc02ff638ade92f..898cfab1f92f0c5c0c5da5a2fe25578183859d19 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_emacs.ml @@ -89,22 +89,23 @@ let print_type_map ppf (parsed, type_map) = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr) items and print_item ppf loc = - try - let ({start = {point = s; _}; stop = {point = e; _}}, locs) = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - in - let locs = List.sort compare locs in - let (bef, aft) = List.assoc (List.hd locs) type_map in - Format.fprintf - ppf - "(@[%d %d %a %a@])@," - s - e - print_stack - bef - print_stack - aft - with Not_found -> () + (let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun hd_loc -> + List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + |> Option.iter (fun (s, e, bef, aft) -> + Format.fprintf + ppf + "(@[%d %d %a %a@])@," + s + e + print_stack + bef + print_stack + aft) in Format.fprintf ppf "(@[%a@])" print_expr_types (root parsed.unexpanded) @@ -151,9 +152,10 @@ let report_errors ppf (parsed, errs) = (fun ppf errs -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in match errs with | top :: errs -> @@ -191,9 +193,10 @@ let report_errors ppf (parsed, errs) = (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in let loc = match err with diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml index 3403e51b3ec2add8944a7a9483ca3eed77a4cf87..4272efc72a2485fd6b3567b32b100541ca9e3d55 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_error_reporter.ml @@ -137,13 +137,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = (Format.asprintf "%a" Micheline_parser.print_location loc)) in let parsed_locations parsed loc = - try - let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table - in - let (ploc, _) = List.assoc oloc parsed.expansion_table in - Some ploc - with Not_found -> None + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + >?? fun oloc -> + List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = 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 4b5bbae81a2cb9cae5d41b4e757b484edc8c6c63..ceb46037d454f330ab267717d7c4f9a6b3ac68ed 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_macros.ml @@ -1010,7 +1010,10 @@ let dxiiivp_roman_of_decimal decimal = let roman = roman_of_decimal decimal in if String.length roman = 1 then (* too short for D*P, fall back to IIIII... *) - String.concat "" (List.init decimal (fun _ -> "I")) + String.concat + "" + ( Result.get_ok + @@ List.init ~when_negative_length:() decimal (fun _ -> "I") ) else roman let unexpand_dxiiivp expanded = diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml index 5a2e5b8d1c1623da260c7d2704279d984bc098a0..fcfc8a3d6fa301194acea9e6d34e833df6266954 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_parser.ml @@ -59,12 +59,19 @@ let expand_all source ast errors = in group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + match + List.map2 + ~when_different_lengths:() + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) + with + | Ok v -> + v + | Error () -> + invalid_arg "Michelson_v1_parser.expand_all" in match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) diff --git a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml index e28a814e941a0a466dca5d550e2b8e5a0728ac78..e31345a9fa8c0bd7101be9a3ce157e76c8245a9e 100644 --- a/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml +++ b/src/proto_004_Pt24m4xi/lib_client/michelson_v1_printer.ml @@ -91,17 +91,19 @@ let inject_types type_map parsed = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let locs = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - |> snd |> List.sort compare - in - let (bef, aft) = List.assoc (List.hd locs) type_map in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun (_, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun head_loc -> + List.assoc head_loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in inject_expr (root parsed.unexpanded) @@ -126,15 +128,16 @@ let unparse ?type_map parse expanded = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let (bef, aft) = - List.assoc (List.assoc loc unexpansion_table) type_map - in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc unexpansion_table + >?? fun loc -> + List.assoc loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in unexpanded |> root |> inject_expr |> Format.asprintf "%a" Micheline_printer.print_expr 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 d7ddc0461c1b1bd9e14674ba60fe13e3c327a8d3..2bed0384c9b2d90d0fc8fa2a33039527b80ba25a 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 @@ -93,7 +93,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> return_unit); diff --git a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_contracts_commands.ml index e3e336045807a752eaa5adf28a18c0341b0fbec9..80850975370ceb7a50d0be3c71ad0847c924e85e 100644 --- a/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_004_Pt24m4xi/lib_client_commands/client_proto_contracts_commands.ml @@ -59,7 +59,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> list_contracts cctxt >>=? fun contracts -> - iter_s + List.iter_es (fun (prefix, alias, contract) -> cctxt#message "%s%s: %s" 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 05f17e3645cd2ec24f59c85f707b2d740dc5578b..eaa22d81fc04f5b8e7c1e8b92192d89e9ebda171 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 @@ -120,7 +120,7 @@ let commands () = (fun () (cctxt : Alpha_client_context.full) -> Program.load cctxt >>=? fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list + List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return_unit); command ~group diff --git a/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml b/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml index 4810999c7c03d2b63a81768f9ec6ce0e6c9fa2f1..c7545528346a7db90c0bfef1f93a2fb23307e112 100644 --- a/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml +++ b/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml @@ -52,7 +52,7 @@ let get_script (rpc : #rpc_context) ~chain ~block contract = let list_contract_labels cctxt ~chain ~block = Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> - rev_map_s + List.rev_map_es (fun h -> ( match Contract.is_implicit h with | Some m -> ( diff --git a/src/proto_005_PsBabyM1/lib_client/client_proto_contracts.ml b/src/proto_005_PsBabyM1/lib_client/client_proto_contracts.ml index d3866ebf330fa0d779e68a16cea048e4c4da4b25..d84a979fd05d866b22813c0ad77b27ef4c859fbe 100644 --- a/src/proto_005_PsBabyM1/lib_client/client_proto_contracts.ml +++ b/src/proto_005_PsBabyM1/lib_client/client_proto_contracts.ml @@ -155,12 +155,12 @@ end let list_contracts cctxt = RawContractAlias.load cctxt >>=? fun raw_contracts -> - Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts + List.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts >>= fun contracts -> Client_keys.Public_key_hash.load cctxt >>=? fun keys -> (* List accounts (implicit contracts of identities) *) - map_s + List.map_es (fun (n, v) -> RawContractAlias.mem cctxt n >>=? fun mem -> diff --git a/src/proto_005_PsBabyM1/lib_client/injection.ml b/src/proto_005_PsBabyM1/lib_client/injection.ml index 6b6488f88df1fe49d20e8b08573fc76dbc555fea..45ef84b149c9d91976eb65395888899929d8b637 100644 --- a/src/proto_005_PsBabyM1/lib_client/injection.ml +++ b/src/proto_005_PsBabyM1/lib_client/injection.ml @@ -779,7 +779,7 @@ let inject_operation (type kind) cctxt ~chain ~block ?confirmations >>= fun () -> Lwt.return (originated_contracts result.contents) >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun c -> cctxt#message "New contract %a originated." Contract.pp c) contracts >>= fun () -> diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml index b142177e0bc755e59ff367a5be2a597879be565f..337ff56bb7f30e989401c0309afe498ffbcc8ce4 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_emacs.ml @@ -89,22 +89,23 @@ let print_type_map ppf (parsed, type_map) = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr) items and print_item ppf loc = - try - let ({start = {point = s; _}; stop = {point = e; _}}, locs) = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - in - let locs = List.sort compare locs in - let (bef, aft) = List.assoc (List.hd locs) type_map in - Format.fprintf - ppf - "(@[%d %d %a %a@])@," - s - e - print_stack - bef - print_stack - aft - with Not_found -> () + (let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun hd_loc -> + List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + |> Option.iter (fun (s, e, bef, aft) -> + Format.fprintf + ppf + "(@[%d %d %a %a@])@," + s + e + print_stack + bef + print_stack + aft) in Format.fprintf ppf "(@[%a@])" print_expr_types (root parsed.unexpanded) @@ -152,9 +153,10 @@ let report_errors ppf (parsed, errs) = (fun ppf errs -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in match errs with | top :: errs -> @@ -192,9 +194,10 @@ let report_errors ppf (parsed, errs) = (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in let loc = match err with diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml index a7597c3786803852f849d81599f58716fb7e8242..2f85546ffe5c6a8f07ae2c51fc02b06996959ee8 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_error_reporter.ml @@ -141,13 +141,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = (Format.asprintf "%a" Micheline_parser.print_location loc)) in let parsed_locations parsed loc = - try - let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table - in - let (ploc, _) = List.assoc oloc parsed.expansion_table in - Some ploc - with Not_found -> None + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + >?? fun oloc -> + List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml index 5a2e5b8d1c1623da260c7d2704279d984bc098a0..fcfc8a3d6fa301194acea9e6d34e833df6266954 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_parser.ml @@ -59,12 +59,19 @@ let expand_all source ast errors = in group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + match + List.map2 + ~when_different_lengths:() + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) + with + | Ok v -> + v + | Error () -> + invalid_arg "Michelson_v1_parser.expand_all" in match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) diff --git a/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml b/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml index 7855ff0ff01ba4c6ba5e56970cbe5abdfd1217d6..aeef79d341fbde0c96e2b0b46fd0b1cab275e1d8 100644 --- a/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml +++ b/src/proto_005_PsBabyM1/lib_client/michelson_v1_printer.ml @@ -130,17 +130,19 @@ let inject_types type_map parsed = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let locs = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - |> snd |> List.sort compare - in - let (bef, aft) = List.assoc (List.hd locs) type_map in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun (_, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun head_loc -> + List.assoc head_loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in inject_expr (root parsed.unexpanded) @@ -165,15 +167,16 @@ let unparse ?type_map parse expanded = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let (bef, aft) = - List.assoc (List.assoc loc unexpansion_table) type_map - in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc unexpansion_table + >?? fun loc -> + List.assoc loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in unexpanded |> root |> inject_expr |> Format.asprintf "%a" Micheline_printer.print_expr 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 487e1712d9dcae42f8792cf60fb152b7faff7e05..54dc1de11c86e62865ecd29ef007e7c363e31830 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 @@ -97,7 +97,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> return_unit); diff --git a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_contracts_commands.ml index 1aa9bd843ff2a012ca390b0605c1e74ca6ab4e73..bb1bea6b3de881d07dfa5a0e95d85ce3e9936478 100644 --- a/src/proto_005_PsBabyM1/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_005_PsBabyM1/lib_client_commands/client_proto_contracts_commands.ml @@ -59,7 +59,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> list_contracts cctxt >>=? fun contracts -> - iter_s + List.iter_es (fun (prefix, alias, contract) -> cctxt#message "%s%s: %s" 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 8bb069be2da282ad097b4e6ac7c51e0137baafcc..7b53b6797fcd8ff113c683ca8263143ef5c9a287 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 @@ -179,7 +179,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> Program.load cctxt >>=? fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list + List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return_unit); command ~group 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 bf469e1ebe401037dbd5575b977b2437933eb95d..97fc10f2cc1a60a3d6cbb9ea2ebe0835670b5736 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml @@ -157,7 +157,7 @@ let delegate_contract cctxt ~chain ~block ?branch ?confirmations ?dry_run let list_contract_labels cctxt ~chain ~block = Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> - rev_map_s + List.rev_map_es (fun h -> ( match Contract.is_implicit h with | Some m -> ( diff --git a/src/proto_006_PsCARTHA/lib_client/client_proto_contracts.ml b/src/proto_006_PsCARTHA/lib_client/client_proto_contracts.ml index d3866ebf330fa0d779e68a16cea048e4c4da4b25..d84a979fd05d866b22813c0ad77b27ef4c859fbe 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_contracts.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_contracts.ml @@ -155,12 +155,12 @@ end let list_contracts cctxt = RawContractAlias.load cctxt >>=? fun raw_contracts -> - Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts + List.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts >>= fun contracts -> Client_keys.Public_key_hash.load cctxt >>=? fun keys -> (* List accounts (implicit contracts of identities) *) - map_s + List.map_es (fun (n, v) -> RawContractAlias.mem cctxt n >>=? fun mem -> diff --git a/src/proto_006_PsCARTHA/lib_client/client_proto_multisig.ml b/src/proto_006_PsCARTHA/lib_client/client_proto_multisig.ml index 7f6d6b509bcccae05176f0f906d7de477d01c178..8a25a33644246ef4e294957170e95a06219344ef 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_multisig.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_multisig.ml @@ -569,7 +569,7 @@ let action_of_expr e = [] ) ], [] ) ], [] ) -> - map_s + List.map_es (function | Tezos_micheline.Micheline.Bytes (_, s) -> return @@ -609,7 +609,7 @@ let multisig_get_information (cctxt : #Protocol_client_context.full) ~chain [ Int (_, counter); Prim (_, D_Pair, [Int (_, threshold); Seq (_, key_nodes)], _) ], _ ) -> - map_s + List.map_es (function | String (_, key_str) -> return @@ Signature.Public_key.of_b58check_exn key_str @@ -624,7 +624,7 @@ let multisig_create_storage ~counter ~threshold ~keys () : Script.expr tzresult Lwt.t = let loc = Tezos_micheline.Micheline_parser.location_zero in let open Tezos_micheline.Micheline in - map_s + List.map_es (fun key -> let key_str = Signature.Public_key.to_b58check key in return (String (loc, key_str))) @@ -643,7 +643,7 @@ let multisig_create_param ~counter ~action ~optional_signatures () : Script.expr tzresult Lwt.t = let loc = Tezos_micheline.Micheline_parser.location_zero in let open Tezos_micheline.Micheline in - map_s + List.map_es (fun sig_opt -> match sig_opt with | None -> @@ -764,7 +764,7 @@ let check_multisig_signatures ~bytes ~threshold ~keys signatures = matching_key_found := true ; opt_sigs_arr.(i) <- Some signature ) in - iter_p + List.iter_ep (fun signature -> matching_key_found := false ; List.iteri (check_signature_against_key_number signature) keys ; diff --git a/src/proto_006_PsCARTHA/lib_client/injection.ml b/src/proto_006_PsCARTHA/lib_client/injection.ml index 6b6488f88df1fe49d20e8b08573fc76dbc555fea..45ef84b149c9d91976eb65395888899929d8b637 100644 --- a/src/proto_006_PsCARTHA/lib_client/injection.ml +++ b/src/proto_006_PsCARTHA/lib_client/injection.ml @@ -779,7 +779,7 @@ let inject_operation (type kind) cctxt ~chain ~block ?confirmations >>= fun () -> Lwt.return (originated_contracts result.contents) >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun c -> cctxt#message "New contract %a originated." Contract.pp c) contracts >>= fun () -> diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml index b142177e0bc755e59ff367a5be2a597879be565f..337ff56bb7f30e989401c0309afe498ffbcc8ce4 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_emacs.ml @@ -89,22 +89,23 @@ let print_type_map ppf (parsed, type_map) = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr) items and print_item ppf loc = - try - let ({start = {point = s; _}; stop = {point = e; _}}, locs) = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - in - let locs = List.sort compare locs in - let (bef, aft) = List.assoc (List.hd locs) type_map in - Format.fprintf - ppf - "(@[%d %d %a %a@])@," - s - e - print_stack - bef - print_stack - aft - with Not_found -> () + (let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun hd_loc -> + List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + |> Option.iter (fun (s, e, bef, aft) -> + Format.fprintf + ppf + "(@[%d %d %a %a@])@," + s + e + print_stack + bef + print_stack + aft) in Format.fprintf ppf "(@[%a@])" print_expr_types (root parsed.unexpanded) @@ -152,9 +153,10 @@ let report_errors ppf (parsed, errs) = (fun ppf errs -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in match errs with | top :: errs -> @@ -192,9 +194,10 @@ let report_errors ppf (parsed, errs) = (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in let loc = match err with diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml index fb078d562d623cca6e5a5d8a0ed4ccd555056986..38065ade1340639c18c3555dd607af46ae0952a8 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_error_reporter.ml @@ -141,13 +141,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = (Format.asprintf "%a" Micheline_parser.print_location loc)) in let parsed_locations parsed loc = - try - let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table - in - let (ploc, _) = List.assoc oloc parsed.expansion_table in - Some ploc - with Not_found -> None + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + >?? fun oloc -> + List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml index 5a2e5b8d1c1623da260c7d2704279d984bc098a0..fcfc8a3d6fa301194acea9e6d34e833df6266954 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_parser.ml @@ -59,12 +59,19 @@ let expand_all source ast errors = in group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + match + List.map2 + ~when_different_lengths:() + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) + with + | Ok v -> + v + | Error () -> + invalid_arg "Michelson_v1_parser.expand_all" in match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) diff --git a/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml b/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml index 7855ff0ff01ba4c6ba5e56970cbe5abdfd1217d6..aeef79d341fbde0c96e2b0b46fd0b1cab275e1d8 100644 --- a/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml +++ b/src/proto_006_PsCARTHA/lib_client/michelson_v1_printer.ml @@ -130,17 +130,19 @@ let inject_types type_map parsed = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let locs = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - |> snd |> List.sort compare - in - let (bef, aft) = List.assoc (List.hd locs) type_map in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun (_, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun head_loc -> + List.assoc head_loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in inject_expr (root parsed.unexpanded) @@ -165,15 +167,16 @@ let unparse ?type_map parse expanded = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let (bef, aft) = - List.assoc (List.assoc loc unexpansion_table) type_map - in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc unexpansion_table + >?? fun loc -> + List.assoc loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in unexpanded |> root |> inject_expr |> Format.asprintf "%a" Micheline_printer.print_expr diff --git a/src/proto_006_PsCARTHA/lib_client/mockup.ml b/src/proto_006_PsCARTHA/lib_client/mockup.ml index 8868e43467dd1b163505da84c90cff2ef9eef10a..5175326fe1bb32b22f20d45975adea5b5ff5dae8 100644 --- a/src/proto_006_PsCARTHA/lib_client/mockup.ml +++ b/src/proto_006_PsCARTHA/lib_client/mockup.ml @@ -189,7 +189,7 @@ let mockup_default_bootstrap_accounts let errors = ref [] in Client_keys.list_keys wallet >>=? fun all_keys -> - Lwt_list.iter_s + List.iter_s (function | (name, pkh, _pk_opt, Some sk_uri) -> ( let contract = @@ -433,7 +433,7 @@ let mem_init : parsed_account_repr_pp) accounts >>= fun () -> - Tezos_base.TzPervasives.map_s to_bootstrap_account accounts + List.map_es to_bootstrap_account accounts >>=? fun bootstrap_accounts -> return (Some bootstrap_accounts) | exception error -> failwith 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 4fadef39c13468483471eb31618f23556099aa89..cf8f287618ba2ed63a160e5cf5aa16caca2c0bbb 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 @@ -216,7 +216,7 @@ let commands network () = (fun () (cctxt : Protocol_client_context.full) -> list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> return_unit); diff --git a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_contracts_commands.ml index 1aa9bd843ff2a012ca390b0605c1e74ca6ab4e73..bb1bea6b3de881d07dfa5a0e95d85ce3e9936478 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_contracts_commands.ml @@ -59,7 +59,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> list_contracts cctxt >>=? fun contracts -> - iter_s + List.iter_es (fun (prefix, alias, contract) -> cctxt#message "%s%s: %s" diff --git a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_multisig_commands.ml index c0d73556114d9f2e7e3bc3abe71981e413d196dd..06a2104d4cfceb2292d05abae2a603a61a43d8bf 100644 --- a/src/proto_006_PsCARTHA/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_006_PsCARTHA/lib_client_commands/client_proto_multisig_commands.ml @@ -192,7 +192,9 @@ let commands () : #Protocol_client_context.full Clic.command list = burn_cap; } in - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + keys >>=? fun keys -> Client_proto_multisig.originate_multisig cctxt @@ -335,7 +337,9 @@ let commands () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys >>=? fun keys -> Client_proto_multisig.prepare_multisig_transaction cctxt @@ -459,7 +463,9 @@ let commands () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys >>=? fun keys -> Client_proto_multisig.prepare_multisig_transaction cctxt 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 8bb069be2da282ad097b4e6ac7c51e0137baafcc..7b53b6797fcd8ff113c683ca8263143ef5c9a287 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 @@ -179,7 +179,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> Program.load cctxt >>=? fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list + List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return_unit); command ~group diff --git a/src/proto_006_PsCARTHA/lib_delegate/client_baking_blocks.ml b/src/proto_006_PsCARTHA/lib_delegate/client_baking_blocks.ml index f4c7de12cdab2953c2b5545189434c1c99382b14..39dd09265cc917ad7092b1440721f0f3cf34a01f 100644 --- a/src/proto_006_PsCARTHA/lib_delegate/client_baking_blocks.ml +++ b/src/proto_006_PsCARTHA/lib_delegate/client_baking_blocks.ml @@ -176,15 +176,16 @@ let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = return_nil | Error _ as err -> Lwt.return err - | Ok (first, last) -> + | Ok (first, last) -> ( let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in Shell_services.Blocks.list cctxt ~chain ~heads:[hash] ~length () - >>=? fun blocks -> - let blocks = - List.remove - (length - Int32.to_int (Raw_level.diff last first)) - (List.hd blocks) - in - if Int32.equal level (Raw_level.to_int32 last) then - return (hash :: blocks) - else return blocks + >>=? function + | [] -> + return_nil + | hd :: _ -> + let blocks = + List.remove (length - Int32.to_int (Raw_level.diff last first)) hd + in + if Int32.equal level (Raw_level.to_int32 last) then + return (hash :: blocks) + else return blocks ) diff --git a/src/proto_006_PsCARTHA/lib_delegate/client_baking_denunciation.ml b/src/proto_006_PsCARTHA/lib_delegate/client_baking_denunciation.ml index 407b69fb8c109093f69672fc12ce12a44dd9ba4f..c9f7e1627ea0a4ca59595d05f04cd2b5d36e31cb 100644 --- a/src/proto_006_PsCARTHA/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_006_PsCARTHA/lib_delegate/client_baking_denunciation.ml @@ -80,7 +80,7 @@ let get_block_offset level = let process_endorsements (cctxt : #Protocol_client_context.full) state (endorsements : Alpha_block_services.operation list) level = - iter_s + List.iter_es (fun {Alpha_block_services.shell; chain_id; receipt; hash; protocol_data; _} -> let chain = `Hash chain_id in @@ -330,11 +330,12 @@ let process_new_block (cctxt : #Protocol_client_context.full) state (* Processing endorsements *) Alpha_block_services.Operations.operations cctxt ~chain ~block () >>= (function - | Ok operations -> - if List.length operations > endorsements_index then - let endorsements = List.nth operations endorsements_index in + | Ok operations -> ( + match List.nth operations endorsements_index with + | Some endorsements -> process_endorsements cctxt state endorsements level - else return_unit + | None -> + return_unit ) | Error errs -> lwt_log_error Tag.DSL.( diff --git a/src/proto_006_PsCARTHA/lib_delegate/client_baking_endorsement.ml b/src/proto_006_PsCARTHA/lib_delegate/client_baking_endorsement.ml index dc173aaa10ca23cc655f579c0262c10aae342b07..8ef2ee02006259c46321b5a37c58b0cd8ecee3cc 100644 --- a/src/proto_006_PsCARTHA/lib_delegate/client_baking_endorsement.ml +++ b/src/proto_006_PsCARTHA/lib_delegate/client_baking_endorsement.ml @@ -255,7 +255,7 @@ let prepare_endorsement ~(max_past : int64) () in get_delegates cctxt state >>=? fun delegates -> - filter_p (allowed_to_endorse cctxt bi) delegates + List.filter_ep (allowed_to_endorse cctxt bi) delegates >>=? fun delegates -> state.pending <- Some {time; block = bi; delegates} ; return_unit @@ -293,7 +293,7 @@ let create (cctxt : #Protocol_client_context.full) ?(max_past = 110L) ~delay in let timeout_k cctxt state (block, delegates) = state.pending <- None ; - iter_s + List.iter_es (fun delegate -> endorse_for_delegate cctxt block delegate >>= function diff --git a/src/proto_006_PsCARTHA/lib_delegate/client_baking_forge.ml b/src/proto_006_PsCARTHA/lib_delegate/client_baking_forge.ml index 3294697623af92999ace34c86dbc789e59f70060..fb9f20896e1c846a51b557c0bb709ef0893feaf1 100644 --- a/src/proto_006_PsCARTHA/lib_delegate/client_baking_forge.ml +++ b/src/proto_006_PsCARTHA/lib_delegate/client_baking_forge.ml @@ -158,7 +158,7 @@ let assert_valid_operations_hash shell_header operations = let compute_endorsing_power cctxt ~chain ~block operations = Shell_services.Chain.chain_id cctxt ~chain () >>=? fun chain_id -> - fold_left_s + List.fold_left_es (fun sum -> function | { Alpha_context.protocol_data = Operation_data {contents = Single (Endorsement _); _}; @@ -260,7 +260,7 @@ let get_manager_operation_gas_and_fee op = let {protocol_data = Operation_data {contents; _}; _} = op in let open Operation in let l = to_list (Contents_list contents) in - fold_left_s + List.fold_left_es (fun ((total_fee, total_gas) as acc) -> function | Contents (Manager_operation {fee; gas_limit; _}) -> (Lwt.return @@ Environment.wrap_error @@ Tez.(total_fee +? fee)) @@ -283,7 +283,7 @@ let sort_manager_operations ~max_size ~hard_gas_limit_per_block ~minimal_fees let gas_ratio = Q.(gas_f / Q.of_bigint hard_gas_limit_per_block) in (size, gas, Q.(fee_f / max size_ratio gas_ratio)) in - filter_map_s + List.filter_map_es (fun op -> get_manager_operation_gas_and_fee op >>=? fun (fee, gas) -> @@ -342,7 +342,7 @@ let retain_operations_up_to_quota operations quota = let trim_manager_operations ~max_size ~hard_gas_limit_per_block manager_operations = - map_s + List.map_es (fun op -> get_manager_operation_gas_and_fee op >>=? fun (_fee, gas) -> @@ -397,7 +397,7 @@ let classify_operations (cctxt : #Protocol_client_context.full) ~chain ~block (* Retrieve the optimist maximum paying manager operations *) let manager_operations = t.(managers_index) in let {Environment.Updater.max_size; _} = - List.nth Main.validation_passes managers_index + Option.get @@ List.nth Main.validation_passes managers_index in sort_manager_operations ~max_size @@ -483,20 +483,20 @@ let decode_priority cctxt chain block ~priority ~endorsing_power = ~delegates:[src_pkh] (chain, block) >>=? fun possibilities -> - try - let {Alpha_services.Delegate.Baking_rights.priority = prio; _} = - List.find - (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level) - possibilities - in - Alpha_services.Delegate.Minimal_valid_time.get - cctxt - (chain, block) - prio - endorsing_power - >>=? fun minimal_timestamp -> return (prio, minimal_timestamp) - with Not_found -> - failwith "No slot found at level %a" Raw_level.pp level ) + match + List.find + (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level) + possibilities + with + | Some {Alpha_services.Delegate.Baking_rights.priority = prio; _} -> + Alpha_services.Delegate.Minimal_valid_time.get + cctxt + (chain, block) + prio + endorsing_power + >>=? fun minimal_timestamp -> return (prio, minimal_timestamp) + | None -> + failwith "No slot found at level %a" Raw_level.pp level ) let unopt_timestamp ?(force = false) timestamp minimal_timestamp = let timestamp = @@ -601,10 +601,10 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority state.index <- index ; return inc) >>=? fun initial_inc -> - let endorsements = List.nth operations endorsements_index in - let votes = List.nth operations votes_index in - let anonymous = List.nth operations anonymous_index in - let managers = List.nth operations managers_index in + let endorsements = Option.get @@ List.nth operations endorsements_index in + let votes = Option.get @@ List.nth operations votes_index in + let anonymous = Option.get @@ List.nth operations anonymous_index in + let managers = Option.get @@ List.nth operations managers_index in let validate_operation inc op = protect (fun () -> add_operation inc op) >>= function @@ -642,7 +642,7 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority >>= fun () -> Lwt.return_none ) in let filter_valid_operations inc ops = - Lwt_list.fold_left_s + List.fold_left_s (fun (inc, acc) op -> validate_operation inc op >>= function @@ -672,15 +672,17 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority let quota : Environment.Updater.quota list = Main.validation_passes in let {Constants.hard_gas_limit_per_block; _} = state.constants.parametric in let votes = - retain_operations_up_to_quota (List.rev votes) (List.nth quota votes_index) + retain_operations_up_to_quota + (List.rev votes) + (Option.get @@ List.nth quota votes_index) in let anonymous = retain_operations_up_to_quota (List.rev anonymous) - (List.nth quota anonymous_index) + (Option.get @@ List.nth quota anonymous_index) in trim_manager_operations - ~max_size:(List.nth quota managers_index).max_size + ~max_size:(Option.get @@ List.nth quota managers_index).max_size ~hard_gas_limit_per_block managers >>=? fun (accepted_managers, _overflowing_managers) -> @@ -712,7 +714,7 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority state.index block_info >>=? fun inc -> - fold_left_s + List.fold_left_es (fun inc op -> add_operation inc op >>=? fun (inc, _receipt) -> return inc) inc (List.flatten operations) @@ -797,20 +799,22 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) (* Ensure that we retain operations up to the quota *) let quota : Environment.Updater.quota list = Main.validation_passes in let endorsements = - List.sub (List.nth operations endorsements_index) endorsers_per_block + List.sub + (Option.get @@ List.nth operations endorsements_index) + endorsers_per_block in let votes = retain_operations_up_to_quota - (List.nth operations votes_index) - (List.nth quota votes_index) + (Option.get @@ List.nth operations votes_index) + (Option.get @@ List.nth quota votes_index) in let anonymous = retain_operations_up_to_quota - (List.nth operations anonymous_index) - (List.nth quota anonymous_index) + (Option.get @@ List.nth operations anonymous_index) + (Option.get @@ List.nth quota anonymous_index) in (* Size/Gas check already occurred in classify operations *) - let managers = List.nth operations managers_index in + let managers = Option.get @@ List.nth operations managers_index in let operations = [endorsements; votes; anonymous; managers] in ( match context_path with | None -> diff --git a/src/proto_006_PsCARTHA/lib_delegate/client_baking_lib.ml b/src/proto_006_PsCARTHA/lib_delegate/client_baking_lib.ml index 72f1b91a6d810885c37a10eb5ae057e81a9dcd28..face4ba87e2cab04f1f057255ad447d39786268d 100644 --- a/src/proto_006_PsCARTHA/lib_delegate/client_baking_lib.ml +++ b/src/proto_006_PsCARTHA/lib_delegate/client_baking_lib.ml @@ -123,7 +123,7 @@ let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block >>=? fun nonces_location -> Client_baking_nonces.load cctxt nonces_location) >>=? fun nonces -> - Lwt_list.filter_map_p + List.filter_map_p (fun hash -> Lwt.catch (fun () -> @@ -138,7 +138,7 @@ let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block >>= fun () -> Lwt.return_none)) block_hashes >>= fun block_infos -> - filter_map_s + List.filter_map_es (fun (bi : Client_baking_blocks.block_info) -> match Client_baking_nonces.find_opt nonces bi.hash with | None -> diff --git a/src/proto_006_PsCARTHA/lib_delegate/client_baking_nonces.ml b/src/proto_006_PsCARTHA/lib_delegate/client_baking_nonces.ml index 7002359cbbd99d75ead1e3c6e05b4e5c93b941ff..7a47c7a6a8b93098ce6c7402f916ab94a03e04da 100644 --- a/src/proto_006_PsCARTHA/lib_delegate/client_baking_nonces.ml +++ b/src/proto_006_PsCARTHA/lib_delegate/client_baking_nonces.ml @@ -156,7 +156,7 @@ let get_unrevealed_nonces cctxt location nonces = ~offset:(-1l) () >>=? fun blocks -> - filter_map_s + List.filter_map_es (fun hash -> match find_opt nonces hash with | None -> diff --git a/src/proto_006_PsCARTHA/lib_delegate/client_baking_revelation.ml b/src/proto_006_PsCARTHA/lib_delegate/client_baking_revelation.ml index 02bc973484a2a0f1be27cf753e2b1d7a310e1005..6aa5d9bc9a8ad3a710fbb27b0b0624ea8beaaf06 100644 --- a/src/proto_006_PsCARTHA/lib_delegate/client_baking_revelation.ml +++ b/src/proto_006_PsCARTHA/lib_delegate/client_baking_revelation.ml @@ -43,7 +43,7 @@ let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain -% a Block_hash.Logging.tag hash) >>= fun () -> return_unit | _ -> - iter_s + List.iter_es (fun (level, nonce) -> Alpha_services.Forge.seed_nonce_revelation cctxt diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/activation.ml b/src/proto_006_PsCARTHA/lib_protocol/test/activation.ml index 4238541617d45d3f237987fc1954fc6445c0808d..998c028c87823243ecb23366c2768139cac4a2b5 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/activation.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/activation.ml @@ -316,7 +316,7 @@ let single_activation () = activation_init () >>=? fun (blk, _contracts, secrets) -> let ({account; activation_code; amount = expected_amount; _} as _first_one) = - List.hd secrets + Option.get @@ List.hd secrets in (* Contract does not exist *) Assert.balance_is @@ -340,7 +340,7 @@ let single_activation () = let multi_activation_1 () = activation_init () >>=? fun (blk, _contracts, secrets) -> - Error_monad.fold_left_s + List.fold_left_es (fun blk {account; activation_code; amount = expected_amount; _} -> Op.activation (B blk) account activation_code >>=? fun operation -> @@ -360,7 +360,7 @@ let multi_activation_1 () = let multi_activation_2 () = activation_init () >>=? fun (blk, _contracts, secrets) -> - Error_monad.fold_left_s + List.fold_left_es (fun ops {account; activation_code; _} -> Op.activation (B blk) account activation_code >>=? fun op -> return (op :: ops)) @@ -369,7 +369,7 @@ let multi_activation_2 () = >>=? fun ops -> Block.bake ~operations:ops blk >>=? fun blk -> - Error_monad.iter_s + List.iter_es (fun {account; amount = expected_amount; _} -> (* Contract does exist *) Assert.balance_is @@ -383,8 +383,10 @@ let multi_activation_2 () = let activation_and_transfer () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; activation_code; _} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in + let bootstrap_contract = Option.get @@ List.hd contracts in let first_contract = Contract.implicit_contract account in Op.activation (B blk) account activation_code >>=? fun operation -> @@ -411,8 +413,10 @@ let activation_and_transfer () = let transfer_to_unactivated_then_activate () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; activation_code; amount} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; activation_code; amount} as _first_one) = + Option.get @@ List.hd secrets + in + let bootstrap_contract = Option.get @@ List.hd contracts in let unactivated_commitment_contract = Contract.implicit_contract account in Context.Contract.balance (B blk) bootstrap_contract >>=? fun b_amount -> @@ -451,7 +455,9 @@ let invalid_activation_with_no_commitments () = Context.init 1 >>=? fun (blk, _) -> let secrets = secrets () in - let ({account; activation_code; _} as _first_one) = List.hd secrets in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in Op.activation (B blk) account activation_code >>=? fun operation -> Block.bake ~operation blk @@ -466,8 +472,10 @@ let invalid_activation_with_no_commitments () = let invalid_activation_wrong_secret () = activation_init () >>=? fun (blk, _, secrets) -> - let ({account; _} as _first_one) = List.nth secrets 0 in - let ({activation_code; _} as _second_one) = List.nth secrets 1 in + let ({account; _} as _first_one) = Option.get @@ List.nth secrets 0 in + let ({activation_code; _} as _second_one) = + Option.get @@ List.nth secrets 1 + in Op.activation (B blk) account activation_code >>=? fun operation -> Block.bake ~operation blk @@ -483,7 +491,7 @@ let invalid_activation_wrong_secret () = let invalid_activation_inexistent_pkh () = activation_init () >>=? fun (blk, _, secrets) -> - let ({activation_code; _} as _first_one) = List.hd secrets in + let ({activation_code; _} as _first_one) = Option.get @@ List.hd secrets in let inexistent_pkh = Signature.Public_key_hash.of_b58check_exn "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" @@ -503,7 +511,9 @@ let invalid_activation_inexistent_pkh () = let invalid_double_activation () = activation_init () >>=? fun (blk, _, secrets) -> - let ({account; activation_code; _} as _first_one) = List.hd secrets in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in Incremental.begin_construction blk >>=? fun inc -> Op.activation (I inc) account activation_code @@ -524,8 +534,8 @@ let invalid_double_activation () = let invalid_transfer_from_unactived_account () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; _} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; _} as _first_one) = Option.get @@ List.hd secrets in + let bootstrap_contract = Option.get @@ List.hd contracts in let unactivated_commitment_contract = Contract.implicit_contract account in (* No activation *) Op.transaction diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/baking.ml b/src/proto_006_PsCARTHA/lib_protocol/test/baking.ml index df561ff26cc24a1208e3eff5213d9e603db2c421..076415f7d928806ef9ee70accf07568be64f362f 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/baking.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/baking.ml @@ -102,11 +102,11 @@ let test_rewards_retrieval () = let block_priorities = 0 -- 10 in let included_endorsements = 0 -- endorsers_per_block in let ranges = List.product block_priorities included_endorsements in - iter_s + List.iter_es (fun (priority, endorsing_power) -> (* bake block at given priority and with given endorsing_power *) let real_endorsers = List.sub endorsers endorsing_power in - map_p + List.map_ep (fun endorser -> Op.endorsement ~delegate:endorser.delegate (B good_b) () >>=? fun operation -> return (Operation.pack operation)) @@ -147,7 +147,7 @@ let test_rewards_retrieval () = accumulated_frozen_balance ) >>=? fun () -> (* check the each endorser was rewarded the right amount *) - iter_p + List.iter_ep (fun endorser -> balance_update endorser.delegate good_b b >>=? fun endorser_frozen_balance -> @@ -174,7 +174,7 @@ let test_rewards_formulas () = let block_priorities = 0 -- 2 in let included_endorsements = 0 -- endorsers_per_block in let ranges = List.product block_priorities included_endorsements in - iter_p + List.iter_ep (fun (priority, endorsing_power) -> Context.get_baking_reward (B b) ~priority ~endorsing_power >>=? fun reward -> @@ -214,7 +214,7 @@ let test_rewards_formulas_equivalence () = let block_priorities = 0 -- 64 in let endorsing_power = 0 -- endorsers_per_block in let ranges = List.product block_priorities endorsing_power in - iter_p + List.iter_ep (fun (block_priority, endorsing_power) -> Baking.baking_reward ctxt diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/combined_operations.ml b/src/proto_006_PsCARTHA/lib_protocol/test/combined_operations.ml index 166d319a082da570f72c8d51dd0c922e6d73ddaf..6b458c33dbe045c797da2c6af587b278ddcc2e33 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/combined_operations.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/combined_operations.ml @@ -43,10 +43,10 @@ let ten_tez = Tez.of_int 10 let multiple_transfers () = Context.init 3 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in - let c3 = List.nth contracts 2 in - map_s (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10) + let (c1, c2, c3) = + match contracts with [c1; c2; c3] -> (c1, c2, c3) | _ -> assert false + in + List.map_es (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10) >>=? fun ops -> Op.combine_operations ~source:c1 (B blk) ops >>=? fun operation -> @@ -77,15 +77,16 @@ let multiple_transfers () = let multiple_origination_and_delegation () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in let n = 10 in Context.get_constants (B blk) >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> Context.Contract.pkh c2 >>=? fun delegate_pkh -> (* Deploy n smart contracts with dummy scripts from c1 *) - map_s + List.map_es (fun i -> Op.origination ~delegate:delegate_pkh @@ -147,7 +148,7 @@ let multiple_origination_and_delegation () = >>=? fun total_cost -> Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost >>=? fun () -> - iter_s + List.iter_es (fun c -> Assert.balance_is ~loc:__LOC__ (I inc) c (Tez.of_int 10)) new_contracts >>=? fun () -> return_unit @@ -166,8 +167,9 @@ let expect_balance_too_low = function let failing_operation_in_the_middle () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.max_tez @@ -222,8 +224,9 @@ let failing_operation_in_the_middle () = let failing_operation_in_the_middle_with_fees () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.max_tez diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/delegation.ml b/src/proto_006_PsCARTHA/lib_protocol/test/delegation.ml index f770b525bbc2c5d134a563b8bfe39df84b02fedc..df3626c1cfce3b4478888e6945df1d50f596aaae 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/delegation.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/delegation.ml @@ -53,7 +53,7 @@ let expect_no_change_registered_delegate_pkh pkh = function let bootstrap_manager_is_bootstrap_delegate () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.hd bootstrap_contracts in + let bootstrap0 = Option.get @@ List.hd bootstrap_contracts in Context.Contract.delegate (B b) bootstrap0 >>=? fun delegate0 -> Context.Contract.manager (B b) bootstrap0 @@ -63,8 +63,8 @@ let bootstrap_manager_is_bootstrap_delegate () = let bootstrap_delegate_cannot_change ~fee () = Context.init 2 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.nth bootstrap_contracts 0 in - let bootstrap1 = List.nth bootstrap_contracts 1 in + let bootstrap0 = Option.get @@ List.nth bootstrap_contracts 0 in + let bootstrap1 = Option.get @@ List.nth bootstrap_contracts 1 in Context.Contract.pkh bootstrap0 >>=? fun pkh1 -> Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) @@ -106,7 +106,7 @@ let bootstrap_delegate_cannot_change ~fee () = let bootstrap_delegate_cannot_be_removed ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Incremental.begin_construction b >>=? fun i -> Context.Contract.balance (I i) bootstrap @@ -144,8 +144,8 @@ let bootstrap_delegate_cannot_be_removed ~fee () = let delegate_can_be_changed_from_unregistered_contract ~fee () = Context.init 2 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.hd bootstrap_contracts in - let bootstrap1 = List.nth bootstrap_contracts 1 in + let bootstrap0 = Option.get @@ List.hd bootstrap_contracts in + let bootstrap1 = Option.get @@ List.nth bootstrap_contracts 1 in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let unregistered = Contract.implicit_contract unregistered_pkh in @@ -197,7 +197,7 @@ let delegate_can_be_changed_from_unregistered_contract ~fee () = let delegate_can_be_removed_from_unregistered_contract ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let unregistered = Contract.implicit_contract unregistered_pkh in @@ -252,7 +252,7 @@ let bootstrap_manager_already_registered_delegate ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun manager -> let pkh = manager.pkh in @@ -289,7 +289,7 @@ let delegate_to_bootstrap_by_origination ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun manager -> Context.Contract.balance (I i) bootstrap @@ -486,7 +486,7 @@ let unregistered_delegate_key_init_origination ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in (* origination with delegate argument *) @@ -537,7 +537,7 @@ let unregistered_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -587,7 +587,7 @@ let unregistered_delegate_key_switch_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -646,7 +646,7 @@ let unregistered_delegate_key_init_origination_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -697,7 +697,7 @@ let unregistered_delegate_key_init_delegation_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -755,7 +755,7 @@ let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -823,7 +823,7 @@ let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -881,7 +881,7 @@ let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -944,7 +944,7 @@ let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -1041,7 +1041,7 @@ let failed_self_delegation_emptied_implicit_contract amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let unregistered_pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -1075,7 +1075,7 @@ let emptying_delegated_implicit_contract_fails amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun bootstrap_manager -> let account = Account.new_account () in @@ -1115,7 +1115,7 @@ let valid_delegate_registration_init_delegation_credit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1168,7 +1168,7 @@ let valid_delegate_registration_switch_delegation_credit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1222,7 +1222,7 @@ let valid_delegate_registration_init_delegation_credit_debit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1290,7 +1290,7 @@ let valid_delegate_registration_switch_delegation_credit_debit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1356,7 +1356,7 @@ let double_registration () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1389,7 +1389,7 @@ let double_registration_when_empty () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1429,7 +1429,7 @@ let double_registration_when_recredited () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1476,7 +1476,7 @@ let unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; _} = Account.new_account () in let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in @@ -1511,7 +1511,7 @@ let unregistered_and_revealed_self_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; pk; _} = Account.new_account () in let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in @@ -1550,7 +1550,7 @@ let registered_self_delegate_key_init_delegation () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; _} = Account.new_account () in let {Account.pkh = delegate_pkh; pk = delegate_pk; _} = Account.new_account () diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/double_baking.ml b/src/proto_006_PsCARTHA/lib_protocol/test/double_baking.ml index 61dbca2294d8badb397768c7e9e32f042fe69be6..eef905537711bb0b2be7d46fd1459037a0c38c20 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/double_baking.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/double_baking.ml @@ -33,8 +33,10 @@ open Alpha_context (* Utility functions *) (****************************************************************) +let get_hd_hd = function x :: y :: _ -> (x, y) | _ -> assert false + let get_first_different_baker baker bakers = - return + return @@ Option.get @@ List.find (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') bakers @@ -42,23 +44,18 @@ let get_first_different_baker baker bakers = let get_first_different_bakers ctxt = Context.get_bakers ctxt >>=? fun bakers -> - let baker_1 = List.hd bakers in - get_first_different_baker baker_1 (List.tl bakers) + let baker_1 = Option.get @@ List.hd bakers in + get_first_different_baker baker_1 (Option.get @@ List.tl bakers) >>=? fun baker_2 -> return (baker_1, baker_2) let get_first_different_endorsers ctxt = Context.get_endorsers ctxt - >>=? fun endorsers -> - let endorser_1 = (List.hd endorsers).delegate in - let endorser_2 = (List.hd (List.tl endorsers)).delegate in - return (endorser_1, endorser_2) + >>=? fun endorsers -> return @@ get_hd_hd endorsers (** Bake two block at the same level using the same policy (i.e. same baker) *) let block_fork ?policy contracts b = - let (contract_a, contract_b) = - (List.hd contracts, List.hd (List.tl contracts)) - in + let (contract_a, contract_b) = get_hd_hd contracts in Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent >>=? fun operation -> Block.bake ?policy ~operation b @@ -75,7 +72,7 @@ let valid_double_baking_evidence () = >>=? fun (b, contracts) -> Context.get_bakers (B b) >>=? fun bakers -> - let priority_0_baker = List.hd bakers in + let priority_0_baker = Option.get @@ List.hd bakers in block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> Op.double_baking (B blk_a) blk_a.header blk_b.header @@ -83,7 +80,7 @@ let valid_double_baking_evidence () = Block.bake ~policy:(Excluding [priority_0_baker]) ~operation blk_a >>=? fun blk -> (* Check that the frozen deposit, the fees and rewards are removed *) - iter_s + List.iter_es (fun kind -> let contract = Alpha_context.Contract.implicit_contract priority_0_baker @@ -157,7 +154,7 @@ let too_late_double_baking_evidence () = >>=? fun Constants.{parametric = {preserved_cycles; _}; _} -> block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> - fold_left_s + List.fold_left_es (fun blk _ -> Block.bake_until_cycle_end blk) blk_a (1 -- (preserved_cycles + 1)) diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/double_endorsement.ml b/src/proto_006_PsCARTHA/lib_protocol/test/double_endorsement.ml index accc3c0ded72d7f22965479cbfff5f4a69214b74..4cd328575f07740c2cb81694663d9bad7b775305 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/double_endorsement.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/double_endorsement.ml @@ -33,25 +33,26 @@ open Alpha_context (* Utility functions *) (****************************************************************) +let get_hd_hd = function x :: y :: _ -> (x, y) | _ -> assert false + let get_first_different_baker baker bakers = - return + return @@ Option.get @@ List.find (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') bakers let get_first_different_bakers ctxt = Context.get_bakers ctxt - >>=? fun bakers -> - let baker_1 = List.hd bakers in - get_first_different_baker baker_1 (List.tl bakers) - >>=? fun baker_2 -> return (baker_1, baker_2) + >>=? function + | [] -> + assert false + | baker_1 :: other_bakers -> + get_first_different_baker baker_1 other_bakers + >>=? fun baker_2 -> return (baker_1, baker_2) let get_first_different_endorsers ctxt = Context.get_endorsers ctxt - >>=? fun endorsers -> - let endorser_1 = List.hd endorsers in - let endorser_2 = List.hd (List.tl endorsers) in - return (endorser_1, endorser_2) + >>=? fun endorsers -> return @@ get_hd_hd endorsers let block_fork b = get_first_different_bakers (B b) @@ -92,7 +93,7 @@ let valid_double_endorsement_evidence () = Block.bake ~policy:(By_account baker) ~operation blk_a >>=? fun blk -> (* Check that the frozen deposit, the fees and rewards are removed *) - iter_s + List.iter_es (fun kind -> let contract = Alpha_context.Contract.implicit_contract delegate in Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero) @@ -161,7 +162,7 @@ let too_late_double_endorsement_evidence () = >>=? fun endorsement_a -> Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b -> - fold_left_s + List.fold_left_es (fun blk _ -> Block.bake_until_cycle_end blk) blk_a (1 -- (preserved_cycles + 1)) @@ -215,10 +216,11 @@ let different_delegates () = let wrong_delegate () = Context.init ~endorsers_per_block:1 2 >>=? fun (b, contracts) -> - Error_monad.map_s (Context.Contract.manager (B b)) contracts + List.map_es (Context.Contract.manager (B b)) contracts >>=? fun accounts -> - let pkh1 = (List.nth accounts 0).Account.pkh in - let pkh2 = (List.nth accounts 1).Account.pkh in + let (account_1, account_2) = get_hd_hd accounts in + let pkh1 = account_1.Account.pkh in + let pkh2 = account_2.Account.pkh in block_fork b >>=? fun (blk_a, blk_b) -> Context.get_endorser (B blk_a) diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/endorsement.ml b/src/proto_006_PsCARTHA/lib_protocol/test/endorsement.ml index 017ae980518e6c27313c191d8527e088e10a3a8b..db62bad546c66c3f85ec6e6236d5f9bfc16bda27 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/endorsement.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/endorsement.ml @@ -38,6 +38,8 @@ open Test_tez (* Utility functions *) (****************************************************************) +let get_hd_hd = function x :: y :: _ -> (x, y) | _ -> assert false + let get_expected_reward ctxt ~priority ~baker ~endorsing_power = ( if baker then Context.get_baking_reward ctxt ~priority ~endorsing_power else return (Test_tez.Tez.of_int 0) ) @@ -135,7 +137,7 @@ let max_endorsement () = endorsers))) endorsers_per_block >>=? fun () -> - fold_left_s + List.fold_left_es (fun (delegates, ops, balances) (endorser : Alpha_services.Delegate.Endorsing_rights.t) -> let delegate = endorser.delegate in @@ -154,22 +156,24 @@ let max_endorsement () = >>=? fun b -> (* One account can endorse more than one time per level, we must check that the bonds are summed up *) - iter_s - (fun (endorser_account, (endorsing_power, previous_balance)) -> + List.iter2_es + ~when_different_lengths:(TzTrace.make (Exn (Failure __LOC__))) + (fun endorser_account (endorsing_power, previous_balance) -> assert_endorser_balance_consistency ~loc:__LOC__ (B b) ~endorsing_power endorser_account previous_balance) - (List.combine delegates previous_balances) + delegates + previous_balances (** Check every that endorsers' balances are consistent with different priorities *) let consistent_priorities () = let priorities = 0 -- 64 in Context.init 64 >>=? fun (b, _) -> - fold_left_s + List.fold_left_es (fun (b, used_pkhes) priority -> (* Choose an endorser that has not baked nor endorsed before *) Context.get_endorsers (B b) @@ -237,7 +241,7 @@ let reward_retrieval () = Block.bake ~policy ~operation b >>=? fun b -> (* Bake (preserved_cycles + 1) cycles *) - fold_left_s + List.fold_left_es (fun b _ -> Block.bake_until_cycle_end ~policy:(Excluding [endorser]) b) b (0 -- preserved_cycles) @@ -267,8 +271,7 @@ let reward_retrieval_two_endorsers () = _ } -> Context.get_endorsers (B b) >>=? fun endorsers -> - let endorser1 = List.hd endorsers in - let endorser2 = List.hd (List.tl endorsers) in + let (endorser1, endorser2) = get_hd_hd endorsers in Context.Contract.balance (B b) (Contract.implicit_contract endorser1.delegate) @@ -332,7 +335,7 @@ let reward_retrieval_two_endorsers () = Signature.Public_key_hash.( endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate) in - let endorser2 = List.find same_endorser2 endorsers in + let endorser2 = Option.get @@ List.find same_endorser2 endorsers in (* No exception raised: in sandboxed mode endorsers do not change between blocks *) Lwt.return Tez.( @@ -366,7 +369,7 @@ let reward_retrieval_two_endorsers () = security_deposit2 >>=? fun () -> (* bake [preserved_cycles] cycles *) - fold_left_s + List.fold_left_es (fun b _ -> Assert.balance_was_debited ~loc:__LOC__ @@ -486,7 +489,7 @@ let duplicate_endorsement () = let not_enough_for_deposit () = Context.init 5 ~endorsers_per_block:1 >>=? fun (b_init, contracts) -> - Error_monad.map_s + List.map_es (fun c -> Context.Contract.manager (B b_init) c >>=? fun m -> return (m, c)) contracts @@ -497,15 +500,17 @@ let not_enough_for_deposit () = Context.get_endorser (B b) >>=? fun (endorser, _slots) -> let (_, contract_other_than_endorser) = - List.find - (fun (c, _) -> - not (Signature.Public_key_hash.equal c.Account.pkh endorser)) - managers + Option.get + @@ List.find + (fun (c, _) -> + not (Signature.Public_key_hash.equal c.Account.pkh endorser)) + managers in let (_, contract_of_endorser) = - List.find - (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser) - managers + Option.get + @@ List.find + (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser) + managers in Context.Contract.balance (B b) (Contract.implicit_contract endorser) >>=? fun initial_balance -> @@ -543,14 +548,14 @@ let endorsement_threshold () = let num_endorsers = List.length endorsers in (* we try to bake with more and more endorsers, but at each iteration with a timestamp smaller than required *) - iter_s + List.iter_es (fun i -> (* the priority is chosen rather arbitrarily *) let priority = num_endorsers - i in let crt_endorsers = List.take_n i endorsers in let endorsing_power = endorsing_power crt_endorsers in let delegates = delegates_with_slots crt_endorsers in - map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates + List.map_es (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates >>=? fun ops -> Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> @@ -580,7 +585,7 @@ let endorsement_threshold () = let priority = 0 in let endorsing_power = endorsing_power endorsers in let delegates = delegates_with_slots endorsers in - map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates + List.map_es (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates >>=? fun ops -> Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/helpers/block.ml b/src/proto_006_PsCARTHA/lib_protocol/test/helpers/block.ml index 121632b82204f3effdd2d57c97325bbbd80e4504..7b9ca5c91dfe1273023b85d63cb58e9fdff3f449 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/helpers/block.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/helpers/block.ml @@ -67,10 +67,11 @@ let get_next_baker_by_priority priority block = block >>=? fun bakers -> let {Alpha_services.Delegate.Baking_rights.delegate = pkh; timestamp; _} = - List.find - (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} -> - p = priority) - bakers + Option.get + @@ List.find + (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} -> + p = priority) + bakers in return (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -85,7 +86,7 @@ let get_next_baker_by_account pkh block = timestamp; priority; _ } = - List.hd bakers + Option.get @@ List.hd bakers in return (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -96,10 +97,11 @@ let get_next_baker_excluding excludes block = timestamp; priority; _ } = - List.find - (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> - not (List.mem delegate excludes)) - bakers + Option.get + @@ List.find + (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> + not (List.mem delegate excludes)) + bakers in return (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -114,7 +116,7 @@ let dispatch_policy = function let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy let get_endorsing_power b = - fold_left_s + List.fold_left_es (fun acc (op : Operation.packed) -> let (Operation_data data) = op.protocol_data in match data.contents with @@ -333,8 +335,9 @@ let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers } in (* Check there is at least one roll *) - ( try - fold_left_s + Lwt.catch + (fun () -> + List.fold_left_es (fun acc (_, amount) -> Environment.wrap_error @@ Tez_repr.( +? ) acc amount >>?= fun acc -> @@ -342,8 +345,8 @@ let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers Tez_repr.zero initial_accounts >>=? fun _ -> - failwith "Insufficient tokens in initial accounts to create one roll" - with Exit -> return_unit ) + failwith "Insufficient tokens in initial accounts to create one roll") + (function Exit -> return_unit | exc -> raise exc) >>=? fun () -> check_constants_consistency constants >>=? fun () -> @@ -418,7 +421,7 @@ let bake ?policy ?timestamp ?operation ?operations pred = let get_constants b = Alpha_services.Constants.all rpc_ctxt b let bake_n ?policy n b = - Error_monad.fold_left_s (fun b _ -> bake ?policy b) b (1 -- n) + List.fold_left_es (fun b _ -> bake ?policy b) b (1 -- n) let bake_until_cycle_end ?policy b = get_constants b @@ -429,7 +432,7 @@ let bake_until_cycle_end ?policy b = bake_n ?policy (Int32.to_int delta) b let bake_until_n_cycle_end ?policy n b = - Error_monad.fold_left_s (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) + List.fold_left_es (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) let bake_until_cycle ?policy cycle (b : t) = get_constants b diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/helpers/context.ml b/src/proto_006_PsCARTHA/lib_protocol/test/helpers/context.ml index a7606169f339516376c850d5ba792dac114819e6..4651e43261ca81b4524d405a40bba8cdaf7efb9c 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/helpers/context.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/helpers/context.ml @@ -109,7 +109,7 @@ let get_endorsers ctxt = let get_endorser ctxt = Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt >>=? fun endorsers -> - let endorser = List.hd endorsers in + let endorser = Option.get @@ List.hd endorsers in return (endorser.delegate, endorser.slots) let get_bakers ctxt = diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/helpers/op.ml b/src/proto_006_PsCARTHA/lib_protocol/test/helpers/op.ml index d202dadd345fcf557ea20abc15ba3b9ade88f8c8..298f52b61033c192c66ba8abeacc28876519680e 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/helpers/op.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/helpers/op.ml @@ -66,7 +66,9 @@ let combine_operations ?public_key ?counter ~source ctxt (packed_operations : packed_operation list) = assert (List.length packed_operations > 0) ; (* Hypothesis : each operation must have the same branch (is this really true?) *) - let {Tezos_base.Operation.branch} = (List.hd packed_operations).shell in + let {Tezos_base.Operation.branch} = + (Option.get @@ List.hd packed_operations).shell + in assert ( List.for_all (fun {shell = {Tezos_base.Operation.branch = b; _}; _} -> diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/origination.ml b/src/proto_006_PsCARTHA/lib_protocol/test/origination.ml index 7b257260e30a9b338f7311a5a007fa71a6736839..2b70e315971637e27d38170a4530e02b633f0615 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/origination.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/origination.ml @@ -37,7 +37,7 @@ let ten_tez = Tez.of_int 10 let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) () = Context.init 1 >>=? fun (b, contracts) -> - let source = List.hd contracts in + let source = Option.get @@ List.hd contracts in Context.Contract.balance (B b) source >>=? fun source_balance -> Op.origination (B b) source ~fee ~credit ~script:Op.dummy_script @@ -82,7 +82,7 @@ let test_origination_balances ~loc:_ ?(fee = Tez.zero) ?(credit = Tez.zero) () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Context.Contract.balance (B b) contract >>=? fun balance -> Op.origination (B b) contract ~fee ~credit ~script:Op.dummy_script @@ -166,8 +166,8 @@ let pay_fee () = let not_tez_in_contract_to_pay_fee () = Context.init 2 >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in + let contract_1 = Option.get @@ List.nth contracts 0 in + let contract_2 = Option.get @@ List.nth contracts 1 in Incremental.begin_construction b >>=? fun inc -> (* transfer everything but one tez from 1 to 2 and check balance of 1 *) @@ -206,7 +206,7 @@ let not_tez_in_contract_to_pay_fee () = let register_contract_get_endorser () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Incremental.begin_construction b >>=? fun inc -> Context.get_endorser (I inc) @@ -220,7 +220,7 @@ let register_contract_get_endorser () = (*******************) let n_originations n ?credit ?fee () = - fold_left_s + List.fold_left_es (fun new_contracts _ -> register_origination ?fee ?credit () >>=? fun (_b, _source, new_contract) -> @@ -242,7 +242,7 @@ let multiple_originations () = let counter () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Incremental.begin_construction b >>=? fun inc -> Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/seed.ml b/src/proto_006_PsCARTHA/lib_protocol/test/seed.ml index b6c43c2071be4268d5305fce44ac27cae4c3b355..c41c4b0abd9cf528d832d6c5b31bd45855945f25 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/seed.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/seed.ml @@ -205,7 +205,7 @@ let revelation_early_wrong_right_twice () = false) >>=? fun () -> (* bake [preserved_cycles] cycles excluding [id] *) - Error_monad.fold_left_s + List.fold_left_es (fun b _ -> Block.bake_until_cycle_end ~policy b) b (1 -- preserved_cycles) diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/transfer.ml b/src/proto_006_PsCARTHA/lib_protocol/test/transfer.ml index 53bccb63cde7934e0961e262a8b4ac9d913547c4..c974e6da26a122ecd062384d229b6feb2722006a 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/transfer.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/transfer.ml @@ -113,7 +113,7 @@ let transfer_to_itself_and_check_balances ~loc b ?(fee = Tez.zero) contract a destination contract with the amount "n" times. *) let n_transactions n b ?fee source dest amount = - fold_left_s + List.fold_left_es (fun b _ -> transfer_and_check_balances ~loc:__LOC__ b ?fee source dest amount >>=? fun (b, _) -> return b) @@ -128,10 +128,11 @@ let ten_tez = Tez.of_int 10 let register_two_contracts () = Context.init 2 - >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in - return (b, contract_1, contract_2) + >>=? function + | (b, [contract_1; contract_2]) -> + return (b, contract_1, contract_2) + | _ -> + assert false (** compute half of the balance and divided by nth times *) @@ -189,7 +190,7 @@ let transfer_zero_tez () = let transfer_zero_implicit () = Context.init 1 >>=? fun (b, contracts) -> - let dest = List.nth contracts 0 in + let dest = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in Incremental.begin_construction b >>=? fun i -> @@ -212,7 +213,7 @@ let transfer_zero_implicit () = let transfer_to_originate_with_fee () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in Incremental.begin_construction b >>=? fun b -> two_nth_of_balance b contract 10L @@ -256,7 +257,7 @@ let transfer_amount_of_contract_balance () = let transfers_to_self () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in Incremental.begin_construction b >>=? fun b -> two_nth_of_balance b contract 3L @@ -305,7 +306,7 @@ let missing_transaction () = let transfer_from_implicit_to_implicit_contract () = Context.init 1 >>=? fun (b, contracts) -> - let bootstrap_contract = List.nth contracts 0 in + let bootstrap_contract = Option.get @@ List.nth contracts 0 in let account_a = Account.new_account () in let account_b = Account.new_account () in Incremental.begin_construction b @@ -346,8 +347,8 @@ let transfer_from_implicit_to_implicit_contract () = let transfer_from_implicit_to_originated_contract () = Context.init 1 >>=? fun (b, contracts) -> - let bootstrap_contract = List.nth contracts 0 in - let contract = List.nth contracts 0 in + let bootstrap_contract = Option.get @@ List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in let src = Contract.implicit_contract account.Account.pkh in Incremental.begin_construction b @@ -448,7 +449,7 @@ let build_a_chain () = register_two_contracts () >>=? fun (b, contract_1, contract_2) -> let ten = Tez.of_int 10 in - fold_left_s + List.fold_left_es (fun b _ -> Incremental.begin_construction b >>=? fun b -> @@ -470,7 +471,7 @@ let build_a_chain () = let empty_implicit () = Context.init 1 >>=? fun (b, contracts) -> - let dest = List.nth contracts 0 in + let dest = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in Incremental.begin_construction b >>=? fun incr -> @@ -533,9 +534,9 @@ let balance_too_low fee () = let balance_too_low_two_transfers fee () = Context.init 3 >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in - let contract_3 = List.nth contracts 2 in + let contract_1 = Option.get @@ List.nth contracts 0 in + let contract_2 = Option.get @@ List.nth contracts 1 in + let contract_3 = Option.get @@ List.nth contracts 2 in Incremental.begin_construction b >>=? fun i -> Context.Contract.balance (I i) contract_1 diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/voting.ml b/src/proto_006_PsCARTHA/lib_protocol/test/voting.ml index 3de561f73190c730264d59ada8d2fe092b90fa3c..bb37575f1ee5637a555a5fc2531aa0e2a30a5e68 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/voting.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/voting.ml @@ -113,7 +113,7 @@ let get_delegates_and_rolls_from_listings b = let get_rolls b delegates loc = Context.Vote.get_listings (B b) >>=? fun l -> - map_s + List.map_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -199,8 +199,8 @@ let test_successful_vote num_delegates () = | Some _ -> failwith "%s - Unexpected proposal" __LOC__) >>=? fun () -> - let del1 = List.nth delegates_p1 0 in - let del2 = List.nth delegates_p1 1 in + let del1 = Option.get @@ List.nth delegates_p1 0 in + let del2 = Option.get @@ List.nth delegates_p1 1 in let props = List.map (fun i -> protos.(i)) (2 -- Constants.max_proposals_per_delegate) in @@ -214,7 +214,11 @@ let test_successful_vote num_delegates () = Context.Vote.get_proposals (B b) >>=? fun ps -> (* correctly count the double proposal for zero *) - (let weight = Int32.add (List.nth rolls_p1 0) (List.nth rolls_p1 1) in + (let weight = + Int32.add + (Option.get @@ List.nth rolls_p1 0) + (Option.get @@ List.nth rolls_p1 1) + in match Environment.Protocol_hash.(Map.find_opt zero ps) with | Some v -> if v = weight then return_unit @@ -296,7 +300,7 @@ let test_successful_vote num_delegates () = failwith "%s - Missing proposal" __LOC__) >>=? fun () -> (* unanimous vote: all delegates --active when p2 started-- vote *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) delegates_p2 >>=? fun operations -> @@ -312,7 +316,7 @@ let test_successful_vote num_delegates () = | _ -> false) >>=? fun () -> - fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls_p2 + List.fold_left_es (fun v acc -> return Int32.(add v acc)) 0l rolls_p2 >>=? fun rolls_sum -> (* # of Yays in ballots matches rolls of the delegate *) Context.Vote.get_ballots (B b) @@ -331,7 +335,7 @@ let test_successful_vote num_delegates () = | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ | l -> - iter_s + List.iter_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -433,13 +437,13 @@ let test_successful_vote num_delegates () = failwith "%s - Missing proposal" __LOC__) >>=? fun () -> (* unanimous vote: all delegates --active when p4 started-- vote *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) delegates_p4 >>=? fun operations -> Block.bake ~operations b >>=? fun b -> - fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls_p4 + List.fold_left_es (fun v acc -> return Int32.(add v acc)) 0l rolls_p4 >>=? fun rolls_sum -> (* # of Yays in ballots matches rolls of the delegate *) Context.Vote.get_ballots (B b) @@ -458,7 +462,7 @@ let test_successful_vote num_delegates () = | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ | l -> - iter_s + List.iter_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -490,7 +494,7 @@ let test_successful_vote num_delegates () = return the first k active delegates with which one can have quorum, that is: their roll sum divided by the total roll sum is bigger than pr_ema_weight/den *) let get_smallest_prefix_voters_for_quorum active_delegates active_rolls = - fold_left_s (fun v acc -> return Int32.(add v acc)) 0l active_rolls + List.fold_left_es (fun v acc -> return Int32.(add v acc)) 0l active_rolls >>=? fun active_rolls_sum -> let rec loop delegates rolls sum selected = match (delegates, rolls) with @@ -515,9 +519,9 @@ let get_expected_participation_ema rolls voter_rolls old_participation_ema = + (pr_num * participation) ) / den in - fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls + List.fold_left_es (fun v acc -> return Int32.(add v acc)) 0l rolls >>=? fun rolls_sum -> - fold_left_s (fun v acc -> return Int32.(add v acc)) 0l voter_rolls + List.fold_left_es (fun v acc -> return Int32.(add v acc)) 0l voter_rolls >>=? fun voter_rolls_sum -> let participation = Int32.to_int voter_rolls_sum * percent_mul / Int32.to_int rolls_sum @@ -541,7 +545,7 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -567,12 +571,12 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2 >>=? fun voters -> (* take the first two voters out so there cannot be quorum *) - let voters_without_quorum = List.tl voters in + let voters_without_quorum = Option.get @@ List.tl voters in get_rolls b voters_without_quorum __LOC__ >>=? fun voters_rolls_in_testing_vote -> (* all voters_without_quorum vote, for yays; no nays, so supermajority is satisfied *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters_without_quorum >>=? fun operations -> @@ -619,7 +623,7 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -645,7 +649,9 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = let open Alpha_context in (* all voters vote, for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters + List.map_es + (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) + voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -679,12 +685,12 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = get_smallest_prefix_voters_for_quorum delegates_p4 rolls_p4 >>=? fun voters -> (* take the first voter out so there cannot be quorum *) - let voters_without_quorum = List.tl voters in + let voters_without_quorum = Option.get @@ List.tl voters in get_rolls b voters_without_quorum __LOC__ >>=? fun voter_rolls -> (* all voters_without_quorum vote, for yays; no nays, so supermajority is satisfied *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters_without_quorum >>=? fun operations -> @@ -722,7 +728,7 @@ let test_multiple_identical_proposals_count_as_one () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - let proposer = List.hd delegates in + let proposer = Option.get @@ List.hd delegates in Op.proposals (B b) proposer [Protocol_hash.zero; Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -765,29 +771,37 @@ let test_supermajority_in_proposal there_is_a_winner () = >>=? fun { parametric = {blocks_per_cycle; blocks_per_voting_period; tokens_per_roll; _}; _ } -> - let del1 = List.nth delegates 0 in - let del2 = List.nth delegates 1 in - let del3 = List.nth delegates 2 in - map_s (fun del -> Context.Contract.pkh del) [del1; del2; del3] + let del1 = Option.get @@ List.nth delegates 0 in + let del2 = Option.get @@ List.nth delegates 1 in + let del3 = Option.get @@ List.nth delegates 2 in + List.map_es (fun del -> Context.Contract.pkh del) [del1; del2; del3] >>=? fun pkhs -> let policy = Block.Excluding pkhs in - Op.transaction (B b) (List.nth delegates 3) del1 tokens_per_roll + Op.transaction + (B b) + (Option.get @@ List.nth delegates 3) + del1 + tokens_per_roll >>=? fun op1 -> - Op.transaction (B b) (List.nth delegates 4) del2 tokens_per_roll + Op.transaction + (B b) + (Option.get @@ List.nth delegates 4) + del2 + tokens_per_roll >>=? fun op2 -> ( if there_is_a_winner then Test_tez.Tez.( *? ) tokens_per_roll 3L else Test_tez.Tez.( *? ) tokens_per_roll 2L ) >>?= fun bal3 -> - Op.transaction (B b) (List.nth delegates 5) del3 bal3 + Op.transaction (B b) (Option.get @@ List.nth delegates 5) del3 bal3 >>=? fun op3 -> Block.bake ~policy ~operations:[op1; op2; op3] b >>=? fun b -> (* we let one voting period pass; we make sure that: - the three selected delegates remain active by re-registering as delegates - their number of rolls do not change *) - fold_left_s + List.fold_left_es (fun b _ -> - Error_monad.map_s + List.map_es (fun del -> Context.Contract.pkh del >>=? fun pkh -> Op.delegation (B b) del (Some pkh)) @@ -841,9 +855,9 @@ let test_quorum_in_proposal has_quorum () = min_proposal_quorum; _ }; _ } -> - let del1 = List.nth delegates 0 in - let del2 = List.nth delegates 1 in - map_s (fun del -> Context.Contract.pkh del) [del1; del2] + let del1 = Option.get @@ List.nth delegates 0 in + let del2 = Option.get @@ List.nth delegates 1 in + List.map_es (fun del -> Context.Contract.pkh del) [del1; del2] >>=? fun pkhs -> let policy = Block.Excluding pkhs in let quorum = @@ -860,9 +874,9 @@ let test_quorum_in_proposal has_quorum () = (* we let one voting period pass; we make sure that: - the two selected delegates remain active by re-registering as delegates - their number of rolls do not change *) - fold_left_s + List.fold_left_es (fun b _ -> - Error_monad.map_s + List.map_es (fun del -> Context.Contract.pkh del >>=? fun pkh -> Op.delegation (B b) del (Some pkh)) @@ -906,7 +920,7 @@ let test_supermajority_in_testing_vote supermajority () = >>=? fun (b, delegates) -> Context.get_constants (B b) >>=? fun {parametric = {blocks_per_voting_period; _}; _} -> - let del1 = List.nth delegates 0 in + let del1 = Option.get @@ List.nth delegates 0 in let proposal = protos.(0) in Op.proposals (B b) del1 [proposal] >>=? fun ops1 -> @@ -946,9 +960,9 @@ let test_supermajority_in_testing_vote supermajority () = let open Alpha_context in let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in let (yays_delegates, _) = List.split_n num_yays rest in - map_s (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates + List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates >>=? fun operations_yays -> - map_s (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates + List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates >>=? fun operations_nays -> let operations = operations_yays @ operations_nays in Block.bake ~operations b @@ -989,7 +1003,7 @@ let test_no_winning_proposal num_delegates () = List.map (fun i -> protos.(i)) (1 -- Constants.max_proposals_per_delegate) in (* all delegates active in p1 propose the same proposals *) - map_s (fun del -> Op.proposals (B b) del props) delegates_p1 + List.map_es (fun del -> Op.proposals (B b) del props) delegates_p1 >>=? fun ops_list -> Block.bake ~operations:ops_list b >>=? fun b -> @@ -1029,7 +1043,7 @@ let test_quorum_capped_maximum num_delegates () = >>=? fun () -> (* propose a new protocol *) let protocol = Protocol_hash.zero in - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [protocol] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -1055,7 +1069,7 @@ let test_quorum_capped_maximum num_delegates () = in let voters = List.take_n minimum_to_pass delegates in (* all voters vote for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -1093,7 +1107,7 @@ let test_quorum_capped_minimum num_delegates () = >>=? fun () -> (* propose a new protocol *) let protocol = Protocol_hash.zero in - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [protocol] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -1119,7 +1133,7 @@ let test_quorum_capped_minimum num_delegates () = in let voters = List.take_n minimum_to_pass delegates in (* all voters vote for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> diff --git a/src/proto_007_PsDELPH1/lib_client/client_proto_context.ml b/src/proto_007_PsDELPH1/lib_client/client_proto_context.ml index 54b1464368b7ce418b6d590103faeb06e7478c22..82d84e99c255fc157744d8a14b8f9071ccbb6d36 100644 --- a/src/proto_007_PsDELPH1/lib_client/client_proto_context.ml +++ b/src/proto_007_PsDELPH1/lib_client/client_proto_context.ml @@ -178,7 +178,7 @@ let delegate_contract cctxt ~chain ~block ?branch ?confirmations ?dry_run let list_contract_labels cctxt ~chain ~block = Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> - rev_map_s + List.rev_map_es (fun h -> ( match Contract.is_implicit h with | Some m -> ( diff --git a/src/proto_007_PsDELPH1/lib_client/client_proto_contracts.ml b/src/proto_007_PsDELPH1/lib_client/client_proto_contracts.ml index 1c2d31d07ac7c00a21a9c32a914b656bdbd4259c..f32dfe165ef55d6ba0ed2d562272a60e30bed3fd 100644 --- a/src/proto_007_PsDELPH1/lib_client/client_proto_contracts.ml +++ b/src/proto_007_PsDELPH1/lib_client/client_proto_contracts.ml @@ -157,12 +157,12 @@ end let list_contracts cctxt = RawContractAlias.load cctxt >>=? fun raw_contracts -> - Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts + List.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts >>= fun contracts -> Client_keys.Public_key_hash.load cctxt >>=? fun keys -> (* List accounts (implicit contracts of identities) *) - map_s + List.map_es (fun (n, v) -> RawContractAlias.mem cctxt n >>=? fun mem -> diff --git a/src/proto_007_PsDELPH1/lib_client/client_proto_multisig.ml b/src/proto_007_PsDELPH1/lib_client/client_proto_multisig.ml index 7f6d6b509bcccae05176f0f906d7de477d01c178..8a25a33644246ef4e294957170e95a06219344ef 100644 --- a/src/proto_007_PsDELPH1/lib_client/client_proto_multisig.ml +++ b/src/proto_007_PsDELPH1/lib_client/client_proto_multisig.ml @@ -569,7 +569,7 @@ let action_of_expr e = [] ) ], [] ) ], [] ) -> - map_s + List.map_es (function | Tezos_micheline.Micheline.Bytes (_, s) -> return @@ -609,7 +609,7 @@ let multisig_get_information (cctxt : #Protocol_client_context.full) ~chain [ Int (_, counter); Prim (_, D_Pair, [Int (_, threshold); Seq (_, key_nodes)], _) ], _ ) -> - map_s + List.map_es (function | String (_, key_str) -> return @@ Signature.Public_key.of_b58check_exn key_str @@ -624,7 +624,7 @@ let multisig_create_storage ~counter ~threshold ~keys () : Script.expr tzresult Lwt.t = let loc = Tezos_micheline.Micheline_parser.location_zero in let open Tezos_micheline.Micheline in - map_s + List.map_es (fun key -> let key_str = Signature.Public_key.to_b58check key in return (String (loc, key_str))) @@ -643,7 +643,7 @@ let multisig_create_param ~counter ~action ~optional_signatures () : Script.expr tzresult Lwt.t = let loc = Tezos_micheline.Micheline_parser.location_zero in let open Tezos_micheline.Micheline in - map_s + List.map_es (fun sig_opt -> match sig_opt with | None -> @@ -764,7 +764,7 @@ let check_multisig_signatures ~bytes ~threshold ~keys signatures = matching_key_found := true ; opt_sigs_arr.(i) <- Some signature ) in - iter_p + List.iter_ep (fun signature -> matching_key_found := false ; List.iteri (check_signature_against_key_number signature) keys ; diff --git a/src/proto_007_PsDELPH1/lib_client/injection.ml b/src/proto_007_PsDELPH1/lib_client/injection.ml index 931ec5d1a70f80f551142e0d6edaf95989eea40d..19dc69e7a5e9784262855fc26b9ef940e223171f 100644 --- a/src/proto_007_PsDELPH1/lib_client/injection.ml +++ b/src/proto_007_PsDELPH1/lib_client/injection.ml @@ -879,7 +879,7 @@ let inject_operation (type kind) cctxt ~chain ~block ?confirmations >>= fun () -> Lwt.return (originated_contracts result.contents) >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun c -> cctxt#message "New contract %a originated." Contract.pp c) contracts >>= fun () -> diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml index b142177e0bc755e59ff367a5be2a597879be565f..337ff56bb7f30e989401c0309afe498ffbcc8ce4 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_emacs.ml @@ -89,22 +89,23 @@ let print_type_map ppf (parsed, type_map) = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr) items and print_item ppf loc = - try - let ({start = {point = s; _}; stop = {point = e; _}}, locs) = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - in - let locs = List.sort compare locs in - let (bef, aft) = List.assoc (List.hd locs) type_map in - Format.fprintf - ppf - "(@[%d %d %a %a@])@," - s - e - print_stack - bef - print_stack - aft - with Not_found -> () + (let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun hd_loc -> + List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + |> Option.iter (fun (s, e, bef, aft) -> + Format.fprintf + ppf + "(@[%d %d %a %a@])@," + s + e + print_stack + bef + print_stack + aft) in Format.fprintf ppf "(@[%a@])" print_expr_types (root parsed.unexpanded) @@ -152,9 +153,10 @@ let report_errors ppf (parsed, errs) = (fun ppf errs -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in match errs with | top :: errs -> @@ -192,9 +194,10 @@ let report_errors ppf (parsed, errs) = (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in let loc = match err with diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml index b541819613cd7e216bbc18196b4f717e78de0dc0..f2cf26ee5dbbf0e0c72bc8cbb9aa56a4f8a2bc78 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_error_reporter.ml @@ -141,13 +141,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = (Format.asprintf "%a" Micheline_parser.print_location loc)) in let parsed_locations parsed loc = - try - let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table - in - let (ploc, _) = List.assoc oloc parsed.expansion_table in - Some ploc - with Not_found -> None + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + >?? fun oloc -> + List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml index 5a2e5b8d1c1623da260c7d2704279d984bc098a0..fcfc8a3d6fa301194acea9e6d34e833df6266954 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_parser.ml @@ -59,12 +59,19 @@ let expand_all source ast errors = in group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + match + List.map2 + ~when_different_lengths:() + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) + with + | Ok v -> + v + | Error () -> + invalid_arg "Michelson_v1_parser.expand_all" in match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) diff --git a/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml b/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml index 458a735a65c11cf598124ca71f9dd7fc34a72431..6f329e53e3aed628b8087c711e7b6b16b51d277f 100644 --- a/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml +++ b/src/proto_007_PsDELPH1/lib_client/michelson_v1_printer.ml @@ -130,17 +130,19 @@ let inject_types type_map parsed = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let locs = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - |> snd |> List.sort compare - in - let (bef, aft) = List.assoc (List.hd locs) type_map in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >>= ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >>= fun (_, locs) -> + let locs = List.sort compare locs in + List.hd locs + >>= fun head_loc -> + List.assoc head_loc type_map + >>= fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in inject_expr (root parsed.unexpanded) @@ -165,15 +167,16 @@ let unparse ?type_map parse expanded = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let (bef, aft) = - List.assoc (List.assoc loc unexpansion_table) type_map - in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >>= ) = Option.bind in + List.assoc loc unexpansion_table + >>= fun loc -> + List.assoc loc type_map + >>= fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in unexpanded |> root |> inject_expr |> Format.asprintf "%a" Micheline_printer.print_expr diff --git a/src/proto_007_PsDELPH1/lib_client/mockup.ml b/src/proto_007_PsDELPH1/lib_client/mockup.ml index 1fa44f9512e3dfd22cc03316fdd84aae63451ad0..f1dc0d4bc85623dec253df1bf547f3ad6b820c54 100644 --- a/src/proto_007_PsDELPH1/lib_client/mockup.ml +++ b/src/proto_007_PsDELPH1/lib_client/mockup.ml @@ -192,7 +192,7 @@ let mockup_default_bootstrap_accounts let errors = ref [] in Client_keys.list_keys wallet >>=? fun all_keys -> - Lwt_list.iter_s + List.iter_s (function | (name, pkh, _pk_opt, Some sk_uri) -> ( let contract = @@ -439,7 +439,7 @@ let mem_init : parsed_account_repr_pp) accounts >>= fun () -> - Tezos_base.TzPervasives.map_s to_bootstrap_account accounts + List.map_es to_bootstrap_account accounts >>=? fun bootstrap_accounts -> return (Some bootstrap_accounts) | exception error -> failwith 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 78df0e578a6854d7c081d8a104f3b3f6874d9a8c..f0358cde8fe0e61c81b3d90084e66dad163223fe 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 @@ -277,7 +277,7 @@ let commands network () = (fun () (cctxt : Protocol_client_context.full) -> list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> return_unit); @@ -840,7 +840,7 @@ let commands network () = >>=? fun (_, src_pk, src_sk) -> return (source, src_pk, src_sk) ) >>=? fun (source, src_pk, src_sk) -> - mapi_p prepare operations + List.mapi_ep prepare operations >>=? fun contents -> let (Manager_list contents) = Injection.manager_of_list contents in Injection.inject_manager_operation diff --git a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_contracts_commands.ml index 1aa9bd843ff2a012ca390b0605c1e74ca6ab4e73..bb1bea6b3de881d07dfa5a0e95d85ce3e9936478 100644 --- a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_contracts_commands.ml @@ -59,7 +59,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> list_contracts cctxt >>=? fun contracts -> - iter_s + List.iter_es (fun (prefix, alias, contract) -> cctxt#message "%s%s: %s" diff --git a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_multisig_commands.ml index c0d73556114d9f2e7e3bc3abe71981e413d196dd..06a2104d4cfceb2292d05abae2a603a61a43d8bf 100644 --- a/src/proto_007_PsDELPH1/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_007_PsDELPH1/lib_client_commands/client_proto_multisig_commands.ml @@ -192,7 +192,9 @@ let commands () : #Protocol_client_context.full Clic.command list = burn_cap; } in - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + keys >>=? fun keys -> Client_proto_multisig.originate_multisig cctxt @@ -335,7 +337,9 @@ let commands () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys >>=? fun keys -> Client_proto_multisig.prepare_multisig_transaction cctxt @@ -459,7 +463,9 @@ let commands () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys >>=? fun keys -> Client_proto_multisig.prepare_multisig_transaction cctxt 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 440b7034187f2dccdda389d6da738cb8d66d55f4..4fd58ddee036367afca9edbdd05ce35d82292d90 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 @@ -179,7 +179,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> Program.load cctxt >>=? fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list + List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return_unit); command ~group diff --git a/src/proto_007_PsDELPH1/lib_delegate/client_baking_blocks.ml b/src/proto_007_PsDELPH1/lib_delegate/client_baking_blocks.ml index f4c7de12cdab2953c2b5545189434c1c99382b14..39dd09265cc917ad7092b1440721f0f3cf34a01f 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/client_baking_blocks.ml +++ b/src/proto_007_PsDELPH1/lib_delegate/client_baking_blocks.ml @@ -176,15 +176,16 @@ let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = return_nil | Error _ as err -> Lwt.return err - | Ok (first, last) -> + | Ok (first, last) -> ( let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in Shell_services.Blocks.list cctxt ~chain ~heads:[hash] ~length () - >>=? fun blocks -> - let blocks = - List.remove - (length - Int32.to_int (Raw_level.diff last first)) - (List.hd blocks) - in - if Int32.equal level (Raw_level.to_int32 last) then - return (hash :: blocks) - else return blocks + >>=? function + | [] -> + return_nil + | hd :: _ -> + let blocks = + List.remove (length - Int32.to_int (Raw_level.diff last first)) hd + in + if Int32.equal level (Raw_level.to_int32 last) then + return (hash :: blocks) + else return blocks ) diff --git a/src/proto_007_PsDELPH1/lib_delegate/client_baking_denunciation.ml b/src/proto_007_PsDELPH1/lib_delegate/client_baking_denunciation.ml index 407b69fb8c109093f69672fc12ce12a44dd9ba4f..c9f7e1627ea0a4ca59595d05f04cd2b5d36e31cb 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_007_PsDELPH1/lib_delegate/client_baking_denunciation.ml @@ -80,7 +80,7 @@ let get_block_offset level = let process_endorsements (cctxt : #Protocol_client_context.full) state (endorsements : Alpha_block_services.operation list) level = - iter_s + List.iter_es (fun {Alpha_block_services.shell; chain_id; receipt; hash; protocol_data; _} -> let chain = `Hash chain_id in @@ -330,11 +330,12 @@ let process_new_block (cctxt : #Protocol_client_context.full) state (* Processing endorsements *) Alpha_block_services.Operations.operations cctxt ~chain ~block () >>= (function - | Ok operations -> - if List.length operations > endorsements_index then - let endorsements = List.nth operations endorsements_index in + | Ok operations -> ( + match List.nth operations endorsements_index with + | Some endorsements -> process_endorsements cctxt state endorsements level - else return_unit + | None -> + return_unit ) | Error errs -> lwt_log_error Tag.DSL.( diff --git a/src/proto_007_PsDELPH1/lib_delegate/client_baking_endorsement.ml b/src/proto_007_PsDELPH1/lib_delegate/client_baking_endorsement.ml index dc173aaa10ca23cc655f579c0262c10aae342b07..8ef2ee02006259c46321b5a37c58b0cd8ecee3cc 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/client_baking_endorsement.ml +++ b/src/proto_007_PsDELPH1/lib_delegate/client_baking_endorsement.ml @@ -255,7 +255,7 @@ let prepare_endorsement ~(max_past : int64) () in get_delegates cctxt state >>=? fun delegates -> - filter_p (allowed_to_endorse cctxt bi) delegates + List.filter_ep (allowed_to_endorse cctxt bi) delegates >>=? fun delegates -> state.pending <- Some {time; block = bi; delegates} ; return_unit @@ -293,7 +293,7 @@ let create (cctxt : #Protocol_client_context.full) ?(max_past = 110L) ~delay in let timeout_k cctxt state (block, delegates) = state.pending <- None ; - iter_s + List.iter_es (fun delegate -> endorse_for_delegate cctxt block delegate >>= function diff --git a/src/proto_007_PsDELPH1/lib_delegate/client_baking_forge.ml b/src/proto_007_PsDELPH1/lib_delegate/client_baking_forge.ml index ba42034375b2412b3e5737d8f06c8141a9692990..968ed41f60e544fc0a8d65ca2d32c911f22fc6a9 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/client_baking_forge.ml +++ b/src/proto_007_PsDELPH1/lib_delegate/client_baking_forge.ml @@ -158,7 +158,7 @@ let assert_valid_operations_hash shell_header operations = let compute_endorsing_power cctxt ~chain ~block operations = Shell_services.Chain.chain_id cctxt ~chain () >>=? fun chain_id -> - fold_left_s + List.fold_left_es (fun sum -> function | { Alpha_context.protocol_data = Operation_data {contents = Single (Endorsement _); _}; @@ -260,7 +260,7 @@ let get_manager_operation_gas_and_fee op = let {protocol_data = Operation_data {contents; _}; _} = op in let open Operation in let l = to_list (Contents_list contents) in - fold_left_s + List.fold_left_es (fun ((total_fee, total_gas) as acc) -> function | Contents (Manager_operation {fee; gas_limit; _}) -> (Lwt.return @@ Environment.wrap_error @@ Tez.(total_fee +? fee)) @@ -287,7 +287,7 @@ let sort_manager_operations ~max_size ~hard_gas_limit_per_block ~minimal_fees in (size, gas, Q.(fee_f / max size_ratio gas_ratio)) in - filter_map_s + List.filter_map_es (fun op -> get_manager_operation_gas_and_fee op >>=? fun (fee, gas) -> @@ -347,7 +347,7 @@ let retain_operations_up_to_quota operations quota = let trim_manager_operations ~max_size ~hard_gas_limit_per_block manager_operations = - map_s + List.map_es (fun op -> get_manager_operation_gas_and_fee op >>=? fun (_fee, gas) -> @@ -402,7 +402,7 @@ let classify_operations (cctxt : #Protocol_client_context.full) ~chain ~block (* Retrieve the optimist maximum paying manager operations *) let manager_operations = t.(managers_index) in let {Environment.Updater.max_size; _} = - List.nth Main.validation_passes managers_index + Option.get @@ List.nth Main.validation_passes managers_index in sort_manager_operations ~max_size @@ -488,20 +488,20 @@ let decode_priority cctxt chain block ~priority ~endorsing_power = ~delegates:[src_pkh] (chain, block) >>=? fun possibilities -> - try - let {Alpha_services.Delegate.Baking_rights.priority = prio; _} = - List.find - (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level) - possibilities - in - Alpha_services.Delegate.Minimal_valid_time.get - cctxt - (chain, block) - prio - endorsing_power - >>=? fun minimal_timestamp -> return (prio, minimal_timestamp) - with Not_found -> - failwith "No slot found at level %a" Raw_level.pp level ) + match + List.find + (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level) + possibilities + with + | Some {Alpha_services.Delegate.Baking_rights.priority = prio; _} -> + Alpha_services.Delegate.Minimal_valid_time.get + cctxt + (chain, block) + prio + endorsing_power + >>=? fun minimal_timestamp -> return (prio, minimal_timestamp) + | None -> + failwith "No slot found at level %a" Raw_level.pp level ) let unopt_timestamp ?(force = false) timestamp minimal_timestamp = let timestamp = @@ -606,10 +606,10 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority state.index <- index ; return inc) >>=? fun initial_inc -> - let endorsements = List.nth operations endorsements_index in - let votes = List.nth operations votes_index in - let anonymous = List.nth operations anonymous_index in - let managers = List.nth operations managers_index in + let endorsements = Option.get @@ List.nth operations endorsements_index in + let votes = Option.get @@ List.nth operations votes_index in + let anonymous = Option.get @@ List.nth operations anonymous_index in + let managers = Option.get @@ List.nth operations managers_index in let validate_operation inc op = protect (fun () -> add_operation inc op) >>= function @@ -647,7 +647,7 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority >>= fun () -> Lwt.return_none ) in let filter_valid_operations inc ops = - Lwt_list.fold_left_s + List.fold_left_s (fun (inc, acc) op -> validate_operation inc op >>= function @@ -677,15 +677,17 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority let quota : Environment.Updater.quota list = Main.validation_passes in let {Constants.hard_gas_limit_per_block; _} = state.constants.parametric in let votes = - retain_operations_up_to_quota (List.rev votes) (List.nth quota votes_index) + retain_operations_up_to_quota + (List.rev votes) + (Option.get @@ List.nth quota votes_index) in let anonymous = retain_operations_up_to_quota (List.rev anonymous) - (List.nth quota anonymous_index) + (Option.get @@ List.nth quota anonymous_index) in trim_manager_operations - ~max_size:(List.nth quota managers_index).max_size + ~max_size:(Option.get @@ List.nth quota managers_index).max_size ~hard_gas_limit_per_block managers >>=? fun (accepted_managers, _overflowing_managers) -> @@ -717,7 +719,7 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority state.index block_info >>=? fun inc -> - fold_left_s + List.fold_left_es (fun inc op -> add_operation inc op >>=? fun (inc, _receipt) -> return inc) inc (List.flatten operations) @@ -802,20 +804,22 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) (* Ensure that we retain operations up to the quota *) let quota : Environment.Updater.quota list = Main.validation_passes in let endorsements = - List.sub (List.nth operations endorsements_index) endorsers_per_block + List.sub + (Option.get @@ List.nth operations endorsements_index) + endorsers_per_block in let votes = retain_operations_up_to_quota - (List.nth operations votes_index) - (List.nth quota votes_index) + (Option.get @@ List.nth operations votes_index) + (Option.get @@ List.nth quota votes_index) in let anonymous = retain_operations_up_to_quota - (List.nth operations anonymous_index) - (List.nth quota anonymous_index) + (Option.get @@ List.nth operations anonymous_index) + (Option.get @@ List.nth quota anonymous_index) in (* Size/Gas check already occurred in classify operations *) - let managers = List.nth operations managers_index in + let managers = Option.get @@ List.nth operations managers_index in let operations = [endorsements; votes; anonymous; managers] in ( match context_path with | None -> diff --git a/src/proto_007_PsDELPH1/lib_delegate/client_baking_lib.ml b/src/proto_007_PsDELPH1/lib_delegate/client_baking_lib.ml index 72f1b91a6d810885c37a10eb5ae057e81a9dcd28..face4ba87e2cab04f1f057255ad447d39786268d 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/client_baking_lib.ml +++ b/src/proto_007_PsDELPH1/lib_delegate/client_baking_lib.ml @@ -123,7 +123,7 @@ let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block >>=? fun nonces_location -> Client_baking_nonces.load cctxt nonces_location) >>=? fun nonces -> - Lwt_list.filter_map_p + List.filter_map_p (fun hash -> Lwt.catch (fun () -> @@ -138,7 +138,7 @@ let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block >>= fun () -> Lwt.return_none)) block_hashes >>= fun block_infos -> - filter_map_s + List.filter_map_es (fun (bi : Client_baking_blocks.block_info) -> match Client_baking_nonces.find_opt nonces bi.hash with | None -> diff --git a/src/proto_007_PsDELPH1/lib_delegate/client_baking_nonces.ml b/src/proto_007_PsDELPH1/lib_delegate/client_baking_nonces.ml index 7002359cbbd99d75ead1e3c6e05b4e5c93b941ff..7a47c7a6a8b93098ce6c7402f916ab94a03e04da 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/client_baking_nonces.ml +++ b/src/proto_007_PsDELPH1/lib_delegate/client_baking_nonces.ml @@ -156,7 +156,7 @@ let get_unrevealed_nonces cctxt location nonces = ~offset:(-1l) () >>=? fun blocks -> - filter_map_s + List.filter_map_es (fun hash -> match find_opt nonces hash with | None -> diff --git a/src/proto_007_PsDELPH1/lib_delegate/client_baking_revelation.ml b/src/proto_007_PsDELPH1/lib_delegate/client_baking_revelation.ml index 02bc973484a2a0f1be27cf753e2b1d7a310e1005..6aa5d9bc9a8ad3a710fbb27b0b0624ea8beaaf06 100644 --- a/src/proto_007_PsDELPH1/lib_delegate/client_baking_revelation.ml +++ b/src/proto_007_PsDELPH1/lib_delegate/client_baking_revelation.ml @@ -43,7 +43,7 @@ let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain -% a Block_hash.Logging.tag hash) >>= fun () -> return_unit | _ -> - iter_s + List.iter_es (fun (level, nonce) -> Alpha_services.Forge.seed_nonce_revelation cctxt diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/activation.ml b/src/proto_007_PsDELPH1/lib_protocol/test/activation.ml index ae3b8dbbe44a217db9a8e07ab11fe714804d6897..792d4b38efb6554ac45637a9cd662210759d3d73 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/activation.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/activation.ml @@ -316,7 +316,7 @@ let single_activation () = activation_init () >>=? fun (blk, _contracts, secrets) -> let ({account; activation_code; amount = expected_amount; _} as _first_one) = - List.hd secrets + Option.get @@ List.hd secrets in (* Contract does not exist *) Assert.balance_is @@ -340,7 +340,7 @@ let single_activation () = let multi_activation_1 () = activation_init () >>=? fun (blk, _contracts, secrets) -> - Error_monad.fold_left_s + List.fold_left_es (fun blk {account; activation_code; amount = expected_amount; _} -> Op.activation (B blk) account activation_code >>=? fun operation -> @@ -360,7 +360,7 @@ let multi_activation_1 () = let multi_activation_2 () = activation_init () >>=? fun (blk, _contracts, secrets) -> - Error_monad.fold_left_s + List.fold_left_es (fun ops {account; activation_code; _} -> Op.activation (B blk) account activation_code >|=? fun op -> op :: ops) [] @@ -368,7 +368,7 @@ let multi_activation_2 () = >>=? fun ops -> Block.bake ~operations:ops blk >>=? fun blk -> - Error_monad.iter_s + List.iter_es (fun {account; amount = expected_amount; _} -> (* Contract does exist *) Assert.balance_is @@ -382,8 +382,10 @@ let multi_activation_2 () = let activation_and_transfer () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; activation_code; _} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in + let bootstrap_contract = Option.get @@ List.hd contracts in let first_contract = Contract.implicit_contract account in Op.activation (B blk) account activation_code >>=? fun operation -> @@ -410,8 +412,10 @@ let activation_and_transfer () = let transfer_to_unactivated_then_activate () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; activation_code; amount} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; activation_code; amount} as _first_one) = + Option.get @@ List.hd secrets + in + let bootstrap_contract = Option.get @@ List.hd contracts in let unactivated_commitment_contract = Contract.implicit_contract account in Context.Contract.balance (B blk) bootstrap_contract >>=? fun b_amount -> @@ -450,7 +454,9 @@ let invalid_activation_with_no_commitments () = Context.init 1 >>=? fun (blk, _) -> let secrets = secrets () in - let ({account; activation_code; _} as _first_one) = List.hd secrets in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in Op.activation (B blk) account activation_code >>=? fun operation -> Block.bake ~operation blk @@ -465,8 +471,10 @@ let invalid_activation_with_no_commitments () = let invalid_activation_wrong_secret () = activation_init () >>=? fun (blk, _, secrets) -> - let ({account; _} as _first_one) = List.nth secrets 0 in - let ({activation_code; _} as _second_one) = List.nth secrets 1 in + let ({account; _} as _first_one) = Option.get @@ List.nth secrets 0 in + let ({activation_code; _} as _second_one) = + Option.get @@ List.nth secrets 1 + in Op.activation (B blk) account activation_code >>=? fun operation -> Block.bake ~operation blk @@ -482,7 +490,7 @@ let invalid_activation_wrong_secret () = let invalid_activation_inexistent_pkh () = activation_init () >>=? fun (blk, _, secrets) -> - let ({activation_code; _} as _first_one) = List.hd secrets in + let ({activation_code; _} as _first_one) = Option.get @@ List.hd secrets in let inexistent_pkh = Signature.Public_key_hash.of_b58check_exn "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" @@ -502,7 +510,9 @@ let invalid_activation_inexistent_pkh () = let invalid_double_activation () = activation_init () >>=? fun (blk, _, secrets) -> - let ({account; activation_code; _} as _first_one) = List.hd secrets in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in Incremental.begin_construction blk >>=? fun inc -> Op.activation (I inc) account activation_code @@ -523,8 +533,8 @@ let invalid_double_activation () = let invalid_transfer_from_unactivated_account () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; _} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; _} as _first_one) = Option.get @@ List.hd secrets in + let bootstrap_contract = Option.get @@ List.hd contracts in let unactivated_commitment_contract = Contract.implicit_contract account in (* No activation *) Op.transaction diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/baking.ml b/src/proto_007_PsDELPH1/lib_protocol/test/baking.ml index 8316752928610a75691ebdcb952411b936dbea46..4785de8128a7475dcc40a25b983dbf1600957f05 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/baking.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/baking.ml @@ -102,11 +102,11 @@ let test_rewards_retrieval () = let block_priorities = 0 -- 10 in let included_endorsements = 0 -- endorsers_per_block in let ranges = List.product block_priorities included_endorsements in - iter_s + List.iter_es (fun (priority, endorsing_power) -> (* bake block at given priority and with given endorsing_power *) let real_endorsers = List.sub endorsers endorsing_power in - map_p + List.map_ep (fun endorser -> Op.endorsement ~delegate:endorser.delegate (B good_b) () >|=? fun operation -> Operation.pack operation) @@ -147,7 +147,7 @@ let test_rewards_retrieval () = accumulated_frozen_balance ) >>=? fun () -> (* check the each endorser was rewarded the right amount *) - iter_p + List.iter_ep (fun endorser -> balance_update endorser.delegate good_b b >>=? fun endorser_frozen_balance -> @@ -174,7 +174,7 @@ let test_rewards_formulas () = let block_priorities = 0 -- 2 in let included_endorsements = 0 -- endorsers_per_block in let ranges = List.product block_priorities included_endorsements in - iter_p + List.iter_ep (fun (priority, endorsing_power) -> Context.get_baking_reward (B b) ~priority ~endorsing_power >>=? fun reward -> @@ -214,7 +214,7 @@ let test_rewards_formulas_equivalence () = let block_priorities = 0 -- 64 in let endorsing_power = 0 -- endorsers_per_block in let ranges = List.product block_priorities endorsing_power in - iter_p + List.iter_ep (fun (block_priority, endorsing_power) -> Baking.baking_reward ctxt diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/combined_operations.ml b/src/proto_007_PsDELPH1/lib_protocol/test/combined_operations.ml index e1701b8acdda3a40fac1589fecd5b7f96487c70a..4b854118849cc8dc97f82d99ca542227272ba59c 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/combined_operations.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/combined_operations.ml @@ -43,10 +43,10 @@ let ten_tez = Tez.of_int 10 let multiple_transfers () = Context.init 3 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in - let c3 = List.nth contracts 2 in - map_s (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10) + let (c1, c2, c3) = + match contracts with [c1; c2; c3] -> (c1, c2, c3) | _ -> assert false + in + List.map_es (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10) >>=? fun ops -> Op.combine_operations ~source:c1 (B blk) ops >>=? fun operation -> @@ -77,15 +77,16 @@ let multiple_transfers () = let multiple_origination_and_delegation () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in let n = 10 in Context.get_constants (B blk) >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> Context.Contract.pkh c2 >>=? fun delegate_pkh -> (* Deploy n smart contracts with dummy scripts from c1 *) - map_s + List.map_es (fun i -> Op.origination ~delegate:delegate_pkh @@ -146,7 +147,7 @@ let multiple_origination_and_delegation () = >>?= fun total_cost -> Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost >>=? fun () -> - iter_s + List.iter_es (fun c -> Assert.balance_is ~loc:__LOC__ (I inc) c (Tez.of_int 10)) new_contracts @@ -164,8 +165,9 @@ let expect_balance_too_low = function let failing_operation_in_the_middle () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.max_tez @@ -220,8 +222,9 @@ let failing_operation_in_the_middle () = let failing_operation_in_the_middle_with_fees () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.max_tez @@ -294,8 +297,9 @@ let expect_wrong_signature list = let wrong_signature_in_the_middle () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.one (B blk) c2 c1 Tez.one diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/delegation.ml b/src/proto_007_PsDELPH1/lib_protocol/test/delegation.ml index 83904dc1f4df6ad74780f7ea93806789bc8790c4..f9ddabc64207a49e144db822b268d8d7c861860c 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/delegation.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/delegation.ml @@ -53,7 +53,7 @@ let expect_no_change_registered_delegate_pkh pkh = function let bootstrap_manager_is_bootstrap_delegate () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.hd bootstrap_contracts in + let bootstrap0 = Option.get @@ List.hd bootstrap_contracts in Context.Contract.delegate (B b) bootstrap0 >>=? fun delegate0 -> Context.Contract.manager (B b) bootstrap0 @@ -63,8 +63,8 @@ let bootstrap_manager_is_bootstrap_delegate () = let bootstrap_delegate_cannot_change ~fee () = Context.init 2 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.nth bootstrap_contracts 0 in - let bootstrap1 = List.nth bootstrap_contracts 1 in + let bootstrap0 = Option.get @@ List.nth bootstrap_contracts 0 in + let bootstrap1 = Option.get @@ List.nth bootstrap_contracts 1 in Context.Contract.pkh bootstrap0 >>=? fun pkh1 -> Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) @@ -106,7 +106,7 @@ let bootstrap_delegate_cannot_change ~fee () = let bootstrap_delegate_cannot_be_removed ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Incremental.begin_construction b >>=? fun i -> Context.Contract.balance (I i) bootstrap @@ -144,8 +144,8 @@ let bootstrap_delegate_cannot_be_removed ~fee () = let delegate_can_be_changed_from_unregistered_contract ~fee () = Context.init 2 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.hd bootstrap_contracts in - let bootstrap1 = List.nth bootstrap_contracts 1 in + let bootstrap0 = Option.get @@ List.hd bootstrap_contracts in + let bootstrap1 = Option.get @@ List.nth bootstrap_contracts 1 in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let unregistered = Contract.implicit_contract unregistered_pkh in @@ -197,7 +197,7 @@ let delegate_can_be_changed_from_unregistered_contract ~fee () = let delegate_can_be_removed_from_unregistered_contract ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let unregistered = Contract.implicit_contract unregistered_pkh in @@ -252,7 +252,7 @@ let bootstrap_manager_already_registered_delegate ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun manager -> let pkh = manager.pkh in @@ -289,7 +289,7 @@ let delegate_to_bootstrap_by_origination ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun manager -> Context.Contract.balance (I i) bootstrap @@ -486,7 +486,7 @@ let unregistered_delegate_key_init_origination ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in (* origination with delegate argument *) @@ -537,7 +537,7 @@ let unregistered_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -587,7 +587,7 @@ let unregistered_delegate_key_switch_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -646,7 +646,7 @@ let unregistered_delegate_key_init_origination_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -697,7 +697,7 @@ let unregistered_delegate_key_init_delegation_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -755,7 +755,7 @@ let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -823,7 +823,7 @@ let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -881,7 +881,7 @@ let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -944,7 +944,7 @@ let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -1041,7 +1041,7 @@ let failed_self_delegation_emptied_implicit_contract amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let unregistered_pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -1075,7 +1075,7 @@ let emptying_delegated_implicit_contract_fails amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun bootstrap_manager -> let account = Account.new_account () in @@ -1115,7 +1115,7 @@ let valid_delegate_registration_init_delegation_credit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1168,7 +1168,7 @@ let valid_delegate_registration_switch_delegation_credit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1222,7 +1222,7 @@ let valid_delegate_registration_init_delegation_credit_debit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1290,7 +1290,7 @@ let valid_delegate_registration_switch_delegation_credit_debit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1356,7 +1356,7 @@ let double_registration () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1389,7 +1389,7 @@ let double_registration_when_empty () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1429,7 +1429,7 @@ let double_registration_when_recredited () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1476,7 +1476,7 @@ let unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; _} = Account.new_account () in let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in @@ -1511,7 +1511,7 @@ let unregistered_and_revealed_self_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; pk; _} = Account.new_account () in let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in @@ -1550,7 +1550,7 @@ let registered_self_delegate_key_init_delegation () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; _} = Account.new_account () in let {Account.pkh = delegate_pkh; pk = delegate_pk; _} = Account.new_account () diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/double_baking.ml b/src/proto_007_PsDELPH1/lib_protocol/test/double_baking.ml index 535cfdb3bc5899393a085af0acf6902015b75624..37f2bff4fe5e3c9c92a136834568e1b136437348 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/double_baking.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/double_baking.ml @@ -33,31 +33,28 @@ open Alpha_context (* Utility functions *) (****************************************************************) +let get_hd_hd = function x :: y :: _ -> (x, y) | _ -> assert false + let get_first_different_baker baker bakers = - List.find - (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') - bakers + Option.get + @@ List.find + (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') + bakers let get_first_different_bakers ctxt = Context.get_bakers ctxt >|=? fun bakers -> - let baker_1 = List.hd bakers in - get_first_different_baker baker_1 (List.tl bakers) + let baker_1 = Option.get @@ List.hd bakers in + get_first_different_baker baker_1 (Option.get @@ List.tl bakers) |> fun baker_2 -> (baker_1, baker_2) let get_first_different_endorsers ctxt = - Context.get_endorsers ctxt - >|=? fun endorsers -> - let endorser_1 = (List.hd endorsers).delegate in - let endorser_2 = (List.hd (List.tl endorsers)).delegate in - (endorser_1, endorser_2) + Context.get_endorsers ctxt >|=? fun endorsers -> get_hd_hd endorsers (** Bake two block at the same level using the same policy (i.e. same baker) *) let block_fork ?policy contracts b = - let (contract_a, contract_b) = - (List.hd contracts, List.hd (List.tl contracts)) - in + let (contract_a, contract_b) = get_hd_hd contracts in Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent >>=? fun operation -> Block.bake ?policy ~operation b @@ -74,7 +71,7 @@ let valid_double_baking_evidence () = >>=? fun (b, contracts) -> Context.get_bakers (B b) >>=? fun bakers -> - let priority_0_baker = List.hd bakers in + let priority_0_baker = Option.get @@ List.hd bakers in block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> Op.double_baking (B blk_a) blk_a.header blk_b.header @@ -82,7 +79,7 @@ let valid_double_baking_evidence () = Block.bake ~policy:(Excluding [priority_0_baker]) ~operation blk_a >>=? fun blk -> (* Check that the frozen deposit, the fees and rewards are removed *) - iter_s + List.iter_es (fun kind -> let contract = Alpha_context.Contract.implicit_contract priority_0_baker @@ -156,7 +153,7 @@ let too_late_double_baking_evidence () = >>=? fun Constants.{parametric = {preserved_cycles; _}; _} -> block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> - fold_left_s + List.fold_left_es (fun blk _ -> Block.bake_until_cycle_end blk) blk_a (1 -- (preserved_cycles + 1)) diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/double_endorsement.ml b/src/proto_007_PsDELPH1/lib_protocol/test/double_endorsement.ml index f644217660702886d2808bd75ecb8efce51f5a91..aade59208a041f86ac6fb83eb74c894fce118b7c 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/double_endorsement.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/double_endorsement.ml @@ -33,24 +33,23 @@ open Alpha_context (* Utility functions *) (****************************************************************) +let get_hd_hd = function x :: y :: _ -> (x, y) | _ -> assert false + let get_first_different_baker baker bakers = - List.find - (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') - bakers + Option.get + @@ List.find + (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') + bakers let get_first_different_bakers ctxt = Context.get_bakers ctxt >|=? fun bakers -> - let baker_1 = List.hd bakers in - get_first_different_baker baker_1 (List.tl bakers) + let baker_1 = Option.get @@ List.hd bakers in + get_first_different_baker baker_1 (Option.get @@ List.tl bakers) |> fun baker_2 -> (baker_1, baker_2) let get_first_different_endorsers ctxt = - Context.get_endorsers ctxt - >|=? fun endorsers -> - let endorser_1 = List.hd endorsers in - let endorser_2 = List.hd (List.tl endorsers) in - (endorser_1, endorser_2) + Context.get_endorsers ctxt >|=? fun endorsers -> get_hd_hd endorsers let block_fork b = get_first_different_bakers (B b) @@ -90,7 +89,7 @@ let valid_double_endorsement_evidence () = Block.bake ~policy:(By_account baker) ~operation blk_a >>=? fun blk -> (* Check that the frozen deposit, the fees and rewards are removed *) - iter_s + List.iter_es (fun kind -> let contract = Alpha_context.Contract.implicit_contract delegate in Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero) @@ -159,7 +158,7 @@ let too_late_double_endorsement_evidence () = >>=? fun endorsement_a -> Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b -> - fold_left_s + List.fold_left_es (fun blk _ -> Block.bake_until_cycle_end blk) blk_a (1 -- (preserved_cycles + 1)) @@ -213,10 +212,11 @@ let different_delegates () = let wrong_delegate () = Context.init ~endorsers_per_block:1 2 >>=? fun (b, contracts) -> - Error_monad.map_s (Context.Contract.manager (B b)) contracts + List.map_es (Context.Contract.manager (B b)) contracts >>=? fun accounts -> - let pkh1 = (List.nth accounts 0).Account.pkh in - let pkh2 = (List.nth accounts 1).Account.pkh in + let (account_1, account_2) = get_hd_hd accounts in + let pkh1 = account_1.Account.pkh in + let pkh2 = account_2.Account.pkh in block_fork b >>=? fun (blk_a, blk_b) -> Context.get_endorser (B blk_a) diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/endorsement.ml b/src/proto_007_PsDELPH1/lib_protocol/test/endorsement.ml index b8481a767d0689abac53f467d98d92523a9fcb57..58cb0354276761f9cf07b9e6305fa1038c6b30ce 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/endorsement.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/endorsement.ml @@ -38,6 +38,8 @@ open Test_tez (* Utility functions *) (****************************************************************) +let get_hd_hd = function x :: y :: _ -> (x, y) | _ -> assert false + let get_expected_reward ctxt ~priority ~baker ~endorsing_power = ( if baker then Context.get_baking_reward ctxt ~priority ~endorsing_power else return (Test_tez.Tez.of_int 0) ) @@ -135,7 +137,7 @@ let max_endorsement () = endorsers))) endorsers_per_block >>=? fun () -> - fold_left_s + List.fold_left_es (fun (delegates, ops, balances) (endorser : Alpha_services.Delegate.Endorsing_rights.t) -> let delegate = endorser.delegate in @@ -153,22 +155,24 @@ let max_endorsement () = >>=? fun b -> (* One account can endorse more than one time per level, we must check that the bonds are summed up *) - iter_s - (fun (endorser_account, (endorsing_power, previous_balance)) -> + List.iter2_es + ~when_different_lengths:(TzTrace.make (Exn (Failure __LOC__))) + (fun endorser_account (endorsing_power, previous_balance) -> assert_endorser_balance_consistency ~loc:__LOC__ (B b) ~endorsing_power endorser_account previous_balance) - (List.combine delegates previous_balances) + delegates + previous_balances (** Check every that endorsers' balances are consistent with different priorities *) let consistent_priorities () = let priorities = 0 -- 64 in Context.init 64 >>=? fun (b, _) -> - fold_left_s + List.fold_left_es (fun (b, used_pkhes) priority -> (* Choose an endorser that has not baked nor endorsed before *) Context.get_endorsers (B b) @@ -236,7 +240,7 @@ let reward_retrieval () = Block.bake ~policy ~operation b >>=? fun b -> (* Bake (preserved_cycles + 1) cycles *) - fold_left_s + List.fold_left_es (fun b _ -> Block.bake_until_cycle_end ~policy:(Excluding [endorser]) b) b (0 -- preserved_cycles) @@ -266,8 +270,7 @@ let reward_retrieval_two_endorsers () = _ } -> Context.get_endorsers (B b) >>=? fun endorsers -> - let endorser1 = List.hd endorsers in - let endorser2 = List.hd (List.tl endorsers) in + let (endorser1, endorser2) = get_hd_hd endorsers in Context.Contract.balance (B b) (Contract.implicit_contract endorser1.delegate) @@ -329,7 +332,7 @@ let reward_retrieval_two_endorsers () = Signature.Public_key_hash.( endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate) in - let endorser2 = List.find same_endorser2 endorsers in + let endorser2 = Option.get @@ List.find same_endorser2 endorsers in (* No exception raised: in sandboxed mode endorsers do not change between blocks *) Tez.( endorsement_security_deposit *? Int64.of_int (List.length endorser2.slots)) @@ -361,7 +364,7 @@ let reward_retrieval_two_endorsers () = security_deposit2 >>=? fun () -> (* bake [preserved_cycles] cycles *) - fold_left_s + List.fold_left_es (fun b _ -> Assert.balance_was_debited ~loc:__LOC__ @@ -481,7 +484,7 @@ let duplicate_endorsement () = let not_enough_for_deposit () = Context.init 5 ~endorsers_per_block:1 >>=? fun (b_init, contracts) -> - Error_monad.map_s + List.map_es (fun c -> Context.Contract.manager (B b_init) c >|=? fun m -> (m, c)) contracts >>=? fun managers -> @@ -491,15 +494,17 @@ let not_enough_for_deposit () = Context.get_endorser (B b) >>=? fun (endorser, _slots) -> let (_, contract_other_than_endorser) = - List.find - (fun (c, _) -> - not (Signature.Public_key_hash.equal c.Account.pkh endorser)) - managers + Option.get + @@ List.find + (fun (c, _) -> + not (Signature.Public_key_hash.equal c.Account.pkh endorser)) + managers in let (_, contract_of_endorser) = - List.find - (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser) - managers + Option.get + @@ List.find + (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser) + managers in Context.Contract.balance (B b) (Contract.implicit_contract endorser) >>=? fun initial_balance -> @@ -537,14 +542,14 @@ let endorsement_threshold () = let num_endorsers = List.length endorsers in (* we try to bake with more and more endorsers, but at each iteration with a timestamp smaller than required *) - iter_s + List.iter_es (fun i -> (* the priority is chosen rather arbitrarily *) let priority = num_endorsers - i in let crt_endorsers = List.take_n i endorsers in let endorsing_power = endorsing_power crt_endorsers in let delegates = delegates_with_slots crt_endorsers in - map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates + List.map_es (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates >>=? fun ops -> Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> @@ -574,7 +579,7 @@ let endorsement_threshold () = let priority = 0 in let endorsing_power = endorsing_power endorsers in let delegates = delegates_with_slots endorsers in - map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates + List.map_es (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates >>=? fun ops -> Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/gas_costs.ml b/src/proto_007_PsDELPH1/lib_protocol/test/gas_costs.ml index aca758723ba2e5e0f655a1c984f56bbabed32dc0..c0bcbcae0934990b23b496e566154876f513752a 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/gas_costs.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/gas_costs.ml @@ -230,7 +230,7 @@ let cast_cost_to_z (c : Alpha_context.Gas.cost) : Z.t = |> Data_encoding.Binary.of_bytes_exn Data_encoding.z let check_cost_reprs_are_all_positive list () = - iter_s + List.iter_es (fun (cost_name, cost) -> if Z.gt cost Z.zero then return_unit else if Z.equal cost Z.zero && List.mem cost_name free then return_unit diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/helpers/block.ml b/src/proto_007_PsDELPH1/lib_protocol/test/helpers/block.ml index d0fb94697479c1b80b0c8ce1a48c2eaed7c2fc9d..ac1294005bccce1c785df2e4249198268799dba7 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/helpers/block.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/helpers/block.ml @@ -67,10 +67,11 @@ let get_next_baker_by_priority priority block = block >|=? fun bakers -> let {Alpha_services.Delegate.Baking_rights.delegate = pkh; timestamp; _} = - List.find - (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} -> - p = priority) - bakers + Option.get + @@ List.find + (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} -> + p = priority) + bakers in (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -85,7 +86,7 @@ let get_next_baker_by_account pkh block = timestamp; priority; _ } = - List.hd bakers + Option.get @@ List.hd bakers in (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -96,10 +97,11 @@ let get_next_baker_excluding excludes block = timestamp; priority; _ } = - List.find - (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> - not (List.mem delegate excludes)) - bakers + Option.get + @@ List.find + (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> + not (List.mem delegate excludes)) + bakers in (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -114,7 +116,7 @@ let dispatch_policy = function let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy let get_endorsing_power b = - fold_left_s + List.fold_left_es (fun acc (op : Operation.packed) -> let (Operation_data data) = op.protocol_data in match data.contents with @@ -328,8 +330,9 @@ let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers } in (* Check there is at least one roll *) - ( try - fold_left_s + Lwt.catch + (fun () -> + List.fold_left_es (fun acc (_, amount) -> Environment.wrap_error @@ Tez_repr.( +? ) acc amount >>?= fun acc -> @@ -337,8 +340,8 @@ let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers Tez_repr.zero initial_accounts >>=? fun _ -> - failwith "Insufficient tokens in initial accounts to create one roll" - with Exit -> return_unit ) + failwith "Insufficient tokens in initial accounts to create one roll") + (function Exit -> return_unit | exc -> raise exc) >>=? fun () -> check_constants_consistency constants >>=? fun () -> @@ -412,7 +415,7 @@ let bake ?policy ?timestamp ?operation ?operations pred = let get_constants b = Alpha_services.Constants.all rpc_ctxt b let bake_n ?policy n b = - Error_monad.fold_left_s (fun b _ -> bake ?policy b) b (1 -- n) + List.fold_left_es (fun b _ -> bake ?policy b) b (1 -- n) let bake_until_cycle_end ?policy b = get_constants b @@ -423,7 +426,7 @@ let bake_until_cycle_end ?policy b = bake_n ?policy (Int32.to_int delta) b let bake_until_n_cycle_end ?policy n b = - Error_monad.fold_left_s (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) + List.fold_left_es (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) let bake_until_cycle ?policy cycle (b : t) = get_constants b diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/helpers/context.ml b/src/proto_007_PsDELPH1/lib_protocol/test/helpers/context.ml index 01001e7e5ef9c09da4f8d11d137642fa6b59d497..448bed932a96162a72011a406dadbf0805382855 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/helpers/context.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/helpers/context.ml @@ -108,7 +108,7 @@ let get_endorsers ctxt = let get_endorser ctxt = Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt >|=? fun endorsers -> - let endorser = List.hd endorsers in + let endorser = Option.get @@ List.hd endorsers in (endorser.delegate, endorser.slots) let get_bakers ctxt = diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/helpers/op.ml b/src/proto_007_PsDELPH1/lib_protocol/test/helpers/op.ml index 8552930e3ee77d8b0201c624d59bbe7a01e5800f..0ef7f64ca2cca52f126829edfefc540973385ff5 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/helpers/op.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/helpers/op.ml @@ -66,7 +66,9 @@ let combine_operations ?public_key ?counter ?spurious_operation ~source ctxt (packed_operations : packed_operation list) = assert (List.length packed_operations > 0) ; (* Hypothesis : each operation must have the same branch (is this really true?) *) - let {Tezos_base.Operation.branch} = (List.hd packed_operations).shell in + let {Tezos_base.Operation.branch} = + (Option.get @@ List.hd packed_operations).shell + in assert ( List.for_all (fun {shell = {Tezos_base.Operation.branch = b; _}; _} -> diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/origination.ml b/src/proto_007_PsDELPH1/lib_protocol/test/origination.ml index f55fd66f2ab80fe7f5f8c50461886a515695e54d..efeec384e7e85b7cf9f51a88a41a051e7ac17cc2 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/origination.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/origination.ml @@ -37,7 +37,7 @@ let ten_tez = Tez.of_int 10 let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) () = Context.init 1 >>=? fun (b, contracts) -> - let source = List.hd contracts in + let source = Option.get @@ List.hd contracts in Context.Contract.balance (B b) source >>=? fun source_balance -> Op.origination (B b) source ~fee ~credit ~script:Op.dummy_script @@ -81,7 +81,7 @@ let test_origination_balances ~loc:_ ?(fee = Tez.zero) ?(credit = Tez.zero) () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Context.Contract.balance (B b) contract >>=? fun balance -> Op.origination (B b) contract ~fee ~credit ~script:Op.dummy_script @@ -163,8 +163,8 @@ let pay_fee () = let not_tez_in_contract_to_pay_fee () = Context.init 2 >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in + let contract_1 = Option.get @@ List.nth contracts 0 in + let contract_2 = Option.get @@ List.nth contracts 1 in Incremental.begin_construction b >>=? fun inc -> (* transfer everything but one tez from 1 to 2 and check balance of 1 *) @@ -203,7 +203,7 @@ let not_tez_in_contract_to_pay_fee () = let register_contract_get_endorser () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Incremental.begin_construction b >>=? fun inc -> Context.get_endorser (I inc) @@ -216,7 +216,7 @@ let register_contract_get_endorser () = (*******************) let n_originations n ?credit ?fee () = - fold_left_s + List.fold_left_es (fun new_contracts _ -> register_origination ?fee ?credit () >|=? fun (_b, _source, new_contract) -> new_contract :: new_contracts) @@ -236,7 +236,7 @@ let multiple_originations () = let counter () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Incremental.begin_construction b >>=? fun inc -> Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/reveal.ml b/src/proto_007_PsDELPH1/lib_protocol/test/reveal.ml index 1fd7bcd93dc856539fc2ae785c34e25a386366a5..8f3f98cb0651ca0d3771adde041d740712abdc9c 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/reveal.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/reveal.ml @@ -33,7 +33,7 @@ let ten_tez = Tez.of_int 10 let simple_reveal () = Context.init 1 >>=? fun (blk, contracts) -> - let c = List.nth contracts 0 in + let c = Option.get @@ List.nth contracts 0 in let new_c = Account.new_account () in let new_contract = Alpha_context.Contract.implicit_contract new_c.pkh in (* Create the contract *) @@ -57,7 +57,7 @@ let simple_reveal () = let empty_account_on_reveal () = Context.init 1 >>=? fun (blk, contracts) -> - let c = List.nth contracts 0 in + let c = Option.get @@ List.nth contracts 0 in let new_c = Account.new_account () in let new_contract = Alpha_context.Contract.implicit_contract new_c.pkh in let amount = Tez.one_mutez in @@ -89,7 +89,7 @@ let empty_account_on_reveal () = let not_enough_found_for_reveal () = Context.init 1 >>=? fun (blk, contracts) -> - let c = List.nth contracts 0 in + let c = Option.get @@ List.nth contracts 0 in let new_c = Account.new_account () in let new_contract = Alpha_context.Contract.implicit_contract new_c.pkh in (* Create the contract *) diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/seed.ml b/src/proto_007_PsDELPH1/lib_protocol/test/seed.ml index fe6429af5a38a22b97ad9b0d5c4f6bcb0ac099ff..1d18737b577f18f9c3e1140e51cd0bd7a60e6943 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/seed.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/seed.ml @@ -205,7 +205,7 @@ let revelation_early_wrong_right_twice () = false) >>=? fun () -> (* bake [preserved_cycles] cycles excluding [id] *) - Error_monad.fold_left_s + List.fold_left_es (fun b _ -> Block.bake_until_cycle_end ~policy b) b (1 -- preserved_cycles) diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/transfer.ml b/src/proto_007_PsDELPH1/lib_protocol/test/transfer.ml index f0f8fb5ac553fcf3b038fd7fafd22781f3870d23..43d2a901d43923345c26f61abf28617325d22933 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/transfer.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/transfer.ml @@ -112,7 +112,7 @@ let transfer_to_itself_and_check_balances ~loc b ?(fee = Tez.zero) contract a destination contract with the amount "n" times. *) let n_transactions n b ?fee source dest amount = - fold_left_s + List.fold_left_es (fun b _ -> transfer_and_check_balances ~loc:__LOC__ b ?fee source dest amount >|=? fun (b, _) -> b) @@ -127,10 +127,11 @@ let ten_tez = Tez.of_int 10 let register_two_contracts () = Context.init 2 - >|=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in - (b, contract_1, contract_2) + >|=? function + | (b, [contract_1; contract_2]) -> + (b, contract_1, contract_2) + | _ -> + assert false (** compute half of the balance and divided by nth times *) @@ -187,7 +188,7 @@ let transfer_zero_tez () = let transfer_zero_implicit () = Context.init 1 >>=? fun (b, contracts) -> - let dest = List.nth contracts 0 in + let dest = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in Incremental.begin_construction b >>=? fun i -> @@ -210,7 +211,7 @@ let transfer_zero_implicit () = let transfer_to_originate_with_fee () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in Incremental.begin_construction b >>=? fun b -> two_nth_of_balance b contract 10L @@ -254,7 +255,7 @@ let transfer_amount_of_contract_balance () = let transfers_to_self () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in Incremental.begin_construction b >>=? fun b -> two_nth_of_balance b contract 3L @@ -303,7 +304,7 @@ let missing_transaction () = let transfer_from_implicit_to_implicit_contract () = Context.init 1 >>=? fun (b, contracts) -> - let bootstrap_contract = List.nth contracts 0 in + let bootstrap_contract = Option.get @@ List.nth contracts 0 in let account_a = Account.new_account () in let account_b = Account.new_account () in Incremental.begin_construction b @@ -344,8 +345,8 @@ let transfer_from_implicit_to_implicit_contract () = let transfer_from_implicit_to_originated_contract () = Context.init 1 >>=? fun (b, contracts) -> - let bootstrap_contract = List.nth contracts 0 in - let contract = List.nth contracts 0 in + let bootstrap_contract = Option.get @@ List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in let src = Contract.implicit_contract account.Account.pkh in Incremental.begin_construction b @@ -446,7 +447,7 @@ let build_a_chain () = register_two_contracts () >>=? fun (b, contract_1, contract_2) -> let ten = Tez.of_int 10 in - fold_left_s + List.fold_left_es (fun b _ -> Incremental.begin_construction b >>=? fun b -> @@ -468,7 +469,7 @@ let build_a_chain () = let empty_implicit () = Context.init 1 >>=? fun (b, contracts) -> - let dest = List.nth contracts 0 in + let dest = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in Incremental.begin_construction b >>=? fun incr -> @@ -531,9 +532,9 @@ let balance_too_low fee () = let balance_too_low_two_transfers fee () = Context.init 3 >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in - let contract_3 = List.nth contracts 2 in + let contract_1 = Option.get @@ List.nth contracts 0 in + let contract_2 = Option.get @@ List.nth contracts 1 in + let contract_3 = Option.get @@ List.nth contracts 2 in Incremental.begin_construction b >>=? fun i -> Context.Contract.balance (I i) contract_1 diff --git a/src/proto_007_PsDELPH1/lib_protocol/test/voting.ml b/src/proto_007_PsDELPH1/lib_protocol/test/voting.ml index 627fdab9abf3cafd59ee550aacbcf9f2e519f25b..8b3b5eaa120206706509a2ebd8881ae72eb04061 100644 --- a/src/proto_007_PsDELPH1/lib_protocol/test/voting.ml +++ b/src/proto_007_PsDELPH1/lib_protocol/test/voting.ml @@ -113,7 +113,7 @@ let get_delegates_and_rolls_from_listings b = let get_rolls b delegates loc = Context.Vote.get_listings (B b) >>=? fun l -> - map_s + List.map_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -199,8 +199,8 @@ let test_successful_vote num_delegates () = | Some _ -> failwith "%s - Unexpected proposal" __LOC__) >>=? fun () -> - let del1 = List.nth delegates_p1 0 in - let del2 = List.nth delegates_p1 1 in + let del1 = Option.get @@ List.nth delegates_p1 0 in + let del2 = Option.get @@ List.nth delegates_p1 1 in let props = List.map (fun i -> protos.(i)) (2 -- Constants.max_proposals_per_delegate) in @@ -214,7 +214,11 @@ let test_successful_vote num_delegates () = Context.Vote.get_proposals (B b) >>=? fun ps -> (* correctly count the double proposal for zero *) - (let weight = Int32.add (List.nth rolls_p1 0) (List.nth rolls_p1 1) in + (let weight = + Int32.add + (Option.get @@ List.nth rolls_p1 0) + (Option.get @@ List.nth rolls_p1 1) + in match Environment.Protocol_hash.(Map.find_opt zero ps) with | Some v -> if v = weight then return_unit @@ -296,7 +300,7 @@ let test_successful_vote num_delegates () = failwith "%s - Missing proposal" __LOC__) >>=? fun () -> (* unanimous vote: all delegates --active when p2 started-- vote *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) delegates_p2 >>=? fun operations -> @@ -332,7 +336,7 @@ let test_successful_vote num_delegates () = | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ | l -> - iter_s + List.iter_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -434,7 +438,7 @@ let test_successful_vote num_delegates () = failwith "%s - Missing proposal" __LOC__) >>=? fun () -> (* unanimous vote: all delegates --active when p4 started-- vote *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) delegates_p4 >>=? fun operations -> @@ -459,7 +463,7 @@ let test_successful_vote num_delegates () = | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ | l -> - iter_s + List.iter_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -542,7 +546,7 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -568,12 +572,12 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2 |> fun voters -> (* take the first two voters out so there cannot be quorum *) - let voters_without_quorum = List.tl voters in + let voters_without_quorum = Option.get @@ List.tl voters in get_rolls b voters_without_quorum __LOC__ >>=? fun voters_rolls_in_testing_vote -> (* all voters_without_quorum vote, for yays; no nays, so supermajority is satisfied *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters_without_quorum >>=? fun operations -> @@ -620,7 +624,7 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -646,7 +650,9 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = let open Alpha_context in (* all voters vote, for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters + List.map_es + (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) + voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -680,12 +686,12 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = get_smallest_prefix_voters_for_quorum delegates_p4 rolls_p4 |> fun voters -> (* take the first voter out so there cannot be quorum *) - let voters_without_quorum = List.tl voters in + let voters_without_quorum = Option.get @@ List.tl voters in get_rolls b voters_without_quorum __LOC__ >>=? fun voter_rolls -> (* all voters_without_quorum vote, for yays; no nays, so supermajority is satisfied *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters_without_quorum >>=? fun operations -> @@ -723,7 +729,7 @@ let test_multiple_identical_proposals_count_as_one () = | _ -> failwith "%s - Unexpected period kind" __LOC__) >>=? fun () -> - let proposer = List.hd delegates in + let proposer = Option.get @@ List.hd delegates in Op.proposals (B b) proposer [Protocol_hash.zero; Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -766,29 +772,37 @@ let test_supermajority_in_proposal there_is_a_winner () = >>=? fun { parametric = {blocks_per_cycle; blocks_per_voting_period; tokens_per_roll; _}; _ } -> - let del1 = List.nth delegates 0 in - let del2 = List.nth delegates 1 in - let del3 = List.nth delegates 2 in - map_s (fun del -> Context.Contract.pkh del) [del1; del2; del3] + let del1 = Option.get @@ List.nth delegates 0 in + let del2 = Option.get @@ List.nth delegates 1 in + let del3 = Option.get @@ List.nth delegates 2 in + List.map_es (fun del -> Context.Contract.pkh del) [del1; del2; del3] >>=? fun pkhs -> let policy = Block.Excluding pkhs in - Op.transaction (B b) (List.nth delegates 3) del1 tokens_per_roll + Op.transaction + (B b) + (Option.get @@ List.nth delegates 3) + del1 + tokens_per_roll >>=? fun op1 -> - Op.transaction (B b) (List.nth delegates 4) del2 tokens_per_roll + Op.transaction + (B b) + (Option.get @@ List.nth delegates 4) + del2 + tokens_per_roll >>=? fun op2 -> ( if there_is_a_winner then Test_tez.Tez.( *? ) tokens_per_roll 3L else Test_tez.Tez.( *? ) tokens_per_roll 2L ) >>?= fun bal3 -> - Op.transaction (B b) (List.nth delegates 5) del3 bal3 + Op.transaction (B b) (Option.get @@ List.nth delegates 5) del3 bal3 >>=? fun op3 -> Block.bake ~policy ~operations:[op1; op2; op3] b >>=? fun b -> (* we let one voting period pass; we make sure that: - the three selected delegates remain active by re-registering as delegates - their number of rolls do not change *) - fold_left_s + List.fold_left_es (fun b _ -> - Error_monad.map_s + List.map_es (fun del -> Context.Contract.pkh del >>=? fun pkh -> Op.delegation (B b) del (Some pkh)) @@ -842,9 +856,9 @@ let test_quorum_in_proposal has_quorum () = min_proposal_quorum; _ }; _ } -> - let del1 = List.nth delegates 0 in - let del2 = List.nth delegates 1 in - map_s (fun del -> Context.Contract.pkh del) [del1; del2] + let del1 = Option.get @@ List.nth delegates 0 in + let del2 = Option.get @@ List.nth delegates 1 in + List.map_es (fun del -> Context.Contract.pkh del) [del1; del2] >>=? fun pkhs -> let policy = Block.Excluding pkhs in let quorum = @@ -861,9 +875,9 @@ let test_quorum_in_proposal has_quorum () = (* we let one voting period pass; we make sure that: - the two selected delegates remain active by re-registering as delegates - their number of rolls do not change *) - fold_left_s + List.fold_left_es (fun b _ -> - Error_monad.map_s + List.map_es (fun del -> Context.Contract.pkh del >>=? fun pkh -> Op.delegation (B b) del (Some pkh)) @@ -907,7 +921,7 @@ let test_supermajority_in_testing_vote supermajority () = >>=? fun (b, delegates) -> Context.get_constants (B b) >>=? fun {parametric = {blocks_per_voting_period; _}; _} -> - let del1 = List.nth delegates 0 in + let del1 = Option.get @@ List.nth delegates 0 in let proposal = protos.(0) in Op.proposals (B b) del1 [proposal] >>=? fun ops1 -> @@ -947,9 +961,9 @@ let test_supermajority_in_testing_vote supermajority () = let open Alpha_context in let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in let (yays_delegates, _) = List.split_n num_yays rest in - map_s (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates + List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates >>=? fun operations_yays -> - map_s (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates + List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates >>=? fun operations_nays -> let operations = operations_yays @ operations_nays in Block.bake ~operations b @@ -990,7 +1004,7 @@ let test_no_winning_proposal num_delegates () = List.map (fun i -> protos.(i)) (1 -- Constants.max_proposals_per_delegate) in (* all delegates active in p1 propose the same proposals *) - map_s (fun del -> Op.proposals (B b) del props) delegates_p1 + List.map_es (fun del -> Op.proposals (B b) del props) delegates_p1 >>=? fun ops_list -> Block.bake ~operations:ops_list b >>=? fun b -> @@ -1030,7 +1044,7 @@ let test_quorum_capped_maximum num_delegates () = >>=? fun () -> (* propose a new protocol *) let protocol = Protocol_hash.zero in - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [protocol] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -1056,7 +1070,7 @@ let test_quorum_capped_maximum num_delegates () = in let voters = List.take_n minimum_to_pass delegates in (* all voters vote for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -1094,7 +1108,7 @@ let test_quorum_capped_minimum num_delegates () = >>=? fun () -> (* propose a new protocol *) let protocol = Protocol_hash.zero in - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [protocol] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -1120,7 +1134,7 @@ let test_quorum_capped_minimum num_delegates () = in let voters = List.take_n minimum_to_pass delegates in (* all voters vote for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_context.ml b/src/proto_008_PtEdoTez/lib_client/client_proto_context.ml index 0b766e2f2318ebeda75209ddc7a3efc6878993ef..e42eb948d88619923be14386ee293446b9985d2f 100644 --- a/src/proto_008_PtEdoTez/lib_client/client_proto_context.ml +++ b/src/proto_008_PtEdoTez/lib_client/client_proto_context.ml @@ -178,7 +178,7 @@ let delegate_contract cctxt ~chain ~block ?branch ?confirmations ?dry_run let list_contract_labels cctxt ~chain ~block = Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> - rev_map_s + List.rev_map_es (fun h -> ( match Contract.is_implicit h with | Some m -> ( diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_contracts.ml b/src/proto_008_PtEdoTez/lib_client/client_proto_contracts.ml index 1c2d31d07ac7c00a21a9c32a914b656bdbd4259c..f32dfe165ef55d6ba0ed2d562272a60e30bed3fd 100644 --- a/src/proto_008_PtEdoTez/lib_client/client_proto_contracts.ml +++ b/src/proto_008_PtEdoTez/lib_client/client_proto_contracts.ml @@ -157,12 +157,12 @@ end let list_contracts cctxt = RawContractAlias.load cctxt >>=? fun raw_contracts -> - Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts + List.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts >>= fun contracts -> Client_keys.Public_key_hash.load cctxt >>=? fun keys -> (* List accounts (implicit contracts of identities) *) - map_s + List.map_es (fun (n, v) -> RawContractAlias.mem cctxt n >>=? fun mem -> diff --git a/src/proto_008_PtEdoTez/lib_client/client_proto_multisig.ml b/src/proto_008_PtEdoTez/lib_client/client_proto_multisig.ml index 009092e213564e954741ee771d69f97819e43bfd..508283d7d088c9f91f99d5f54b6d63c1bf3b61b1 100644 --- a/src/proto_008_PtEdoTez/lib_client/client_proto_multisig.ml +++ b/src/proto_008_PtEdoTez/lib_client/client_proto_multisig.ml @@ -569,7 +569,7 @@ let action_of_expr e = [] ) ], [] ) ], [] ) -> - map_s + List.map_es (function | Tezos_micheline.Micheline.Bytes (_, s) -> return @@ -608,7 +608,7 @@ let multisig_get_information (cctxt : #Protocol_client_context.full) ~chain D_Pair, [Int (_, counter); Int (_, threshold); Seq (_, key_nodes)], _ ) -> - map_s + List.map_es (function | String (_, key_str) -> return @@ Signature.Public_key.of_b58check_exn key_str @@ -623,7 +623,7 @@ let multisig_create_storage ~counter ~threshold ~keys () : Script.expr tzresult Lwt.t = let loc = Tezos_micheline.Micheline_parser.location_zero in let open Tezos_micheline.Micheline in - map_s + List.map_es (fun key -> let key_str = Signature.Public_key.to_b58check key in return (String (loc, key_str))) @@ -642,7 +642,7 @@ let multisig_create_param ~counter ~action ~optional_signatures () : Script.expr tzresult Lwt.t = let loc = Tezos_micheline.Micheline_parser.location_zero in let open Tezos_micheline.Micheline in - map_s + List.map_es (fun sig_opt -> match sig_opt with | None -> @@ -763,7 +763,7 @@ let check_multisig_signatures ~bytes ~threshold ~keys signatures = matching_key_found := true ; opt_sigs_arr.(i) <- Some signature ) in - iter_p + List.iter_ep (fun signature -> matching_key_found := false ; List.iteri (check_signature_against_key_number signature) keys ; diff --git a/src/proto_008_PtEdoTez/lib_client/injection.ml b/src/proto_008_PtEdoTez/lib_client/injection.ml index c23acffda0d042c4227c2ce34cde3f43db6402df..91469bd0ce5313c249457a8d4315752d8c75e34b 100644 --- a/src/proto_008_PtEdoTez/lib_client/injection.ml +++ b/src/proto_008_PtEdoTez/lib_client/injection.ml @@ -843,7 +843,7 @@ let inject_operation (type kind) cctxt ~chain ~block ?confirmations >>= fun () -> Lwt.return (originated_contracts result.contents) >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun c -> cctxt#message "New contract %a originated." Contract.pp c) contracts >>= fun () -> diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_emacs.ml b/src/proto_008_PtEdoTez/lib_client/michelson_v1_emacs.ml index 40ee5ce3e6ffee549b56f4877de3803832334fc3..07f493fc42a2887da6513c47a1597c4c5b3b60fa 100644 --- a/src/proto_008_PtEdoTez/lib_client/michelson_v1_emacs.ml +++ b/src/proto_008_PtEdoTez/lib_client/michelson_v1_emacs.ml @@ -89,22 +89,23 @@ let print_type_map ppf (parsed, type_map) = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr) items and print_item ppf loc = - try - let ({start = {point = s; _}; stop = {point = e; _}}, locs) = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - in - let locs = List.sort compare locs in - let (bef, aft) = List.assoc (List.hd locs) type_map in - Format.fprintf - ppf - "(@[%d %d %a %a@])@," - s - e - print_stack - bef - print_stack - aft - with Not_found -> () + (let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun hd_loc -> + List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + |> Option.iter (fun (s, e, bef, aft) -> + Format.fprintf + ppf + "(@[%d %d %a %a@])@," + s + e + print_stack + bef + print_stack + aft) in Format.fprintf ppf "(@[%a@])" print_expr_types (root parsed.unexpanded) @@ -154,9 +155,10 @@ let report_errors ppf (parsed, errs) = (fun ppf errs -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in match errs with | top :: errs -> @@ -194,9 +196,10 @@ let report_errors ppf (parsed, errs) = (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in let loc = match err with diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_error_reporter.ml b/src/proto_008_PtEdoTez/lib_client/michelson_v1_error_reporter.ml index 7c5e9632ecf55f47e91bab5ea8ba8eaff78fa41e..cf723f405df917c2c935e72cbe5fd52f11d42efc 100644 --- a/src/proto_008_PtEdoTez/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_008_PtEdoTez/lib_client/michelson_v1_error_reporter.ml @@ -146,13 +146,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = (Format.asprintf "%a" Micheline_parser.print_location loc)) in let parsed_locations parsed loc = - try - let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table - in - let (ploc, _) = List.assoc oloc parsed.expansion_table in - Some ploc - with Not_found -> None + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + >?? fun oloc -> + List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_parser.ml b/src/proto_008_PtEdoTez/lib_client/michelson_v1_parser.ml index 5a2e5b8d1c1623da260c7d2704279d984bc098a0..fcfc8a3d6fa301194acea9e6d34e833df6266954 100644 --- a/src/proto_008_PtEdoTez/lib_client/michelson_v1_parser.ml +++ b/src/proto_008_PtEdoTez/lib_client/michelson_v1_parser.ml @@ -59,12 +59,19 @@ let expand_all source ast errors = in group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + match + List.map2 + ~when_different_lengths:() + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) + with + | Ok v -> + v + | Error () -> + invalid_arg "Michelson_v1_parser.expand_all" in match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) diff --git a/src/proto_008_PtEdoTez/lib_client/michelson_v1_printer.ml b/src/proto_008_PtEdoTez/lib_client/michelson_v1_printer.ml index c7e613eec00021b15260cdeb62ca23312a06ee17..4065060a5d9f4957c6d27afa6389a5f43831c13c 100644 --- a/src/proto_008_PtEdoTez/lib_client/michelson_v1_printer.ml +++ b/src/proto_008_PtEdoTez/lib_client/michelson_v1_printer.ml @@ -134,17 +134,19 @@ let inject_types type_map parsed = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let locs = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - |> snd |> List.sort compare - in - let (bef, aft) = List.assoc (List.hd locs) type_map in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun (_, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun head_loc -> + List.assoc head_loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in inject_expr (root parsed.unexpanded) @@ -169,15 +171,16 @@ let unparse ?type_map parse expanded = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let (bef, aft) = - List.assoc (List.assoc loc unexpansion_table) type_map - in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc unexpansion_table + >?? fun loc -> + List.assoc loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in unexpanded |> root |> inject_expr |> Format.asprintf "%a" Micheline_printer.print_expr diff --git a/src/proto_008_PtEdoTez/lib_client/mockup.ml b/src/proto_008_PtEdoTez/lib_client/mockup.ml index 1fa44f9512e3dfd22cc03316fdd84aae63451ad0..f1dc0d4bc85623dec253df1bf547f3ad6b820c54 100644 --- a/src/proto_008_PtEdoTez/lib_client/mockup.ml +++ b/src/proto_008_PtEdoTez/lib_client/mockup.ml @@ -192,7 +192,7 @@ let mockup_default_bootstrap_accounts let errors = ref [] in Client_keys.list_keys wallet >>=? fun all_keys -> - Lwt_list.iter_s + List.iter_s (function | (name, pkh, _pk_opt, Some sk_uri) -> ( let contract = @@ -439,7 +439,7 @@ let mem_init : parsed_account_repr_pp) accounts >>= fun () -> - Tezos_base.TzPervasives.map_s to_bootstrap_account accounts + List.map_es to_bootstrap_account accounts >>=? fun bootstrap_accounts -> return (Some bootstrap_accounts) | exception error -> failwith diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_context_commands.ml b/src/proto_008_PtEdoTez/lib_client_commands/client_proto_context_commands.ml index ae254fc70d52d68a57c8926fd50ce33723e7f4d0..13afd73154e0997ad178d228ebcc13d94f6b422b 100644 --- a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_008_PtEdoTez/lib_client_commands/client_proto_context_commands.ml @@ -277,7 +277,7 @@ let commands network () = (fun () (cctxt : Protocol_client_context.full) -> list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> return_unit); @@ -840,7 +840,7 @@ let commands network () = >>=? fun (_, src_pk, src_sk) -> return (source, src_pk, src_sk) ) >>=? fun (source, src_pk, src_sk) -> - mapi_p prepare operations + List.mapi_ep prepare operations >>=? fun contents -> let (Manager_list contents) = Injection.manager_of_list contents in Injection.inject_manager_operation diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_008_PtEdoTez/lib_client_commands/client_proto_contracts_commands.ml index 1aa9bd843ff2a012ca390b0605c1e74ca6ab4e73..bb1bea6b3de881d07dfa5a0e95d85ce3e9936478 100644 --- a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_008_PtEdoTez/lib_client_commands/client_proto_contracts_commands.ml @@ -59,7 +59,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> list_contracts cctxt >>=? fun contracts -> - iter_s + List.iter_es (fun (prefix, alias, contract) -> cctxt#message "%s%s: %s" diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_008_PtEdoTez/lib_client_commands/client_proto_multisig_commands.ml index c0d73556114d9f2e7e3bc3abe71981e413d196dd..06a2104d4cfceb2292d05abae2a603a61a43d8bf 100644 --- a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_008_PtEdoTez/lib_client_commands/client_proto_multisig_commands.ml @@ -192,7 +192,9 @@ let commands () : #Protocol_client_context.full Clic.command list = burn_cap; } in - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + keys >>=? fun keys -> Client_proto_multisig.originate_multisig cctxt @@ -335,7 +337,9 @@ let commands () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys >>=? fun keys -> Client_proto_multisig.prepare_multisig_transaction cctxt @@ -459,7 +463,9 @@ let commands () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys >>=? fun keys -> Client_proto_multisig.prepare_multisig_transaction cctxt diff --git a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_programs_commands.ml b/src/proto_008_PtEdoTez/lib_client_commands/client_proto_programs_commands.ml index c7bc31894536f42f115315e1c2384af82e2e0aca..f84320640c6c082ec0a879bd486ffcb812d5ed59 100644 --- a/src/proto_008_PtEdoTez/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_008_PtEdoTez/lib_client_commands/client_proto_programs_commands.ml @@ -191,7 +191,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> Program.load cctxt >>=? fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list + List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return_unit); command ~group diff --git a/src/proto_008_PtEdoTez/lib_client_sapling/client_sapling_commands.ml b/src/proto_008_PtEdoTez/lib_client_sapling/client_sapling_commands.ml index f089cbf09b5e38bfc8dcb3d9eee0f66c51710ebe..e5754d67a1e902e0fdbe17d5cb767535996bbaa2 100644 --- a/src/proto_008_PtEdoTez/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_008_PtEdoTez/lib_client_sapling/client_sapling_commands.ml @@ -809,7 +809,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> Sapling_key.load cctxt >>=? fun l -> - iter_s + List.iter_es (fun (s, _) -> cctxt#message "%s" s >>= fun () -> return_unit) (List.sort (fun (s1, _) (s2, _) -> String.compare s1 s2) l)); shield_cmd; diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_blocks.ml b/src/proto_008_PtEdoTez/lib_delegate/client_baking_blocks.ml index 5ded180478a7219646346be7e323138f6cfa6a21..8e811b0b4b9ba61cd4e7be21af138552e8607ae8 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/client_baking_blocks.ml +++ b/src/proto_008_PtEdoTez/lib_delegate/client_baking_blocks.ml @@ -202,7 +202,7 @@ let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = let blocks = List.remove (length - Int32.to_int (Raw_level.diff last first)) - (List.hd blocks) + (Option.get @@ List.hd blocks) in if Int32.equal level (Raw_level.to_int32 last) then return (hash :: blocks) diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_denunciation.ml b/src/proto_008_PtEdoTez/lib_delegate/client_baking_denunciation.ml index 407b69fb8c109093f69672fc12ce12a44dd9ba4f..d13f276e1b344477c743a3471daf4c6bc1af7116 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_008_PtEdoTez/lib_delegate/client_baking_denunciation.ml @@ -80,7 +80,7 @@ let get_block_offset level = let process_endorsements (cctxt : #Protocol_client_context.full) state (endorsements : Alpha_block_services.operation list) level = - iter_s + List.iter_es (fun {Alpha_block_services.shell; chain_id; receipt; hash; protocol_data; _} -> let chain = `Hash chain_id in @@ -332,7 +332,9 @@ let process_new_block (cctxt : #Protocol_client_context.full) state >>= (function | Ok operations -> if List.length operations > endorsements_index then - let endorsements = List.nth operations endorsements_index in + let endorsements = + Option.get @@ List.nth operations endorsements_index + in process_endorsements cctxt state endorsements level else return_unit | Error errs -> diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_endorsement.ml b/src/proto_008_PtEdoTez/lib_delegate/client_baking_endorsement.ml index dc173aaa10ca23cc655f579c0262c10aae342b07..8ef2ee02006259c46321b5a37c58b0cd8ecee3cc 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/client_baking_endorsement.ml +++ b/src/proto_008_PtEdoTez/lib_delegate/client_baking_endorsement.ml @@ -255,7 +255,7 @@ let prepare_endorsement ~(max_past : int64) () in get_delegates cctxt state >>=? fun delegates -> - filter_p (allowed_to_endorse cctxt bi) delegates + List.filter_ep (allowed_to_endorse cctxt bi) delegates >>=? fun delegates -> state.pending <- Some {time; block = bi; delegates} ; return_unit @@ -293,7 +293,7 @@ let create (cctxt : #Protocol_client_context.full) ?(max_past = 110L) ~delay in let timeout_k cctxt state (block, delegates) = state.pending <- None ; - iter_s + List.iter_es (fun delegate -> endorse_for_delegate cctxt block delegate >>= function diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml b/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml index 3e139f9d3fc5e29afe8450f8442018cc4819fb20..28aad1e5ba11b49ce99b3c04832fe66eaf2a8465 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml +++ b/src/proto_008_PtEdoTez/lib_delegate/client_baking_forge.ml @@ -158,7 +158,7 @@ let assert_valid_operations_hash shell_header operations = let compute_endorsing_power cctxt ~chain ~block operations = Shell_services.Chain.chain_id cctxt ~chain () >>=? fun chain_id -> - fold_left_s + List.fold_left_es (fun sum -> function | { Alpha_context.protocol_data = Operation_data {contents = Single (Endorsement _); _}; @@ -260,7 +260,7 @@ let get_manager_operation_gas_and_fee op = let {protocol_data = Operation_data {contents; _}; _} = op in let open Operation in let l = to_list (Contents_list contents) in - fold_left_s + List.fold_left_es (fun ((total_fee, total_gas) as acc) -> function | Contents (Manager_operation {fee; gas_limit; _}) -> (Lwt.return @@ Environment.wrap_error @@ Tez.(total_fee +? fee)) @@ -287,7 +287,7 @@ let sort_manager_operations ~max_size ~hard_gas_limit_per_block ~minimal_fees in (size, gas, Q.(fee_f / max size_ratio gas_ratio)) in - filter_map_s + List.filter_map_es (fun op -> get_manager_operation_gas_and_fee op >>=? fun (fee, gas) -> @@ -347,7 +347,7 @@ let retain_operations_up_to_quota operations quota = let trim_manager_operations ~max_size ~hard_gas_limit_per_block manager_operations = - map_s + List.map_es (fun op -> get_manager_operation_gas_and_fee op >>=? fun (_fee, gas) -> @@ -402,7 +402,7 @@ let classify_operations (cctxt : #Protocol_client_context.full) ~chain ~block (* Retrieve the optimist maximum paying manager operations *) let manager_operations = t.(managers_index) in let {Environment.Updater.max_size; _} = - List.nth Main.validation_passes managers_index + Option.get @@ List.nth Main.validation_passes managers_index in sort_manager_operations ~max_size @@ -488,20 +488,20 @@ let decode_priority cctxt chain block ~priority ~endorsing_power = ~delegates:[src_pkh] (chain, block) >>=? fun possibilities -> - try - let {Alpha_services.Delegate.Baking_rights.priority = prio; _} = - List.find - (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level) - possibilities - in - Alpha_services.Delegate.Minimal_valid_time.get - cctxt - (chain, block) - prio - endorsing_power - >>=? fun minimal_timestamp -> return (prio, minimal_timestamp) - with Not_found -> - failwith "No slot found at level %a" Raw_level.pp level ) + match + List.find + (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level) + possibilities + with + | None -> + failwith "No slot found at level %a" Raw_level.pp level + | Some {Alpha_services.Delegate.Baking_rights.priority = prio; _} -> + Alpha_services.Delegate.Minimal_valid_time.get + cctxt + (chain, block) + prio + endorsing_power + >>=? fun minimal_timestamp -> return (prio, minimal_timestamp) ) let unopt_timestamp ?(force = false) timestamp minimal_timestamp = let timestamp = @@ -606,10 +606,10 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority state.index <- index ; return inc) >>=? fun initial_inc -> - let endorsements = List.nth operations endorsements_index in - let votes = List.nth operations votes_index in - let anonymous = List.nth operations anonymous_index in - let managers = List.nth operations managers_index in + let endorsements = Option.get @@ List.nth operations endorsements_index in + let votes = Option.get @@ List.nth operations votes_index in + let anonymous = Option.get @@ List.nth operations anonymous_index in + let managers = Option.get @@ List.nth operations managers_index in let validate_operation inc op = protect (fun () -> add_operation inc op) >>= function @@ -647,14 +647,10 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority >>= fun () -> Lwt.return_none ) in let filter_valid_operations inc ops = - Lwt_list.fold_left_s + List.fold_left_s (fun (inc, acc) op -> validate_operation inc op - >>= function - | None -> - Lwt.return (inc, acc) - | Some inc' -> - Lwt.return (inc', op :: acc)) + >|= function None -> (inc, acc) | Some inc' -> (inc', op :: acc)) (inc, []) ops in @@ -677,15 +673,17 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority let quota : Environment.Updater.quota list = Main.validation_passes in let {Constants.hard_gas_limit_per_block; _} = state.constants.parametric in let votes = - retain_operations_up_to_quota (List.rev votes) (List.nth quota votes_index) + retain_operations_up_to_quota + (List.rev votes) + (Option.get @@ List.nth quota votes_index) in let anonymous = retain_operations_up_to_quota (List.rev anonymous) - (List.nth quota anonymous_index) + (Option.get @@ List.nth quota anonymous_index) in trim_manager_operations - ~max_size:(List.nth quota managers_index).max_size + ~max_size:(Option.get @@ List.nth quota managers_index).max_size ~hard_gas_limit_per_block managers >>=? fun (accepted_managers, _overflowing_managers) -> @@ -717,7 +715,7 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority state.index block_info >>=? fun inc -> - fold_left_s + List.fold_left_es (fun inc op -> add_operation inc op >>=? fun (inc, _receipt) -> return inc) inc (List.flatten operations) @@ -818,20 +816,22 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) (* Ensure that we retain operations up to the quota *) let quota : Environment.Updater.quota list = Main.validation_passes in let endorsements = - List.sub (List.nth operations endorsements_index) endorsers_per_block + List.sub + (Option.get @@ List.nth operations endorsements_index) + endorsers_per_block in let votes = retain_operations_up_to_quota - (List.nth operations votes_index) - (List.nth quota votes_index) + (Option.get @@ List.nth operations votes_index) + (Option.get @@ List.nth quota votes_index) in let anonymous = retain_operations_up_to_quota - (List.nth operations anonymous_index) - (List.nth quota anonymous_index) + (Option.get @@ List.nth operations anonymous_index) + (Option.get @@ List.nth quota anonymous_index) in (* Size/Gas check already occurred in classify operations *) - let managers = List.nth operations managers_index in + let managers = Option.get @@ List.nth operations managers_index in let operations = [endorsements; votes; anonymous; managers] in ( match context_path with | None -> diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_lib.ml b/src/proto_008_PtEdoTez/lib_delegate/client_baking_lib.ml index 72f1b91a6d810885c37a10eb5ae057e81a9dcd28..face4ba87e2cab04f1f057255ad447d39786268d 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/client_baking_lib.ml +++ b/src/proto_008_PtEdoTez/lib_delegate/client_baking_lib.ml @@ -123,7 +123,7 @@ let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block >>=? fun nonces_location -> Client_baking_nonces.load cctxt nonces_location) >>=? fun nonces -> - Lwt_list.filter_map_p + List.filter_map_p (fun hash -> Lwt.catch (fun () -> @@ -138,7 +138,7 @@ let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block >>= fun () -> Lwt.return_none)) block_hashes >>= fun block_infos -> - filter_map_s + List.filter_map_es (fun (bi : Client_baking_blocks.block_info) -> match Client_baking_nonces.find_opt nonces bi.hash with | None -> diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_nonces.ml b/src/proto_008_PtEdoTez/lib_delegate/client_baking_nonces.ml index 7002359cbbd99d75ead1e3c6e05b4e5c93b941ff..7a47c7a6a8b93098ce6c7402f916ab94a03e04da 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/client_baking_nonces.ml +++ b/src/proto_008_PtEdoTez/lib_delegate/client_baking_nonces.ml @@ -156,7 +156,7 @@ let get_unrevealed_nonces cctxt location nonces = ~offset:(-1l) () >>=? fun blocks -> - filter_map_s + List.filter_map_es (fun hash -> match find_opt nonces hash with | None -> diff --git a/src/proto_008_PtEdoTez/lib_delegate/client_baking_revelation.ml b/src/proto_008_PtEdoTez/lib_delegate/client_baking_revelation.ml index 02bc973484a2a0f1be27cf753e2b1d7a310e1005..6aa5d9bc9a8ad3a710fbb27b0b0624ea8beaaf06 100644 --- a/src/proto_008_PtEdoTez/lib_delegate/client_baking_revelation.ml +++ b/src/proto_008_PtEdoTez/lib_delegate/client_baking_revelation.ml @@ -43,7 +43,7 @@ let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain -% a Block_hash.Logging.tag hash) >>= fun () -> return_unit | _ -> - iter_s + List.iter_es (fun (level, nonce) -> Alpha_services.Forge.seed_nonce_revelation cctxt diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/activation.ml b/src/proto_008_PtEdoTez/lib_protocol/test/activation.ml index ae3b8dbbe44a217db9a8e07ab11fe714804d6897..792d4b38efb6554ac45637a9cd662210759d3d73 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/activation.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/activation.ml @@ -316,7 +316,7 @@ let single_activation () = activation_init () >>=? fun (blk, _contracts, secrets) -> let ({account; activation_code; amount = expected_amount; _} as _first_one) = - List.hd secrets + Option.get @@ List.hd secrets in (* Contract does not exist *) Assert.balance_is @@ -340,7 +340,7 @@ let single_activation () = let multi_activation_1 () = activation_init () >>=? fun (blk, _contracts, secrets) -> - Error_monad.fold_left_s + List.fold_left_es (fun blk {account; activation_code; amount = expected_amount; _} -> Op.activation (B blk) account activation_code >>=? fun operation -> @@ -360,7 +360,7 @@ let multi_activation_1 () = let multi_activation_2 () = activation_init () >>=? fun (blk, _contracts, secrets) -> - Error_monad.fold_left_s + List.fold_left_es (fun ops {account; activation_code; _} -> Op.activation (B blk) account activation_code >|=? fun op -> op :: ops) [] @@ -368,7 +368,7 @@ let multi_activation_2 () = >>=? fun ops -> Block.bake ~operations:ops blk >>=? fun blk -> - Error_monad.iter_s + List.iter_es (fun {account; amount = expected_amount; _} -> (* Contract does exist *) Assert.balance_is @@ -382,8 +382,10 @@ let multi_activation_2 () = let activation_and_transfer () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; activation_code; _} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in + let bootstrap_contract = Option.get @@ List.hd contracts in let first_contract = Contract.implicit_contract account in Op.activation (B blk) account activation_code >>=? fun operation -> @@ -410,8 +412,10 @@ let activation_and_transfer () = let transfer_to_unactivated_then_activate () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; activation_code; amount} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; activation_code; amount} as _first_one) = + Option.get @@ List.hd secrets + in + let bootstrap_contract = Option.get @@ List.hd contracts in let unactivated_commitment_contract = Contract.implicit_contract account in Context.Contract.balance (B blk) bootstrap_contract >>=? fun b_amount -> @@ -450,7 +454,9 @@ let invalid_activation_with_no_commitments () = Context.init 1 >>=? fun (blk, _) -> let secrets = secrets () in - let ({account; activation_code; _} as _first_one) = List.hd secrets in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in Op.activation (B blk) account activation_code >>=? fun operation -> Block.bake ~operation blk @@ -465,8 +471,10 @@ let invalid_activation_with_no_commitments () = let invalid_activation_wrong_secret () = activation_init () >>=? fun (blk, _, secrets) -> - let ({account; _} as _first_one) = List.nth secrets 0 in - let ({activation_code; _} as _second_one) = List.nth secrets 1 in + let ({account; _} as _first_one) = Option.get @@ List.nth secrets 0 in + let ({activation_code; _} as _second_one) = + Option.get @@ List.nth secrets 1 + in Op.activation (B blk) account activation_code >>=? fun operation -> Block.bake ~operation blk @@ -482,7 +490,7 @@ let invalid_activation_wrong_secret () = let invalid_activation_inexistent_pkh () = activation_init () >>=? fun (blk, _, secrets) -> - let ({activation_code; _} as _first_one) = List.hd secrets in + let ({activation_code; _} as _first_one) = Option.get @@ List.hd secrets in let inexistent_pkh = Signature.Public_key_hash.of_b58check_exn "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" @@ -502,7 +510,9 @@ let invalid_activation_inexistent_pkh () = let invalid_double_activation () = activation_init () >>=? fun (blk, _, secrets) -> - let ({account; activation_code; _} as _first_one) = List.hd secrets in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in Incremental.begin_construction blk >>=? fun inc -> Op.activation (I inc) account activation_code @@ -523,8 +533,8 @@ let invalid_double_activation () = let invalid_transfer_from_unactivated_account () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; _} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; _} as _first_one) = Option.get @@ List.hd secrets in + let bootstrap_contract = Option.get @@ List.hd contracts in let unactivated_commitment_contract = Contract.implicit_contract account in (* No activation *) Op.transaction diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/baking.ml b/src/proto_008_PtEdoTez/lib_protocol/test/baking.ml index 2405aa9f93b3486dcb39152828ed2c74ebd0b745..9b750d2e33fec2367c35ae9acfa8f60f5eaeb1d6 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/baking.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/baking.ml @@ -103,11 +103,11 @@ let test_rewards_retrieval () = let block_priorities = 0 -- 10 in let included_endorsements = 0 -- endorsers_per_block in let ranges = List.product block_priorities included_endorsements in - iter_s + List.iter_es (fun (priority, endorsing_power) -> (* bake block at given priority and with given endorsing_power *) let real_endorsers = List.sub endorsers endorsing_power in - map_p + List.map_ep (fun endorser -> Op.endorsement ~delegate:endorser.delegate (B good_b) () >|=? fun operation -> Operation.pack operation) @@ -148,7 +148,7 @@ let test_rewards_retrieval () = accumulated_frozen_balance ) >>=? fun () -> (* check the each endorser was rewarded the right amount *) - iter_p + List.iter_ep (fun endorser -> balance_update endorser.delegate good_b b >>=? fun endorser_frozen_balance -> @@ -175,7 +175,7 @@ let test_rewards_formulas () = let block_priorities = 0 -- 2 in let included_endorsements = 0 -- endorsers_per_block in let ranges = List.product block_priorities included_endorsements in - iter_p + List.iter_ep (fun (priority, endorsing_power) -> Context.get_baking_reward (B b) ~priority ~endorsing_power >>=? fun reward -> @@ -215,7 +215,7 @@ let test_rewards_formulas_equivalence () = let block_priorities = 0 -- 64 in let endorsing_power = 0 -- endorsers_per_block in let ranges = List.product block_priorities endorsing_power in - iter_p + List.iter_ep (fun (block_priority, endorsing_power) -> Baking.baking_reward ctxt @@ -256,7 +256,7 @@ let test_voting_power_cache () = >>=? fun (block, _contracts) -> Context.get_bakers (B block) >>=? fun bakers -> - let baker = List.hd bakers in + let baker = Option.get @@ List.hd bakers in let assert_voting_power n block = get_voting_power block baker >>=? fun voting_power -> diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/combined_operations.ml b/src/proto_008_PtEdoTez/lib_protocol/test/combined_operations.ml index e1701b8acdda3a40fac1589fecd5b7f96487c70a..b24c8f033f4ecf0aa33316ae63e972727a69242e 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/combined_operations.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/combined_operations.ml @@ -43,10 +43,10 @@ let ten_tez = Tez.of_int 10 let multiple_transfers () = Context.init 3 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in - let c3 = List.nth contracts 2 in - map_s (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10) + let c1 = Option.get @@ List.nth contracts 0 in + let c2 = Option.get @@ List.nth contracts 1 in + let c3 = Option.get @@ List.nth contracts 2 in + List.map_es (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10) >>=? fun ops -> Op.combine_operations ~source:c1 (B blk) ops >>=? fun operation -> @@ -77,15 +77,15 @@ let multiple_transfers () = let multiple_origination_and_delegation () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let c1 = Option.get @@ List.nth contracts 0 in + let c2 = Option.get @@ List.nth contracts 1 in let n = 10 in Context.get_constants (B blk) >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> Context.Contract.pkh c2 >>=? fun delegate_pkh -> (* Deploy n smart contracts with dummy scripts from c1 *) - map_s + List.map_es (fun i -> Op.origination ~delegate:delegate_pkh @@ -146,7 +146,7 @@ let multiple_origination_and_delegation () = >>?= fun total_cost -> Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost >>=? fun () -> - iter_s + List.iter_es (fun c -> Assert.balance_is ~loc:__LOC__ (I inc) c (Tez.of_int 10)) new_contracts @@ -164,8 +164,8 @@ let expect_balance_too_low = function let failing_operation_in_the_middle () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let c1 = Option.get @@ List.nth contracts 0 in + let c2 = Option.get @@ List.nth contracts 1 in Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.max_tez @@ -220,8 +220,8 @@ let failing_operation_in_the_middle () = let failing_operation_in_the_middle_with_fees () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let c1 = Option.get @@ List.nth contracts 0 in + let c2 = Option.get @@ List.nth contracts 1 in Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.max_tez @@ -294,8 +294,8 @@ let expect_wrong_signature list = let wrong_signature_in_the_middle () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let c1 = Option.get @@ List.nth contracts 0 in + let c2 = Option.get @@ List.nth contracts 1 in Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.one (B blk) c2 c1 Tez.one diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/delegation.ml b/src/proto_008_PtEdoTez/lib_protocol/test/delegation.ml index 83904dc1f4df6ad74780f7ea93806789bc8790c4..f9ddabc64207a49e144db822b268d8d7c861860c 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/delegation.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/delegation.ml @@ -53,7 +53,7 @@ let expect_no_change_registered_delegate_pkh pkh = function let bootstrap_manager_is_bootstrap_delegate () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.hd bootstrap_contracts in + let bootstrap0 = Option.get @@ List.hd bootstrap_contracts in Context.Contract.delegate (B b) bootstrap0 >>=? fun delegate0 -> Context.Contract.manager (B b) bootstrap0 @@ -63,8 +63,8 @@ let bootstrap_manager_is_bootstrap_delegate () = let bootstrap_delegate_cannot_change ~fee () = Context.init 2 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.nth bootstrap_contracts 0 in - let bootstrap1 = List.nth bootstrap_contracts 1 in + let bootstrap0 = Option.get @@ List.nth bootstrap_contracts 0 in + let bootstrap1 = Option.get @@ List.nth bootstrap_contracts 1 in Context.Contract.pkh bootstrap0 >>=? fun pkh1 -> Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) @@ -106,7 +106,7 @@ let bootstrap_delegate_cannot_change ~fee () = let bootstrap_delegate_cannot_be_removed ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Incremental.begin_construction b >>=? fun i -> Context.Contract.balance (I i) bootstrap @@ -144,8 +144,8 @@ let bootstrap_delegate_cannot_be_removed ~fee () = let delegate_can_be_changed_from_unregistered_contract ~fee () = Context.init 2 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.hd bootstrap_contracts in - let bootstrap1 = List.nth bootstrap_contracts 1 in + let bootstrap0 = Option.get @@ List.hd bootstrap_contracts in + let bootstrap1 = Option.get @@ List.nth bootstrap_contracts 1 in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let unregistered = Contract.implicit_contract unregistered_pkh in @@ -197,7 +197,7 @@ let delegate_can_be_changed_from_unregistered_contract ~fee () = let delegate_can_be_removed_from_unregistered_contract ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let unregistered = Contract.implicit_contract unregistered_pkh in @@ -252,7 +252,7 @@ let bootstrap_manager_already_registered_delegate ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun manager -> let pkh = manager.pkh in @@ -289,7 +289,7 @@ let delegate_to_bootstrap_by_origination ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun manager -> Context.Contract.balance (I i) bootstrap @@ -486,7 +486,7 @@ let unregistered_delegate_key_init_origination ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in (* origination with delegate argument *) @@ -537,7 +537,7 @@ let unregistered_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -587,7 +587,7 @@ let unregistered_delegate_key_switch_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -646,7 +646,7 @@ let unregistered_delegate_key_init_origination_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -697,7 +697,7 @@ let unregistered_delegate_key_init_delegation_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -755,7 +755,7 @@ let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -823,7 +823,7 @@ let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -881,7 +881,7 @@ let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -944,7 +944,7 @@ let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -1041,7 +1041,7 @@ let failed_self_delegation_emptied_implicit_contract amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let unregistered_pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -1075,7 +1075,7 @@ let emptying_delegated_implicit_contract_fails amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun bootstrap_manager -> let account = Account.new_account () in @@ -1115,7 +1115,7 @@ let valid_delegate_registration_init_delegation_credit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1168,7 +1168,7 @@ let valid_delegate_registration_switch_delegation_credit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1222,7 +1222,7 @@ let valid_delegate_registration_init_delegation_credit_debit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1290,7 +1290,7 @@ let valid_delegate_registration_switch_delegation_credit_debit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1356,7 +1356,7 @@ let double_registration () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1389,7 +1389,7 @@ let double_registration_when_empty () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1429,7 +1429,7 @@ let double_registration_when_recredited () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1476,7 +1476,7 @@ let unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; _} = Account.new_account () in let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in @@ -1511,7 +1511,7 @@ let unregistered_and_revealed_self_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; pk; _} = Account.new_account () in let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in @@ -1550,7 +1550,7 @@ let registered_self_delegate_key_init_delegation () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; _} = Account.new_account () in let {Account.pkh = delegate_pkh; pk = delegate_pk; _} = Account.new_account () diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/double_baking.ml b/src/proto_008_PtEdoTez/lib_protocol/test/double_baking.ml index 535cfdb3bc5899393a085af0acf6902015b75624..e16509921a0efd524431e11b84c98df822d66ad5 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/double_baking.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/double_baking.ml @@ -34,29 +34,33 @@ open Alpha_context (****************************************************************) let get_first_different_baker baker bakers = - List.find - (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') - bakers + Option.get + @@ List.find + (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') + bakers let get_first_different_bakers ctxt = Context.get_bakers ctxt >|=? fun bakers -> - let baker_1 = List.hd bakers in - get_first_different_baker baker_1 (List.tl bakers) + let baker_1 = Option.get @@ List.hd bakers in + get_first_different_baker baker_1 (Option.get @@ List.tl bakers) |> fun baker_2 -> (baker_1, baker_2) let get_first_different_endorsers ctxt = Context.get_endorsers ctxt >|=? fun endorsers -> - let endorser_1 = (List.hd endorsers).delegate in - let endorser_2 = (List.hd (List.tl endorsers)).delegate in + let endorser_1 = (Option.get @@ List.hd endorsers).delegate in + let endorser_2 = + (Option.get @@ List.hd (Option.get @@ List.tl endorsers)).delegate + in (endorser_1, endorser_2) (** Bake two block at the same level using the same policy (i.e. same baker) *) let block_fork ?policy contracts b = let (contract_a, contract_b) = - (List.hd contracts, List.hd (List.tl contracts)) + ( Option.get @@ List.hd contracts, + Option.get @@ List.hd (Option.get @@ List.tl contracts) ) in Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent >>=? fun operation -> @@ -74,7 +78,7 @@ let valid_double_baking_evidence () = >>=? fun (b, contracts) -> Context.get_bakers (B b) >>=? fun bakers -> - let priority_0_baker = List.hd bakers in + let priority_0_baker = Option.get @@ List.hd bakers in block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> Op.double_baking (B blk_a) blk_a.header blk_b.header @@ -82,7 +86,7 @@ let valid_double_baking_evidence () = Block.bake ~policy:(Excluding [priority_0_baker]) ~operation blk_a >>=? fun blk -> (* Check that the frozen deposit, the fees and rewards are removed *) - iter_s + List.iter_es (fun kind -> let contract = Alpha_context.Contract.implicit_contract priority_0_baker @@ -156,7 +160,7 @@ let too_late_double_baking_evidence () = >>=? fun Constants.{parametric = {preserved_cycles; _}; _} -> block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> - fold_left_s + List.fold_left_es (fun blk _ -> Block.bake_until_cycle_end blk) blk_a (1 -- (preserved_cycles + 1)) diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/double_endorsement.ml b/src/proto_008_PtEdoTez/lib_protocol/test/double_endorsement.ml index f644217660702886d2808bd75ecb8efce51f5a91..74a41704e66413f17f6014ab10a915cbcc7295e9 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/double_endorsement.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/double_endorsement.ml @@ -34,22 +34,23 @@ open Alpha_context (****************************************************************) let get_first_different_baker baker bakers = - List.find - (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') - bakers + Option.get + @@ List.find + (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') + bakers let get_first_different_bakers ctxt = Context.get_bakers ctxt >|=? fun bakers -> - let baker_1 = List.hd bakers in - get_first_different_baker baker_1 (List.tl bakers) + let baker_1 = Option.get @@ List.hd bakers in + get_first_different_baker baker_1 (Option.get @@ List.tl bakers) |> fun baker_2 -> (baker_1, baker_2) let get_first_different_endorsers ctxt = Context.get_endorsers ctxt >|=? fun endorsers -> - let endorser_1 = List.hd endorsers in - let endorser_2 = List.hd (List.tl endorsers) in + let endorser_1 = Option.get @@ List.hd endorsers in + let endorser_2 = Option.get @@ List.hd (Option.get @@ List.tl endorsers) in (endorser_1, endorser_2) let block_fork b = @@ -90,7 +91,7 @@ let valid_double_endorsement_evidence () = Block.bake ~policy:(By_account baker) ~operation blk_a >>=? fun blk -> (* Check that the frozen deposit, the fees and rewards are removed *) - iter_s + List.iter_es (fun kind -> let contract = Alpha_context.Contract.implicit_contract delegate in Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero) @@ -159,7 +160,7 @@ let too_late_double_endorsement_evidence () = >>=? fun endorsement_a -> Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b -> - fold_left_s + List.fold_left_es (fun blk _ -> Block.bake_until_cycle_end blk) blk_a (1 -- (preserved_cycles + 1)) @@ -213,10 +214,10 @@ let different_delegates () = let wrong_delegate () = Context.init ~endorsers_per_block:1 2 >>=? fun (b, contracts) -> - Error_monad.map_s (Context.Contract.manager (B b)) contracts + List.map_es (Context.Contract.manager (B b)) contracts >>=? fun accounts -> - let pkh1 = (List.nth accounts 0).Account.pkh in - let pkh2 = (List.nth accounts 1).Account.pkh in + let pkh1 = (Option.get @@ List.nth accounts 0).Account.pkh in + let pkh2 = (Option.get @@ List.nth accounts 1).Account.pkh in block_fork b >>=? fun (blk_a, blk_b) -> Context.get_endorser (B blk_a) diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/endorsement.ml b/src/proto_008_PtEdoTez/lib_protocol/test/endorsement.ml index b8481a767d0689abac53f467d98d92523a9fcb57..97f9b35b1240c4f2223ad1d2784f5240e54a96df 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/endorsement.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/endorsement.ml @@ -135,7 +135,7 @@ let max_endorsement () = endorsers))) endorsers_per_block >>=? fun () -> - fold_left_s + List.fold_left_es (fun (delegates, ops, balances) (endorser : Alpha_services.Delegate.Endorsing_rights.t) -> let delegate = endorser.delegate in @@ -153,22 +153,25 @@ let max_endorsement () = >>=? fun b -> (* One account can endorse more than one time per level, we must check that the bonds are summed up *) - iter_s - (fun (endorser_account, (endorsing_power, previous_balance)) -> + List.iter2_es + ~when_different_lengths: + (TzTrace.make (Exn (Failure "Unequal delegates and balances lengths"))) + (fun endorser_account (endorsing_power, previous_balance) -> assert_endorser_balance_consistency ~loc:__LOC__ (B b) ~endorsing_power endorser_account previous_balance) - (List.combine delegates previous_balances) + delegates + previous_balances (** Check every that endorsers' balances are consistent with different priorities *) let consistent_priorities () = let priorities = 0 -- 64 in Context.init 64 >>=? fun (b, _) -> - fold_left_s + List.fold_left_es (fun (b, used_pkhes) priority -> (* Choose an endorser that has not baked nor endorsed before *) Context.get_endorsers (B b) @@ -236,7 +239,7 @@ let reward_retrieval () = Block.bake ~policy ~operation b >>=? fun b -> (* Bake (preserved_cycles + 1) cycles *) - fold_left_s + List.fold_left_es (fun b _ -> Block.bake_until_cycle_end ~policy:(Excluding [endorser]) b) b (0 -- preserved_cycles) @@ -266,8 +269,8 @@ let reward_retrieval_two_endorsers () = _ } -> Context.get_endorsers (B b) >>=? fun endorsers -> - let endorser1 = List.hd endorsers in - let endorser2 = List.hd (List.tl endorsers) in + let endorser1 = Option.get @@ List.hd endorsers in + let endorser2 = Option.get @@ List.nth endorsers 1 in Context.Contract.balance (B b) (Contract.implicit_contract endorser1.delegate) @@ -329,7 +332,7 @@ let reward_retrieval_two_endorsers () = Signature.Public_key_hash.( endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate) in - let endorser2 = List.find same_endorser2 endorsers in + let endorser2 = Option.get @@ List.find same_endorser2 endorsers in (* No exception raised: in sandboxed mode endorsers do not change between blocks *) Tez.( endorsement_security_deposit *? Int64.of_int (List.length endorser2.slots)) @@ -361,7 +364,7 @@ let reward_retrieval_two_endorsers () = security_deposit2 >>=? fun () -> (* bake [preserved_cycles] cycles *) - fold_left_s + List.fold_left_es (fun b _ -> Assert.balance_was_debited ~loc:__LOC__ @@ -481,7 +484,7 @@ let duplicate_endorsement () = let not_enough_for_deposit () = Context.init 5 ~endorsers_per_block:1 >>=? fun (b_init, contracts) -> - Error_monad.map_s + List.map_es (fun c -> Context.Contract.manager (B b_init) c >|=? fun m -> (m, c)) contracts >>=? fun managers -> @@ -491,15 +494,17 @@ let not_enough_for_deposit () = Context.get_endorser (B b) >>=? fun (endorser, _slots) -> let (_, contract_other_than_endorser) = - List.find - (fun (c, _) -> - not (Signature.Public_key_hash.equal c.Account.pkh endorser)) - managers + Option.get + @@ List.find + (fun (c, _) -> + not (Signature.Public_key_hash.equal c.Account.pkh endorser)) + managers in let (_, contract_of_endorser) = - List.find - (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser) - managers + Option.get + @@ List.find + (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser) + managers in Context.Contract.balance (B b) (Contract.implicit_contract endorser) >>=? fun initial_balance -> @@ -537,14 +542,14 @@ let endorsement_threshold () = let num_endorsers = List.length endorsers in (* we try to bake with more and more endorsers, but at each iteration with a timestamp smaller than required *) - iter_s + List.iter_es (fun i -> (* the priority is chosen rather arbitrarily *) let priority = num_endorsers - i in let crt_endorsers = List.take_n i endorsers in let endorsing_power = endorsing_power crt_endorsers in let delegates = delegates_with_slots crt_endorsers in - map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates + List.map_es (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates >>=? fun ops -> Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> @@ -574,7 +579,7 @@ let endorsement_threshold () = let priority = 0 in let endorsing_power = endorsing_power endorsers in let delegates = delegates_with_slots endorsers in - map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates + List.map_es (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates >>=? fun ops -> Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/gas_costs.ml b/src/proto_008_PtEdoTez/lib_protocol/test/gas_costs.ml index 8cc33ed40f2489e5d9144d829206cde1052ff5ac..217c90086269da171d9bb3f94a052d40e7b2d50e 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/gas_costs.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/gas_costs.ml @@ -229,7 +229,7 @@ let cast_cost_to_z (c : Alpha_context.Gas.cost) : Z.t = |> Data_encoding.Binary.of_bytes_exn Data_encoding.z let check_cost_reprs_are_all_positive list () = - iter_s + List.iter_es (fun (cost_name, cost) -> if Z.gt cost Z.zero then return_unit else if Z.equal cost Z.zero && List.mem cost_name free then return_unit diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/block.ml b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/block.ml index c43e57530f86036596ce6ef6c50e8fffb6072bb5..dc58af43cd1c8e2801bf676589f96be8f978646e 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/block.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/block.ml @@ -68,10 +68,11 @@ let get_next_baker_by_priority priority block = block >|=? fun bakers -> let {Alpha_services.Delegate.Baking_rights.delegate = pkh; timestamp; _} = - List.find - (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} -> - p = priority) - bakers + Option.get + @@ List.find + (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} -> + p = priority) + bakers in (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -86,7 +87,7 @@ let get_next_baker_by_account pkh block = timestamp; priority; _ } = - List.hd bakers + Option.get @@ List.hd bakers in (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -97,10 +98,11 @@ let get_next_baker_excluding excludes block = timestamp; priority; _ } = - List.find - (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> - not (List.mem delegate excludes)) - bakers + Option.get + @@ List.find + (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> + not (List.mem delegate excludes)) + bakers in (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -115,7 +117,7 @@ let dispatch_policy = function let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy let get_endorsing_power b = - fold_left_s + List.fold_left_es (fun acc (op : Operation.packed) -> let (Operation_data data) = op.protocol_data in match data.contents with @@ -329,17 +331,20 @@ let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers } in (* Check there is at least one roll *) - ( try - fold_left_s + (let exception Return_unit_now in + Lwt.catch + (fun () -> + List.fold_left_es (fun acc (_, amount) -> Environment.wrap_error @@ Tez_repr.( +? ) acc amount >>?= fun acc -> - if acc >= constants.tokens_per_roll then raise Exit else return acc) + if acc >= constants.tokens_per_roll then raise Return_unit_now + else return acc) Tez_repr.zero initial_accounts >>=? fun _ -> - failwith "Insufficient tokens in initial accounts to create one roll" - with Exit -> return_unit ) + failwith "Insufficient tokens in initial accounts to create one roll") + (function Return_unit_now -> return_unit | exc -> raise exc)) >>=? fun () -> check_constants_consistency constants >>=? fun () -> @@ -376,7 +381,7 @@ let apply header ?(operations = []) pred = ~predecessor_timestamp:pred.header.shell.timestamp header >>=? fun vstate -> - fold_left_s + List.fold_left_es (fun vstate op -> apply_operation vstate op >|=? fun (state, _result) -> state) vstate @@ -411,7 +416,7 @@ let bake ?policy ?timestamp ?operation ?operations pred = let get_constants b = Alpha_services.Constants.all rpc_ctxt b let bake_n ?policy n b = - Error_monad.fold_left_s (fun b _ -> bake ?policy b) b (1 -- n) + List.fold_left_es (fun b _ -> bake ?policy b) b (1 -- n) let bake_until_cycle_end ?policy b = get_constants b @@ -422,7 +427,7 @@ let bake_until_cycle_end ?policy b = bake_n ?policy (Int32.to_int delta) b let bake_until_n_cycle_end ?policy n b = - Error_monad.fold_left_s (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) + List.fold_left_es (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) let current_cycle b = get_constants b diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml index 84987952bc138841cf64d0a877928719474dbd2b..12264e667a330839738c6d6f9e423d77d64475a1 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/context.ml @@ -108,7 +108,7 @@ let get_endorsers ctxt = let get_endorser ctxt = Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt >|=? fun endorsers -> - let endorser = List.hd endorsers in + let endorser = Option.get @@ List.hd endorsers in (endorser.delegate, endorser.slots) let get_voting_power = Alpha_services.Delegate.voting_power rpc_ctxt diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/op.ml b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/op.ml index 691ccfa171e990755f807c943086130299e73b23..1d4ec4556f272f96f6a85dbde287f85f1b325d4a 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/op.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/op.ml @@ -66,7 +66,9 @@ let combine_operations ?public_key ?counter ?spurious_operation ~source ctxt (packed_operations : packed_operation list) = assert (List.length packed_operations > 0) ; (* Hypothesis : each operation must have the same branch (is this really true?) *) - let {Tezos_base.Operation.branch} = (List.hd packed_operations).shell in + let {Tezos_base.Operation.branch} = + (Option.get @@ List.hd packed_operations).shell + in assert ( List.for_all (fun {shell = {Tezos_base.Operation.branch = b; _}; _} -> diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/sapling_helpers.ml index b26e1de737d9ea70b49448a289061db69eca816f..8a052bcb341e2e257cc22b799038e13fa64a9bd8 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/helpers/sapling_helpers.ml @@ -401,11 +401,16 @@ module Interpreter_helpers = struct Sapling.Core.Wallet.Viewing_key.(new_address vk index) in let outputs = - List.init number_outputs (fun _ -> + List.init ~when_negative_length:() number_outputs (fun _ -> Sapling.Forge.make_output new_addr amount_output (Bytes.create memo_size)) + |> function + | Error () -> + assert false (* starts at 2 and increases *) + | Ok outputs -> + outputs in let tr_hex = to_hex diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/origination.ml b/src/proto_008_PtEdoTez/lib_protocol/test/origination.ml index f55fd66f2ab80fe7f5f8c50461886a515695e54d..efeec384e7e85b7cf9f51a88a41a051e7ac17cc2 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/origination.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/origination.ml @@ -37,7 +37,7 @@ let ten_tez = Tez.of_int 10 let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) () = Context.init 1 >>=? fun (b, contracts) -> - let source = List.hd contracts in + let source = Option.get @@ List.hd contracts in Context.Contract.balance (B b) source >>=? fun source_balance -> Op.origination (B b) source ~fee ~credit ~script:Op.dummy_script @@ -81,7 +81,7 @@ let test_origination_balances ~loc:_ ?(fee = Tez.zero) ?(credit = Tez.zero) () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Context.Contract.balance (B b) contract >>=? fun balance -> Op.origination (B b) contract ~fee ~credit ~script:Op.dummy_script @@ -163,8 +163,8 @@ let pay_fee () = let not_tez_in_contract_to_pay_fee () = Context.init 2 >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in + let contract_1 = Option.get @@ List.nth contracts 0 in + let contract_2 = Option.get @@ List.nth contracts 1 in Incremental.begin_construction b >>=? fun inc -> (* transfer everything but one tez from 1 to 2 and check balance of 1 *) @@ -203,7 +203,7 @@ let not_tez_in_contract_to_pay_fee () = let register_contract_get_endorser () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Incremental.begin_construction b >>=? fun inc -> Context.get_endorser (I inc) @@ -216,7 +216,7 @@ let register_contract_get_endorser () = (*******************) let n_originations n ?credit ?fee () = - fold_left_s + List.fold_left_es (fun new_contracts _ -> register_origination ?fee ?credit () >|=? fun (_b, _source, new_contract) -> new_contract :: new_contracts) @@ -236,7 +236,7 @@ let multiple_originations () = let counter () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Incremental.begin_construction b >>=? fun inc -> Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/reveal.ml b/src/proto_008_PtEdoTez/lib_protocol/test/reveal.ml index 1fd7bcd93dc856539fc2ae785c34e25a386366a5..8f3f98cb0651ca0d3771adde041d740712abdc9c 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/reveal.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/reveal.ml @@ -33,7 +33,7 @@ let ten_tez = Tez.of_int 10 let simple_reveal () = Context.init 1 >>=? fun (blk, contracts) -> - let c = List.nth contracts 0 in + let c = Option.get @@ List.nth contracts 0 in let new_c = Account.new_account () in let new_contract = Alpha_context.Contract.implicit_contract new_c.pkh in (* Create the contract *) @@ -57,7 +57,7 @@ let simple_reveal () = let empty_account_on_reveal () = Context.init 1 >>=? fun (blk, contracts) -> - let c = List.nth contracts 0 in + let c = Option.get @@ List.nth contracts 0 in let new_c = Account.new_account () in let new_contract = Alpha_context.Contract.implicit_contract new_c.pkh in let amount = Tez.one_mutez in @@ -89,7 +89,7 @@ let empty_account_on_reveal () = let not_enough_found_for_reveal () = Context.init 1 >>=? fun (blk, contracts) -> - let c = List.nth contracts 0 in + let c = Option.get @@ List.nth contracts 0 in let new_c = Account.new_account () in let new_contract = Alpha_context.Contract.implicit_contract new_c.pkh in (* Create the contract *) diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/script_gas.ml b/src/proto_008_PtEdoTez/lib_protocol/test/script_gas.ml index 966756df6217197a6ee15c6437a03c340227d19e..8a4a50e291430736ad9ae5f202b15718a2622221 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/script_gas.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/script_gas.ml @@ -98,11 +98,14 @@ module Tested_terms () = struct lazy_terms let check_correctness () = - Error_monad.iter2_p + List.iter2_e + ~when_different_lengths: + (TzTrace.make + (Exn (Failure "min costs and full costs have different lengths"))) (fun min full -> - if Z.leq min full then return_unit + if Z.leq min full then ok_unit else - failwith + generic_error "Script_repr: inconsistent costs %a vs %a@." Z.pp_print min @@ -110,6 +113,8 @@ module Tested_terms () = struct full) minimal_costs full_costs + + let check_correctness () = Lwt.return @@ check_correctness () end let check_property () = diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/seed.ml b/src/proto_008_PtEdoTez/lib_protocol/test/seed.ml index fe6429af5a38a22b97ad9b0d5c4f6bcb0ac099ff..1d18737b577f18f9c3e1140e51cd0bd7a60e6943 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/seed.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/seed.ml @@ -205,7 +205,7 @@ let revelation_early_wrong_right_twice () = false) >>=? fun () -> (* bake [preserved_cycles] cycles excluding [id] *) - Error_monad.fold_left_s + List.fold_left_es (fun b _ -> Block.bake_until_cycle_end ~policy b) b (1 -- preserved_cycles) diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/test_helpers_rpcs.ml b/src/proto_008_PtEdoTez/lib_protocol/test/test_helpers_rpcs.ml index 3753fac0f46a26f7520cf37f522e85768873f3a9..096a3400b2f71fa1a44f513cb7461ce52c6813f8 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/test_helpers_rpcs.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/test_helpers_rpcs.ml @@ -44,7 +44,7 @@ let test_baking_rights () = assert (List.length rights = max_priority + 1) ; (* filtering by delegate *) let d = - Contract.is_implicit (List.nth contracts 0) + Contract.is_implicit (Option.get @@ List.nth contracts 0) |> Option.unopt_assert ~loc:__POS__ in get Block.rpc_ctxt b ~all:true ~delegates:[d] diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/test_sapling.ml b/src/proto_008_PtEdoTez/lib_protocol/test/test_sapling.ml index 9f6b6cac9621691bd5e0f2de661e2d91b7bbf9d9..bf2d45e5eb4cf5d6307c4a2919e31c578e5d19de 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/test_sapling.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/test_sapling.ml @@ -25,6 +25,10 @@ open Protocol +let list_init n f = + List.init ~when_negative_length:() n f + |> function Error () -> assert false | Ok r -> r + module Raw_context_tests = struct open Sapling_helpers.Common @@ -54,7 +58,7 @@ module Raw_context_tests = struct Sapling_storage.init ctx id ~memo_size:0 >>= wrap >>=? fun ctx -> - fold_left_s + List.fold_left_es (fun ctx pos -> Sapling_storage.Commitments.get_root ctx id >>= wrap @@ -137,7 +141,7 @@ module Raw_context_tests = struct Sapling_storage.init ctx id ~memo_size:0 >>= wrap >>=? fun ctx -> - let nf_list_ctx = List.init 10 (fun _ -> gen_nf ()) in + let nf_list_ctx = list_init 10 (fun _ -> gen_nf ()) in let state = List.fold_left (fun state nf -> Sapling_storage.nullifiers_add state nf) @@ -147,14 +151,14 @@ module Raw_context_tests = struct Sapling_storage.apply_diff ctx id state.diff >>= wrap >>=? fun (ctx, _) -> - let nf_list_diff = List.init 10 (fun _ -> gen_nf ()) in + let nf_list_diff = list_init 10 (fun _ -> gen_nf ()) in let state = List.fold_left (fun state nf -> Sapling_storage.nullifiers_add state nf) state nf_list_diff in - Error_monad.iter_p + List.iter_ep (fun nf -> Sapling_storage.nullifiers_mem ctx state nf >>= wrap @@ -163,8 +167,8 @@ module Raw_context_tests = struct return_unit) (nf_list_ctx @ nf_list_diff) >>=? fun () -> - let nf_list_absent = List.init 10 (fun _ -> gen_nf ()) in - Error_monad.iter_p + let nf_list_absent = list_init 10 (fun _ -> gen_nf ()) in + List.iter_ep (fun nf -> Sapling_storage.nullifiers_mem ctx state nf >>= wrap @@ -200,7 +204,7 @@ module Raw_context_tests = struct Sapling_storage.state_from_id ctx id >>= wrap >>=? fun (diff, ctx) -> - let list_added = List.init 10 (fun _ -> gen_cm_cipher ~memo_size ()) in + let list_added = list_init 10 (fun _ -> gen_cm_cipher ~memo_size ()) in let state = Sapling_storage.add diff list_added in Sapling_storage.apply_diff ctx id state.diff >>= wrap @@ -218,7 +222,7 @@ module Raw_context_tests = struct >>=? fun result -> let expected_cm = List.map fst expected in assert (result = expected_cm) ; - test_from (Int64.succ from) until (List.tl expected) + test_from (Int64.succ from) until (Option.get @@ List.tl expected) in test_from 0L 9L list_added @@ -247,7 +251,7 @@ module Raw_context_tests = struct >>= wrap >>=? fun ctx -> let list_to_add = - fst @@ List.split @@ List.init 33 (fun _ -> gen_cm_cipher ~memo_size ()) + fst @@ List.split @@ list_init 33 (fun _ -> gen_cm_cipher ~memo_size ()) in let rec test counter ctx = if counter >= 32 then return_unit @@ -256,7 +260,7 @@ module Raw_context_tests = struct Sapling_storage.Commitments.add ctx id_one_by_one - [List.nth list_to_add counter] + [Option.get @@ List.nth list_to_add counter] (Int64.of_int counter) >>= wrap (* create a new tree and add a list of cms *) @@ -273,7 +277,8 @@ module Raw_context_tests = struct Sapling_storage.Commitments.add ctx id_all_at_once - (List.init (counter + 1) (fun i -> List.nth list_to_add i)) + (list_init (counter + 1) (fun i -> + Option.get @@ List.nth list_to_add i)) 0L >>= wrap >>=? fun (ctx, _size) -> @@ -301,7 +306,7 @@ module Raw_context_tests = struct (Hacl.Rand.gen 32) in let roots_ctx = - List.init + list_init (Int32.to_int Sapling_storage.Roots.size + 10) (fun _ -> gen_root ()) in @@ -325,7 +330,7 @@ module Raw_context_tests = struct >>= wrap >>=? fun ctx -> (* Add one root per level to the context *) - Error_monad.fold_left_s + List.fold_left_es (fun (ctx, cnt) root -> Sapling_storage.Roots.add ctx id root >>= wrap @@ -348,7 +353,7 @@ module Raw_context_tests = struct Sapling_storage. {id = Some id; diff = Sapling_storage.empty_diff; memo_size = 0} in - Error_monad.fold_left_s + List.fold_left_es (fun i root -> Sapling_storage.root_mem ctx state root >>= wrap @@ -359,13 +364,13 @@ module Raw_context_tests = struct roots_ctx >>=? fun _ -> (* Add roots w/o increasing the level *) - let roots_same_level = List.init 10 (fun _ -> gen_root ()) in - Error_monad.fold_left_s + let roots_same_level = list_init 10 (fun _ -> gen_root ()) in + List.fold_left_es (fun ctx root -> Sapling_storage.Roots.add ctx id root >>= wrap) ctx roots_same_level >>=? fun ctx -> - Error_monad.fold_left_s + List.fold_left_es (fun (i, ctx) root -> Sapling_storage.root_mem ctx state root >>= wrap @@ -447,7 +452,7 @@ module Alpha_context_tests = struct let ctime_shields = Unix.gettimeofday () -. start in Printf.printf "client_shields %f\n" ctime_shields ; let start = Unix.gettimeofday () in - Error_monad.fold_left_s + List.fold_left_es (fun ctx vt -> verify_update ctx ~id vt |> assert_some >|=? fun (ctx, _id) -> ctx) ctx @@ -462,7 +467,7 @@ module Alpha_context_tests = struct let ctime_transfers = Unix.gettimeofday () -. start in Printf.printf "client_txs %f\n" ctime_transfers ; let start = Unix.gettimeofday () in - Error_monad.fold_left_s + List.fold_left_es (fun ctx vt -> verify_update ctx ~id vt |> assert_some >|=? fun (ctx, _id) -> ctx) ctx @@ -541,7 +546,7 @@ module Alpha_context_tests = struct (* randomize one output to fail check outputs *) (* don't randomize the ciphertext as it is not part of the proof *) let open Sapling.Core.Client.UTXO in - let o = List.hd vt.outputs in + let o = Option.get @@ List.hd vt.outputs in let o_wrong_cm = { o with @@ -663,7 +668,7 @@ module Interpreter_tests = struct let wb = wallet_gen () in let list_addr = gen_addr 15 wb.vk in let list_forge_input = - List.init 14 (fun pos_int -> + list_init 14 (fun pos_int -> let pos = Int64.of_int pos_int in let forge_input = snd @@ -715,7 +720,7 @@ module Interpreter_tests = struct (* The inputs total [total] mutez and 15 of those are transfered in shielded tez *) assert (Int64.equal diff (Int64.of_int (total - 15))) ; let list_forge_input = - List.init 15 (fun i -> + list_init 15 (fun i -> let pos = Int64.of_int (i + 14 + 14) in let forge_input = snd @@ -815,7 +820,7 @@ module Interpreter_tests = struct (Format.sprintf "(Pair 0x%s 0)") anti_replay_2 in - let transaction = List.hd transactions in + let transaction = Option.get @@ List.hd transactions in let parameters = Alpha_context.Script.(lazy_expr (expression_from_string transaction)) in diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/transfer.ml b/src/proto_008_PtEdoTez/lib_protocol/test/transfer.ml index f0f8fb5ac553fcf3b038fd7fafd22781f3870d23..033b11ff65e890c7d648cb2e8a9fc7ba70282404 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/transfer.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/transfer.ml @@ -112,7 +112,7 @@ let transfer_to_itself_and_check_balances ~loc b ?(fee = Tez.zero) contract a destination contract with the amount "n" times. *) let n_transactions n b ?fee source dest amount = - fold_left_s + List.fold_left_es (fun b _ -> transfer_and_check_balances ~loc:__LOC__ b ?fee source dest amount >|=? fun (b, _) -> b) @@ -128,8 +128,8 @@ let ten_tez = Tez.of_int 10 let register_two_contracts () = Context.init 2 >|=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in + let contract_1 = Option.get @@ List.nth contracts 0 in + let contract_2 = Option.get @@ List.nth contracts 1 in (b, contract_1, contract_2) (** compute half of the balance and divided by nth @@ -187,7 +187,7 @@ let transfer_zero_tez () = let transfer_zero_implicit () = Context.init 1 >>=? fun (b, contracts) -> - let dest = List.nth contracts 0 in + let dest = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in Incremental.begin_construction b >>=? fun i -> @@ -210,7 +210,7 @@ let transfer_zero_implicit () = let transfer_to_originate_with_fee () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in Incremental.begin_construction b >>=? fun b -> two_nth_of_balance b contract 10L @@ -254,7 +254,7 @@ let transfer_amount_of_contract_balance () = let transfers_to_self () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in Incremental.begin_construction b >>=? fun b -> two_nth_of_balance b contract 3L @@ -303,7 +303,7 @@ let missing_transaction () = let transfer_from_implicit_to_implicit_contract () = Context.init 1 >>=? fun (b, contracts) -> - let bootstrap_contract = List.nth contracts 0 in + let bootstrap_contract = Option.get @@ List.nth contracts 0 in let account_a = Account.new_account () in let account_b = Account.new_account () in Incremental.begin_construction b @@ -344,8 +344,8 @@ let transfer_from_implicit_to_implicit_contract () = let transfer_from_implicit_to_originated_contract () = Context.init 1 >>=? fun (b, contracts) -> - let bootstrap_contract = List.nth contracts 0 in - let contract = List.nth contracts 0 in + let bootstrap_contract = Option.get @@ List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in let src = Contract.implicit_contract account.Account.pkh in Incremental.begin_construction b @@ -446,7 +446,7 @@ let build_a_chain () = register_two_contracts () >>=? fun (b, contract_1, contract_2) -> let ten = Tez.of_int 10 in - fold_left_s + List.fold_left_es (fun b _ -> Incremental.begin_construction b >>=? fun b -> @@ -468,7 +468,7 @@ let build_a_chain () = let empty_implicit () = Context.init 1 >>=? fun (b, contracts) -> - let dest = List.nth contracts 0 in + let dest = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in Incremental.begin_construction b >>=? fun incr -> @@ -531,9 +531,9 @@ let balance_too_low fee () = let balance_too_low_two_transfers fee () = Context.init 3 >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in - let contract_3 = List.nth contracts 2 in + let contract_1 = Option.get @@ List.nth contracts 0 in + let contract_2 = Option.get @@ List.nth contracts 1 in + let contract_3 = Option.get @@ List.nth contracts 2 in Incremental.begin_construction b >>=? fun i -> Context.Contract.balance (I i) contract_1 diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/typechecking.ml b/src/proto_008_PtEdoTez/lib_protocol/test/typechecking.ml index a32922b27065874b7e14c7e024b7e42a5a5cbe34..548d8a5f78ebcfbe8e2a0962c8dba57190a25dc8 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/typechecking.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/typechecking.ml @@ -35,7 +35,7 @@ let test_context () = let test_context_with_nat_nat_big_map () = Context.init 3 >>=? fun (b, contracts) -> - let source = List.hd contracts in + let source = Option.get @@ List.hd contracts in Op.origination (B b) source ~script:Op.dummy_script >>=? fun (operation, originated) -> Block.bake ~operation b @@ -726,7 +726,7 @@ let test_optimal_comb () = v >>=? fun (unparsed, ctxt) -> let (unparsed_canonical, unparsed_size) = size_of_micheline unparsed in - Error_monad.iter_s (fun other_repr -> + List.iter_es (fun other_repr -> let (other_repr_canonical, other_repr_size) = size_of_micheline other_repr in diff --git a/src/proto_008_PtEdoTez/lib_protocol/test/voting.ml b/src/proto_008_PtEdoTez/lib_protocol/test/voting.ml index 21051e7d7a0ead79619362c9830c4e90ed9c2dac..f886f128c42618948fc05424cfe38471a626b077 100644 --- a/src/proto_008_PtEdoTez/lib_protocol/test/voting.ml +++ b/src/proto_008_PtEdoTez/lib_protocol/test/voting.ml @@ -174,7 +174,7 @@ let get_delegates_and_rolls_from_listings b = let get_rolls b delegates loc = Context.Vote.get_listings (B b) >>=? fun l -> - map_s + List.map_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -255,8 +255,8 @@ let test_successful_vote num_delegates () = | Some _ -> failwith "%s - Unexpected proposal" __LOC__) >>=? fun () -> - let del1 = List.nth delegates_p1 0 in - let del2 = List.nth delegates_p1 1 in + let del1 = Option.get @@ List.nth delegates_p1 0 in + let del2 = Option.get @@ List.nth delegates_p1 1 in let props = List.map (fun i -> protos.(i)) (2 -- Constants.max_proposals_per_delegate) in @@ -270,7 +270,11 @@ let test_successful_vote num_delegates () = Context.Vote.get_proposals (B b) >>=? fun ps -> (* correctly count the double proposal for zero *) - (let weight = Int32.add (List.nth rolls_p1 0) (List.nth rolls_p1 1) in + (let weight = + Int32.add + (Option.get @@ List.nth rolls_p1 0) + (Option.get @@ List.nth rolls_p1 1) + in match Environment.Protocol_hash.(Map.find_opt zero ps) with | Some v -> if v = weight then return_unit @@ -331,7 +335,7 @@ let test_successful_vote num_delegates () = failwith "%s - Missing proposal" __LOC__) >>=? fun () -> (* unanimous vote: all delegates --active when p2 started-- vote *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) delegates_p2 >>=? fun operations -> @@ -367,7 +371,7 @@ let test_successful_vote num_delegates () = | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ | l -> - iter_s + List.iter_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -430,7 +434,7 @@ let test_successful_vote num_delegates () = failwith "%s - Missing proposal" __LOC__) >>=? fun () -> (* unanimous vote: all delegates --active when p4 started-- vote *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) delegates_p4 >>=? fun operations -> @@ -455,7 +459,7 @@ let test_successful_vote num_delegates () = | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ | l -> - iter_s + List.iter_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -542,7 +546,7 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = let open Alpha_context in assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -564,12 +568,12 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2 participation_ema |> fun voters -> (* take the first two voters out so there cannot be quorum *) - let voters_without_quorum = List.tl voters in + let voters_without_quorum = Option.get @@ List.tl voters in get_rolls b voters_without_quorum __LOC__ >>=? fun voters_rolls_in_testing_vote -> (* all voters_without_quorum vote, for yays; no nays, so supermajority is satisfied *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters_without_quorum >>=? fun operations -> @@ -604,7 +608,7 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = >>=? fun (b, delegates) -> assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -626,7 +630,9 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = let open Alpha_context in (* all voters vote, for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters + List.map_es + (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) + voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -655,12 +661,12 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = get_smallest_prefix_voters_for_quorum delegates_p4 rolls_p4 participation_ema |> fun voters -> (* take the first voter out so there cannot be quorum *) - let voters_without_quorum = List.tl voters in + let voters_without_quorum = Option.get @@ List.tl voters in get_rolls b voters_without_quorum __LOC__ >>=? fun voter_rolls -> (* all voters_without_quorum vote, for yays; no nays, so supermajority is satisfied *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters_without_quorum >>=? fun operations -> @@ -689,7 +695,7 @@ let test_multiple_identical_proposals_count_as_one () = >>=? fun (b, delegates) -> assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - let proposer = List.hd delegates in + let proposer = Option.get @@ List.hd delegates in Op.proposals (B b) proposer [Protocol_hash.zero; Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -732,29 +738,37 @@ let test_supermajority_in_proposal there_is_a_winner () = >>=? fun { parametric = {blocks_per_cycle; tokens_per_roll; blocks_per_voting_period; _}; _ } -> - let del1 = List.nth delegates 0 in - let del2 = List.nth delegates 1 in - let del3 = List.nth delegates 2 in - map_s (fun del -> Context.Contract.pkh del) [del1; del2; del3] + let del1 = Option.get @@ List.nth delegates 0 in + let del2 = Option.get @@ List.nth delegates 1 in + let del3 = Option.get @@ List.nth delegates 2 in + List.map_es (fun del -> Context.Contract.pkh del) [del1; del2; del3] >>=? fun pkhs -> let policy = Block.Excluding pkhs in - Op.transaction (B b) (List.nth delegates 3) del1 tokens_per_roll + Op.transaction + (B b) + (Option.get @@ List.nth delegates 3) + del1 + tokens_per_roll >>=? fun op1 -> - Op.transaction (B b) (List.nth delegates 4) del2 tokens_per_roll + Op.transaction + (B b) + (Option.get @@ List.nth delegates 4) + del2 + tokens_per_roll >>=? fun op2 -> ( if there_is_a_winner then Test_tez.Tez.( *? ) tokens_per_roll 3L else Test_tez.Tez.( *? ) tokens_per_roll 2L ) >>?= fun bal3 -> - Op.transaction (B b) (List.nth delegates 5) del3 bal3 + Op.transaction (B b) (Option.get @@ List.nth delegates 5) del3 bal3 >>=? fun op3 -> Block.bake ~policy ~operations:[op1; op2; op3] b >>=? fun b -> (* we let one voting period pass; we make sure that: - the three selected delegates remain active by re-registering as delegates - their number of rolls do not change *) - fold_left_s + List.fold_left_es (fun b _ -> - Error_monad.map_s + List.map_es (fun del -> Context.Contract.pkh del >>=? fun pkh -> Op.delegation (B b) del (Some pkh)) @@ -795,9 +809,9 @@ let test_quorum_in_proposal has_quorum () = blocks_per_voting_period; _ }; _ } -> - let del1 = List.nth delegates 0 in - let del2 = List.nth delegates 1 in - map_s (fun del -> Context.Contract.pkh del) [del1; del2] + let del1 = Option.get @@ List.nth delegates 0 in + let del2 = Option.get @@ List.nth delegates 1 in + List.map_es (fun del -> Context.Contract.pkh del) [del1; del2] >>=? fun pkhs -> let policy = Block.Excluding pkhs in let quorum = @@ -814,9 +828,9 @@ let test_quorum_in_proposal has_quorum () = (* we let one voting period pass; we make sure that: - the two selected delegates remain active by re-registering as delegates - their number of rolls do not change *) - fold_left_s + List.fold_left_es (fun b _ -> - Error_monad.map_s + List.map_es (fun del -> Context.Contract.pkh del >>=? fun pkh -> Op.delegation (B b) del (Some pkh)) @@ -844,7 +858,7 @@ let test_supermajority_in_testing_vote supermajority () = let min_proposal_quorum = Int32.(of_int @@ (100_00 / 100)) in Context.init ~min_proposal_quorum 100 >>=? fun (b, delegates) -> - let del1 = List.nth delegates 0 in + let del1 = Option.get @@ List.nth delegates 0 in let proposal = protos.(0) in Op.proposals (B b) del1 [proposal] >>=? fun ops1 -> @@ -879,9 +893,9 @@ let test_supermajority_in_testing_vote supermajority () = let open Alpha_context in let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in let (yays_delegates, _) = List.split_n num_yays rest in - map_s (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates + List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates >>=? fun operations_yays -> - map_s (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates + List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates >>=? fun operations_nays -> let operations = operations_yays @ operations_nays in Block.bake ~operations b @@ -906,7 +920,7 @@ let test_no_winning_proposal num_delegates () = List.map (fun i -> protos.(i)) (1 -- Constants.max_proposals_per_delegate) in (* all delegates active in p1 propose the same proposals *) - map_s (fun del -> Op.proposals (B b) del props) delegates_p1 + List.map_es (fun del -> Op.proposals (B b) del props) delegates_p1 >>=? fun ops_list -> Block.bake ~operations:ops_list b >>=? fun b -> @@ -934,7 +948,7 @@ let test_quorum_capped_maximum num_delegates () = >>=? fun () -> (* propose a new protocol *) let protocol = Protocol_hash.zero in - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [protocol] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -954,7 +968,7 @@ let test_quorum_capped_maximum num_delegates () = in let voters = List.take_n minimum_to_pass delegates in (* all voters vote for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -982,7 +996,7 @@ let test_quorum_capped_minimum num_delegates () = >>=? fun () -> (* propose a new protocol *) let protocol = Protocol_hash.zero in - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [protocol] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -1002,7 +1016,7 @@ let test_quorum_capped_minimum num_delegates () = in let voters = List.take_n minimum_to_pass delegates in (* all voters vote for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -1028,9 +1042,9 @@ let test_voting_power_updated_each_voting_period () = ~initial_balances:[80_000_000_000L; 48_000_000_000L; 4_000_000_000_000L] 3 >>=? fun (block, contracts) -> - let con1 = List.nth contracts 0 in - let con2 = List.nth contracts 1 in - let con3 = List.nth contracts 2 in + let con1 = Option.get @@ List.nth contracts 0 in + let con2 = Option.get @@ List.nth contracts 1 in + let con3 = Option.get @@ List.nth contracts 2 in (* Retrieve balance of con1 *) Context.Contract.balance (B block) con1 >>=? fun balance1 -> @@ -1051,9 +1065,9 @@ let test_voting_power_updated_each_voting_period () = Context.get_bakers (B block) >>=? fun bakers -> (* [Context.init] and [Context.get_bakers] store the accounts in reversed orders *) - let baker1 = List.nth bakers 2 in - let baker2 = List.nth bakers 1 in - let baker3 = List.nth bakers 0 in + let baker1 = Option.get @@ List.nth bakers 2 in + let baker2 = Option.get @@ List.nth bakers 1 in + let baker3 = Option.get @@ List.nth bakers 0 in (* Auxiliary assert_voting_power *) let assert_voting_power ~loc n block baker = get_voting_power block baker diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 0b766e2f2318ebeda75209ddc7a3efc6878993ef..e42eb948d88619923be14386ee293446b9985d2f 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -178,7 +178,7 @@ let delegate_contract cctxt ~chain ~block ?branch ?confirmations ?dry_run let list_contract_labels cctxt ~chain ~block = Alpha_services.Contract.list cctxt (chain, block) >>=? fun contracts -> - rev_map_s + List.rev_map_es (fun h -> ( match Contract.is_implicit h with | Some m -> ( diff --git a/src/proto_alpha/lib_client/client_proto_contracts.ml b/src/proto_alpha/lib_client/client_proto_contracts.ml index 1c2d31d07ac7c00a21a9c32a914b656bdbd4259c..f32dfe165ef55d6ba0ed2d562272a60e30bed3fd 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts.ml +++ b/src/proto_alpha/lib_client/client_proto_contracts.ml @@ -157,12 +157,12 @@ end let list_contracts cctxt = RawContractAlias.load cctxt >>=? fun raw_contracts -> - Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts + List.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts >>= fun contracts -> Client_keys.Public_key_hash.load cctxt >>=? fun keys -> (* List accounts (implicit contracts of identities) *) - map_s + List.map_es (fun (n, v) -> RawContractAlias.mem cctxt n >>=? fun mem -> diff --git a/src/proto_alpha/lib_client/client_proto_multisig.ml b/src/proto_alpha/lib_client/client_proto_multisig.ml index 009092e213564e954741ee771d69f97819e43bfd..508283d7d088c9f91f99d5f54b6d63c1bf3b61b1 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.ml +++ b/src/proto_alpha/lib_client/client_proto_multisig.ml @@ -569,7 +569,7 @@ let action_of_expr e = [] ) ], [] ) ], [] ) -> - map_s + List.map_es (function | Tezos_micheline.Micheline.Bytes (_, s) -> return @@ -608,7 +608,7 @@ let multisig_get_information (cctxt : #Protocol_client_context.full) ~chain D_Pair, [Int (_, counter); Int (_, threshold); Seq (_, key_nodes)], _ ) -> - map_s + List.map_es (function | String (_, key_str) -> return @@ Signature.Public_key.of_b58check_exn key_str @@ -623,7 +623,7 @@ let multisig_create_storage ~counter ~threshold ~keys () : Script.expr tzresult Lwt.t = let loc = Tezos_micheline.Micheline_parser.location_zero in let open Tezos_micheline.Micheline in - map_s + List.map_es (fun key -> let key_str = Signature.Public_key.to_b58check key in return (String (loc, key_str))) @@ -642,7 +642,7 @@ let multisig_create_param ~counter ~action ~optional_signatures () : Script.expr tzresult Lwt.t = let loc = Tezos_micheline.Micheline_parser.location_zero in let open Tezos_micheline.Micheline in - map_s + List.map_es (fun sig_opt -> match sig_opt with | None -> @@ -763,7 +763,7 @@ let check_multisig_signatures ~bytes ~threshold ~keys signatures = matching_key_found := true ; opt_sigs_arr.(i) <- Some signature ) in - iter_p + List.iter_ep (fun signature -> matching_key_found := false ; List.iteri (check_signature_against_key_number signature) keys ; diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index c23acffda0d042c4227c2ce34cde3f43db6402df..91469bd0ce5313c249457a8d4315752d8c75e34b 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -843,7 +843,7 @@ let inject_operation (type kind) cctxt ~chain ~block ?confirmations >>= fun () -> Lwt.return (originated_contracts result.contents) >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun c -> cctxt#message "New contract %a originated." Contract.pp c) contracts >>= fun () -> diff --git a/src/proto_alpha/lib_client/michelson_v1_emacs.ml b/src/proto_alpha/lib_client/michelson_v1_emacs.ml index 40ee5ce3e6ffee549b56f4877de3803832334fc3..07f493fc42a2887da6513c47a1597c4c5b3b60fa 100644 --- a/src/proto_alpha/lib_client/michelson_v1_emacs.ml +++ b/src/proto_alpha/lib_client/michelson_v1_emacs.ml @@ -89,22 +89,23 @@ let print_type_map ppf (parsed, type_map) = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr) items and print_item ppf loc = - try - let ({start = {point = s; _}; stop = {point = e; _}}, locs) = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - in - let locs = List.sort compare locs in - let (bef, aft) = List.assoc (List.hd locs) type_map in - Format.fprintf - ppf - "(@[%d %d %a %a@])@," - s - e - print_stack - bef - print_stack - aft - with Not_found -> () + (let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun ({start = {point = s; _}; stop = {point = e; _}}, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun hd_loc -> + List.assoc hd_loc type_map >?? fun (bef, aft) -> Some (s, e, bef, aft)) + |> Option.iter (fun (s, e, bef, aft) -> + Format.fprintf + ppf + "(@[%d %d %a %a@])@," + s + e + print_stack + bef + print_stack + aft) in Format.fprintf ppf "(@[%a@])" print_expr_types (root parsed.unexpanded) @@ -154,9 +155,10 @@ let report_errors ppf (parsed, errs) = (fun ppf errs -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in match errs with | top :: errs -> @@ -194,9 +196,10 @@ let report_errors ppf (parsed, errs) = (Format.pp_print_list (fun ppf err -> let find_location loc = let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + Option.get + @@ List.assoc loc parsed.Michelson_v1_parser.unexpansion_table in - fst (List.assoc oloc parsed.expansion_table) + fst (Option.get @@ List.assoc oloc parsed.expansion_table) in let loc = match err with diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index 7c5e9632ecf55f47e91bab5ea8ba8eaff78fa41e..cf723f405df917c2c935e72cbe5fd52f11d42efc 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -146,13 +146,10 @@ let report_errors ~details ~show_source ?parsed ppf errs = (Format.asprintf "%a" Micheline_parser.print_location loc)) in let parsed_locations parsed loc = - try - let oloc = - List.assoc loc parsed.Michelson_v1_parser.unexpansion_table - in - let (ploc, _) = List.assoc oloc parsed.expansion_table in - Some ploc - with Not_found -> None + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.unexpansion_table + >?? fun oloc -> + List.assoc oloc parsed.expansion_table >?? fun (ploc, _) -> Some ploc in let print_source ppf (parsed, _hilights) (* TODO *) = let lines = diff --git a/src/proto_alpha/lib_client/michelson_v1_parser.ml b/src/proto_alpha/lib_client/michelson_v1_parser.ml index 5a2e5b8d1c1623da260c7d2704279d984bc098a0..fcfc8a3d6fa301194acea9e6d34e833df6266954 100644 --- a/src/proto_alpha/lib_client/michelson_v1_parser.ml +++ b/src/proto_alpha/lib_client/michelson_v1_parser.ml @@ -59,12 +59,19 @@ let expand_all source ast errors = in group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) + match + List.map2 + ~when_different_lengths:() + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) + with + | Ok v -> + v + | Error () -> + invalid_arg "Michelson_v1_parser.expand_all" in match Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.ml b/src/proto_alpha/lib_client/michelson_v1_printer.ml index c7e613eec00021b15260cdeb62ca23312a06ee17..4065060a5d9f4957c6d27afa6389a5f43831c13c 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.ml +++ b/src/proto_alpha/lib_client/michelson_v1_printer.ml @@ -134,17 +134,19 @@ let inject_types type_map parsed = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let locs = - List.assoc loc parsed.Michelson_v1_parser.expansion_table - |> snd |> List.sort compare - in - let (bef, aft) = List.assoc (List.hd locs) type_map in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc parsed.Michelson_v1_parser.expansion_table + >?? fun (_, locs) -> + let locs = List.sort compare locs in + List.hd locs + >?? fun head_loc -> + List.assoc head_loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in inject_expr (root parsed.unexpanded) @@ -169,15 +171,16 @@ let unparse ?type_map parse expanded = | Bytes (loc, value) -> Bytes (inject_loc `after loc, value) and inject_loc which loc = - try - let stack = - let (bef, aft) = - List.assoc (List.assoc loc unexpansion_table) type_map - in - match which with `before -> bef | `after -> aft - in - {comment = Some (Format.asprintf "%a" print_stack stack)} - with Not_found -> {comment = None} + let comment = + let ( >?? ) = Option.bind in + List.assoc loc unexpansion_table + >?? fun loc -> + List.assoc loc type_map + >?? fun (bef, aft) -> + let stack = match which with `before -> bef | `after -> aft in + Some (Format.asprintf "%a" print_stack stack) + in + {comment} in unexpanded |> root |> inject_expr |> Format.asprintf "%a" Micheline_printer.print_expr diff --git a/src/proto_alpha/lib_client/mockup.ml b/src/proto_alpha/lib_client/mockup.ml index 1fa44f9512e3dfd22cc03316fdd84aae63451ad0..f1dc0d4bc85623dec253df1bf547f3ad6b820c54 100644 --- a/src/proto_alpha/lib_client/mockup.ml +++ b/src/proto_alpha/lib_client/mockup.ml @@ -192,7 +192,7 @@ let mockup_default_bootstrap_accounts let errors = ref [] in Client_keys.list_keys wallet >>=? fun all_keys -> - Lwt_list.iter_s + List.iter_s (function | (name, pkh, _pk_opt, Some sk_uri) -> ( let contract = @@ -439,7 +439,7 @@ let mem_init : parsed_account_repr_pp) accounts >>= fun () -> - Tezos_base.TzPervasives.map_s to_bootstrap_account accounts + List.map_es to_bootstrap_account accounts >>=? fun bootstrap_accounts -> return (Some bootstrap_accounts) | exception error -> failwith 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 ae254fc70d52d68a57c8926fd50ce33723e7f4d0..13afd73154e0997ad178d228ebcc13d94f6b422b 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 @@ -277,7 +277,7 @@ let commands network () = (fun () (cctxt : Protocol_client_context.full) -> list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block >>=? fun contracts -> - Lwt_list.iter_s + List.iter_s (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) contracts >>= fun () -> return_unit); @@ -840,7 +840,7 @@ let commands network () = >>=? fun (_, src_pk, src_sk) -> return (source, src_pk, src_sk) ) >>=? fun (source, src_pk, src_sk) -> - mapi_p prepare operations + List.mapi_ep prepare operations >>=? fun contents -> let (Manager_list contents) = Injection.manager_of_list contents in Injection.inject_manager_operation diff --git a/src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml index 1aa9bd843ff2a012ca390b0605c1e74ca6ab4e73..bb1bea6b3de881d07dfa5a0e95d85ce3e9936478 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml @@ -59,7 +59,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> list_contracts cctxt >>=? fun contracts -> - iter_s + List.iter_es (fun (prefix, alias, contract) -> cctxt#message "%s%s: %s" diff --git a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml index c0d73556114d9f2e7e3bc3abe71981e413d196dd..06a2104d4cfceb2292d05abae2a603a61a43d8bf 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml @@ -192,7 +192,9 @@ let commands () : #Protocol_client_context.full Clic.command list = burn_cap; } in - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + keys >>=? fun keys -> Client_proto_multisig.originate_multisig cctxt @@ -335,7 +337,9 @@ let commands () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys >>=? fun keys -> Client_proto_multisig.prepare_multisig_transaction cctxt @@ -459,7 +463,9 @@ let commands () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys >>=? fun keys -> Client_proto_multisig.prepare_multisig_transaction cctxt diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index c7bc31894536f42f115315e1c2384af82e2e0aca..f84320640c6c082ec0a879bd486ffcb812d5ed59 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -191,7 +191,7 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> Program.load cctxt >>=? fun list -> - Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list + List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> return_unit); command ~group 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 f089cbf09b5e38bfc8dcb3d9eee0f66c51710ebe..150ee2e4cb809b157edac078072b501d797d221e 100644 --- a/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml +++ b/src/proto_alpha/lib_client_sapling/client_sapling_commands.ml @@ -809,9 +809,10 @@ let commands () = (fun () (cctxt : Protocol_client_context.full) -> Sapling_key.load cctxt >>=? fun l -> - iter_s - (fun (s, _) -> cctxt#message "%s" s >>= fun () -> return_unit) - (List.sort (fun (s1, _) (s2, _) -> String.compare s1 s2) l)); + List.iter_s + (fun (s, _) -> cctxt#message "%s" s) + (List.sort (fun (s1, _) (s2, _) -> String.compare s1 s2) l) + >>= fun () -> return_unit); shield_cmd; unshield_cmd; forge_shielded_cmd; diff --git a/src/proto_alpha/lib_delegate/client_baking_blocks.ml b/src/proto_alpha/lib_delegate/client_baking_blocks.ml index 5ded180478a7219646346be7e323138f6cfa6a21..e9dabfa81c708f8189bda857ac97badbfbe4c2a0 100644 --- a/src/proto_alpha/lib_delegate/client_baking_blocks.ml +++ b/src/proto_alpha/lib_delegate/client_baking_blocks.ml @@ -195,15 +195,16 @@ let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = return_nil | Error _ as err -> Lwt.return err - | Ok (first, last) -> + | Ok (first, last) -> ( let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in Shell_services.Blocks.list cctxt ~chain ~heads:[hash] ~length () - >>=? fun blocks -> - let blocks = - List.remove - (length - Int32.to_int (Raw_level.diff last first)) - (List.hd blocks) - in - if Int32.equal level (Raw_level.to_int32 last) then - return (hash :: blocks) - else return blocks + >>=? function + | [] -> + return_nil + | hd :: _ -> + let blocks = + List.remove (length - Int32.to_int (Raw_level.diff last first)) hd + in + if Int32.equal level (Raw_level.to_int32 last) then + return (hash :: blocks) + else return blocks ) diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml index 407b69fb8c109093f69672fc12ce12a44dd9ba4f..c9f7e1627ea0a4ca59595d05f04cd2b5d36e31cb 100644 --- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml @@ -80,7 +80,7 @@ let get_block_offset level = let process_endorsements (cctxt : #Protocol_client_context.full) state (endorsements : Alpha_block_services.operation list) level = - iter_s + List.iter_es (fun {Alpha_block_services.shell; chain_id; receipt; hash; protocol_data; _} -> let chain = `Hash chain_id in @@ -330,11 +330,12 @@ let process_new_block (cctxt : #Protocol_client_context.full) state (* Processing endorsements *) Alpha_block_services.Operations.operations cctxt ~chain ~block () >>= (function - | Ok operations -> - if List.length operations > endorsements_index then - let endorsements = List.nth operations endorsements_index in + | Ok operations -> ( + match List.nth operations endorsements_index with + | Some endorsements -> process_endorsements cctxt state endorsements level - else return_unit + | None -> + return_unit ) | Error errs -> lwt_log_error Tag.DSL.( diff --git a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml index dc173aaa10ca23cc655f579c0262c10aae342b07..8ef2ee02006259c46321b5a37c58b0cd8ecee3cc 100644 --- a/src/proto_alpha/lib_delegate/client_baking_endorsement.ml +++ b/src/proto_alpha/lib_delegate/client_baking_endorsement.ml @@ -255,7 +255,7 @@ let prepare_endorsement ~(max_past : int64) () in get_delegates cctxt state >>=? fun delegates -> - filter_p (allowed_to_endorse cctxt bi) delegates + List.filter_ep (allowed_to_endorse cctxt bi) delegates >>=? fun delegates -> state.pending <- Some {time; block = bi; delegates} ; return_unit @@ -293,7 +293,7 @@ let create (cctxt : #Protocol_client_context.full) ?(max_past = 110L) ~delay in let timeout_k cctxt state (block, delegates) = state.pending <- None ; - iter_s + List.iter_es (fun delegate -> endorse_for_delegate cctxt block delegate >>= function diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index 3e139f9d3fc5e29afe8450f8442018cc4819fb20..6a01e168ba27ea30206d28fe0867ffcc7a799fd0 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -158,7 +158,7 @@ let assert_valid_operations_hash shell_header operations = let compute_endorsing_power cctxt ~chain ~block operations = Shell_services.Chain.chain_id cctxt ~chain () >>=? fun chain_id -> - fold_left_s + List.fold_left_es (fun sum -> function | { Alpha_context.protocol_data = Operation_data {contents = Single (Endorsement _); _}; @@ -260,7 +260,7 @@ let get_manager_operation_gas_and_fee op = let {protocol_data = Operation_data {contents; _}; _} = op in let open Operation in let l = to_list (Contents_list contents) in - fold_left_s + List.fold_left_es (fun ((total_fee, total_gas) as acc) -> function | Contents (Manager_operation {fee; gas_limit; _}) -> (Lwt.return @@ Environment.wrap_error @@ Tez.(total_fee +? fee)) @@ -287,7 +287,7 @@ let sort_manager_operations ~max_size ~hard_gas_limit_per_block ~minimal_fees in (size, gas, Q.(fee_f / max size_ratio gas_ratio)) in - filter_map_s + List.filter_map_es (fun op -> get_manager_operation_gas_and_fee op >>=? fun (fee, gas) -> @@ -347,7 +347,7 @@ let retain_operations_up_to_quota operations quota = let trim_manager_operations ~max_size ~hard_gas_limit_per_block manager_operations = - map_s + List.map_es (fun op -> get_manager_operation_gas_and_fee op >>=? fun (_fee, gas) -> @@ -402,7 +402,7 @@ let classify_operations (cctxt : #Protocol_client_context.full) ~chain ~block (* Retrieve the optimist maximum paying manager operations *) let manager_operations = t.(managers_index) in let {Environment.Updater.max_size; _} = - List.nth Main.validation_passes managers_index + Option.get @@ List.nth Main.validation_passes managers_index in sort_manager_operations ~max_size @@ -488,20 +488,20 @@ let decode_priority cctxt chain block ~priority ~endorsing_power = ~delegates:[src_pkh] (chain, block) >>=? fun possibilities -> - try - let {Alpha_services.Delegate.Baking_rights.priority = prio; _} = - List.find - (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level) - possibilities - in - Alpha_services.Delegate.Minimal_valid_time.get - cctxt - (chain, block) - prio - endorsing_power - >>=? fun minimal_timestamp -> return (prio, minimal_timestamp) - with Not_found -> - failwith "No slot found at level %a" Raw_level.pp level ) + match + List.find + (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level) + possibilities + with + | Some {Alpha_services.Delegate.Baking_rights.priority = prio; _} -> + Alpha_services.Delegate.Minimal_valid_time.get + cctxt + (chain, block) + prio + endorsing_power + >>=? fun minimal_timestamp -> return (prio, minimal_timestamp) + | None -> + failwith "No slot found at level %a" Raw_level.pp level ) let unopt_timestamp ?(force = false) timestamp minimal_timestamp = let timestamp = @@ -606,10 +606,10 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority state.index <- index ; return inc) >>=? fun initial_inc -> - let endorsements = List.nth operations endorsements_index in - let votes = List.nth operations votes_index in - let anonymous = List.nth operations anonymous_index in - let managers = List.nth operations managers_index in + let endorsements = Option.get @@ List.nth operations endorsements_index in + let votes = Option.get @@ List.nth operations votes_index in + let anonymous = Option.get @@ List.nth operations anonymous_index in + let managers = Option.get @@ List.nth operations managers_index in let validate_operation inc op = protect (fun () -> add_operation inc op) >>= function @@ -647,7 +647,7 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority >>= fun () -> Lwt.return_none ) in let filter_valid_operations inc ops = - Lwt_list.fold_left_s + List.fold_left_s (fun (inc, acc) op -> validate_operation inc op >>= function @@ -677,15 +677,17 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority let quota : Environment.Updater.quota list = Main.validation_passes in let {Constants.hard_gas_limit_per_block; _} = state.constants.parametric in let votes = - retain_operations_up_to_quota (List.rev votes) (List.nth quota votes_index) + retain_operations_up_to_quota + (List.rev votes) + (Option.get @@ List.nth quota votes_index) in let anonymous = retain_operations_up_to_quota (List.rev anonymous) - (List.nth quota anonymous_index) + (Option.get @@ List.nth quota anonymous_index) in trim_manager_operations - ~max_size:(List.nth quota managers_index).max_size + ~max_size:(Option.get @@ List.nth quota managers_index).max_size ~hard_gas_limit_per_block managers >>=? fun (accepted_managers, _overflowing_managers) -> @@ -717,7 +719,7 @@ let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority state.index block_info >>=? fun inc -> - fold_left_s + List.fold_left_es (fun inc op -> add_operation inc op >>=? fun (inc, _receipt) -> return inc) inc (List.flatten operations) @@ -818,20 +820,22 @@ let forge_block cctxt ?force ?operations ?(best_effort = operations = None) (* Ensure that we retain operations up to the quota *) let quota : Environment.Updater.quota list = Main.validation_passes in let endorsements = - List.sub (List.nth operations endorsements_index) endorsers_per_block + List.sub + (Option.get @@ List.nth operations endorsements_index) + endorsers_per_block in let votes = retain_operations_up_to_quota - (List.nth operations votes_index) - (List.nth quota votes_index) + (Option.get @@ List.nth operations votes_index) + (Option.get @@ List.nth quota votes_index) in let anonymous = retain_operations_up_to_quota - (List.nth operations anonymous_index) - (List.nth quota anonymous_index) + (Option.get @@ List.nth operations anonymous_index) + (Option.get @@ List.nth quota anonymous_index) in (* Size/Gas check already occurred in classify operations *) - let managers = List.nth operations managers_index in + let managers = Option.get @@ List.nth operations managers_index in let operations = [endorsements; votes; anonymous; managers] in ( match context_path with | None -> diff --git a/src/proto_alpha/lib_delegate/client_baking_lib.ml b/src/proto_alpha/lib_delegate/client_baking_lib.ml index 72f1b91a6d810885c37a10eb5ae057e81a9dcd28..face4ba87e2cab04f1f057255ad447d39786268d 100644 --- a/src/proto_alpha/lib_delegate/client_baking_lib.ml +++ b/src/proto_alpha/lib_delegate/client_baking_lib.ml @@ -123,7 +123,7 @@ let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block >>=? fun nonces_location -> Client_baking_nonces.load cctxt nonces_location) >>=? fun nonces -> - Lwt_list.filter_map_p + List.filter_map_p (fun hash -> Lwt.catch (fun () -> @@ -138,7 +138,7 @@ let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block >>= fun () -> Lwt.return_none)) block_hashes >>= fun block_infos -> - filter_map_s + List.filter_map_es (fun (bi : Client_baking_blocks.block_info) -> match Client_baking_nonces.find_opt nonces bi.hash with | None -> diff --git a/src/proto_alpha/lib_delegate/client_baking_nonces.ml b/src/proto_alpha/lib_delegate/client_baking_nonces.ml index 7002359cbbd99d75ead1e3c6e05b4e5c93b941ff..7a47c7a6a8b93098ce6c7402f916ab94a03e04da 100644 --- a/src/proto_alpha/lib_delegate/client_baking_nonces.ml +++ b/src/proto_alpha/lib_delegate/client_baking_nonces.ml @@ -156,7 +156,7 @@ let get_unrevealed_nonces cctxt location nonces = ~offset:(-1l) () >>=? fun blocks -> - filter_map_s + List.filter_map_es (fun hash -> match find_opt nonces hash with | None -> diff --git a/src/proto_alpha/lib_delegate/client_baking_revelation.ml b/src/proto_alpha/lib_delegate/client_baking_revelation.ml index 02bc973484a2a0f1be27cf753e2b1d7a310e1005..6aa5d9bc9a8ad3a710fbb27b0b0624ea8beaaf06 100644 --- a/src/proto_alpha/lib_delegate/client_baking_revelation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_revelation.ml @@ -43,7 +43,7 @@ let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain -% a Block_hash.Logging.tag hash) >>= fun () -> return_unit | _ -> - iter_s + List.iter_es (fun (level, nonce) -> Alpha_services.Forge.seed_nonce_revelation cctxt diff --git a/src/proto_alpha/lib_protocol/test/activation.ml b/src/proto_alpha/lib_protocol/test/activation.ml index ae3b8dbbe44a217db9a8e07ab11fe714804d6897..792d4b38efb6554ac45637a9cd662210759d3d73 100644 --- a/src/proto_alpha/lib_protocol/test/activation.ml +++ b/src/proto_alpha/lib_protocol/test/activation.ml @@ -316,7 +316,7 @@ let single_activation () = activation_init () >>=? fun (blk, _contracts, secrets) -> let ({account; activation_code; amount = expected_amount; _} as _first_one) = - List.hd secrets + Option.get @@ List.hd secrets in (* Contract does not exist *) Assert.balance_is @@ -340,7 +340,7 @@ let single_activation () = let multi_activation_1 () = activation_init () >>=? fun (blk, _contracts, secrets) -> - Error_monad.fold_left_s + List.fold_left_es (fun blk {account; activation_code; amount = expected_amount; _} -> Op.activation (B blk) account activation_code >>=? fun operation -> @@ -360,7 +360,7 @@ let multi_activation_1 () = let multi_activation_2 () = activation_init () >>=? fun (blk, _contracts, secrets) -> - Error_monad.fold_left_s + List.fold_left_es (fun ops {account; activation_code; _} -> Op.activation (B blk) account activation_code >|=? fun op -> op :: ops) [] @@ -368,7 +368,7 @@ let multi_activation_2 () = >>=? fun ops -> Block.bake ~operations:ops blk >>=? fun blk -> - Error_monad.iter_s + List.iter_es (fun {account; amount = expected_amount; _} -> (* Contract does exist *) Assert.balance_is @@ -382,8 +382,10 @@ let multi_activation_2 () = let activation_and_transfer () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; activation_code; _} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in + let bootstrap_contract = Option.get @@ List.hd contracts in let first_contract = Contract.implicit_contract account in Op.activation (B blk) account activation_code >>=? fun operation -> @@ -410,8 +412,10 @@ let activation_and_transfer () = let transfer_to_unactivated_then_activate () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; activation_code; amount} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; activation_code; amount} as _first_one) = + Option.get @@ List.hd secrets + in + let bootstrap_contract = Option.get @@ List.hd contracts in let unactivated_commitment_contract = Contract.implicit_contract account in Context.Contract.balance (B blk) bootstrap_contract >>=? fun b_amount -> @@ -450,7 +454,9 @@ let invalid_activation_with_no_commitments () = Context.init 1 >>=? fun (blk, _) -> let secrets = secrets () in - let ({account; activation_code; _} as _first_one) = List.hd secrets in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in Op.activation (B blk) account activation_code >>=? fun operation -> Block.bake ~operation blk @@ -465,8 +471,10 @@ let invalid_activation_with_no_commitments () = let invalid_activation_wrong_secret () = activation_init () >>=? fun (blk, _, secrets) -> - let ({account; _} as _first_one) = List.nth secrets 0 in - let ({activation_code; _} as _second_one) = List.nth secrets 1 in + let ({account; _} as _first_one) = Option.get @@ List.nth secrets 0 in + let ({activation_code; _} as _second_one) = + Option.get @@ List.nth secrets 1 + in Op.activation (B blk) account activation_code >>=? fun operation -> Block.bake ~operation blk @@ -482,7 +490,7 @@ let invalid_activation_wrong_secret () = let invalid_activation_inexistent_pkh () = activation_init () >>=? fun (blk, _, secrets) -> - let ({activation_code; _} as _first_one) = List.hd secrets in + let ({activation_code; _} as _first_one) = Option.get @@ List.hd secrets in let inexistent_pkh = Signature.Public_key_hash.of_b58check_exn "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" @@ -502,7 +510,9 @@ let invalid_activation_inexistent_pkh () = let invalid_double_activation () = activation_init () >>=? fun (blk, _, secrets) -> - let ({account; activation_code; _} as _first_one) = List.hd secrets in + let ({account; activation_code; _} as _first_one) = + Option.get @@ List.hd secrets + in Incremental.begin_construction blk >>=? fun inc -> Op.activation (I inc) account activation_code @@ -523,8 +533,8 @@ let invalid_double_activation () = let invalid_transfer_from_unactivated_account () = activation_init () >>=? fun (blk, contracts, secrets) -> - let ({account; _} as _first_one) = List.hd secrets in - let bootstrap_contract = List.hd contracts in + let ({account; _} as _first_one) = Option.get @@ List.hd secrets in + let bootstrap_contract = Option.get @@ List.hd contracts in let unactivated_commitment_contract = Contract.implicit_contract account in (* No activation *) Op.transaction diff --git a/src/proto_alpha/lib_protocol/test/baking.ml b/src/proto_alpha/lib_protocol/test/baking.ml index 2405aa9f93b3486dcb39152828ed2c74ebd0b745..9b750d2e33fec2367c35ae9acfa8f60f5eaeb1d6 100644 --- a/src/proto_alpha/lib_protocol/test/baking.ml +++ b/src/proto_alpha/lib_protocol/test/baking.ml @@ -103,11 +103,11 @@ let test_rewards_retrieval () = let block_priorities = 0 -- 10 in let included_endorsements = 0 -- endorsers_per_block in let ranges = List.product block_priorities included_endorsements in - iter_s + List.iter_es (fun (priority, endorsing_power) -> (* bake block at given priority and with given endorsing_power *) let real_endorsers = List.sub endorsers endorsing_power in - map_p + List.map_ep (fun endorser -> Op.endorsement ~delegate:endorser.delegate (B good_b) () >|=? fun operation -> Operation.pack operation) @@ -148,7 +148,7 @@ let test_rewards_retrieval () = accumulated_frozen_balance ) >>=? fun () -> (* check the each endorser was rewarded the right amount *) - iter_p + List.iter_ep (fun endorser -> balance_update endorser.delegate good_b b >>=? fun endorser_frozen_balance -> @@ -175,7 +175,7 @@ let test_rewards_formulas () = let block_priorities = 0 -- 2 in let included_endorsements = 0 -- endorsers_per_block in let ranges = List.product block_priorities included_endorsements in - iter_p + List.iter_ep (fun (priority, endorsing_power) -> Context.get_baking_reward (B b) ~priority ~endorsing_power >>=? fun reward -> @@ -215,7 +215,7 @@ let test_rewards_formulas_equivalence () = let block_priorities = 0 -- 64 in let endorsing_power = 0 -- endorsers_per_block in let ranges = List.product block_priorities endorsing_power in - iter_p + List.iter_ep (fun (block_priority, endorsing_power) -> Baking.baking_reward ctxt @@ -256,7 +256,7 @@ let test_voting_power_cache () = >>=? fun (block, _contracts) -> Context.get_bakers (B block) >>=? fun bakers -> - let baker = List.hd bakers in + let baker = Option.get @@ List.hd bakers in let assert_voting_power n block = get_voting_power block baker >>=? fun voting_power -> diff --git a/src/proto_alpha/lib_protocol/test/combined_operations.ml b/src/proto_alpha/lib_protocol/test/combined_operations.ml index e1701b8acdda3a40fac1589fecd5b7f96487c70a..84d9b38146c8a6b38deb56ed8b22575e8d392622 100644 --- a/src/proto_alpha/lib_protocol/test/combined_operations.ml +++ b/src/proto_alpha/lib_protocol/test/combined_operations.ml @@ -43,10 +43,10 @@ let ten_tez = Tez.of_int 10 let multiple_transfers () = Context.init 3 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in - let c3 = List.nth contracts 2 in - map_s (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10) + let (c1, c2, c3) = + match contracts with [c1; c2; c3] -> (c1, c2, c3) | _ -> assert false + in + List.map_es (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10) >>=? fun ops -> Op.combine_operations ~source:c1 (B blk) ops >>=? fun operation -> @@ -77,15 +77,16 @@ let multiple_transfers () = let multiple_origination_and_delegation () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in let n = 10 in Context.get_constants (B blk) >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> Context.Contract.pkh c2 >>=? fun delegate_pkh -> (* Deploy n smart contracts with dummy scripts from c1 *) - map_s + List.map_es (fun i -> Op.origination ~delegate:delegate_pkh @@ -146,7 +147,7 @@ let multiple_origination_and_delegation () = >>?= fun total_cost -> Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost >>=? fun () -> - iter_s + List.iter_es (fun c -> Assert.balance_is ~loc:__LOC__ (I inc) c (Tez.of_int 10)) new_contracts @@ -164,8 +165,9 @@ let expect_balance_too_low = function let failing_operation_in_the_middle () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.max_tez @@ -220,8 +222,9 @@ let failing_operation_in_the_middle () = let failing_operation_in_the_middle_with_fees () = Context.init 2 >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in + let (c1, c2) = + match contracts with [c1; c2] -> (c1, c2) | _ -> assert false + in Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.max_tez @@ -293,37 +296,38 @@ let expect_wrong_signature list = let wrong_signature_in_the_middle () = Context.init 2 - >>=? fun (blk, contracts) -> - let c1 = List.nth contracts 0 in - let c2 = List.nth contracts 1 in - Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one - >>=? fun op1 -> - Op.transaction ~fee:Tez.one (B blk) c2 c1 Tez.one - >>=? fun op2 -> - Incremental.begin_construction blk - >>=? fun inc -> - (* Make legit transfers, performing reveals *) - Incremental.add_operation inc op1 - >>=? fun inc -> - Incremental.add_operation inc op2 - >>=? fun inc -> - (* Cook transactions for actual test *) - Op.transaction ~fee:Tez.one (I inc) c1 c2 Tez.one - >>=? fun op1 -> - Op.transaction ~fee:Tez.one (I inc) c1 c2 Tez.one - >>=? fun op2 -> - Op.transaction ~fee:Tez.one (I inc) c1 c2 Tez.one - >>=? fun op3 -> - Op.transaction ~fee:Tez.one (I inc) c2 c1 Tez.one - >>=? fun spurious_operation -> - let operations = [op1; op2; op3] in - Op.combine_operations ~spurious_operation ~source:c1 (I inc) operations - >>=? fun operation -> - Incremental.add_operation - ~expect_apply_failure:expect_wrong_signature - inc - operation - >>=? fun _inc -> return_unit + >>=? function + | (_, []) | (_, [_]) -> + assert false + | (blk, c1 :: c2 :: _) -> + Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one + >>=? fun op1 -> + Op.transaction ~fee:Tez.one (B blk) c2 c1 Tez.one + >>=? fun op2 -> + Incremental.begin_construction blk + >>=? fun inc -> + (* Make legit transfers, performing reveals *) + Incremental.add_operation inc op1 + >>=? fun inc -> + Incremental.add_operation inc op2 + >>=? fun inc -> + (* Cook transactions for actual test *) + Op.transaction ~fee:Tez.one (I inc) c1 c2 Tez.one + >>=? fun op1 -> + Op.transaction ~fee:Tez.one (I inc) c1 c2 Tez.one + >>=? fun op2 -> + Op.transaction ~fee:Tez.one (I inc) c1 c2 Tez.one + >>=? fun op3 -> + Op.transaction ~fee:Tez.one (I inc) c2 c1 Tez.one + >>=? fun spurious_operation -> + let operations = [op1; op2; op3] in + Op.combine_operations ~spurious_operation ~source:c1 (I inc) operations + >>=? fun operation -> + Incremental.add_operation + ~expect_apply_failure:expect_wrong_signature + inc + operation + >>=? fun _inc -> return_unit let tests = [ Test.tztest "multiple transfers" `Quick multiple_transfers; diff --git a/src/proto_alpha/lib_protocol/test/delegation.ml b/src/proto_alpha/lib_protocol/test/delegation.ml index 83904dc1f4df6ad74780f7ea93806789bc8790c4..f9ddabc64207a49e144db822b268d8d7c861860c 100644 --- a/src/proto_alpha/lib_protocol/test/delegation.ml +++ b/src/proto_alpha/lib_protocol/test/delegation.ml @@ -53,7 +53,7 @@ let expect_no_change_registered_delegate_pkh pkh = function let bootstrap_manager_is_bootstrap_delegate () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.hd bootstrap_contracts in + let bootstrap0 = Option.get @@ List.hd bootstrap_contracts in Context.Contract.delegate (B b) bootstrap0 >>=? fun delegate0 -> Context.Contract.manager (B b) bootstrap0 @@ -63,8 +63,8 @@ let bootstrap_manager_is_bootstrap_delegate () = let bootstrap_delegate_cannot_change ~fee () = Context.init 2 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.nth bootstrap_contracts 0 in - let bootstrap1 = List.nth bootstrap_contracts 1 in + let bootstrap0 = Option.get @@ List.nth bootstrap_contracts 0 in + let bootstrap1 = Option.get @@ List.nth bootstrap_contracts 1 in Context.Contract.pkh bootstrap0 >>=? fun pkh1 -> Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) @@ -106,7 +106,7 @@ let bootstrap_delegate_cannot_change ~fee () = let bootstrap_delegate_cannot_be_removed ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Incremental.begin_construction b >>=? fun i -> Context.Contract.balance (I i) bootstrap @@ -144,8 +144,8 @@ let bootstrap_delegate_cannot_be_removed ~fee () = let delegate_can_be_changed_from_unregistered_contract ~fee () = Context.init 2 >>=? fun (b, bootstrap_contracts) -> - let bootstrap0 = List.hd bootstrap_contracts in - let bootstrap1 = List.nth bootstrap_contracts 1 in + let bootstrap0 = Option.get @@ List.hd bootstrap_contracts in + let bootstrap1 = Option.get @@ List.nth bootstrap_contracts 1 in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let unregistered = Contract.implicit_contract unregistered_pkh in @@ -197,7 +197,7 @@ let delegate_can_be_changed_from_unregistered_contract ~fee () = let delegate_can_be_removed_from_unregistered_contract ~fee () = Context.init 1 >>=? fun (b, bootstrap_contracts) -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let unregistered = Contract.implicit_contract unregistered_pkh in @@ -252,7 +252,7 @@ let bootstrap_manager_already_registered_delegate ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun manager -> let pkh = manager.pkh in @@ -289,7 +289,7 @@ let delegate_to_bootstrap_by_origination ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun manager -> Context.Contract.balance (I i) bootstrap @@ -486,7 +486,7 @@ let unregistered_delegate_key_init_origination ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in (* origination with delegate argument *) @@ -537,7 +537,7 @@ let unregistered_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -587,7 +587,7 @@ let unregistered_delegate_key_switch_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -646,7 +646,7 @@ let unregistered_delegate_key_init_origination_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -697,7 +697,7 @@ let unregistered_delegate_key_init_delegation_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -755,7 +755,7 @@ let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -823,7 +823,7 @@ let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -881,7 +881,7 @@ let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let unregistered_account = Account.new_account () in let unregistered_pkh = Account.(unregistered_account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -944,7 +944,7 @@ let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let bootstrap_pkh = Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__ in @@ -1041,7 +1041,7 @@ let failed_self_delegation_emptied_implicit_contract amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let unregistered_pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract unregistered_pkh in @@ -1075,7 +1075,7 @@ let emptying_delegated_implicit_contract_fails amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in Context.Contract.manager (I i) bootstrap >>=? fun bootstrap_manager -> let account = Account.new_account () in @@ -1115,7 +1115,7 @@ let valid_delegate_registration_init_delegation_credit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1168,7 +1168,7 @@ let valid_delegate_registration_switch_delegation_credit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1222,7 +1222,7 @@ let valid_delegate_registration_init_delegation_credit_debit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1290,7 +1290,7 @@ let valid_delegate_registration_switch_delegation_credit_debit amount () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let delegate_account = Account.new_account () in let delegate_pkh = Account.(delegate_account.pkh) in let impl_contract = Contract.implicit_contract delegate_pkh in @@ -1356,7 +1356,7 @@ let double_registration () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1389,7 +1389,7 @@ let double_registration_when_empty () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1429,7 +1429,7 @@ let double_registration_when_recredited () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let account = Account.new_account () in let pkh = Account.(account.pkh) in let impl_contract = Contract.implicit_contract pkh in @@ -1476,7 +1476,7 @@ let unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; _} = Account.new_account () in let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in @@ -1511,7 +1511,7 @@ let unregistered_and_revealed_self_delegate_key_init_delegation ~fee () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; pk; _} = Account.new_account () in let {Account.pkh = delegate_pkh; _} = Account.new_account () in let contract = Alpha_context.Contract.implicit_contract pkh in @@ -1550,7 +1550,7 @@ let registered_self_delegate_key_init_delegation () = >>=? fun (b, bootstrap_contracts) -> Incremental.begin_construction b >>=? fun i -> - let bootstrap = List.hd bootstrap_contracts in + let bootstrap = Option.get @@ List.hd bootstrap_contracts in let {Account.pkh; _} = Account.new_account () in let {Account.pkh = delegate_pkh; pk = delegate_pk; _} = Account.new_account () diff --git a/src/proto_alpha/lib_protocol/test/double_baking.ml b/src/proto_alpha/lib_protocol/test/double_baking.ml index 535cfdb3bc5899393a085af0acf6902015b75624..f4aa22ca8bb0cd22d6a2641088680748d399ccea 100644 --- a/src/proto_alpha/lib_protocol/test/double_baking.ml +++ b/src/proto_alpha/lib_protocol/test/double_baking.ml @@ -33,31 +33,29 @@ open Alpha_context (* Utility functions *) (****************************************************************) +let get_hd_hd = function x :: y :: _ -> (x, y) | _ -> assert false + let get_first_different_baker baker bakers = - List.find - (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') - bakers + Option.get + @@ List.find + (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') + bakers let get_first_different_bakers ctxt = Context.get_bakers ctxt - >|=? fun bakers -> - let baker_1 = List.hd bakers in - get_first_different_baker baker_1 (List.tl bakers) - |> fun baker_2 -> (baker_1, baker_2) + >|=? function + | [] | [_] -> + assert false + | baker_1 :: other_bakers -> + (baker_1, get_first_different_baker baker_1 other_bakers) let get_first_different_endorsers ctxt = - Context.get_endorsers ctxt - >|=? fun endorsers -> - let endorser_1 = (List.hd endorsers).delegate in - let endorser_2 = (List.hd (List.tl endorsers)).delegate in - (endorser_1, endorser_2) + Context.get_endorsers ctxt >|=? fun endorsers -> get_hd_hd endorsers (** Bake two block at the same level using the same policy (i.e. same baker) *) let block_fork ?policy contracts b = - let (contract_a, contract_b) = - (List.hd contracts, List.hd (List.tl contracts)) - in + let (contract_a, contract_b) = get_hd_hd contracts in Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent >>=? fun operation -> Block.bake ?policy ~operation b @@ -74,7 +72,7 @@ let valid_double_baking_evidence () = >>=? fun (b, contracts) -> Context.get_bakers (B b) >>=? fun bakers -> - let priority_0_baker = List.hd bakers in + let priority_0_baker = Option.get @@ List.hd bakers in block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> Op.double_baking (B blk_a) blk_a.header blk_b.header @@ -82,7 +80,7 @@ let valid_double_baking_evidence () = Block.bake ~policy:(Excluding [priority_0_baker]) ~operation blk_a >>=? fun blk -> (* Check that the frozen deposit, the fees and rewards are removed *) - iter_s + List.iter_es (fun kind -> let contract = Alpha_context.Contract.implicit_contract priority_0_baker @@ -156,7 +154,7 @@ let too_late_double_baking_evidence () = >>=? fun Constants.{parametric = {preserved_cycles; _}; _} -> block_fork ~policy:(By_priority 0) contracts b >>=? fun (blk_a, blk_b) -> - fold_left_s + List.fold_left_es (fun blk _ -> Block.bake_until_cycle_end blk) blk_a (1 -- (preserved_cycles + 1)) diff --git a/src/proto_alpha/lib_protocol/test/double_endorsement.ml b/src/proto_alpha/lib_protocol/test/double_endorsement.ml index f644217660702886d2808bd75ecb8efce51f5a91..ca73e1b9be0f46bdf09a9fbb3927eef73677f474 100644 --- a/src/proto_alpha/lib_protocol/test/double_endorsement.ml +++ b/src/proto_alpha/lib_protocol/test/double_endorsement.ml @@ -33,24 +33,24 @@ open Alpha_context (* Utility functions *) (****************************************************************) +let get_hd_hd = function x :: y :: _ -> (x, y) | _ -> assert false + let get_first_different_baker baker bakers = - List.find - (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') - bakers + Option.get + @@ List.find + (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') + bakers let get_first_different_bakers ctxt = Context.get_bakers ctxt - >|=? fun bakers -> - let baker_1 = List.hd bakers in - get_first_different_baker baker_1 (List.tl bakers) - |> fun baker_2 -> (baker_1, baker_2) + >|=? function + | [] -> + assert false + | baker_1 :: other_bakers -> + (baker_1, get_first_different_baker baker_1 other_bakers) let get_first_different_endorsers ctxt = - Context.get_endorsers ctxt - >|=? fun endorsers -> - let endorser_1 = List.hd endorsers in - let endorser_2 = List.hd (List.tl endorsers) in - (endorser_1, endorser_2) + Context.get_endorsers ctxt >|=? fun endorsers -> get_hd_hd endorsers let block_fork b = get_first_different_bakers (B b) @@ -90,7 +90,7 @@ let valid_double_endorsement_evidence () = Block.bake ~policy:(By_account baker) ~operation blk_a >>=? fun blk -> (* Check that the frozen deposit, the fees and rewards are removed *) - iter_s + List.iter_es (fun kind -> let contract = Alpha_context.Contract.implicit_contract delegate in Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero) @@ -159,7 +159,7 @@ let too_late_double_endorsement_evidence () = >>=? fun endorsement_a -> Op.endorsement ~delegate (B blk_b) () >>=? fun endorsement_b -> - fold_left_s + List.fold_left_es (fun blk _ -> Block.bake_until_cycle_end blk) blk_a (1 -- (preserved_cycles + 1)) @@ -213,10 +213,11 @@ let different_delegates () = let wrong_delegate () = Context.init ~endorsers_per_block:1 2 >>=? fun (b, contracts) -> - Error_monad.map_s (Context.Contract.manager (B b)) contracts + List.map_es (Context.Contract.manager (B b)) contracts >>=? fun accounts -> - let pkh1 = (List.nth accounts 0).Account.pkh in - let pkh2 = (List.nth accounts 1).Account.pkh in + let (account_1, account_2) = get_hd_hd accounts in + let pkh1 = account_1.Account.pkh in + let pkh2 = account_2.Account.pkh in block_fork b >>=? fun (blk_a, blk_b) -> Context.get_endorser (B blk_a) diff --git a/src/proto_alpha/lib_protocol/test/endorsement.ml b/src/proto_alpha/lib_protocol/test/endorsement.ml index b8481a767d0689abac53f467d98d92523a9fcb57..58cb0354276761f9cf07b9e6305fa1038c6b30ce 100644 --- a/src/proto_alpha/lib_protocol/test/endorsement.ml +++ b/src/proto_alpha/lib_protocol/test/endorsement.ml @@ -38,6 +38,8 @@ open Test_tez (* Utility functions *) (****************************************************************) +let get_hd_hd = function x :: y :: _ -> (x, y) | _ -> assert false + let get_expected_reward ctxt ~priority ~baker ~endorsing_power = ( if baker then Context.get_baking_reward ctxt ~priority ~endorsing_power else return (Test_tez.Tez.of_int 0) ) @@ -135,7 +137,7 @@ let max_endorsement () = endorsers))) endorsers_per_block >>=? fun () -> - fold_left_s + List.fold_left_es (fun (delegates, ops, balances) (endorser : Alpha_services.Delegate.Endorsing_rights.t) -> let delegate = endorser.delegate in @@ -153,22 +155,24 @@ let max_endorsement () = >>=? fun b -> (* One account can endorse more than one time per level, we must check that the bonds are summed up *) - iter_s - (fun (endorser_account, (endorsing_power, previous_balance)) -> + List.iter2_es + ~when_different_lengths:(TzTrace.make (Exn (Failure __LOC__))) + (fun endorser_account (endorsing_power, previous_balance) -> assert_endorser_balance_consistency ~loc:__LOC__ (B b) ~endorsing_power endorser_account previous_balance) - (List.combine delegates previous_balances) + delegates + previous_balances (** Check every that endorsers' balances are consistent with different priorities *) let consistent_priorities () = let priorities = 0 -- 64 in Context.init 64 >>=? fun (b, _) -> - fold_left_s + List.fold_left_es (fun (b, used_pkhes) priority -> (* Choose an endorser that has not baked nor endorsed before *) Context.get_endorsers (B b) @@ -236,7 +240,7 @@ let reward_retrieval () = Block.bake ~policy ~operation b >>=? fun b -> (* Bake (preserved_cycles + 1) cycles *) - fold_left_s + List.fold_left_es (fun b _ -> Block.bake_until_cycle_end ~policy:(Excluding [endorser]) b) b (0 -- preserved_cycles) @@ -266,8 +270,7 @@ let reward_retrieval_two_endorsers () = _ } -> Context.get_endorsers (B b) >>=? fun endorsers -> - let endorser1 = List.hd endorsers in - let endorser2 = List.hd (List.tl endorsers) in + let (endorser1, endorser2) = get_hd_hd endorsers in Context.Contract.balance (B b) (Contract.implicit_contract endorser1.delegate) @@ -329,7 +332,7 @@ let reward_retrieval_two_endorsers () = Signature.Public_key_hash.( endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate) in - let endorser2 = List.find same_endorser2 endorsers in + let endorser2 = Option.get @@ List.find same_endorser2 endorsers in (* No exception raised: in sandboxed mode endorsers do not change between blocks *) Tez.( endorsement_security_deposit *? Int64.of_int (List.length endorser2.slots)) @@ -361,7 +364,7 @@ let reward_retrieval_two_endorsers () = security_deposit2 >>=? fun () -> (* bake [preserved_cycles] cycles *) - fold_left_s + List.fold_left_es (fun b _ -> Assert.balance_was_debited ~loc:__LOC__ @@ -481,7 +484,7 @@ let duplicate_endorsement () = let not_enough_for_deposit () = Context.init 5 ~endorsers_per_block:1 >>=? fun (b_init, contracts) -> - Error_monad.map_s + List.map_es (fun c -> Context.Contract.manager (B b_init) c >|=? fun m -> (m, c)) contracts >>=? fun managers -> @@ -491,15 +494,17 @@ let not_enough_for_deposit () = Context.get_endorser (B b) >>=? fun (endorser, _slots) -> let (_, contract_other_than_endorser) = - List.find - (fun (c, _) -> - not (Signature.Public_key_hash.equal c.Account.pkh endorser)) - managers + Option.get + @@ List.find + (fun (c, _) -> + not (Signature.Public_key_hash.equal c.Account.pkh endorser)) + managers in let (_, contract_of_endorser) = - List.find - (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser) - managers + Option.get + @@ List.find + (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser) + managers in Context.Contract.balance (B b) (Contract.implicit_contract endorser) >>=? fun initial_balance -> @@ -537,14 +542,14 @@ let endorsement_threshold () = let num_endorsers = List.length endorsers in (* we try to bake with more and more endorsers, but at each iteration with a timestamp smaller than required *) - iter_s + List.iter_es (fun i -> (* the priority is chosen rather arbitrarily *) let priority = num_endorsers - i in let crt_endorsers = List.take_n i endorsers in let endorsing_power = endorsing_power crt_endorsers in let delegates = delegates_with_slots crt_endorsers in - map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates + List.map_es (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates >>=? fun ops -> Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> @@ -574,7 +579,7 @@ let endorsement_threshold () = let priority = 0 in let endorsing_power = endorsing_power endorsers in let delegates = delegates_with_slots endorsers in - map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates + List.map_es (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates >>=? fun ops -> Context.get_minimal_valid_time (B b) ~priority ~endorsing_power >>=? fun timestamp -> diff --git a/src/proto_alpha/lib_protocol/test/gas_costs.ml b/src/proto_alpha/lib_protocol/test/gas_costs.ml index 8cc33ed40f2489e5d9144d829206cde1052ff5ac..217c90086269da171d9bb3f94a052d40e7b2d50e 100644 --- a/src/proto_alpha/lib_protocol/test/gas_costs.ml +++ b/src/proto_alpha/lib_protocol/test/gas_costs.ml @@ -229,7 +229,7 @@ let cast_cost_to_z (c : Alpha_context.Gas.cost) : Z.t = |> Data_encoding.Binary.of_bytes_exn Data_encoding.z let check_cost_reprs_are_all_positive list () = - iter_s + List.iter_es (fun (cost_name, cost) -> if Z.gt cost Z.zero then return_unit else if Z.equal cost Z.zero && List.mem cost_name free then return_unit diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 125a6591cb92c821e0fb05b24db6cc962bf5178e..beaa12d0aeeb7e83a892b20d42022c7849ebc456 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -68,10 +68,11 @@ let get_next_baker_by_priority priority block = block >|=? fun bakers -> let {Alpha_services.Delegate.Baking_rights.delegate = pkh; timestamp; _} = - List.find - (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} -> - p = priority) - bakers + Option.get + @@ List.find + (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} -> + p = priority) + bakers in (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -86,7 +87,7 @@ let get_next_baker_by_account pkh block = timestamp; priority; _ } = - List.hd bakers + Option.get @@ List.hd bakers in (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -97,10 +98,11 @@ let get_next_baker_excluding excludes block = timestamp; priority; _ } = - List.find - (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> - not (List.mem delegate excludes)) - bakers + Option.get + @@ List.find + (fun {Alpha_services.Delegate.Baking_rights.delegate; _} -> + not (List.mem delegate excludes)) + bakers in (pkh, priority, Option.unopt_exn (Failure "") timestamp) @@ -115,7 +117,7 @@ let dispatch_policy = function let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy let get_endorsing_power b = - fold_left_s + List.fold_left_es (fun acc (op : Operation.packed) -> let (Operation_data data) = op.protocol_data in match data.contents with @@ -329,8 +331,9 @@ let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers } in (* Check there is at least one roll *) - ( try - fold_left_s + Lwt.catch + (fun () -> + List.fold_left_es (fun acc (_, amount) -> Environment.wrap_error @@ Tez_repr.( +? ) acc amount >>?= fun acc -> @@ -338,8 +341,8 @@ let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers Tez_repr.zero initial_accounts >>=? fun _ -> - failwith "Insufficient tokens in initial accounts to create one roll" - with Exit -> return_unit ) + failwith "Insufficient tokens in initial accounts to create one roll") + (function Exit -> return_unit | exc -> raise exc) >>=? fun () -> check_constants_consistency constants >>=? fun () -> @@ -376,7 +379,7 @@ let apply header ?(operations = []) pred = ~predecessor_timestamp:pred.header.shell.timestamp header >>=? fun vstate -> - fold_left_s + List.fold_left_es (fun vstate op -> apply_operation vstate op >|=? fun (state, _result) -> state) vstate @@ -411,7 +414,7 @@ let bake ?policy ?timestamp ?operation ?operations pred = let get_constants b = Alpha_services.Constants.all rpc_ctxt b let bake_n ?policy n b = - Error_monad.fold_left_s (fun b _ -> bake ?policy b) b (1 -- n) + List.fold_left_es (fun b _ -> bake ?policy b) b (1 -- n) let bake_until_cycle_end ?policy b = get_constants b @@ -422,7 +425,7 @@ let bake_until_cycle_end ?policy b = bake_n ?policy (Int32.to_int delta) b let bake_until_n_cycle_end ?policy n b = - Error_monad.fold_left_s (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) + List.fold_left_es (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) let current_cycle b = get_constants b diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index 84987952bc138841cf64d0a877928719474dbd2b..12264e667a330839738c6d6f9e423d77d64475a1 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -108,7 +108,7 @@ let get_endorsers ctxt = let get_endorser ctxt = Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt >|=? fun endorsers -> - let endorser = List.hd endorsers in + let endorser = Option.get @@ List.hd endorsers in (endorser.delegate, endorser.slots) let get_voting_power = Alpha_services.Delegate.voting_power rpc_ctxt diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index 691ccfa171e990755f807c943086130299e73b23..1d4ec4556f272f96f6a85dbde287f85f1b325d4a 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -66,7 +66,9 @@ let combine_operations ?public_key ?counter ?spurious_operation ~source ctxt (packed_operations : packed_operation list) = assert (List.length packed_operations > 0) ; (* Hypothesis : each operation must have the same branch (is this really true?) *) - let {Tezos_base.Operation.branch} = (List.hd packed_operations).shell in + let {Tezos_base.Operation.branch} = + (Option.get @@ List.hd packed_operations).shell + in assert ( List.for_all (fun {shell = {Tezos_base.Operation.branch = b; _}; _} -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml index b26e1de737d9ea70b49448a289061db69eca816f..ba2b94cfdfa24c7923aad755f8a48980333577eb 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml @@ -401,11 +401,16 @@ module Interpreter_helpers = struct Sapling.Core.Wallet.Viewing_key.(new_address vk index) in let outputs = - List.init number_outputs (fun _ -> + List.init ~when_negative_length:() number_outputs (fun _ -> Sapling.Forge.make_output new_addr amount_output (Bytes.create memo_size)) + |> function + | Error () -> + assert false (* conditional above guards against this *) + | Ok outputs -> + outputs in let tr_hex = to_hex diff --git a/src/proto_alpha/lib_protocol/test/origination.ml b/src/proto_alpha/lib_protocol/test/origination.ml index f55fd66f2ab80fe7f5f8c50461886a515695e54d..efeec384e7e85b7cf9f51a88a41a051e7ac17cc2 100644 --- a/src/proto_alpha/lib_protocol/test/origination.ml +++ b/src/proto_alpha/lib_protocol/test/origination.ml @@ -37,7 +37,7 @@ let ten_tez = Tez.of_int 10 let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) () = Context.init 1 >>=? fun (b, contracts) -> - let source = List.hd contracts in + let source = Option.get @@ List.hd contracts in Context.Contract.balance (B b) source >>=? fun source_balance -> Op.origination (B b) source ~fee ~credit ~script:Op.dummy_script @@ -81,7 +81,7 @@ let test_origination_balances ~loc:_ ?(fee = Tez.zero) ?(credit = Tez.zero) () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Context.Contract.balance (B b) contract >>=? fun balance -> Op.origination (B b) contract ~fee ~credit ~script:Op.dummy_script @@ -163,8 +163,8 @@ let pay_fee () = let not_tez_in_contract_to_pay_fee () = Context.init 2 >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in + let contract_1 = Option.get @@ List.nth contracts 0 in + let contract_2 = Option.get @@ List.nth contracts 1 in Incremental.begin_construction b >>=? fun inc -> (* transfer everything but one tez from 1 to 2 and check balance of 1 *) @@ -203,7 +203,7 @@ let not_tez_in_contract_to_pay_fee () = let register_contract_get_endorser () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Incremental.begin_construction b >>=? fun inc -> Context.get_endorser (I inc) @@ -216,7 +216,7 @@ let register_contract_get_endorser () = (*******************) let n_originations n ?credit ?fee () = - fold_left_s + List.fold_left_es (fun new_contracts _ -> register_origination ?fee ?credit () >|=? fun (_b, _source, new_contract) -> new_contract :: new_contracts) @@ -236,7 +236,7 @@ let multiple_originations () = let counter () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.hd contracts in + let contract = Option.get @@ List.hd contracts in Incremental.begin_construction b >>=? fun inc -> Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script diff --git a/src/proto_alpha/lib_protocol/test/reveal.ml b/src/proto_alpha/lib_protocol/test/reveal.ml index 1fd7bcd93dc856539fc2ae785c34e25a386366a5..5833aa1aa4c32af108c3241459d9b11585129449 100644 --- a/src/proto_alpha/lib_protocol/test/reveal.ml +++ b/src/proto_alpha/lib_protocol/test/reveal.ml @@ -33,7 +33,7 @@ let ten_tez = Tez.of_int 10 let simple_reveal () = Context.init 1 >>=? fun (blk, contracts) -> - let c = List.nth contracts 0 in + let c = Option.get @@ List.hd contracts in let new_c = Account.new_account () in let new_contract = Alpha_context.Contract.implicit_contract new_c.pkh in (* Create the contract *) @@ -57,7 +57,7 @@ let simple_reveal () = let empty_account_on_reveal () = Context.init 1 >>=? fun (blk, contracts) -> - let c = List.nth contracts 0 in + let c = Option.get @@ List.hd contracts in let new_c = Account.new_account () in let new_contract = Alpha_context.Contract.implicit_contract new_c.pkh in let amount = Tez.one_mutez in @@ -89,7 +89,7 @@ let empty_account_on_reveal () = let not_enough_found_for_reveal () = Context.init 1 >>=? fun (blk, contracts) -> - let c = List.nth contracts 0 in + let c = Option.get @@ List.hd contracts in let new_c = Account.new_account () in let new_contract = Alpha_context.Contract.implicit_contract new_c.pkh in (* Create the contract *) diff --git a/src/proto_alpha/lib_protocol/test/script_gas.ml b/src/proto_alpha/lib_protocol/test/script_gas.ml index 966756df6217197a6ee15c6437a03c340227d19e..3bbd175040bd4d335d27df62aae44dce53adc203 100644 --- a/src/proto_alpha/lib_protocol/test/script_gas.ml +++ b/src/proto_alpha/lib_protocol/test/script_gas.ml @@ -98,11 +98,13 @@ module Tested_terms () = struct lazy_terms let check_correctness () = - Error_monad.iter2_p + List.iter2_e + ~when_different_lengths: + (TzTrace.make @@ Exn (Failure "differently sized cost lists")) (fun min full -> - if Z.leq min full then return_unit + if Z.leq min full then ok_unit else - failwith + generic_error "Script_repr: inconsistent costs %a vs %a@." Z.pp_print min @@ -110,6 +112,8 @@ module Tested_terms () = struct full) minimal_costs full_costs + + let check_correctness () = Lwt.return @@ check_correctness () end let check_property () = diff --git a/src/proto_alpha/lib_protocol/test/seed.ml b/src/proto_alpha/lib_protocol/test/seed.ml index fe6429af5a38a22b97ad9b0d5c4f6bcb0ac099ff..1d18737b577f18f9c3e1140e51cd0bd7a60e6943 100644 --- a/src/proto_alpha/lib_protocol/test/seed.ml +++ b/src/proto_alpha/lib_protocol/test/seed.ml @@ -205,7 +205,7 @@ let revelation_early_wrong_right_twice () = false) >>=? fun () -> (* bake [preserved_cycles] cycles excluding [id] *) - Error_monad.fold_left_s + List.fold_left_es (fun b _ -> Block.bake_until_cycle_end ~policy b) b (1 -- preserved_cycles) diff --git a/src/proto_alpha/lib_protocol/test/test_helpers_rpcs.ml b/src/proto_alpha/lib_protocol/test/test_helpers_rpcs.ml index 3753fac0f46a26f7520cf37f522e85768873f3a9..11bf1dbb0dab1fc0cc446719ddd7c640e5d2d683 100644 --- a/src/proto_alpha/lib_protocol/test/test_helpers_rpcs.ml +++ b/src/proto_alpha/lib_protocol/test/test_helpers_rpcs.ml @@ -44,7 +44,7 @@ let test_baking_rights () = assert (List.length rights = max_priority + 1) ; (* filtering by delegate *) let d = - Contract.is_implicit (List.nth contracts 0) + Option.bind (List.nth contracts 0) Contract.is_implicit |> Option.unopt_assert ~loc:__POS__ in get Block.rpc_ctxt b ~all:true ~delegates:[d] diff --git a/src/proto_alpha/lib_protocol/test/test_sapling.ml b/src/proto_alpha/lib_protocol/test/test_sapling.ml index 1e10bdc022c7644ffcafbacb3485e96b6a490398..0a3ae140f3799020bc6dcf352322c1208b8bf081 100644 --- a/src/proto_alpha/lib_protocol/test/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/test_sapling.ml @@ -54,7 +54,7 @@ module Raw_context_tests = struct Sapling_storage.init ctx id ~memo_size:0 >>= wrap >>=? fun ctx -> - fold_left_s + List.fold_left_es (fun ctx pos -> Sapling_storage.Commitments.get_root ctx id >>= wrap @@ -137,7 +137,11 @@ module Raw_context_tests = struct Sapling_storage.init ctx id ~memo_size:0 >>= wrap >>=? fun ctx -> - let nf_list_ctx = List.init 10 (fun _ -> gen_nf ()) in + let nf_list_ctx = + List.init ~when_negative_length:() 10 (fun _ -> gen_nf ()) + |> function + | Error () -> assert false (* 10 > 0 *) | Ok nf_list_ctx -> nf_list_ctx + in let state = List.fold_left (fun state nf -> Sapling_storage.nullifiers_add state nf) @@ -147,14 +151,18 @@ module Raw_context_tests = struct Sapling_storage.apply_diff ctx id state.diff >>= wrap >>=? fun (ctx, _) -> - let nf_list_diff = List.init 10 (fun _ -> gen_nf ()) in + let nf_list_diff = + List.init ~when_negative_length:() 10 (fun _ -> gen_nf ()) + |> function + | Error () -> assert false (* 10 > 0 *) | Ok nf_list_diff -> nf_list_diff + in let state = List.fold_left (fun state nf -> Sapling_storage.nullifiers_add state nf) state nf_list_diff in - Error_monad.iter_p + List.iter_ep (fun nf -> Sapling_storage.nullifiers_mem ctx state nf >>= wrap @@ -163,8 +171,15 @@ module Raw_context_tests = struct return_unit) (nf_list_ctx @ nf_list_diff) >>=? fun () -> - let nf_list_absent = List.init 10 (fun _ -> gen_nf ()) in - Error_monad.iter_p + let nf_list_absent = + List.init 10 ~when_negative_length:() (fun _ -> gen_nf ()) + |> function + | Error () -> + assert false (* 10 > 0 *) + | Ok nf_list_absent -> + nf_list_absent + in + List.iter_ep (fun nf -> Sapling_storage.nullifiers_mem ctx state nf >>= wrap @@ -200,7 +215,12 @@ module Raw_context_tests = struct Sapling_storage.state_from_id ctx id >>= wrap >>=? fun (diff, ctx) -> - let list_added = List.init 10 (fun _ -> gen_cm_cipher ~memo_size ()) in + let list_added = + List.init ~when_negative_length:() 10 (fun _ -> + gen_cm_cipher ~memo_size ()) + |> function + | Error () -> assert false (* 10 > 0 *) | Ok list_added -> list_added + in let state = Sapling_storage.add diff list_added in Sapling_storage.apply_diff ctx id state.diff >>= wrap @@ -218,7 +238,7 @@ module Raw_context_tests = struct >>=? fun result -> let expected_cm = List.map fst expected in assert (result = expected_cm) ; - test_from (Int64.succ from) until (List.tl expected) + test_from (Int64.succ from) until (Option.get @@ List.tl expected) in test_from 0L 9L list_added @@ -247,7 +267,10 @@ module Raw_context_tests = struct >>= wrap >>=? fun ctx -> let list_to_add = - fst @@ List.split @@ List.init 33 (fun _ -> gen_cm_cipher ~memo_size ()) + fst @@ List.split + @@ ( List.init ~when_negative_length:() 33 (fun _ -> + gen_cm_cipher ~memo_size ()) + |> function Error () -> assert false (* 33 > 0 *) | Ok r -> r ) in let rec test counter ctx = if counter >= 32 then return_unit @@ -256,7 +279,7 @@ module Raw_context_tests = struct Sapling_storage.Commitments.add ctx id_one_by_one - [List.nth list_to_add counter] + [Option.get @@ List.nth list_to_add counter] (Int64.of_int counter) >>= wrap (* create a new tree and add a list of cms *) @@ -273,7 +296,9 @@ module Raw_context_tests = struct Sapling_storage.Commitments.add ctx id_all_at_once - (List.init (counter + 1) (fun i -> List.nth list_to_add i)) + ( List.init ~when_negative_length:() (counter + 1) (fun i -> + Option.get @@ List.nth list_to_add i) + |> function Error () -> assert false (* counter >= 0*) | Ok r -> r ) 0L >>= wrap >>=? fun (ctx, _size) -> @@ -302,8 +327,11 @@ module Raw_context_tests = struct in let roots_ctx = List.init + ~when_negative_length:() (Int32.to_int Sapling_storage.Roots.size + 10) (fun _ -> gen_root ()) + |> function + | Error () -> assert false (* size >= 0 *) | Ok roots_ctx -> roots_ctx in Context.init 1 >>=? fun (b, _) -> @@ -325,7 +353,7 @@ module Raw_context_tests = struct >>= wrap >>=? fun ctx -> (* Add one root per level to the context *) - Error_monad.fold_left_s + List.fold_left_es (fun (ctx, cnt) root -> Sapling_storage.Roots.add ctx id root >>= wrap @@ -348,7 +376,7 @@ module Raw_context_tests = struct Sapling_storage. {id = Some id; diff = Sapling_storage.empty_diff; memo_size = 0} in - Error_monad.fold_left_s + List.fold_left_es (fun i root -> Sapling_storage.root_mem ctx state root >>= wrap @@ -359,13 +387,20 @@ module Raw_context_tests = struct roots_ctx >>=? fun _ -> (* Add roots w/o increasing the level *) - let roots_same_level = List.init 10 (fun _ -> gen_root ()) in - Error_monad.fold_left_s + let roots_same_level = + List.init ~when_negative_length:() 10 (fun _ -> gen_root ()) + |> function + | Error () -> + assert false (* 10 > 0 *) + | Ok roots_same_level -> + roots_same_level + in + List.fold_left_es (fun ctx root -> Sapling_storage.Roots.add ctx id root >>= wrap) ctx roots_same_level >>=? fun ctx -> - Error_monad.fold_left_s + List.fold_left_es (fun (i, ctx) root -> Sapling_storage.root_mem ctx state root >>= wrap @@ -447,7 +482,7 @@ module Alpha_context_tests = struct let ctime_shields = Unix.gettimeofday () -. start in Printf.printf "client_shields %f\n" ctime_shields ; let start = Unix.gettimeofday () in - Error_monad.fold_left_s + List.fold_left_es (fun ctx vt -> verify_update ctx ~id vt |> assert_some >|=? fun (ctx, _id) -> ctx) ctx @@ -462,7 +497,7 @@ module Alpha_context_tests = struct let ctime_transfers = Unix.gettimeofday () -. start in Printf.printf "client_txs %f\n" ctime_transfers ; let start = Unix.gettimeofday () in - Error_monad.fold_left_s + List.fold_left_es (fun ctx vt -> verify_update ctx ~id vt |> assert_some >|=? fun (ctx, _id) -> ctx) ctx @@ -541,7 +576,7 @@ module Alpha_context_tests = struct (* randomize one output to fail check outputs *) (* don't randomize the ciphertext as it is not part of the proof *) let open Sapling.Core.Client.UTXO in - let o = List.hd vt.outputs in + let o = Option.get @@ List.hd vt.outputs in let o_wrong_cm = { o with @@ -663,7 +698,7 @@ module Interpreter_tests = struct let wb = wallet_gen () in let list_addr = gen_addr 15 wb.vk in let list_forge_input = - List.init 14 (fun pos_int -> + List.init ~when_negative_length:() 14 (fun pos_int -> let pos = Int64.of_int pos_int in let forge_input = snd @@ -671,6 +706,11 @@ module Interpreter_tests = struct |> Option.unopt_assert ~loc:__POS__ ) in forge_input) + |> function + | Error () -> + assert false (* 14 > 0 *) + | Ok list_forge_input -> + list_forge_input in let list_forge_output = List.map @@ -715,7 +755,7 @@ module Interpreter_tests = struct (* The inputs total [total] mutez and 15 of those are transfered in shielded tez *) assert (Int64.equal diff (Int64.of_int (total - 15))) ; let list_forge_input = - List.init 15 (fun i -> + List.init ~when_negative_length:() 15 (fun i -> let pos = Int64.of_int (i + 14 + 14) in let forge_input = snd @@ -723,6 +763,11 @@ module Interpreter_tests = struct |> Option.unopt_assert ~loc:__POS__ ) in forge_input) + |> function + | Error () -> + assert false (* 14 > 0 *) + | Ok list_forge_input -> + list_forge_input in let addr_a = snd @@ -815,7 +860,7 @@ module Interpreter_tests = struct (Format.sprintf "(Pair 0x%s 0)") anti_replay_2 in - let transaction = List.hd transactions in + let transaction = Option.get @@ List.hd transactions in let parameters = Alpha_context.Script.(lazy_expr (expression_from_string transaction)) in diff --git a/src/proto_alpha/lib_protocol/test/transfer.ml b/src/proto_alpha/lib_protocol/test/transfer.ml index f0f8fb5ac553fcf3b038fd7fafd22781f3870d23..31ac4ab26a286a188ae92951c4990ca4c4e00720 100644 --- a/src/proto_alpha/lib_protocol/test/transfer.ml +++ b/src/proto_alpha/lib_protocol/test/transfer.ml @@ -112,7 +112,7 @@ let transfer_to_itself_and_check_balances ~loc b ?(fee = Tez.zero) contract a destination contract with the amount "n" times. *) let n_transactions n b ?fee source dest amount = - fold_left_s + List.fold_left_es (fun b _ -> transfer_and_check_balances ~loc:__LOC__ b ?fee source dest amount >|=? fun (b, _) -> b) @@ -127,10 +127,11 @@ let ten_tez = Tez.of_int 10 let register_two_contracts () = Context.init 2 - >|=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in - (b, contract_1, contract_2) + >|=? function + | (_, []) | (_, [_]) -> + assert false + | (b, contract_1 :: contract_2 :: _) -> + (b, contract_1, contract_2) (** compute half of the balance and divided by nth times *) @@ -187,7 +188,7 @@ let transfer_zero_tez () = let transfer_zero_implicit () = Context.init 1 >>=? fun (b, contracts) -> - let dest = List.nth contracts 0 in + let dest = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in Incremental.begin_construction b >>=? fun i -> @@ -210,7 +211,7 @@ let transfer_zero_implicit () = let transfer_to_originate_with_fee () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in Incremental.begin_construction b >>=? fun b -> two_nth_of_balance b contract 10L @@ -254,7 +255,7 @@ let transfer_amount_of_contract_balance () = let transfers_to_self () = Context.init 1 >>=? fun (b, contracts) -> - let contract = List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in Incremental.begin_construction b >>=? fun b -> two_nth_of_balance b contract 3L @@ -303,7 +304,7 @@ let missing_transaction () = let transfer_from_implicit_to_implicit_contract () = Context.init 1 >>=? fun (b, contracts) -> - let bootstrap_contract = List.nth contracts 0 in + let bootstrap_contract = Option.get @@ List.nth contracts 0 in let account_a = Account.new_account () in let account_b = Account.new_account () in Incremental.begin_construction b @@ -344,8 +345,8 @@ let transfer_from_implicit_to_implicit_contract () = let transfer_from_implicit_to_originated_contract () = Context.init 1 >>=? fun (b, contracts) -> - let bootstrap_contract = List.nth contracts 0 in - let contract = List.nth contracts 0 in + let bootstrap_contract = Option.get @@ List.nth contracts 0 in + let contract = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in let src = Contract.implicit_contract account.Account.pkh in Incremental.begin_construction b @@ -446,7 +447,7 @@ let build_a_chain () = register_two_contracts () >>=? fun (b, contract_1, contract_2) -> let ten = Tez.of_int 10 in - fold_left_s + List.fold_left_es (fun b _ -> Incremental.begin_construction b >>=? fun b -> @@ -468,7 +469,7 @@ let build_a_chain () = let empty_implicit () = Context.init 1 >>=? fun (b, contracts) -> - let dest = List.nth contracts 0 in + let dest = Option.get @@ List.nth contracts 0 in let account = Account.new_account () in Incremental.begin_construction b >>=? fun incr -> @@ -531,9 +532,9 @@ let balance_too_low fee () = let balance_too_low_two_transfers fee () = Context.init 3 >>=? fun (b, contracts) -> - let contract_1 = List.nth contracts 0 in - let contract_2 = List.nth contracts 1 in - let contract_3 = List.nth contracts 2 in + let contract_1 = Option.get @@ List.nth contracts 0 in + let contract_2 = Option.get @@ List.nth contracts 1 in + let contract_3 = Option.get @@ List.nth contracts 2 in Incremental.begin_construction b >>=? fun i -> Context.Contract.balance (I i) contract_1 diff --git a/src/proto_alpha/lib_protocol/test/typechecking.ml b/src/proto_alpha/lib_protocol/test/typechecking.ml index 874857ba738ab8b2dbc541d6b21d1d38e091b7ba..992c2b143b78a300e8de63f08ee3e9747e62dc63 100644 --- a/src/proto_alpha/lib_protocol/test/typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/typechecking.ml @@ -35,7 +35,7 @@ let test_context () = let test_context_with_nat_nat_big_map () = Context.init 3 >>=? fun (b, contracts) -> - let source = List.hd contracts in + let source = Option.get @@ List.hd contracts in Op.origination (B b) source ~script:Op.dummy_script >>=? fun (operation, originated) -> Block.bake ~operation b @@ -725,7 +725,7 @@ let test_optimal_comb () = v >>=? fun (unparsed, ctxt) -> let (unparsed_canonical, unparsed_size) = size_of_micheline unparsed in - Error_monad.iter_s (fun other_repr -> + List.iter_es (fun other_repr -> let (other_repr_canonical, other_repr_size) = size_of_micheline other_repr in diff --git a/src/proto_alpha/lib_protocol/test/voting.ml b/src/proto_alpha/lib_protocol/test/voting.ml index 21051e7d7a0ead79619362c9830c4e90ed9c2dac..f886f128c42618948fc05424cfe38471a626b077 100644 --- a/src/proto_alpha/lib_protocol/test/voting.ml +++ b/src/proto_alpha/lib_protocol/test/voting.ml @@ -174,7 +174,7 @@ let get_delegates_and_rolls_from_listings b = let get_rolls b delegates loc = Context.Vote.get_listings (B b) >>=? fun l -> - map_s + List.map_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -255,8 +255,8 @@ let test_successful_vote num_delegates () = | Some _ -> failwith "%s - Unexpected proposal" __LOC__) >>=? fun () -> - let del1 = List.nth delegates_p1 0 in - let del2 = List.nth delegates_p1 1 in + let del1 = Option.get @@ List.nth delegates_p1 0 in + let del2 = Option.get @@ List.nth delegates_p1 1 in let props = List.map (fun i -> protos.(i)) (2 -- Constants.max_proposals_per_delegate) in @@ -270,7 +270,11 @@ let test_successful_vote num_delegates () = Context.Vote.get_proposals (B b) >>=? fun ps -> (* correctly count the double proposal for zero *) - (let weight = Int32.add (List.nth rolls_p1 0) (List.nth rolls_p1 1) in + (let weight = + Int32.add + (Option.get @@ List.nth rolls_p1 0) + (Option.get @@ List.nth rolls_p1 1) + in match Environment.Protocol_hash.(Map.find_opt zero ps) with | Some v -> if v = weight then return_unit @@ -331,7 +335,7 @@ let test_successful_vote num_delegates () = failwith "%s - Missing proposal" __LOC__) >>=? fun () -> (* unanimous vote: all delegates --active when p2 started-- vote *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) delegates_p2 >>=? fun operations -> @@ -367,7 +371,7 @@ let test_successful_vote num_delegates () = | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ | l -> - iter_s + List.iter_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -430,7 +434,7 @@ let test_successful_vote num_delegates () = failwith "%s - Missing proposal" __LOC__) >>=? fun () -> (* unanimous vote: all delegates --active when p4 started-- vote *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) delegates_p4 >>=? fun operations -> @@ -455,7 +459,7 @@ let test_successful_vote num_delegates () = | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ | l -> - iter_s + List.iter_es (fun delegate -> Context.Contract.pkh delegate >>=? fun pkh -> @@ -542,7 +546,7 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = let open Alpha_context in assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -564,12 +568,12 @@ let test_not_enough_quorum_in_testing_vote num_delegates () = get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2 participation_ema |> fun voters -> (* take the first two voters out so there cannot be quorum *) - let voters_without_quorum = List.tl voters in + let voters_without_quorum = Option.get @@ List.tl voters in get_rolls b voters_without_quorum __LOC__ >>=? fun voters_rolls_in_testing_vote -> (* all voters_without_quorum vote, for yays; no nays, so supermajority is satisfied *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters_without_quorum >>=? fun operations -> @@ -604,7 +608,7 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = >>=? fun (b, delegates) -> assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -626,7 +630,9 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = let open Alpha_context in (* all voters vote, for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters + List.map_es + (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) + voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -655,12 +661,12 @@ let test_not_enough_quorum_in_promotion_vote num_delegates () = get_smallest_prefix_voters_for_quorum delegates_p4 rolls_p4 participation_ema |> fun voters -> (* take the first voter out so there cannot be quorum *) - let voters_without_quorum = List.tl voters in + let voters_without_quorum = Option.get @@ List.tl voters in get_rolls b voters_without_quorum __LOC__ >>=? fun voter_rolls -> (* all voters_without_quorum vote, for yays; no nays, so supermajority is satisfied *) - map_s + List.map_es (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters_without_quorum >>=? fun operations -> @@ -689,7 +695,7 @@ let test_multiple_identical_proposals_count_as_one () = >>=? fun (b, delegates) -> assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - let proposer = List.hd delegates in + let proposer = Option.get @@ List.hd delegates in Op.proposals (B b) proposer [Protocol_hash.zero; Protocol_hash.zero] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -732,29 +738,37 @@ let test_supermajority_in_proposal there_is_a_winner () = >>=? fun { parametric = {blocks_per_cycle; tokens_per_roll; blocks_per_voting_period; _}; _ } -> - let del1 = List.nth delegates 0 in - let del2 = List.nth delegates 1 in - let del3 = List.nth delegates 2 in - map_s (fun del -> Context.Contract.pkh del) [del1; del2; del3] + let del1 = Option.get @@ List.nth delegates 0 in + let del2 = Option.get @@ List.nth delegates 1 in + let del3 = Option.get @@ List.nth delegates 2 in + List.map_es (fun del -> Context.Contract.pkh del) [del1; del2; del3] >>=? fun pkhs -> let policy = Block.Excluding pkhs in - Op.transaction (B b) (List.nth delegates 3) del1 tokens_per_roll + Op.transaction + (B b) + (Option.get @@ List.nth delegates 3) + del1 + tokens_per_roll >>=? fun op1 -> - Op.transaction (B b) (List.nth delegates 4) del2 tokens_per_roll + Op.transaction + (B b) + (Option.get @@ List.nth delegates 4) + del2 + tokens_per_roll >>=? fun op2 -> ( if there_is_a_winner then Test_tez.Tez.( *? ) tokens_per_roll 3L else Test_tez.Tez.( *? ) tokens_per_roll 2L ) >>?= fun bal3 -> - Op.transaction (B b) (List.nth delegates 5) del3 bal3 + Op.transaction (B b) (Option.get @@ List.nth delegates 5) del3 bal3 >>=? fun op3 -> Block.bake ~policy ~operations:[op1; op2; op3] b >>=? fun b -> (* we let one voting period pass; we make sure that: - the three selected delegates remain active by re-registering as delegates - their number of rolls do not change *) - fold_left_s + List.fold_left_es (fun b _ -> - Error_monad.map_s + List.map_es (fun del -> Context.Contract.pkh del >>=? fun pkh -> Op.delegation (B b) del (Some pkh)) @@ -795,9 +809,9 @@ let test_quorum_in_proposal has_quorum () = blocks_per_voting_period; _ }; _ } -> - let del1 = List.nth delegates 0 in - let del2 = List.nth delegates 1 in - map_s (fun del -> Context.Contract.pkh del) [del1; del2] + let del1 = Option.get @@ List.nth delegates 0 in + let del2 = Option.get @@ List.nth delegates 1 in + List.map_es (fun del -> Context.Contract.pkh del) [del1; del2] >>=? fun pkhs -> let policy = Block.Excluding pkhs in let quorum = @@ -814,9 +828,9 @@ let test_quorum_in_proposal has_quorum () = (* we let one voting period pass; we make sure that: - the two selected delegates remain active by re-registering as delegates - their number of rolls do not change *) - fold_left_s + List.fold_left_es (fun b _ -> - Error_monad.map_s + List.map_es (fun del -> Context.Contract.pkh del >>=? fun pkh -> Op.delegation (B b) del (Some pkh)) @@ -844,7 +858,7 @@ let test_supermajority_in_testing_vote supermajority () = let min_proposal_quorum = Int32.(of_int @@ (100_00 / 100)) in Context.init ~min_proposal_quorum 100 >>=? fun (b, delegates) -> - let del1 = List.nth delegates 0 in + let del1 = Option.get @@ List.nth delegates 0 in let proposal = protos.(0) in Op.proposals (B b) del1 [proposal] >>=? fun ops1 -> @@ -879,9 +893,9 @@ let test_supermajority_in_testing_vote supermajority () = let open Alpha_context in let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in let (yays_delegates, _) = List.split_n num_yays rest in - map_s (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates + List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates >>=? fun operations_yays -> - map_s (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates + List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates >>=? fun operations_nays -> let operations = operations_yays @ operations_nays in Block.bake ~operations b @@ -906,7 +920,7 @@ let test_no_winning_proposal num_delegates () = List.map (fun i -> protos.(i)) (1 -- Constants.max_proposals_per_delegate) in (* all delegates active in p1 propose the same proposals *) - map_s (fun del -> Op.proposals (B b) del props) delegates_p1 + List.map_es (fun del -> Op.proposals (B b) del props) delegates_p1 >>=? fun ops_list -> Block.bake ~operations:ops_list b >>=? fun b -> @@ -934,7 +948,7 @@ let test_quorum_capped_maximum num_delegates () = >>=? fun () -> (* propose a new protocol *) let protocol = Protocol_hash.zero in - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [protocol] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -954,7 +968,7 @@ let test_quorum_capped_maximum num_delegates () = in let voters = List.take_n minimum_to_pass delegates in (* all voters vote for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -982,7 +996,7 @@ let test_quorum_capped_minimum num_delegates () = >>=? fun () -> (* propose a new protocol *) let protocol = Protocol_hash.zero in - let proposer = List.nth delegates 0 in + let proposer = Option.get @@ List.nth delegates 0 in Op.proposals (B b) proposer [protocol] >>=? fun ops -> Block.bake ~operations:[ops] b @@ -1002,7 +1016,7 @@ let test_quorum_capped_minimum num_delegates () = in let voters = List.take_n minimum_to_pass delegates in (* all voters vote for yays; no nays, so supermajority is satisfied *) - map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters + List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters >>=? fun operations -> Block.bake ~operations b >>=? fun b -> @@ -1028,9 +1042,9 @@ let test_voting_power_updated_each_voting_period () = ~initial_balances:[80_000_000_000L; 48_000_000_000L; 4_000_000_000_000L] 3 >>=? fun (block, contracts) -> - let con1 = List.nth contracts 0 in - let con2 = List.nth contracts 1 in - let con3 = List.nth contracts 2 in + let con1 = Option.get @@ List.nth contracts 0 in + let con2 = Option.get @@ List.nth contracts 1 in + let con3 = Option.get @@ List.nth contracts 2 in (* Retrieve balance of con1 *) Context.Contract.balance (B block) con1 >>=? fun balance1 -> @@ -1051,9 +1065,9 @@ let test_voting_power_updated_each_voting_period () = Context.get_bakers (B block) >>=? fun bakers -> (* [Context.init] and [Context.get_bakers] store the accounts in reversed orders *) - let baker1 = List.nth bakers 2 in - let baker2 = List.nth bakers 1 in - let baker3 = List.nth bakers 0 in + let baker1 = Option.get @@ List.nth bakers 2 in + let baker2 = Option.get @@ List.nth bakers 1 in + let baker3 = Option.get @@ List.nth bakers 0 in (* Auxiliary assert_voting_power *) let assert_voting_power ~loc n block baker = get_voting_power block baker diff --git a/src/proto_demo_counter/lib_client/client_proto_commands.ml b/src/proto_demo_counter/lib_client/client_proto_commands.ml index 756e94c26159aec8b2bd151f1a1b1577cf63bf05..524b0bc3504f2de709723f551b48398e198f261f 100644 --- a/src/proto_demo_counter/lib_client/client_proto_commands.ml +++ b/src/proto_demo_counter/lib_client/client_proto_commands.ml @@ -45,7 +45,7 @@ let bake (cctxt : Protocol_client_context.full) message : unit tzresult Lwt.t = let header_encoded = Data_encoding.Binary.to_bytes_exn Block_header.encoding header in - let preapply_result = List.hd preapply_result in + let preapply_result = Option.get @@ List.hd preapply_result in let operations = [List.map snd preapply_result.applied] in Shell_services.Injection.block cctxt header_encoded operations >>=? fun block_hash ->