From 0448a8d37af1f7f82ad1edf0d36f9beffd50773e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 4 Jun 2020 09:15:09 +0100 Subject: [PATCH 1/5] Error_monad: update the old operator to regular naming scheme --- src/bin_client/main_client.ml | 2 +- src/lib_clic/clic.ml | 20 +++++++++---------- src/lib_client_base/client_keys.ml | 2 +- src/lib_error_monad/monad_maker.ml | 2 +- src/lib_error_monad/sig.ml | 6 +----- .../environment_V0.ml | 2 ++ src/lib_shell/bench/bench_tool.ml | 4 ++-- src/lib_signer_backends/unix/with_ledger.ml | 4 ++-- src/lib_storage/context_dump.ml | 6 +++--- .../lib_client/client_proto_context.ml | 2 +- .../lib_client/client_proto_context.ml | 2 +- .../lib_client/client_proto_context.ml | 2 +- .../lib_protocol/test/helpers/assert.ml | 2 +- .../lib_protocol/test/helpers/block.ml | 4 ++-- .../lib_client/client_proto_context.ml | 2 +- .../lib_protocol/test/helpers/assert.ml | 2 +- .../lib_protocol/test/helpers/block.ml | 4 ++-- 17 files changed, 33 insertions(+), 35 deletions(-) diff --git a/src/bin_client/main_client.ml b/src/bin_client/main_client.ml index 32c5fc0fa254..14c29a94a569 100644 --- a/src/bin_client/main_client.ml +++ b/src/bin_client/main_client.ml @@ -151,7 +151,7 @@ let select_commands ctxt {chain; block; protocol; _} = check_network ctxt >>= fun network -> get_commands_for_version ctxt network chain block protocol - >>|? fun (_, commands_for_version) -> + >|=? fun (_, commands_for_version) -> Client_rpc_commands.commands @ Tezos_signer_backends_unix.Ledger.commands () @ Client_keys_commands.commands network diff --git a/src/lib_clic/clic.ml b/src/lib_clic/clic.ml index e717ca18d919..20ec7206631b 100644 --- a/src/lib_clic/clic.ml +++ b/src/lib_clic/clic.ml @@ -55,7 +55,7 @@ let compose_parameters {converter = c1; autocomplete = a1'} } let map_parameter ~f {converter; autocomplete} = - {converter = (fun ctx s -> converter ctx s >>|? f); autocomplete} + {converter = (fun ctx s -> converter ctx s >|=? f); autocomplete} type label = {long : string; short : char option} @@ -846,7 +846,7 @@ let parse_arg : return_none | Some [s] -> trace (Bad_option_argument ("--" ^ long, command)) (converter ctx s) - >>|? fun x -> Some x + >|=? fun x -> Some x | Some (_ :: _) -> fail (Multiple_occurrences ("--" ^ long, command)) ) | DefArg {label = {long; short = _}; kind = {converter; _}; default; _} -> ( @@ -895,7 +895,7 @@ let rec parse_args : | AddArg (arg, rest) -> parse_arg ?command arg args_dict ctx >>=? fun arg -> - parse_args ?command rest args_dict ctx >>|? fun rest -> (arg, rest) + parse_args ?command rest args_dict ctx >|=? fun rest -> (arg, rest) let empty_args_dict = TzString.Map.empty @@ -1024,7 +1024,7 @@ let make_args_dict_filter ?command spec args = (make_arities_dict spec TzString.Map.empty) (TzString.Map.empty, []) args - >>|? fun (dict, remaining) -> (dict, List.rev remaining) + >|=? fun (dict, remaining) -> (dict, List.rev remaining) let ( >> ) arg1 arg2 = AddArg (arg1, arg2) @@ -1732,7 +1732,7 @@ let find_command tree initial_arguments = then fail (Help (Some command)) else make_args_dict_filter ~command spec remaining - >>|? fun (dict, remaining) -> + >|=? fun (dict, remaining) -> (command, dict, List.rev_append acc remaining) | (TPrefix {stop = Some cmd; _}, []) -> return (cmd, empty_args_dict, initial_arguments) @@ -1830,7 +1830,7 @@ let complete_options (type ctx) continuation args args_spec ind (ctx : ctx) = match args with | _ when ind = 0 -> continuation args 0 - >>|? fun cont_args -> cont_args @ remaining_spec seen args_spec + >|=? fun cont_args -> cont_args @ remaining_spec seen args_spec | [] -> Stdlib.failwith "cli_entries internal autocomplete error" | arg :: tl -> @@ -1840,7 +1840,7 @@ let complete_options (type ctx) continuation args args_spec ind (ctx : ctx) = match (arity, tl) with | (0, args) when ind = 0 -> continuation args 0 - >>|? fun cont_args -> remaining_spec seen args_spec @ cont_args + >|=? fun cont_args -> remaining_spec seen args_spec @ cont_args | (0, args) -> help args (ind - 1) seen | (1, _) when ind = 1 -> @@ -1864,7 +1864,7 @@ let complete_next_tree cctxt = function @ List.map fst prefix ) | TSeq (command, autocomplete) -> complete_func autocomplete cctxt - >>|? fun completions -> completions @ list_command_args command + >|=? fun completions -> completions @ list_command_args command | TParam {autocomplete; _} -> complete_func autocomplete cctxt | TStop command -> @@ -1904,7 +1904,7 @@ let autocompletion ~script ~cur_arg ~prev_arg ~args ~global_options commands in ( if prev_arg = script then complete_next_tree cctxt tree - >>|? fun command_completions -> + >|=? fun command_completions -> let (Argument {spec; _}) = global_options in list_args spec @ command_completions else @@ -1919,7 +1919,7 @@ let autocompletion ~script ~cur_arg ~prev_arg ~args ~global_options commands spec index cctxt ) - >>|? fun completions -> + >|=? fun completions -> List.filter (fun completion -> Re.Str.(string_match (regexp_string cur_arg) completion 0)) diff --git a/src/lib_client_base/client_keys.ml b/src/lib_client_base/client_keys.ml index 65cc823287a6..2004b0f24963 100644 --- a/src/lib_client_base/client_keys.ml +++ b/src/lib_client_base/client_keys.ml @@ -288,7 +288,7 @@ let sign cctxt ?watermark sk_uri buf = let append cctxt ?watermark loc buf = sign cctxt ?watermark loc buf - >>|? fun signature -> Signature.concat buf signature + >|=? fun signature -> Signature.concat buf signature let check ?watermark pk_uri signature buf = public_key pk_uri diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index d0f4a5ed1cde..0e1052e01154 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -126,7 +126,7 @@ struct let ( >|?= ) v f = match v with Error _ as e -> Lwt.return e | Ok v -> f v >>= Lwt.return_ok - let ( >>|? ) v f = v >>=? fun v -> Lwt.return_ok (f v) + let ( >|=? ) v f = v >>=? fun v -> Lwt.return_ok (f v) let ( >|= ) = Lwt.( >|= ) diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index 0eb0e5685512..c60d3f882e88 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -223,10 +223,6 @@ module type MONAD = sig - the next character is [=] for Lwt or [?] for Error - the next character (if present) is [=] for Lwt or [?] for Error, it is only used for operator that are within both monads. - - There is an exception to this pattern: [>>|?]. It is a combined map - operator and it should be [>|=?] according to the pattern. This is kept - as-is for backwards compatibility. *) (** Lwt's bind reexported. Following Lwt's convention, in this operator and @@ -249,7 +245,7 @@ module type MONAD = sig 'a tzresult Lwt.t -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t (** Combined map operator. *) - val ( >>|? ) : 'a tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t + val ( >|=? ) : 'a tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t (** Injecting bind operator. This is for transitioning from the simple Error monad to the combined Error-Lwt monad. diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index dc9cffd533d4..23136f2315e4 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -538,6 +538,8 @@ struct include Error_core include Tezos_error_monad.Monad_maker.Make (Error_core) + + let ( >>|? ) = ( >|=? ) (* for backward compatibility *) end let () = diff --git a/src/lib_shell/bench/bench_tool.ml b/src/lib_shell/bench/bench_tool.ml index 36b58bb379ec..52ea0dfbf8a1 100644 --- a/src/lib_shell/bench/bench_tool.ml +++ b/src/lib_shell/bench/bench_tool.ml @@ -243,7 +243,7 @@ let step gen_state blk : Block.t tzresult Lwt.t = in (* Nonce *) Alpha_services.Helpers.current_level ~offset:1l Block.rpc_ctxt blk - >>|? (function + >|=? (function | Level.{expected_commitment = true; cycle; level; _} -> if_debug (fun () -> Format.printf "[DEBUG] Committing a nonce\n%!") ; @@ -277,7 +277,7 @@ let step gen_state blk : Block.t tzresult Lwt.t = (* Revelations *) (* TODO debug cycle *) Alpha_services.Helpers.current_level ~offset:1l Incremental.rpc_ctxt inc - >>|? (function + >|=? (function | {cycle; level; _} -> ( if_debug (fun () -> Format.printf "[DEBUG] Current cycle : %a\n%!" Cycle.pp cycle) ; diff --git a/src/lib_signer_backends/unix/with_ledger.ml b/src/lib_signer_backends/unix/with_ledger.ml index 0fdd1212ceef..e0036acae38f 100644 --- a/src/lib_signer_backends/unix/with_ledger.ml +++ b/src/lib_signer_backends/unix/with_ledger.ml @@ -179,7 +179,7 @@ module Ledger_commands = struct ~main_chain_id ~main_hwm ~test_hwm) ) - >>|? fun pk -> + >|=? fun pk -> match curve with | Ed25519 | Bip32_ed25519 -> let pk = Cstruct.to_bytes pk in @@ -239,7 +239,7 @@ module Ledger_commands = struct let open Ledgerwallet_tezos.Version in if version.major < 2 then wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_authorized_key ~pp hid) - >>|? fun path -> `Legacy_path path + >|=? fun path -> `Legacy_path path else wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_authorized_path_and_curve ~pp hid) diff --git a/src/lib_storage/context_dump.ml b/src/lib_storage/context_dump.ml index a2d853369d19..32656ded1b59 100644 --- a/src/lib_storage/context_dump.ml +++ b/src/lib_storage/context_dump.ml @@ -455,7 +455,7 @@ module Make (I : Dump_interface) = struct Buffer.add_bytes buf b let get_mbytes rbuf = - get_int64 rbuf >>|? Int64.to_int + get_int64 rbuf >|=? Int64.to_int >>=? fun l -> let b = Bytes.create l in read_mbytes rbuf b >>=? fun () -> return b @@ -464,7 +464,7 @@ module Make (I : Dump_interface) = struct let get_command rbuf = get_mbytes rbuf - >>|? fun bytes -> Data_encoding.Binary.of_bytes_exn command_encoding bytes + >|=? fun bytes -> Data_encoding.Binary.of_bytes_exn command_encoding bytes let set_root buf block_header info parents block_data = let root = Root {block_header; info; parents; block_data} in @@ -523,7 +523,7 @@ module Make (I : Dump_interface) = struct let read_snapshot_metadata rbuf = get_mbytes rbuf - >>|? fun bytes -> + >|=? fun bytes -> Data_encoding.(Binary.of_bytes_exn snapshot_metadata_encoding) bytes let check_version v = 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 17fbb49634b1..6471228c7b89 100644 --- a/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml +++ b/src/proto_004_Pt24m4xi/lib_client/client_proto_context.ml @@ -79,7 +79,7 @@ let list_contract_labels (cctxt : #Alpha_client_context.full) ~chain ~block = let h_b58 = Contract.to_b58check h in return (nm, h_b58, kind)) contracts - >>|? List.rev + >|=? List.rev let get_manager (cctxt : #Alpha_client_context.full) ~chain ~block source = Client_proto_contracts.get_manager cctxt ~chain ~block source 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 46b35a183099..64b5ef586c36 100644 --- a/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml +++ b/src/proto_005_PsBabyM1/lib_client/client_proto_context.ml @@ -83,7 +83,7 @@ let list_contract_labels cctxt ~chain ~block = let h_b58 = Contract.to_b58check h in return (nm, h_b58, kind)) contracts - >>|? List.rev + >|=? List.rev type period_info = { current_period_kind : Voting_period.kind; 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 ece0796c6f12..6d47e8b8d074 100644 --- a/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml +++ b/src/proto_006_PsCARTHA/lib_client/client_proto_context.ml @@ -191,7 +191,7 @@ let list_contract_labels cctxt ~chain ~block = let h_b58 = Contract.to_b58check h in return (nm, h_b58, kind)) contracts - >>|? List.rev + >|=? List.rev let message_added_contract (cctxt : #full) name = cctxt#message "Contract memorized as %s." name diff --git a/src/proto_006_PsCARTHA/lib_protocol/test/helpers/assert.ml b/src/proto_006_PsCARTHA/lib_protocol/test/helpers/assert.ml index b36644df4fdd..56d92a515860 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/helpers/assert.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/helpers/assert.ml @@ -123,7 +123,7 @@ let print_balances ctxt id = Contract.balance ~kind:Fees ctxt id >>=? fun fees -> Contract.balance ~kind:Rewards ctxt id - >>|? fun rewards -> + >|=? fun rewards -> Format.printf "\nMain: %s\nDeposit: %s\nFees: %s\nRewards: %s\n" (Alpha_context.Tez.to_string main) 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 11de707be243..f66c04e03ba3 100644 --- a/src/proto_006_PsCARTHA/lib_protocol/test/helpers/block.ml +++ b/src/proto_006_PsCARTHA/lib_protocol/test/helpers/block.ml @@ -196,7 +196,7 @@ module Forge = struct assert false ) >>=? fun fitness -> Alpha_services.Helpers.current_level ~offset:1l rpc_ctxt pred - >>|? (function + >|=? (function | {expected_commitment = true; _} -> Some (fst (Proto_Nonce.generate ())) | {expected_commitment = false; _} -> @@ -392,7 +392,7 @@ let apply header ?(operations = []) pred = Main.finalize_block vstate >>=? fun (validation, _result) -> return validation.context) >|= Environment.wrap_error - >>|? fun context -> + >|=? fun context -> let hash = Block_header.hash header in {hash; header; operations; context} diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index ece0796c6f12..6d47e8b8d074 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -191,7 +191,7 @@ let list_contract_labels cctxt ~chain ~block = let h_b58 = Contract.to_b58check h in return (nm, h_b58, kind)) contracts - >>|? List.rev + >|=? List.rev let message_added_contract (cctxt : #full) name = cctxt#message "Contract memorized as %s." name diff --git a/src/proto_alpha/lib_protocol/test/helpers/assert.ml b/src/proto_alpha/lib_protocol/test/helpers/assert.ml index b36644df4fdd..56d92a515860 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/assert.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/assert.ml @@ -123,7 +123,7 @@ let print_balances ctxt id = Contract.balance ~kind:Fees ctxt id >>=? fun fees -> Contract.balance ~kind:Rewards ctxt id - >>|? fun rewards -> + >|=? fun rewards -> Format.printf "\nMain: %s\nDeposit: %s\nFees: %s\nRewards: %s\n" (Alpha_context.Tez.to_string main) diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index b64a4fc6910e..77c79e43848f 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -196,7 +196,7 @@ module Forge = struct assert false ) >>=? fun fitness -> Alpha_services.Helpers.current_level ~offset:1l rpc_ctxt pred - >>|? (function + >|=? (function | {expected_commitment = true; _} -> Some (fst (Proto_Nonce.generate ())) | {expected_commitment = false; _} -> @@ -392,7 +392,7 @@ let apply header ?(operations = []) pred = Main.finalize_block vstate >>=? fun (validation, _result) -> return validation.context) >|= Environment.wrap_error - >>|? fun context -> + >|=? fun context -> let hash = Block_header.hash header in {hash; header; operations; context} -- GitLab From 5da141479404395f4aa28470e11b39080578ebd5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 15 Jun 2020 11:45:08 +0100 Subject: [PATCH 2/5] Error_monad: variants for parallel combinators {join,all,both}_{e,p,ep} --- src/lib_error_monad/monad_maker.ml | 44 ++++++++++++++++++++++++------ src/lib_error_monad/sig.ml | 23 ++++++++++++++-- src/lib_p2p/test/process.ml | 8 +++--- 3 files changed, 60 insertions(+), 15 deletions(-) diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index 0e1052e01154..e7493d06483d 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -412,16 +412,42 @@ struct | h :: t -> fold_right_s f t init >>=? fun acc -> f h acc - let rec join = function + let join_p = Lwt.join + + let all_p = Lwt.all + + let both_p = Lwt.both + + let rec join_e = function | [] -> - return_unit - | t :: ts -> ( - t - >>= function - | Error _ as err -> - join ts >>=? fun () -> Lwt.return err - | Ok () -> - join ts ) + ok_unit + | t :: ts -> + t >>? fun () -> join_e ts + + let all_e ts = + let rec aux acc = function + | [] -> + Ok (List.rev acc) + | t :: ts -> + t >>? fun v -> aux (v :: acc) ts + in + aux [] ts + + let both_e a b = + match (a, b) with + | (Ok a, Ok b) -> + Ok (a, b) + | (Error err, Ok _) | (Ok _, Error err) -> + Error err + | (Error erra, Error errb) -> + (* Improve this once we improved the support for parallel traces *) + ignore errb ; Error erra + + let join_ep ts = all_p ts >|= join_e + + let all_ep ts = all_p ts >|= all_e + + let both_ep a b = both_p a b >|= fun (a, b) -> both_e a b let record_trace err result = match result with Ok _ as res -> res | Error errs -> Error (err :: errs) diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index c60d3f882e88..33772468ef79 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -389,6 +389,25 @@ module type MONAD = sig val fold_right_s : ('a -> 'b -> 'b tzresult Lwt.t) -> 'a list -> 'b -> 'b tzresult Lwt.t - (** A {!Lwt.join} in the monad *) - val join : unit tzresult Lwt.t list -> unit tzresult Lwt.t + (** A few aliases for Lwt functions *) + val join_p : unit Lwt.t list -> unit Lwt.t + + val all_p : 'a Lwt.t list -> 'a list Lwt.t + + val both_p : 'a Lwt.t -> 'b Lwt.t -> ('a * 'b) Lwt.t + + (** Similar functions in the error monad *) + val join_e : unit tzresult list -> unit tzresult + + val all_e : 'a tzresult list -> 'a list tzresult + + val both_e : 'a tzresult -> 'b tzresult -> ('a * 'b) tzresult + + (** Similar functions in the combined monad *) + val join_ep : unit tzresult Lwt.t list -> unit tzresult Lwt.t + + val all_ep : 'a tzresult Lwt.t list -> 'a list tzresult Lwt.t + + val both_ep : + 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t end diff --git a/src/lib_p2p/test/process.ml b/src/lib_p2p/test/process.ml index 7a4bdb1d85f4..3c57ddd8a3b5 100644 --- a/src/lib_p2p/test/process.ml +++ b/src/lib_p2p/test/process.ml @@ -188,24 +188,24 @@ let wait_all processes = lwt_log_error "Early error!" >>= fun () -> List.iter Lwt.cancel remaining ; - join remaining + join_ep remaining >>= fun _ -> failwith "A process finished with error %d !" n | Some ([Exn (Signaled n)], remaining) -> lwt_log_error "Early error!" >>= fun () -> List.iter Lwt.cancel remaining ; - join remaining + join_ep remaining >>= fun _ -> failwith "A process was killed by a SIG%s !" (signal_name n) | Some ([Exn (Stopped n)], remaining) -> lwt_log_error "Early error!" >>= fun () -> List.iter Lwt.cancel remaining ; - join remaining + join_ep remaining >>= fun _ -> failwith "A process was stopped by a SIG%s !" (signal_name n) | Some (err, remaining) -> lwt_log_error "@[Unexpected error!@,%a@]" pp_print_error err >>= fun () -> List.iter Lwt.cancel remaining ; - join remaining + join_ep remaining >>= fun _ -> failwith "A process finished with an unexpected error !" -- GitLab From f5eeebeec4357851a1869a6547aa9e0b5bba1aaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 16 Jun 2020 09:23:21 +0100 Subject: [PATCH 3/5] Everywhere: minor simplifications in use of join --- src/lib_p2p/test/test_p2p_io_scheduler.ml | 2 +- src/lib_stdlib/test/test_lwt_pipe.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lib_p2p/test/test_p2p_io_scheduler.ml b/src/lib_p2p/test/test_p2p_io_scheduler.ml index 2672f7b6d84d..09d10f8e14ab 100644 --- a/src/lib_p2p/test/test_p2p_io_scheduler.ml +++ b/src/lib_p2p/test/test_p2p_io_scheduler.ml @@ -115,7 +115,7 @@ 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.join (List.map receive conns) + Lwt_list.iter_p receive conns >>= fun () -> iter_p P2p_io_scheduler.close conns >>=? fun () -> diff --git a/src/lib_stdlib/test/test_lwt_pipe.ml b/src/lib_stdlib/test/test_lwt_pipe.ml index 41c27084ae04..842c38ebceb6 100644 --- a/src/lib_stdlib/test/test_lwt_pipe.ml +++ b/src/lib_stdlib/test/test_lwt_pipe.ml @@ -42,8 +42,8 @@ let rec gen acc f = function 0 -> acc | n -> gen (f () :: acc) f (pred n) let run qsize nbp nbc p c = let q = Lwt_pipe.create ~size:(qsize, fun () -> qsize) () in let producers = gen [] (fun () -> producer q p) nbp in - let consumers = gen [] (fun () -> consumer q c) nbc in - Lwt.join producers <&> Lwt.join consumers + let consumers_and_producers = gen producers (fun () -> consumer q c) nbc in + Lwt.join consumers_and_producers let main () = let qsize = ref 10 in -- GitLab From b4d162bbe766a68670a4990462a5fc202f22f1d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 16 Jun 2020 09:45:48 +0100 Subject: [PATCH 4/5] Error_monad: add type equality constraints --- src/lib_error_monad/error_monad.mli | 2 +- src/lib_error_monad/monad.ml | 2 ++ src/lib_error_monad/monad.mli | 2 ++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index 8ab19ed755e1..780a74ac4f81 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -31,7 +31,7 @@ type error_category = | `Temporary (** Errors that may not happen in a later context *) | `Permanent (** Errors that will happen no matter the context *) ] -include Sig.CORE +include Sig.CORE with type error = Core.error include Sig.EXT with type error := error diff --git a/src/lib_error_monad/monad.ml b/src/lib_error_monad/monad.ml index f9e28edf769e..cab4df91a6d9 100644 --- a/src/lib_error_monad/monad.ml +++ b/src/lib_error_monad/monad.ml @@ -24,4 +24,6 @@ (* *) (*****************************************************************************) +type error = Core.error = .. + include Monad_maker.Make (Core) diff --git a/src/lib_error_monad/monad.mli b/src/lib_error_monad/monad.mli index 49a353ec27f9..fb5a160a980a 100644 --- a/src/lib_error_monad/monad.mli +++ b/src/lib_error_monad/monad.mli @@ -24,4 +24,6 @@ (* *) (*****************************************************************************) +type error = Core.error = .. + include Sig.MONAD with type error := Core.error -- GitLab From d7daf3f19120cf01f0fece886e3d1046f6bf19d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 16 Jun 2020 12:25:38 +0100 Subject: [PATCH 5/5] Error_monad: minor copyright/packaging changes --- src/lib_error_monad/error_monad.ml | 2 +- src/lib_error_monad/error_monad.mli | 1 + src/lib_error_monad/tezos-error-monad.opam | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index 31e23872e7e5..f103a8b3b3d9 100644 --- a/src/lib_error_monad/error_monad.ml +++ b/src/lib_error_monad/error_monad.ml @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2019 Nomadic Labs *) +(* 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"),*) diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index 780a74ac4f81..aa1a589ae8c6 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* 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"),*) diff --git a/src/lib_error_monad/tezos-error-monad.opam b/src/lib_error_monad/tezos-error-monad.opam index 53fa48272cb3..c4dba5058c08 100644 --- a/src/lib_error_monad/tezos-error-monad.opam +++ b/src/lib_error_monad/tezos-error-monad.opam @@ -8,6 +8,7 @@ license: "MIT" depends: [ "tezos-tooling" { with-test } "dune" { >= "1.11" } + "ocaml" { >= "4.07" } "tezos-stdlib" "data-encoding" { = "0.2" } "lwt" -- GitLab