From 2928d79c31d96b678afe2fdb4c99b99e71a3fe15 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 01/12] 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..7a5e890f48ca 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 backwards 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 b29f767c2844f66895d1aef9d710727a1e5c0e48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 14 May 2020 14:06:14 +0100 Subject: [PATCH 02/12] Lwtreslib: lwt- and error-monad-aware replacements for stdlib bits --- .gitlab-ci.yml | 5 + src/lib_error_monad/error_monad.ml | 10 +- src/lib_error_monad/error_monad.mli | 5 + src/lib_error_monad/monad_maker.ml | 63 ++++- src/lib_error_monad/sig.ml | 25 ++ src/lib_error_monad/tezos-error-monad.opam | 1 + src/lib_lwt_result_stdlib/.ocamlformat | 12 + src/lib_lwt_result_stdlib/dune | 14 + src/lib_lwt_result_stdlib/dune-project | 2 + .../functors/.ocamlformat | 12 + src/lib_lwt_result_stdlib/functors/dune | 10 + src/lib_lwt_result_stdlib/functors/map.ml | 64 +++++ src/lib_lwt_result_stdlib/functors/map.mli | 30 +++ src/lib_lwt_result_stdlib/functors/seq.ml | 244 +++++++++++++++++ src/lib_lwt_result_stdlib/functors/seq.mli | 27 ++ src/lib_lwt_result_stdlib/functors/set.ml | 61 +++++ src/lib_lwt_result_stdlib/functors/set.mli | 30 +++ src/lib_lwt_result_stdlib/lib/.ocamlformat | 12 + src/lib_lwt_result_stdlib/lib/dune | 13 + src/lib_lwt_result_stdlib/lib/map.ml | 26 ++ src/lib_lwt_result_stdlib/lib/map.mli | 29 +++ src/lib_lwt_result_stdlib/lib/seq.ml | 26 ++ src/lib_lwt_result_stdlib/lib/seq.mli | 26 ++ src/lib_lwt_result_stdlib/lib/set.ml | 26 ++ src/lib_lwt_result_stdlib/lib/set.mli | 29 +++ src/lib_lwt_result_stdlib/lwtreslib.ml | 28 ++ src/lib_lwt_result_stdlib/lwtreslib.mli | 30 +++ src/lib_lwt_result_stdlib/sigs/.ocamlformat | 12 + src/lib_lwt_result_stdlib/sigs/dune | 10 + src/lib_lwt_result_stdlib/sigs/map.ml | 136 ++++++++++ src/lib_lwt_result_stdlib/sigs/seq.ml | 245 ++++++++++++++++++ src/lib_lwt_result_stdlib/sigs/set.ml | 117 +++++++++ .../tezos-lwt-result-stdlib.opam | 19 ++ 33 files changed, 1388 insertions(+), 11 deletions(-) create mode 100644 src/lib_lwt_result_stdlib/.ocamlformat create mode 100644 src/lib_lwt_result_stdlib/dune create mode 100644 src/lib_lwt_result_stdlib/dune-project create mode 100644 src/lib_lwt_result_stdlib/functors/.ocamlformat create mode 100644 src/lib_lwt_result_stdlib/functors/dune create mode 100644 src/lib_lwt_result_stdlib/functors/map.ml create mode 100644 src/lib_lwt_result_stdlib/functors/map.mli create mode 100644 src/lib_lwt_result_stdlib/functors/seq.ml create mode 100644 src/lib_lwt_result_stdlib/functors/seq.mli create mode 100644 src/lib_lwt_result_stdlib/functors/set.ml create mode 100644 src/lib_lwt_result_stdlib/functors/set.mli create mode 100644 src/lib_lwt_result_stdlib/lib/.ocamlformat create mode 100644 src/lib_lwt_result_stdlib/lib/dune create mode 100644 src/lib_lwt_result_stdlib/lib/map.ml create mode 100644 src/lib_lwt_result_stdlib/lib/map.mli create mode 100644 src/lib_lwt_result_stdlib/lib/seq.ml create mode 100644 src/lib_lwt_result_stdlib/lib/seq.mli create mode 100644 src/lib_lwt_result_stdlib/lib/set.ml create mode 100644 src/lib_lwt_result_stdlib/lib/set.mli create mode 100644 src/lib_lwt_result_stdlib/lwtreslib.ml create mode 100644 src/lib_lwt_result_stdlib/lwtreslib.mli create mode 100644 src/lib_lwt_result_stdlib/sigs/.ocamlformat create mode 100644 src/lib_lwt_result_stdlib/sigs/dune create mode 100644 src/lib_lwt_result_stdlib/sigs/map.ml create mode 100644 src/lib_lwt_result_stdlib/sigs/seq.ml create mode 100644 src/lib_lwt_result_stdlib/sigs/set.ml create mode 100644 src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index abcd9585ca23..7724d826d576 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -886,6 +886,11 @@ opam:tezos-lmdb: variables: package: tezos-lmdb +opam:tezos-lwt-result-stdlib: + <<: *opam_definition + variables: + package: tezos-lwt-result-stdlib + opam:tezos-mempool-006-PsCARTHA: <<: *opam_definition variables: diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index 31e23872e7e5..e6fd1df813ea 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"),*) @@ -30,7 +30,15 @@ type error_category = [`Branch | `Temporary | `Permanent] +module Core = Core include Core + +module Monad = struct + type error = Core.error = .. + + include Monad +end + include Monad module Make (Prefix : Sig.PREFIX) : sig diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index 8ab19ed755e1..6325b6707c6c 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"),*) @@ -33,10 +34,14 @@ type error_category = include Sig.CORE +module Core : Sig.CORE with type error = error + include Sig.EXT with type error := error include Sig.WITH_WRAPPED with type error := error +module Monad : Sig.MONAD with type error = Core.error + include Sig.MONAD with type error := error (** Erroneous result (shortcut for generic errors) *) diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index 0e1052e01154..26fb20de5dee 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -405,6 +405,31 @@ struct | h :: t -> f init h >>=? fun acc -> fold_left_s f acc t + let rec fold_left f init l = + match l with + | [] -> + ok init + | h :: t -> + f init h >>? fun acc -> fold_left f acc t + + let rec fold_left2_s ~if_diff_length f init xs ys = + match (xs, ys) with + | ([], []) -> + return init + | ([], _ :: _) | (_ :: _, []) -> + if_diff_length + | (x :: xs, y :: ys) -> + f init x y >>=? fun acc -> fold_left2_s ~if_diff_length f acc xs ys + + let rec fold_left2 ~if_diff_length f init xs ys = + match (xs, ys) with + | ([], []) -> + ok init + | ([], _ :: _) | (_ :: _, []) -> + if_diff_length + | (x :: xs, y :: ys) -> + f init x y >>? fun acc -> fold_left2 ~if_diff_length f acc xs ys + let rec fold_right_s f l init = match l with | [] -> @@ -412,16 +437,34 @@ struct | h :: t -> fold_right_s f t init >>=? fun acc -> f h acc - let rec join = function - | [] -> - return_unit - | t :: ts -> ( - t - >>= function - | Error _ as err -> - join ts >>=? fun () -> Lwt.return err - | Ok () -> - join ts ) + let join ts = + let rec aux = function + | [] -> + ok_unit + | t :: ts -> + t >>? fun () -> aux ts + in + Lwt.all ts >|= aux + + let all ts = + let rec aux acc = function + | [] -> + Ok (List.rev acc) + | t :: ts -> + t >>? fun v -> aux (v :: acc) ts + in + Lwt.all ts >|= aux [] + + let both a b = + Lwt.both a b + >|= function + | (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 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..18ebd4f2b831 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -385,10 +385,35 @@ module type MONAD = sig val fold_left_s : ('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b list -> 'a tzresult Lwt.t + val fold_left : ('a -> 'b -> 'a tzresult) -> 'a -> 'b list -> 'a tzresult + + (** Folding over two lists, if the lists are of different length then + [if_diff_length], which is meant to be [Error _] with a locally + appropriate error, is returned. *) + val fold_left2_s : + if_diff_length:'a tzresult Lwt.t -> + ('a -> 'b -> 'c -> 'a tzresult Lwt.t) -> + 'a -> + 'b list -> + 'c list -> + 'a tzresult Lwt.t + + val fold_left2 : + if_diff_length:'a tzresult -> + ('a -> 'b -> 'c -> 'a tzresult) -> + 'a -> + 'b list -> + 'c list -> + 'a tzresult + (** A {!List.fold_right} in the monad *) 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 + + val all : 'a tzresult Lwt.t list -> 'a list tzresult Lwt.t + + val both : 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t end 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" diff --git a/src/lib_lwt_result_stdlib/.ocamlformat b/src/lib_lwt_result_stdlib/.ocamlformat new file mode 100644 index 000000000000..8278a132e3d6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_lwt_result_stdlib/dune b/src/lib_lwt_result_stdlib/dune new file mode 100644 index 000000000000..bf5ef425ad83 --- /dev/null +++ b/src/lib_lwt_result_stdlib/dune @@ -0,0 +1,14 @@ +(library + (name tezos_lwt_result_stdlib) + (public_name tezos-lwt-result-stdlib) + (flags (:standard -open Tezos_error_monad)) + (libraries tezos-error-monad + lwt + tezos-lwt-result-stdlib.sigs + tezos-lwt-result-stdlib.functors + tezos-lwt-result-stdlib.lib)) + +(alias + (name runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/dune-project b/src/lib_lwt_result_stdlib/dune-project new file mode 100644 index 000000000000..f139b54d6093 --- /dev/null +++ b/src/lib_lwt_result_stdlib/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name tezos-lwt-result-stdlib) diff --git a/src/lib_lwt_result_stdlib/functors/.ocamlformat b/src/lib_lwt_result_stdlib/functors/.ocamlformat new file mode 100644 index 000000000000..8278a132e3d6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_lwt_result_stdlib/functors/dune b/src/lib_lwt_result_stdlib/functors/dune new file mode 100644 index 000000000000..470c866c324a --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/dune @@ -0,0 +1,10 @@ +(library + (name functors) + (public_name tezos-lwt-result-stdlib.functors) + (flags (:standard -open Tezos_error_monad)) + (libraries tezos-error-monad lwt tezos-lwt-result-stdlib.sigs)) + +(alias + (name runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/functors/map.ml b/src/lib_lwt_result_stdlib/functors/map.ml new file mode 100644 index 000000000000..c9133163e8db --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/map.ml @@ -0,0 +1,64 @@ +(*****************************************************************************) +(* *) +(* 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 (Seq : Sigs.Seq.S) = struct + module type S = Sigs.Map.S with type 'a tzresult := 'a Seq.Monad.tzresult + + module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t = struct + open Seq + include Stdlib.Map.Make (Ord) + + let iter_e f t = iter_e (fun (k, v) -> f k v) (to_seq t) + + let iter_s f t = iter_s (fun (k, v) -> f k v) (to_seq t) + + let iter_es f t = iter_es (fun (k, v) -> f k v) (to_seq t) + + let iter_p f t = iter_p (fun (k, v) -> f k v) (to_seq t) + + let iter_ep f t = iter_ep (fun (k, v) -> f k v) (to_seq t) + + let fold_e f t init = + fold_left_e (fun acc (k, v) -> f k v acc) init (to_seq t) + + let fold_s f t init = + fold_left_s (fun acc (k, v) -> f k v acc) init (to_seq t) + + let fold_es f t init = + fold_left_es (fun acc (k, v) -> f k v acc) init (to_seq t) + + let min_binding = min_binding_opt + + let max_binding = max_binding_opt + + let choose = choose_opt + + let find = find_opt + + let find_first = find_first_opt + + let find_last = find_last_opt + end +end diff --git a/src/lib_lwt_result_stdlib/functors/map.mli b/src/lib_lwt_result_stdlib/functors/map.mli new file mode 100644 index 000000000000..be1a2a1cc134 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/map.mli @@ -0,0 +1,30 @@ +(*****************************************************************************) +(* *) +(* 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 (Seq : Sigs.Seq.S) : sig + module type S = Sigs.Map.S with type 'a tzresult := 'a Seq.Monad.tzresult + + module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t +end diff --git a/src/lib_lwt_result_stdlib/functors/seq.ml b/src/lib_lwt_result_stdlib/functors/seq.ml new file mode 100644 index 000000000000..bd06fc634ba1 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/seq.ml @@ -0,0 +1,244 @@ +(*****************************************************************************) +(* *) +(* 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 : Tezos_error_monad.Sig.MONAD) : + Sigs.Seq.S with module Monad = Monad = struct + module Monad = Monad + open Monad + include Stdlib.Seq + + let ok_nil = Ok Nil + + let return_nil = Lwt.return ok_nil + + let ok_empty = Ok empty + + let return_empty = Lwt.return ok_empty + + let lwt_empty = Lwt.return empty + + let rec fold_left_e f acc seq = + match seq () with + | Nil -> + Ok acc + | Cons (item, seq) -> + f acc item >>? fun acc -> fold_left_e f acc seq + + let rec fold_left_s f acc seq = + match seq () with + | Nil -> + Lwt.return acc + | Cons (item, seq) -> + f acc item >>= fun acc -> fold_left_s f acc seq + + let rec fold_left_es f acc seq = + match seq () with + | Nil -> + Monad.return acc + | Cons (item, seq) -> + f acc item >>=? fun acc -> fold_left_es f acc seq + + let rec iter_e f seq = + match seq () with + | Nil -> + ok_unit + | Cons (item, seq) -> + f item >>? fun () -> iter_e f seq + + let rec iter_s f seq = + match seq () with + | Nil -> + Lwt.return_unit + | Cons (item, seq) -> + f item >>= fun () -> iter_s f seq + + let rec iter_es f seq = + match seq () with + | Nil -> + return_unit + | Cons (item, seq) -> + f item >>=? fun () -> iter_es f seq + + let iter_p f seq = + let rec iter_p f seq acc = + match seq () with + | Nil -> + Lwt.join acc + | Cons (item, seq) -> + iter_p f seq (f item :: acc) + in + iter_p f seq [] + + let iter_ep f seq = + let rec iter_ep f seq acc = + match seq () with + | Nil -> + join acc + | Cons (item, seq) -> + iter_ep f seq (f item :: acc) + in + iter_ep f seq [] + + let rec map_e f seq = + match seq () with + | Nil -> + ok_empty + | Cons (item, seq) -> + f item + >>? fun item -> + map_e f seq >>? fun seq -> ok (fun () -> Cons (item, seq)) + + let rec map_s f seq = + match seq () with + | Nil -> + lwt_empty + | Cons (item, seq) -> + f item + >>= fun item -> + map_s f seq >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) + + let rec map_es f seq = + match seq () with + | Nil -> + return_empty + | Cons (item, seq) -> + f item + >>=? fun item -> + map_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) + + let map_p f seq = + Lwt.all (fold_left (fun acc x -> f x :: acc) [] seq) >|= List.to_seq + + let map_ep f seq = + Monad.all (fold_left (fun acc x -> f x :: acc) [] seq) >|=? List.to_seq + + let rec filter_e f seq = + match seq () with + | Nil -> + ok_empty + | Cons (item, seq) -> ( + f item + >>? function + | false -> + filter_e f seq + | true -> + filter_e f seq >>? fun seq -> ok (fun () -> Cons (item, seq)) ) + + let rec filter_s f seq = + match seq () with + | Nil -> + lwt_empty + | Cons (item, seq) -> ( + f item + >>= function + | false -> + filter_s f seq + | true -> + filter_s f seq + >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) ) + + let rec filter_es f seq = + match seq () with + | Nil -> + return_empty + | Cons (item, seq) -> ( + f item + >>=? function + | false -> + filter_es f seq + | true -> + filter_es f seq + >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) ) + + let rec filter_map_e f seq = + match seq () with + | Nil -> + ok_empty + | Cons (item, seq) -> ( + f item + >>? function + | None -> + filter_map_e f seq + | Some item -> + filter_map_e f seq >>? fun seq -> ok (fun () -> Cons (item, seq)) ) + + let rec filter_map_s f seq = + match seq () with + | Nil -> + lwt_empty + | Cons (item, seq) -> ( + f item + >>= function + | None -> + filter_map_s f seq + | Some item -> + filter_map_s f seq + >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) ) + + let rec filter_map_es f seq = + match seq () with + | Nil -> + return_empty + | Cons (item, seq) -> ( + f item + >>=? function + | None -> + filter_map_es f seq + | Some item -> + filter_map_es f seq + >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) ) + + let rec find_first f seq = + match seq () with + | Nil -> + None + | Cons (item, seq) -> + if f item then Some item else find_first f seq + + let rec find_first_e f seq = + match seq () with + | Nil -> + ok_none + | Cons (item, seq) -> ( + f item + >>? function true -> ok_some item | false -> find_first_e f seq ) + + let rec find_first_s f seq = + match seq () with + | Nil -> + Lwt.return_none + | Cons (item, seq) -> ( + f item + >>= function + | true -> Lwt.return_some item | false -> find_first_s f seq ) + + let rec find_first_es f seq = + match seq () with + | Nil -> + return_none + | Cons (item, seq) -> ( + f item + >>=? function true -> return_some item | false -> find_first_es f seq ) +end diff --git a/src/lib_lwt_result_stdlib/functors/seq.mli b/src/lib_lwt_result_stdlib/functors/seq.mli new file mode 100644 index 000000000000..052b83234d36 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/seq.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 : Tezos_error_monad.Sig.MONAD) : + Sigs.Seq.S with module Monad = Monad diff --git a/src/lib_lwt_result_stdlib/functors/set.ml b/src/lib_lwt_result_stdlib/functors/set.ml new file mode 100644 index 000000000000..c20ea9d01857 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/set.ml @@ -0,0 +1,61 @@ +(*****************************************************************************) +(* *) +(* 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 (Seq : Sigs.Seq.S) = struct + module type S = Sigs.Set.S with type 'a tzresult := 'a Seq.Monad.tzresult + + module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t = struct + open Seq + include Stdlib.Set.Make (Ord) + + let iter_e f t = iter_e f (to_seq t) + + let iter_s f t = iter_s f (to_seq t) + + let iter_p f t = iter_p f (to_seq t) + + let iter_es f t = iter_es f (to_seq t) + + let iter_ep f t = iter_ep f (to_seq t) + + let fold_e f t init = fold_left_e (fun acc e -> f e acc) init (to_seq t) + + let fold_s f t init = fold_left_s (fun acc e -> f e acc) init (to_seq t) + + let fold_es f t init = fold_left_es (fun acc e -> f e acc) init (to_seq t) + + let min_elt = min_elt_opt + + let max_elt = max_elt_opt + + let choose = choose_opt + + let find = find_opt + + let find_first = find_first_opt + + let find_last = find_last_opt + end +end diff --git a/src/lib_lwt_result_stdlib/functors/set.mli b/src/lib_lwt_result_stdlib/functors/set.mli new file mode 100644 index 000000000000..ffec5a396af9 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/set.mli @@ -0,0 +1,30 @@ +(*****************************************************************************) +(* *) +(* 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 (Seq : Sigs.Seq.S) : sig + module type S = Sigs.Set.S with type 'a tzresult := 'a Seq.Monad.tzresult + + module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t +end diff --git a/src/lib_lwt_result_stdlib/lib/.ocamlformat b/src/lib_lwt_result_stdlib/lib/.ocamlformat new file mode 100644 index 000000000000..8278a132e3d6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_lwt_result_stdlib/lib/dune b/src/lib_lwt_result_stdlib/lib/dune new file mode 100644 index 000000000000..989575c402ca --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/dune @@ -0,0 +1,13 @@ +(library + (name lib) + (public_name tezos-lwt-result-stdlib.lib) + (flags (:standard -open Tezos_error_monad)) + (libraries tezos-error-monad + lwt + tezos-lwt-result-stdlib.sigs + tezos-lwt-result-stdlib.functors)) + +(alias + (name runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/lib/map.ml b/src/lib_lwt_result_stdlib/lib/map.ml new file mode 100644 index 000000000000..634fa4b2dc02 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/map.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.Map.Make (Seq) diff --git a/src/lib_lwt_result_stdlib/lib/map.mli b/src/lib_lwt_result_stdlib/lib/map.mli new file mode 100644 index 000000000000..275d5c8fa9f4 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/map.mli @@ -0,0 +1,29 @@ +(*****************************************************************************) +(* *) +(* 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 type S = + Sigs.Map.S with type 'a tzresult := 'a Error_monad.Monad.tzresult + +module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t diff --git a/src/lib_lwt_result_stdlib/lib/seq.ml b/src/lib_lwt_result_stdlib/lib/seq.ml new file mode 100644 index 000000000000..e41e8875114e --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/seq.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.Seq.Make (Error_monad.Monad) diff --git a/src/lib_lwt_result_stdlib/lib/seq.mli b/src/lib_lwt_result_stdlib/lib/seq.mli new file mode 100644 index 000000000000..4ee918039a36 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/seq.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.Seq.S with module Monad = Error_monad.Monad diff --git a/src/lib_lwt_result_stdlib/lib/set.ml b/src/lib_lwt_result_stdlib/lib/set.ml new file mode 100644 index 000000000000..81203765bec4 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/set.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.Set.Make (Seq) diff --git a/src/lib_lwt_result_stdlib/lib/set.mli b/src/lib_lwt_result_stdlib/lib/set.mli new file mode 100644 index 000000000000..33cfbe5f7700 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/set.mli @@ -0,0 +1,29 @@ +(*****************************************************************************) +(* *) +(* 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 type S = + Sigs.Set.S with type 'a tzresult := 'a Error_monad.Monad.tzresult + +module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t diff --git a/src/lib_lwt_result_stdlib/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml new file mode 100644 index 000000000000..7d29527fa227 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -0,0 +1,28 @@ +(*****************************************************************************) +(* *) +(* 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 Seq = Lib.Seq +module Set = Lib.Set +module Map = Lib.Map diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli new file mode 100644 index 000000000000..71771de53626 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -0,0 +1,30 @@ +(*****************************************************************************) +(* *) +(* 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 Seq : module type of Lib.Seq + +module Set : module type of Lib.Set + +module Map : module type of Lib.Map diff --git a/src/lib_lwt_result_stdlib/sigs/.ocamlformat b/src/lib_lwt_result_stdlib/sigs/.ocamlformat new file mode 100644 index 000000000000..8278a132e3d6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_lwt_result_stdlib/sigs/dune b/src/lib_lwt_result_stdlib/sigs/dune new file mode 100644 index 000000000000..20c1eb1b92c2 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/dune @@ -0,0 +1,10 @@ +(library + (name sigs) + (public_name tezos-lwt-result-stdlib.sigs) + (flags (:standard -open Tezos_error_monad)) + (libraries tezos-error-monad lwt)) + +(alias + (name runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/sigs/map.ml b/src/lib_lwt_result_stdlib/sigs/map.ml new file mode 100644 index 000000000000..f17125697f16 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/map.ml @@ -0,0 +1,136 @@ +(*****************************************************************************) +(* *) +(* 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 type S = sig + type 'a tzresult + + type key + + type +'a t + + val empty : 'a t + + val is_empty : 'a t -> bool + + val mem : key -> 'a t -> bool + + val add : key -> 'a -> 'a t -> 'a t + + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + + val singleton : key -> 'a -> 'a t + + val remove : key -> 'a t -> 'a t + + val merge : + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + + val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t + + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + + val iter : (key -> 'a -> unit) -> 'a t -> unit + + (** [iter_e f m] applies [f] to the bindings of [m] one by one in an + unspecified order. If all the applications result in [Ok ()], then the + result of the iteration is [Ok ()]. If any of the applications results in + [Error e] then the iteration stops and the result of the iteration is + [Error e]. *) + val iter_e : (key -> 'a -> unit tzresult) -> 'a t -> unit tzresult + + val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + (** [iter_es f m] applies [f] to the bindings of [m] in an unspecified order, + one after the other as the promises resolve. If all the applications + result in [Ok ()], then the result of the iteration is [Ok ()]. If any of + the applications results in [Error e] then the iteration stops and the + result of the iteration is [Error e]. *) + val iter_es : + (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + + (** [iter_ep f m] applies [f] to the bindings of [m]. All the applications are + done concurrently. If all the applications result in [Ok ()], then the + result of the iteration is [Ok ()]. If any of the applications results in + [Error e] then the result of the iteration is [Error e]. *) + val iter_ep : + (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + + (** [fold_e f m init] is + [f k1 d1 init >>? fun acc -> f k2 d2 acc >>? fun acc -> …] where [kN] is + the key bound to [dN] in [m]. *) + val fold_e : (key -> 'a -> 'b -> 'b tzresult) -> 'a t -> 'b -> 'b tzresult + + val fold_s : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t + + (** [fold_es f m init] is + [f k1 d1 init >>=? fun acc -> f k2 d2 acc >>=? fun acc -> …] where [kN] is + the key bound to [dN] in [m]. *) + val fold_es : + (key -> 'a -> 'b -> 'b tzresult Lwt.t) -> 'a t -> 'b -> 'b tzresult Lwt.t + + val for_all : (key -> 'a -> bool) -> 'a t -> bool + + val exists : (key -> 'a -> bool) -> 'a t -> bool + + val filter : (key -> 'a -> bool) -> 'a t -> 'a t + + val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + + val cardinal : 'a t -> int + + val bindings : 'a t -> (key * 'a) list + + val min_binding : 'a t -> (key * 'a) option + + val max_binding : 'a t -> (key * 'a) option + + val choose : 'a t -> (key * 'a) option + + val split : key -> 'a t -> 'a t * 'a option * 'a t + + val find : key -> 'a t -> 'a option + + val find_first : (key -> bool) -> 'a t -> (key * 'a) option + + val find_last : (key -> bool) -> 'a t -> (key * 'a) option + + val map : ('a -> 'b) -> 'a t -> 'b t + + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t + + val to_seq : 'a t -> (key * 'a) Stdlib.Seq.t + + val to_seq_from : key -> 'a t -> (key * 'a) Stdlib.Seq.t + + val add_seq : (key * 'a) Stdlib.Seq.t -> 'a t -> 'a t + + val of_seq : (key * 'a) Stdlib.Seq.t -> 'a t +end diff --git a/src/lib_lwt_result_stdlib/sigs/seq.ml b/src/lib_lwt_result_stdlib/sigs/seq.ml new file mode 100644 index 000000000000..ebd85a64b5e6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/seq.ml @@ -0,0 +1,245 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** A wrapper around {!Stdlib.Seq} that includes lwt-, error- and + lwt-error-aware traversal functions. + + All traversal functions that are suffixed with [_e] are within the error + monad. Note that this functions have a “fail-early” behaviour: the traversal + is interrupted as when any of the intermediate application fails (i.e., + returns an [Error _]). + + All traversal functions that are suffixed with [_s] are within Lwt. These + functions traverse the elements sequentially: the promise for a given step + of the traversal is only initiated when the promise for the previous step is + resolved. Note that these functions have a fail-early behaviour: the + traversal is interrupted if any of the intermediate promise is rejected. + + All the traversal functions that are suffixed with [_p] are within Lwt. + These functions traverse the elements concurrently: the promise for all the + steps are created immediately. The suffix [_p] is chosen for similarity with + the {!Lwt_list} functions even though, as with {!Lwt_list}'s functions there + is no parallelism involved, only concurrency. Note that these functions have + a “best-effort” behaviour: the whole-traversal promise (i.e., the promise + returned by the [_p]-suffixed function) only resolves once each of the step + promises have resolved. Even if one of the step promise is rejected, the + whole-traversal promise is only rejected once all the other step promises + have resolved. + + All the traversal functions that are suffixed with [_es] are within the + combined error-and-Lwt monad. These function traverse the elements + sequentially with a fail-early behaviour for both rejection (as an Lwt + promise) and failure (as a result). + + All the traversal functions that are suffixed with [_ep] are within the + combined error-and-Lwt monad. These function traverse the elements + concurrently with a best-effort behaviour. +*) +module type S = sig + module Monad : Tezos_error_monad.Sig.MONAD + + open Monad + + (** including the OCaml's {!Stdlib.Seq} module to share the {!Seq.t} type + (including concrete definition) and to bring the existing functions. *) + include + module type of Stdlib.Seq + with type 'a t = 'a Stdlib.Seq.t + and type 'a node = 'a Stdlib.Seq.node + + (** in-monad, preallocated empty/nil *) + + val ok_empty : 'a t tzresult + + val return_empty : 'a t tzresult Lwt.t + + val ok_nil : 'a node tzresult + + val return_nil : 'a node tzresult Lwt.t + + (** Similar to {!fold_left} but wraps the traversal in {!tzresult}. The + traversal is interrupted if one of the step returns an [Error _]. *) + val fold_left_e : ('a -> 'b -> 'a tzresult) -> 'a -> 'b t -> 'a tzresult + + (** Similar to {!fold_left} but wraps the traversing in {!Lwt}. Each step of + the traversal is started after the previous one has resolved. The + traversal is interrupted if one of the promise is rejected. *) + val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t + + (** Similar to {!fold_left} but wraps the traversing in {!tzresult Lwt.t}. + Each step of the traversal is started after the previous one resolved. The + traversal is interrupted if one of the step is rejected or is fulfilled + with [Error _]. *) + val fold_left_es : + ('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b t -> 'a tzresult Lwt.t + + (** Similar to {!iter} but wraps the iteration in {!tzresult}. The iteration + is interrupted if one of the step returns an [Error _]. *) + val iter_e : ('a -> unit tzresult) -> 'a t -> unit tzresult + + (** Similar to {!iter} but wraps the iteration in {!Lwt}. Each step + of the iteration is started after the previous one resolved. The iteration + is interrupted if one of the promise is rejected. *) + val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + (** Similar to {!iter} but wraps the iteration in {!tzresult Lwt.t}. Each step + of the iteration is started after the previous one resolved. The iteration + is interrupted if one of the promise is rejected of fulfilled with an + [Error _]. *) + val iter_es : ('a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + + (** Similar to {!iter} but wraps the iteration in {!Lwt}. All the + steps of the iteration are started concurrently. The promise [iter_p f s] + is resolved only once all the promises of the iteration are. At this point + it is either fulfilled if all promises are, or rejected if at least one of + them is. *) + val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + (** Similar to {!iter} but wraps the iteration in {!tzresult Lwt.t}. All the + steps of the iteration are started concurrently. The promise [iter_ep] + resolves once all the promises of the traversal resolve. At this point it + either: + - is rejected if at least one of the promises is, otherwise + - is fulfilled with [Error _] if at least one of the promises is, + otherwise + - is fulfilled with [Ok ()] if all the promises are. *) + val iter_ep : ('a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + + (** Similar to {!map} but wraps the transformation in {!tzresult}. The + traversal is interrupted if any of the application returns an [Error _]. + + Note that, unlike {!map}, [map_e] is not lazy: it applies the + transformation immediately to all the elements of the sequence (unless it + is interrupted by an [Error _]) and does not terminate on infinite + sequences (again, unless interrupted). Moreover [map_e] is not + tail-recursive. *) + val map_e : ('a -> 'b tzresult) -> 'a t -> 'b t tzresult + + (** Similar to {!map} but wraps the transformation in {!Lwt}. Each + transformation is done sequentially, only starting once the previous + one has resolved. The traversal is interrupted if any of the promise is + rejected. + + Note that, unlike {!map}, [map_s] is not lazy: it applies the + transformation eagerly to all the elements of the sequence (unless + interrupted by a rejection) and does not terminate on infinite sequences + (again, unless interrupted). Moreover [map_s] is not tail-recursive. *) + val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t + + (** Similar to {!map} but wraps the transformation in {!tzresult Lwt.t}. Each + transformation is done sequentially, only starting once the previous + one has resolved. The traversal is interrupted if any of the promise is + rejected or fulfilled with an [Error _]. + + Note that, unlike {!map}, [map_es] is not lazy: it applies the + transformation eagerly to all the elements of the sequence (unless + interrupted by rejection or an [Error _]) and does not terminate on + infinite sequences (again, unless interrupted). Moreover [map_es] is not + tail-recursive. *) + val map_es : ('a -> 'b tzresult Lwt.t) -> 'a t -> 'b t tzresult Lwt.t + + (** Similar to {!map} but wraps the transformation in {!Lwt}. All the + transformations are done concurrently. The promise [map_p f s] resolves + once all the promises of the traversal resolve. At this point it is + fulfilled if all the promises are, and it is rejected if any of them are. + + Note that, unlike {!map}, [map_p] is not lazy: it applies the + transformation eagerly to all the elements of the sequence and does not + terminate on infinite sequences. Moreover [map_p] is not tail-recursive. + *) + val map_p : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t + + (** Similar to {!map} but wraps the transformation in {!tzresult Lwt}. All the + transformations are done concurrently. The promise [map_p f s] resolves + once all the promises of the traversal resolve. At this point it is + rejected if any of the promises are, and otherwise it is resolved with + [Error _] if any of the promises are, and otherwise it is fulfilled (if + all the promises are). + + Note that, unlike {!map}, [map_ep] is not lazy: it applies the + transformation eagerly to all the elements of the sequence and does not + terminate on infinite sequences. Moreover [map_p] is not tail-recursive. + *) + val map_ep : ('a -> 'b tzresult Lwt.t) -> 'a t -> 'b t tzresult Lwt.t + + (** Similar to {!filter} but wraps the transformation in {!tzresult}. Note + that, unlike {!filter}, [filter_e] is not lazy: it applies the + transformation immediately and does not terminate on infinite sequences. + Moreover [filter_e] is not tail-recursive. *) + val filter_e : ('a -> bool tzresult) -> 'a t -> 'a t tzresult + + (** Similar to {!filter} but wraps the transformation in {!Lwt.t}. Each + test of the predicate is done sequentially, only starting once the + previous one has resolved. Note that, unlike {!filter}, [filter_s] is not + lazy: it applies the transformation immediately and does not terminate on + infinite sequences. Moreover [filter_s] is not tail-recursive. *) + val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t Lwt.t + + (** Similar to {!filter} but wraps the transformation in {!tzresult Lwt.t}. + Each test of the predicate is done sequentially, only starting once the + previous one has resolved. Note that, unlike {!filter}, [filter_es] is not + lazy: it applies the transformation immediately and does not terminate on + infinite sequences. Moreover [filter_es] is not tail-recursive. *) + val filter_es : ('a -> bool tzresult Lwt.t) -> 'a t -> 'a t tzresult Lwt.t + + (** Similar to {!filter_map} but within [tzresult]. Not lazy and not + tail-recursive. *) + val filter_map_e : ('a -> 'b option tzresult) -> 'a t -> 'b t tzresult + + (** Similar to {!filter_map} but within [Lwt.t]. Not lazy and not + tail-recursive. *) + val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t Lwt.t + + (** Similar to {!filter_map} but within [tzresult Lwt.t]. Not lazy and not + tail-recursive. *) + val filter_map_es : + ('a -> 'b option tzresult Lwt.t) -> 'a t -> 'b t tzresult Lwt.t + + (** [find_first f t] is [Some x] where [x] is the first item in [t] such that + [f x]. It is [None] if there are no such element. It does not terminate if + the sequence is infinite and the predicate is always false. *) + val find_first : ('a -> bool) -> 'a t -> 'a option + + (** [find_first_e f t] is similar to {!find_first} but wraps the search within + {!tzresult}. Specifically, [find_first_e f t] is either + - [Ok (Some x)] if forall [y] before [x] [f y = Ok false] and + [f x = Ok true], + - [Error e] if there exists [x] such that forall [y] before [x] + [f y = Ok false] and [f x = Error e], + - [Ok None] otherwise and [t] is finite, + - an expression that never returns otherwise. *) + val find_first_e : ('a -> bool tzresult) -> 'a t -> 'a option tzresult + + (** [find_first_s f t] is similar to {!find_first} but wrapped within + [Lwt.t]. The search is identical to [find_first_e] but each + predicate is applied when the previous one has resolved. *) + val find_first_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t + + (** [find_first_es f t] is similar to {!find_first} but wrapped within + [tzresult Lwt.t]. The search is identical to [find_first_e] but each + predicate is applied when the previous one has resolved. *) + val find_first_es : + ('a -> bool tzresult Lwt.t) -> 'a t -> 'a option tzresult Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/sigs/set.ml b/src/lib_lwt_result_stdlib/sigs/set.ml new file mode 100644 index 000000000000..b08bfc3fa982 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/set.ml @@ -0,0 +1,117 @@ +(*****************************************************************************) +(* *) +(* 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 type S = sig + type 'a tzresult + + type elt + + type t + + val empty : t + + val is_empty : t -> bool + + val mem : elt -> t -> bool + + val add : elt -> t -> t + + val singleton : elt -> t + + val remove : elt -> t -> t + + val union : t -> t -> t + + val inter : t -> t -> t + + val disjoint : t -> t -> bool + + val diff : t -> t -> t + + val compare : t -> t -> int + + val equal : t -> t -> bool + + val subset : t -> t -> bool + + val iter : (elt -> unit) -> t -> unit + + val iter_e : (elt -> unit tzresult) -> t -> unit tzresult + + val iter_s : (elt -> unit Lwt.t) -> t -> unit Lwt.t + + val iter_p : (elt -> unit Lwt.t) -> t -> unit Lwt.t + + val iter_es : (elt -> unit tzresult Lwt.t) -> t -> unit tzresult Lwt.t + + val iter_ep : (elt -> unit tzresult Lwt.t) -> t -> unit tzresult Lwt.t + + val map : (elt -> elt) -> t -> t + + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + + val fold_e : (elt -> 'a -> 'a tzresult) -> t -> 'a -> 'a tzresult + + val fold_s : (elt -> 'a -> 'a Lwt.t) -> t -> 'a -> 'a Lwt.t + + val fold_es : + (elt -> 'a -> 'a tzresult Lwt.t) -> t -> 'a -> 'a tzresult Lwt.t + + val for_all : (elt -> bool) -> t -> bool + + val exists : (elt -> bool) -> t -> bool + + val filter : (elt -> bool) -> t -> t + + val partition : (elt -> bool) -> t -> t * t + + val cardinal : t -> int + + val elements : t -> elt list + + val min_elt : t -> elt option + + val max_elt : t -> elt option + + val choose : t -> elt option + + val split : elt -> t -> t * bool * t + + val find : elt -> t -> elt option + + val find_first : (elt -> bool) -> t -> elt option + + val find_last : (elt -> bool) -> t -> elt option + + val of_list : elt list -> t + + val to_seq_from : elt -> t -> elt Stdlib.Seq.t + + val to_seq : t -> elt Stdlib.Seq.t + + val add_seq : elt Stdlib.Seq.t -> t -> t + + val of_seq : elt Stdlib.Seq.t -> t +end diff --git a/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam b/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam new file mode 100644 index 000000000000..2a428934eeb6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam @@ -0,0 +1,19 @@ +opam-version: "2.0" +maintainer: "contact@tezos.com" +authors: [ "Tezos devteam" ] +homepage: "https://www.tezos.com/" +bug-reports: "https://gitlab.com/tezos/tezos/issues" +dev-repo: "git+https://gitlab.com/tezos/tezos.git" +license: "MIT" +depends: [ + "tezos-tooling" { with-test } + "dune" { >= "1.11" } + "ocaml" { >= "4.07" } + "tezos-error-monad" + "lwt" +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos: error-aware stdlib replacement" -- GitLab From 5aa14a1c4e7439355e1e59ad24ea16ebbd5403e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 22 May 2020 14:57:44 +0100 Subject: [PATCH 03/12] Lwtreslib: Hastbl --- src/lib_lwt_result_stdlib/functors/hashtbl.ml | 59 ++++++++++++ .../functors/hashtbl.mli | 30 ++++++ src/lib_lwt_result_stdlib/lib/hashtbl.ml | 26 ++++++ src/lib_lwt_result_stdlib/lib/hashtbl.mli | 29 ++++++ src/lib_lwt_result_stdlib/lwtreslib.ml | 1 + src/lib_lwt_result_stdlib/lwtreslib.mli | 2 + src/lib_lwt_result_stdlib/sigs/hashtbl.ml | 93 +++++++++++++++++++ 7 files changed, 240 insertions(+) create mode 100644 src/lib_lwt_result_stdlib/functors/hashtbl.ml create mode 100644 src/lib_lwt_result_stdlib/functors/hashtbl.mli create mode 100644 src/lib_lwt_result_stdlib/lib/hashtbl.ml create mode 100644 src/lib_lwt_result_stdlib/lib/hashtbl.mli create mode 100644 src/lib_lwt_result_stdlib/sigs/hashtbl.ml diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml new file mode 100644 index 000000000000..8c24e6bc0131 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.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. *) +(* *) +(*****************************************************************************) + +module Make (Seq : Sigs.Seq.S) = struct + module type S = Sigs.Hashtbl.S with type 'a tzresult := 'a Seq.Monad.tzresult + + module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t = struct + open Seq + include Stdlib.Hashtbl.Make (H) + + let iter_e f t = iter_e (fun (k, v) -> f k v) (to_seq t) + + let iter_s f t = iter_s (fun (k, v) -> f k v) (to_seq t) + + let iter_es f t = iter_es (fun (k, v) -> f k v) (to_seq t) + + let iter_p f t = iter_p (fun (k, v) -> f k v) (to_seq t) + + let iter_ep f t = iter_ep (fun (k, v) -> f k v) (to_seq t) + + let fold_e f t init = + fold_left_e (fun acc (k, v) -> f k v acc) init (to_seq t) + + let fold_s f t init = + fold_left_s (fun acc (k, v) -> f k v acc) init (to_seq t) + + let fold_es f t init = + fold_left_es (fun acc (k, v) -> f k v acc) init (to_seq t) + + let find = find_opt + + let try_map_inplace f t = + filter_map_inplace + (fun k v -> match f k v with Error _ -> None | Ok r -> Some r) + t + end +end diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.mli b/src/lib_lwt_result_stdlib/functors/hashtbl.mli new file mode 100644 index 000000000000..12c44a94d10e --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.mli @@ -0,0 +1,30 @@ +(*****************************************************************************) +(* *) +(* 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 (Seq : Sigs.Seq.S) : sig + module type S = Sigs.Hashtbl.S with type 'a tzresult := 'a Seq.Monad.tzresult + + module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t +end diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.ml b/src/lib_lwt_result_stdlib/lib/hashtbl.ml new file mode 100644 index 000000000000..13033733a770 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.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.Hashtbl.Make (Seq) diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.mli b/src/lib_lwt_result_stdlib/lib/hashtbl.mli new file mode 100644 index 000000000000..964f524d1be6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.mli @@ -0,0 +1,29 @@ +(*****************************************************************************) +(* *) +(* 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 type S = + Sigs.Hashtbl.S with type 'a tzresult := 'a Error_monad.Monad.tzresult + +module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t diff --git a/src/lib_lwt_result_stdlib/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml index 7d29527fa227..a40eb489f321 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.ml +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -26,3 +26,4 @@ module Seq = Lib.Seq module Set = Lib.Set module Map = Lib.Map +module Hashtbl = Lib.Hashtbl diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index 71771de53626..24d222e5264f 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -28,3 +28,5 @@ module Seq : module type of Lib.Seq module Set : module type of Lib.Set module Map : module type of Lib.Map + +module Hashtbl : module type of Lib.Hashtbl diff --git a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml new file mode 100644 index 000000000000..087ab65f6c10 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -0,0 +1,93 @@ +(*****************************************************************************) +(* *) +(* 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 type S = sig + type 'a tzresult + + type key + + type 'a t + + val create : int -> 'a t + + val clear : 'a t -> unit + + val reset : 'a t -> unit + + val add : 'a t -> key -> 'a -> unit + + val remove : 'a t -> key -> unit + + val find : 'a t -> key -> 'a option + + val find_all : 'a t -> key -> 'a list + + val replace : 'a t -> key -> 'a -> unit + + val mem : 'a t -> key -> bool + + val iter : (key -> 'a -> unit) -> 'a t -> unit + + val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t + + val iter_e : (key -> 'a -> unit tzresult) -> 'a t -> unit tzresult + + val iter_es : + (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + + val iter_ep : + (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + + val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit + + val try_map_inplace : (key -> 'a -> 'a tzresult) -> 'a t -> unit + + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val fold_s : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t + + val fold_e : (key -> 'a -> 'b -> 'b tzresult) -> 'a t -> 'b -> 'b tzresult + + val fold_es : + (key -> 'a -> 'b -> 'b tzresult Lwt.t) -> 'a t -> 'b -> 'b tzresult Lwt.t + + val length : 'a t -> int + + val stats : 'a t -> Stdlib.Hashtbl.statistics + + val to_seq : 'a t -> (key * 'a) Stdlib.Seq.t + + val to_seq_keys : _ t -> key Stdlib.Seq.t + + val to_seq_values : 'a t -> 'a Stdlib.Seq.t + + val add_seq : 'a t -> (key * 'a) Stdlib.Seq.t -> unit + + val replace_seq : 'a t -> (key * 'a) Stdlib.Seq.t -> unit + + val of_seq : (key * 'a) Stdlib.Seq.t -> 'a t +end -- GitLab From 2251224644000ab30eb338126ac8b24837cd96db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 22 May 2020 15:23:27 +0100 Subject: [PATCH 04/12] Lwtreslib: Lwt-specialised Hashtbl This is a replacement for Error_table (in Error_monad) --- src/lib_error_monad/test/dune | 19 ---- src/lib_lwt_result_stdlib/functors/hashtbl.ml | 88 +++++++++++++++++++ .../functors/hashtbl.mli | 5 ++ src/lib_lwt_result_stdlib/lib/hashtbl.mli | 5 ++ src/lib_lwt_result_stdlib/sigs/hashtbl.ml | 43 +++++++++ src/lib_lwt_result_stdlib/test/.ocamlformat | 12 +++ .../test/assert.ml | 0 src/lib_lwt_result_stdlib/test/dune | 20 +++++ .../test/test_hashtbl.ml} | 78 ++++++++-------- .../tezos-lwt-result-stdlib.opam | 1 + 10 files changed, 211 insertions(+), 60 deletions(-) delete mode 100644 src/lib_error_monad/test/dune create mode 100644 src/lib_lwt_result_stdlib/test/.ocamlformat rename src/{lib_error_monad => lib_lwt_result_stdlib}/test/assert.ml (100%) create mode 100644 src/lib_lwt_result_stdlib/test/dune rename src/{lib_error_monad/test/test_error_tables.ml => lib_lwt_result_stdlib/test/test_hashtbl.ml} (72%) diff --git a/src/lib_error_monad/test/dune b/src/lib_error_monad/test/dune deleted file mode 100644 index 34250ff973a6..000000000000 --- a/src/lib_error_monad/test/dune +++ /dev/null @@ -1,19 +0,0 @@ -(executables - (names test_error_tables) - (libraries tezos-error-monad - lwt.unix - alcotest-lwt) - (flags (:standard -open Tezos_error_monad))) - -(alias - (name buildtest) - (deps test_error_tables.exe)) - -(alias - (name runtest_error_tables) - (action (run %{exe:test_error_tables.exe}))) - -(alias - (name runtest) - (package tezos-error-monad) - (deps (alias runtest_error_tables))) diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml index 8c24e6bc0131..91c3fe4afe6d 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -56,4 +56,92 @@ module Make (Seq : Sigs.Seq.S) = struct (fun k v -> match f k v with Error _ -> None | Ok r -> Some r) t end + + module type S_LWT = + Sigs.Hashtbl.S_LWT with type 'a tzresult := 'a Seq.Monad.tzresult + + module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t = + struct + open Seq + open Seq.Monad + module T = Stdlib.Hashtbl.Make (H) + + type key = H.t + + type 'a t = { + table : 'a Seq.Monad.tzresult Lwt.t T.t; + cleaners : unit Lwt.t T.t; + } + + let create n = {table = T.create n; cleaners = T.create n} + + let clear t = + T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ; + T.iter (fun _ a -> Lwt.cancel a) t.table ; + T.clear t.cleaners ; + T.clear t.table + + let reset t = + T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ; + T.iter (fun _ a -> Lwt.cancel a) t.table ; + T.reset t.cleaners ; + T.reset t.table + + let find_or_make t k i = + match T.find_opt t.table k with + | Some a -> + a + | None -> + let p = i () in + T.add t.table k p ; + T.add + t.cleaners + k + ( p + >>= function + | Ok _ -> + T.remove t.cleaners k ; Lwt.return_unit + | Error _ -> + T.remove t.table k ; T.remove t.cleaners k ; Lwt.return_unit ) ; + p + + let find t k = T.find_opt t.table k + + let remove t k = + (match T.find_opt t.cleaners k with None -> () | Some a -> Lwt.cancel a) ; + T.remove t.cleaners k ; + (match T.find_opt t.table k with None -> () | Some a -> Lwt.cancel a) ; + T.remove t.table k + + let mem t k = T.mem t.table k + + let iter_es f t = iter_es (fun (k, v) -> v >>=? f k) (T.to_seq t.table) + + let iter_ep f t = iter_ep (fun (k, v) -> v >>=? f k) (T.to_seq t.table) + + let fold_es f t init = + fold_left_es + (fun acc (k, v) -> v >>=? fun vv -> f k vv acc) + init + (T.to_seq t.table) + + let fold_keys f t init = T.fold (fun k _ acc -> f k acc) t.table init + + let fold_promises f t init = T.fold f t.table init + + let fold_resolved f t init = + T.fold + (fun k p acc -> + match Lwt.state p with + | Lwt.Return (Ok v) -> + f k v acc + | Lwt.Return (Error _) | Lwt.Fail _ | Lwt.Sleep -> + acc) + t.table + init + + let length t = T.length t.table + + let stats t = T.stats t.table + end end diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.mli b/src/lib_lwt_result_stdlib/functors/hashtbl.mli index 12c44a94d10e..db699c2eb910 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.mli @@ -27,4 +27,9 @@ module Make (Seq : Sigs.Seq.S) : sig module type S = Sigs.Hashtbl.S with type 'a tzresult := 'a Seq.Monad.tzresult module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t + + module type S_LWT = + Sigs.Hashtbl.S_LWT with type 'a tzresult := 'a Seq.Monad.tzresult + + module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t end diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.mli b/src/lib_lwt_result_stdlib/lib/hashtbl.mli index 964f524d1be6..1ee1f1d98d86 100644 --- a/src/lib_lwt_result_stdlib/lib/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.mli @@ -27,3 +27,8 @@ module type S = Sigs.Hashtbl.S with type 'a tzresult := 'a Error_monad.Monad.tzresult module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t + +module type S_LWT = + Sigs.Hashtbl.S_LWT with type 'a tzresult := 'a Error_monad.Monad.tzresult + +module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t diff --git a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml index 087ab65f6c10..cd83ec3e0054 100644 --- a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -91,3 +91,46 @@ module type S = sig val of_seq : (key * 'a) Stdlib.Seq.t -> 'a t end + +module type S_LWT = sig + type 'a tzresult + + type key + + type 'a t + + val create : int -> 'a t + + val clear : 'a t -> unit + + val reset : 'a t -> unit + + val find_or_make : + 'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t + + val remove : 'a t -> key -> unit + + val find : 'a t -> key -> 'a tzresult Lwt.t option + + val mem : 'a t -> key -> bool + + val iter_es : + (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + + val iter_ep : + (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + + val fold_es : + (key -> 'a -> 'b -> 'b tzresult Lwt.t) -> 'a t -> 'b -> 'b tzresult Lwt.t + + val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val fold_promises : + (key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + + val length : 'a t -> int + + val stats : 'a t -> Stdlib.Hashtbl.statistics +end diff --git a/src/lib_lwt_result_stdlib/test/.ocamlformat b/src/lib_lwt_result_stdlib/test/.ocamlformat new file mode 100644 index 000000000000..8278a132e3d6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/.ocamlformat @@ -0,0 +1,12 @@ +version=0.10 +wrap-fun-args=false +let-binding-spacing=compact +field-space=loose +break-separators=after-and-docked +sequence-style=separator +doc-comments=before +margin=80 +module-item-spacing=sparse +parens-tuple=always +parens-tuple-patterns=always +break-string-literals=newlines-and-wrap diff --git a/src/lib_error_monad/test/assert.ml b/src/lib_lwt_result_stdlib/test/assert.ml similarity index 100% rename from src/lib_error_monad/test/assert.ml rename to src/lib_lwt_result_stdlib/test/assert.ml diff --git a/src/lib_lwt_result_stdlib/test/dune b/src/lib_lwt_result_stdlib/test/dune new file mode 100644 index 000000000000..2eaac865f285 --- /dev/null +++ b/src/lib_lwt_result_stdlib/test/dune @@ -0,0 +1,20 @@ +(executables + (names test_hashtbl) + (libraries tezos-lwt-result-stdlib + tezos-error-monad + lwt.unix + alcotest-lwt) + (flags (:standard -open Tezos_lwt_result_stdlib))) + +(alias + (name buildtest) + (deps test_hashtbl.exe)) + +(alias + (name runtest_hashtbl) + (action (run %{exe:test_hashtbl.exe}))) + +(alias + (name runtest) + (package tezos-lwt-result-stdlib) + (deps (alias runtest_hashtbl))) diff --git a/src/lib_error_monad/test/test_error_tables.ml b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml similarity index 72% rename from src/lib_error_monad/test/test_error_tables.ml rename to src/lib_lwt_result_stdlib/test/test_hashtbl.ml index 942999e18c3c..d2614628ad5e 100644 --- a/src/lib_error_monad/test/test_error_tables.ml +++ b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml @@ -23,19 +23,19 @@ (* *) (*****************************************************************************) -open Lwt.Infix +open Tezos_error_monad.Error_monad -module IntErrorTable = Error_table.Make (Hashtbl.Make (struct +module IntLwtHashtbl = Lwtreslib.Hashtbl.Make_Lwt (struct type t = int let equal x y = x = y let hash x = x -end)) +end) let test_add_remove _ _ = - let t = IntErrorTable.create 2 in - IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0) + let t = IntLwtHashtbl.create 2 in + IntLwtHashtbl.find_or_make t 0 (fun () -> return 0) >>= function | Error _ -> Assert.fail "Ok 0" "Error _" "find_or_make" @@ -43,89 +43,86 @@ let test_add_remove _ _ = if not (n = 0) then Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make" else - match IntErrorTable.find_opt t 0 with + match IntLwtHashtbl.find t 0 with | None -> - Assert.fail "Some (Ok 0)" "None" "find_opt" + Assert.fail "Some (Ok 0)" "None" "find" | Some p -> ( p >>= function | Error _ -> - Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt" + Assert.fail "Some (Ok 0)" "Some (Error _)" "find" | Ok n -> if not (n = 0) then Assert.fail "Some (Ok 0)" (Format.asprintf "Some (Ok %d)" n) - "find_opt" + "find" else ( - IntErrorTable.remove t 0 ; - match IntErrorTable.find_opt t 0 with + IntLwtHashtbl.remove t 0 ; + match IntLwtHashtbl.find t 0 with | Some _ -> - Assert.fail "None" "Some _" "remove;find_opt" + Assert.fail "None" "Some _" "remove;find" | None -> Lwt.return_unit ) ) ) let test_add_add _ _ = - let t = IntErrorTable.create 2 in - IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0) + let t = IntLwtHashtbl.create 2 in + IntLwtHashtbl.find_or_make t 0 (fun () -> return 0) >>= fun _ -> - IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 1) + IntLwtHashtbl.find_or_make t 0 (fun () -> return 1) >>= fun _ -> - match IntErrorTable.find_opt t 0 with + match IntLwtHashtbl.find t 0 with | None -> - Assert.fail "Some (Ok 0)" "None" "find_opt" + Assert.fail "Some (Ok 0)" "None" "find" | Some p -> ( p >>= function | Error _ -> - Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt" + Assert.fail "Some (Ok 0)" "Some (Error _)" "find" | Ok n -> if not (n = 0) then - Assert.fail - "Some (Ok 0)" - (Format.asprintf "Some (Ok %d)" n) - "find_opt" + Assert.fail "Some (Ok 0)" (Format.asprintf "Some (Ok %d)" n) "find" else Lwt.return_unit ) let test_length _ _ = - let t = IntErrorTable.create 2 in - IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0) + let t = IntLwtHashtbl.create 2 in + IntLwtHashtbl.find_or_make t 0 (fun () -> return 0) >>= fun _ -> - IntErrorTable.find_or_make t 1 (fun () -> Error_monad.return 1) + IntLwtHashtbl.find_or_make t 1 (fun () -> return 1) >>= fun _ -> - IntErrorTable.find_or_make t 2 (fun () -> Error_monad.return 2) + IntLwtHashtbl.find_or_make t 2 (fun () -> return 2) >>= fun _ -> - IntErrorTable.find_or_make t 3 (fun () -> Error_monad.return 3) + IntLwtHashtbl.find_or_make t 3 (fun () -> return 3) >>= fun _ -> - let l = IntErrorTable.length t in + let l = IntLwtHashtbl.length t in if not (l = 4) then Assert.fail "4" (Format.asprintf "%d" l) "length" else Lwt.return_unit let test_self_clean _ _ = - let t = IntErrorTable.create 2 in - IntErrorTable.find_or_make t 0 (fun () -> Lwt.return (Ok 0)) + let t = IntLwtHashtbl.create 2 in + IntLwtHashtbl.find_or_make t 0 (fun () -> Lwt.return (Ok 0)) >>= fun _ -> - IntErrorTable.find_or_make t 1 (fun () -> Lwt.return (Error [])) + IntLwtHashtbl.find_or_make t 1 (fun () -> Lwt.return (Error [])) >>= fun _ -> - IntErrorTable.find_or_make t 2 (fun () -> Lwt.return (Error [])) + IntLwtHashtbl.find_or_make t 2 (fun () -> Lwt.return (Error [])) >>= fun _ -> - IntErrorTable.find_or_make t 3 (fun () -> Lwt.return (Ok 3)) + IntLwtHashtbl.find_or_make t 3 (fun () -> Lwt.return (Ok 3)) >>= fun _ -> - IntErrorTable.find_or_make t 4 (fun () -> Lwt.return (Ok 4)) + IntLwtHashtbl.find_or_make t 4 (fun () -> Lwt.return (Ok 4)) >>= fun _ -> - IntErrorTable.find_or_make t 5 (fun () -> Lwt.return (Error [])) + IntLwtHashtbl.find_or_make t 5 (fun () -> Lwt.return (Error [])) >>= fun _ -> - let l = IntErrorTable.length t in + let l = IntLwtHashtbl.length t in if not (l = 3) then Assert.fail "3" (Format.asprintf "%d" l) "length" else Lwt.return_unit let test_order _ _ = - let t = IntErrorTable.create 2 in + let t = IntLwtHashtbl.create 2 in let (wter, wker) = Lwt.task () in let world = ref [] in (* PROMISE A *) let p_a = - IntErrorTable.find_or_make t 0 (fun () -> + IntLwtHashtbl.find_or_make t 0 (fun () -> wter >>= fun r -> world := "a_inner" :: !world ; @@ -138,7 +135,7 @@ let test_order _ _ = >>= fun () -> (* PROMISE B *) let p_b = - IntErrorTable.find_or_make t 0 (fun () -> + IntLwtHashtbl.find_or_make t 0 (fun () -> world := "b_inner" :: !world ; Lwt.return (Ok 1024)) >>= fun r_b -> @@ -185,5 +182,4 @@ let tests = Alcotest_lwt.test_case "self_clean" `Quick test_length; Alcotest_lwt.test_case "order" `Quick test_order ] -let () = - Alcotest_lwt.run "error_tables" [("error_tables", tests)] |> Lwt_main.run +let () = Alcotest_lwt.run "hashtbl" [("hashtbl-lwt", tests)] |> Lwt_main.run diff --git a/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam b/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam index 2a428934eeb6..6fb5f31fa4f5 100644 --- a/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam +++ b/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam @@ -11,6 +11,7 @@ depends: [ "ocaml" { >= "4.07" } "tezos-error-monad" "lwt" + "alcotest-lwt" { with-test & >= "1.1.0" } ] build: [ ["dune" "build" "-p" name "-j" jobs] -- GitLab From b2ac43aff6af15c2459e31856c6061b3e03589be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 22 May 2020 15:32:51 +0100 Subject: [PATCH 05/12] Error_monad: remove Error_table, use Lwtreslib.Hashtbl.S_LWT instead --- src/lib_base/p2p_peer.mli | 3 +- src/lib_crypto/dune | 1 + src/lib_crypto/helpers.ml | 2 +- src/lib_crypto/s.ml | 2 +- src/lib_crypto/tezos-crypto.opam | 1 + src/lib_error_monad/error_table.ml | 144 --------------------- src/lib_error_monad/error_table.mli | 104 --------------- src/lib_error_monad/test/.ocamlformat | 12 -- src/lib_error_monad/tezos-error-monad.opam | 1 - src/lib_shell/chain_validator.ml | 2 +- 10 files changed, 7 insertions(+), 265 deletions(-) delete mode 100644 src/lib_error_monad/error_table.ml delete mode 100644 src/lib_error_monad/error_table.mli delete mode 100644 src/lib_error_monad/test/.ocamlformat diff --git a/src/lib_base/p2p_peer.mli b/src/lib_base/p2p_peer.mli index 7810d9add6cb..90db74a55fbd 100644 --- a/src/lib_base/p2p_peer.mli +++ b/src/lib_base/p2p_peer.mli @@ -28,7 +28,8 @@ module Map = Id.Map module Set = Id.Set module Table = Id.Table -module Error_table : Error_table.S with type key = Table.key +module Error_table : + Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.S_LWT with type key = Table.key module Filter : sig type t = Accepted | Running | Disconnected diff --git a/src/lib_crypto/dune b/src/lib_crypto/dune index cc86fd7b8143..793b9a17e800 100644 --- a/src/lib_crypto/dune +++ b/src/lib_crypto/dune @@ -8,6 +8,7 @@ (libraries tezos-stdlib data-encoding tezos-error-monad + tezos-lwt-result-stdlib tezos-rpc lwt hacl-star diff --git a/src/lib_crypto/helpers.ml b/src/lib_crypto/helpers.ml index 7e4212b8f5e0..268b1ef6d45a 100644 --- a/src/lib_crypto/helpers.ml +++ b/src/lib_crypto/helpers.ml @@ -257,7 +257,7 @@ struct end module Error_table = struct - include Error_table.Make (Table) + include Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.Make_Lwt (H) end module WeakRingTable = struct diff --git a/src/lib_crypto/s.ml b/src/lib_crypto/s.ml index f7d5359f70d4..2a43d4d74d1a 100644 --- a/src/lib_crypto/s.ml +++ b/src/lib_crypto/s.ml @@ -169,7 +169,7 @@ module type INDEXES = sig end module Error_table : sig - include Error_table.S with type key = t + include Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.S_LWT with type key = t end module WeakRingTable : sig diff --git a/src/lib_crypto/tezos-crypto.opam b/src/lib_crypto/tezos-crypto.opam index 3109fb2565f2..cdc4ae0292ab 100644 --- a/src/lib_crypto/tezos-crypto.opam +++ b/src/lib_crypto/tezos-crypto.opam @@ -11,6 +11,7 @@ depends: [ "tezos-stdlib" "data-encoding" { = "0.2" } "tezos-error-monad" + "tezos-lwt-result-stdlib" "tezos-rpc" "tezos-clic" "lwt" diff --git a/src/lib_error_monad/error_table.ml b/src/lib_error_monad/error_table.ml deleted file mode 100644 index 6422e0fff378..000000000000 --- a/src/lib_error_monad/error_table.ml +++ /dev/null @@ -1,144 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 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 Error_monad - -module type S = sig - type key - - type 'a t - - val create : int -> 'a t - - val clear : 'a t -> unit - - val reset : 'a t -> unit - - val find_or_make : - 'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t - - val remove : 'a t -> key -> unit - - val find_opt : 'a t -> key -> 'a tzresult Lwt.t option - - val mem : 'a t -> key -> bool - - val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - val fold : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t - - val fold_promises : - (key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b - - val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - - val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b - - val length : 'a t -> int -end - -module Make (T : Hashtbl.S) : S with type key = T.key = struct - type key = T.key - - type 'a t = {table : 'a tzresult Lwt.t T.t; cleaners : unit Lwt.t T.t} - - let create n = {table = T.create n; cleaners = T.create n} - - let clear t = - T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ; - T.iter (fun _ a -> Lwt.cancel a) t.table ; - T.clear t.cleaners ; - T.clear t.table - - let reset t = - T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ; - T.iter (fun _ a -> Lwt.cancel a) t.table ; - T.reset t.cleaners ; - T.reset t.table - - let find_or_make t k i = - match T.find_opt t.table k with - | Some a -> - a - | None -> - let p = i () in - T.add t.table k p ; - T.add - t.cleaners - k - ( p - >>= function - | Ok _ -> - T.remove t.cleaners k ; Lwt.return_unit - | Error _ -> - T.remove t.table k ; T.remove t.cleaners k ; Lwt.return_unit ) ; - p - - let remove t k = - (match T.find_opt t.cleaners k with None -> () | Some a -> Lwt.cancel a) ; - T.remove t.cleaners k ; - (match T.find_opt t.table k with None -> () | Some a -> Lwt.cancel a) ; - T.remove t.table k - - let find_opt t k = T.find_opt t.table k - - let mem t k = T.mem t.table k - - let iter_s f t = - T.fold (fun k a acc -> (k, a) :: acc) t.table [] - |> Lwt_list.iter_s (fun (k, a) -> - a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a) - - let iter_p f t = - T.fold (fun k a acc -> (k, a) :: acc) t.table [] - |> Lwt_list.iter_p (fun (k, a) -> - a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a) - - let fold f t acc = - T.fold (fun k a acc -> (k, a) :: acc) t.table [] - |> Lwt_list.fold_left_s - (fun acc (k, a) -> - a >>= function Error _ -> Lwt.return acc | Ok a -> f k a acc) - acc - - let fold_promises f t acc = T.fold f t.table acc - - let fold_resolved f t acc = - T.fold - (fun k a acc -> - match Lwt.state a with - | Lwt.Sleep | Lwt.Fail _ | Lwt.Return (Error _) -> - acc - | Lwt.Return (Ok a) -> - f k a acc) - t.table - acc - - let fold_keys f t acc = T.fold (fun k _ acc -> f k acc) t.table acc - - let length t = T.length t.table -end diff --git a/src/lib_error_monad/error_table.mli b/src/lib_error_monad/error_table.mli deleted file mode 100644 index 7594c352e52f..000000000000 --- a/src/lib_error_monad/error_table.mli +++ /dev/null @@ -1,104 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 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 Error_monad - -module type S = sig - (** This is mostly [Hashtbl.S] with the following differences: - - Looking up an element and creating an element to insert in the table are - the same operations. In other words: - - The function [find_or_make t k gen] behaves in two separate ways - depending if an element is already bound to key [k] in table [t]. - - If an element is bound, then it is returned. - - Otherwise, an element is generated using the [gen] function and recorded - in the table. - - The table does not record elements per se. Instead it records promises of - results of elements. This means that [find_or_make t k gen] is a value - within the lwt-error monad. - - The table automatically cleans itself of errors. Specifically, when one of - the promises resolves as an error, all the caller of [find_or_make] for - the matching key are woken up with [Error] and the value is removed from - the table. The next call to [find_or_make] with the same key causes the - provided [gen] function to be called. *) - - type key - - type 'a t - - val create : int -> 'a t - - val clear : 'a t -> unit - - val reset : 'a t -> unit - - (** [find_or_make t k gen] is [p] if [k] is already bound to [k] in [t]. In - this case, no side-effect is performed. - - [find_or_make t k gen] is [r] if [k] is not bound in [t] where [r] is [gen - ()]. In this case, [r] becomes bound to [k] in [t]. In addition, a - listener is added to [r] so that if [r] resolves to [Error _], the binding - is removed. *) - val find_or_make : - 'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t - - val remove : 'a t -> key -> unit - - (** [find_opt t k] is [None] if there are no bindings for [k] in [t], and - [Some p] if [p] is bound to [k] in [t]. *) - val find_opt : 'a t -> key -> 'a tzresult Lwt.t option - - val mem : 'a t -> key -> bool - - val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - (** [iter_{s,p} f t] iterates [f] over the promises of [t]. It blocks on - unresolved promises and only applies the function on the ones that resolve - successfully. *) - val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - - (** [fold f t init] folds [f] over the successfully resolving promises - of [t]. I.e., it goes through the promises in the table and waits for each - of the promise to resolve in order to fold over it. *) - val fold : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t - - (** [fold_promises f t init] folds [f] over the promises of [t]. *) - val fold_promises : - (key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b - - (** [fold_resolved f t init] folds [f] over the successfully resolved promises - of [t]. *) - val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - - (** [fold_keys f t init] folds [f] over the keys bound in [t]. *) - val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b - - val length : 'a t -> int -end - -(** Intended use: [Make(Hashtbl.Make(M))]. *) -module Make (T : Hashtbl.S) : S with type key = T.key diff --git a/src/lib_error_monad/test/.ocamlformat b/src/lib_error_monad/test/.ocamlformat deleted file mode 100644 index 8278a132e3d6..000000000000 --- a/src/lib_error_monad/test/.ocamlformat +++ /dev/null @@ -1,12 +0,0 @@ -version=0.10 -wrap-fun-args=false -let-binding-spacing=compact -field-space=loose -break-separators=after-and-docked -sequence-style=separator -doc-comments=before -margin=80 -module-item-spacing=sparse -parens-tuple=always -parens-tuple-patterns=always -break-string-literals=newlines-and-wrap diff --git a/src/lib_error_monad/tezos-error-monad.opam b/src/lib_error_monad/tezos-error-monad.opam index c4dba5058c08..3df391ffb101 100644 --- a/src/lib_error_monad/tezos-error-monad.opam +++ b/src/lib_error_monad/tezos-error-monad.opam @@ -13,7 +13,6 @@ depends: [ "data-encoding" { = "0.2" } "lwt" "lwt-canceler" { = "0.2" } - "alcotest-lwt" { with-test & >= "1.1.0" } ] build: [ ["dune" "build" "-p" name "-j" jobs] diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 68ce570163b2..099e3163ead0 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -651,7 +651,7 @@ let on_launch start_prevalidator w _ parameters = trace) (fun () -> let nv = Worker.state w in - match P2p_peer.Error_table.find_opt nv.active_peers peer_id with + match P2p_peer.Error_table.find nv.active_peers peer_id with | None -> return_unit | Some pv -> -- GitLab From 7646fd787268b7f0eb82196cbb9bbb09e3e7e7e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 25 May 2020 09:49:02 +0100 Subject: [PATCH 06/12] CI: update_unit_test, update_opam_test --- .gitlab-ci.yml | 83 ++++++++++++++++++++++++++------------------------ 1 file changed, 44 insertions(+), 39 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7724d826d576..581138fe4cfe 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -96,100 +96,95 @@ build: # this section is updated using the script scripts/update_unit_test.sh ##BEGIN_UNITEST## -unit:shell: - <<: *test_definition - script: - - dune build @src/lib_shell/runtest - -unit:client_base: +unit:signer_backends/unix: <<: *test_definition script: - - dune build @src/lib_client_base/runtest + - dune build @src/lib_signer_backends/unix/runtest -unit:requester: +unit:signer_backends: <<: *test_definition script: - - dune build @src/lib_requester/runtest + - dune build @src/lib_signer_backends/runtest -unit:error_monad: +unit:crypto: <<: *test_definition script: - - dune build @src/lib_error_monad/runtest + - dune build @src/lib_crypto/runtest -unit:src/proto_006_PsCARTHA/lib_client: +unit:protocol_environment: <<: *test_definition script: - - dune build @src/proto_006_PsCARTHA/lib_client/runtest + - dune build @src/lib_protocol_environment/runtest -unit:src/proto_006_PsCARTHA/lib_protocol: +unit:stdlib: <<: *test_definition script: - - dune build @src/proto_006_PsCARTHA/lib_protocol/runtest + - dune build @src/lib_stdlib/runtest -unit:src/proto_alpha/lib_client: +unit:shell: <<: *test_definition script: - - dune build @src/proto_alpha/lib_client/runtest + - dune build @src/lib_shell/runtest -unit:src/proto_alpha/lib_protocol: +unit:src/bin_client: <<: *test_definition script: - - dune build @src/proto_alpha/lib_protocol/runtest + - dune build @src/bin_client/runtest -unit:crypto: +unit:error_monad: <<: *test_definition script: - - dune build @src/lib_crypto/runtest + - dune build @src/lib_error_monad/runtest -unit:stdlib: +unit:micheline: <<: *test_definition script: - - dune build @src/lib_stdlib/runtest + - dune build @src/lib_micheline/runtest unit:storage: <<: *test_definition script: - dune build @src/lib_storage/runtest -unit:p2p: +unit:src/proto_006_PsCARTHA/lib_client: <<: *test_definition script: - - dune build @src/lib_p2p/runtest + - dune build @src/proto_006_PsCARTHA/lib_client/runtest -unit:micheline: +unit:src/proto_006_PsCARTHA/lib_protocol: <<: *test_definition script: - - dune build @src/lib_micheline/runtest + - dune build @src/proto_006_PsCARTHA/lib_protocol/runtest -unit:protocol_environment: +unit:src/proto_alpha/lib_client: <<: *test_definition script: - - dune build @src/lib_protocol_environment/runtest + - dune build @src/proto_alpha/lib_client/runtest -unit:signer_backends/unix: +unit:src/proto_alpha/lib_protocol: <<: *test_definition script: - - dune build @src/lib_signer_backends/unix/runtest + - dune build @src/proto_alpha/lib_protocol/runtest -unit:signer_backends: +unit:lwt_result_stdlib: <<: *test_definition script: - - dune build @src/lib_signer_backends/runtest + - dune build @src/lib_lwt_result_stdlib/runtest -unit:src/bin_client: +unit:client_base: <<: *test_definition script: - - dune build @src/bin_client/runtest + - dune build @src/lib_client_base/runtest -unit:ocaml-uecc: +unit:requester: <<: *test_definition script: - - dune build @vendors/ocaml-uecc/runtest + - dune build @src/lib_requester/runtest -unit:ocaml-ledger-wallet: +unit:p2p: <<: *test_definition script: - - dune build @vendors/ocaml-ledger-wallet/runtest + - dune build @src/lib_p2p/runtest unit:ocaml-secp256k1: <<: *test_definition @@ -201,6 +196,16 @@ unit:ocaml-lmdb: script: - dune build @vendors/ocaml-lmdb/runtest +unit:ocaml-ledger-wallet: + <<: *test_definition + script: + - dune build @vendors/ocaml-ledger-wallet/runtest + +unit:ocaml-uecc: + <<: *test_definition + script: + - dune build @vendors/ocaml-uecc/runtest + ##END_UNITEST## -- GitLab From 7c94765dc552cd88e74f650f4b142112187e4d3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 1 Jun 2020 17:31:35 +0100 Subject: [PATCH 07/12] Lwtreslib: add blurb about library's aim and scope --- src/lib_lwt_result_stdlib/lwtreslib.mli | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index 24d222e5264f..4f2865c1862c 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -23,6 +23,28 @@ (* *) (*****************************************************************************) +(** [Error_monad]-aware replacements for parts of the Stdlib. + + This library aims to provide replacements to some parts of the Stdlib that: + + - do not raise exceptions (e.g., it shadows [Map.find] with [Map.find_opt]), + - include traversal functions for Lwt (think [Lwt_list] for [List]), + [tzresult], and the combined [tzresult]-Lwt monad (think the + list-traversal functions from [Error_monad]. + + The aim is to allow the use of the standard OCaml data-structures within the + context of Lwt and the Error monad. This is already somewhat available for + [List] through the combination of {!Stdlib.List} (for basic functionality), + {!Lwt_list} (for the Lwt-aware traversals), and {!Error_monad} (for the + error-aware and combined-error-lwt-aware traversal). + + More and more modules will be added to this Library. In particular [List] + (to avoid splitting the functionality from three distinct libraries and to + provide more consistent coverage), [Array], and [Option] will be made + available. + +*) + module Seq : module type of Lib.Seq module Set : module type of Lib.Set -- GitLab From ca4bfc639cccbbf4670a0ad76041b24e653109e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 3 Jun 2020 12:02:06 +0100 Subject: [PATCH 08/12] Lwtreslib: better documentation and implementation for Hashtbl --- src/lib_lwt_result_stdlib/functors/hashtbl.ml | 74 +++++++++---------- src/lib_lwt_result_stdlib/sigs/hashtbl.ml | 51 +++++++++++++ 2 files changed, 85 insertions(+), 40 deletions(-) diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml index 91c3fe4afe6d..8dc9b2bc2904 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -68,66 +68,60 @@ module Make (Seq : Sigs.Seq.S) = struct type key = H.t - type 'a t = { - table : 'a Seq.Monad.tzresult Lwt.t T.t; - cleaners : unit Lwt.t T.t; - } + type 'a t = 'a Seq.Monad.tzresult Lwt.t T.t - let create n = {table = T.create n; cleaners = T.create n} + let create n = T.create n let clear t = - T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ; - T.iter (fun _ a -> Lwt.cancel a) t.table ; - T.clear t.cleaners ; - T.clear t.table + T.iter (fun _ a -> Lwt.cancel a) t ; + T.clear t let reset t = - T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ; - T.iter (fun _ a -> Lwt.cancel a) t.table ; - T.reset t.cleaners ; - T.reset t.table + T.iter (fun _ a -> Lwt.cancel a) t ; + T.reset t - let find_or_make t k i = - match T.find_opt t.table k with + let find_or_make t k make = + match T.find_opt t k with | Some a -> a | None -> - let p = i () in - T.add t.table k p ; - T.add - t.cleaners - k - ( p - >>= function - | Ok _ -> - T.remove t.cleaners k ; Lwt.return_unit - | Error _ -> - T.remove t.table k ; T.remove t.cleaners k ; Lwt.return_unit ) ; + let p = Lwt.apply make () in + ( match Lwt.state p with + | Return (Ok _) -> + T.add t k p + | Return (Error _) -> + () + | Fail _ -> + () + | Sleep -> + T.add t k p ; + Lwt.on_any + p + (function Ok _ -> () | Error _ -> T.remove t k) + (fun _ -> T.remove t k) ) ; p - let find t k = T.find_opt t.table k + let find t k = T.find_opt t k let remove t k = - (match T.find_opt t.cleaners k with None -> () | Some a -> Lwt.cancel a) ; - T.remove t.cleaners k ; - (match T.find_opt t.table k with None -> () | Some a -> Lwt.cancel a) ; - T.remove t.table k + (match T.find_opt t k with None -> () | Some a -> Lwt.cancel a) ; + T.remove t k - let mem t k = T.mem t.table k + let mem t k = T.mem t k - let iter_es f t = iter_es (fun (k, v) -> v >>=? f k) (T.to_seq t.table) + let iter_es f t = iter_es (fun (k, v) -> v >>=? f k) (T.to_seq t) - let iter_ep f t = iter_ep (fun (k, v) -> v >>=? f k) (T.to_seq t.table) + let iter_ep f t = iter_ep (fun (k, v) -> v >>=? f k) (T.to_seq t) let fold_es f t init = fold_left_es (fun acc (k, v) -> v >>=? fun vv -> f k vv acc) init - (T.to_seq t.table) + (T.to_seq t) - let fold_keys f t init = T.fold (fun k _ acc -> f k acc) t.table init + let fold_keys f t init = T.fold (fun k _ acc -> f k acc) t init - let fold_promises f t init = T.fold f t.table init + let fold_promises f t init = T.fold f t init let fold_resolved f t init = T.fold @@ -137,11 +131,11 @@ module Make (Seq : Sigs.Seq.S) = struct f k v acc | Lwt.Return (Error _) | Lwt.Fail _ | Lwt.Sleep -> acc) - t.table + t init - let length t = T.length t.table + let length t = T.length t - let stats t = T.stats t.table + let stats t = T.stats t end end diff --git a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml index cd83ec3e0054..ecc751ce1583 100644 --- a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -23,6 +23,9 @@ (* *) (*****************************************************************************) +(** Modules with the signature [S] are safe (e.g., [find] uses [option] rather + than raising [Not_found]) extensions of [Hashtbl.S] with some Lwt- and + Error-aware traversal functions. *) module type S = sig type 'a tzresult @@ -92,6 +95,54 @@ module type S = sig val of_seq : (key * 'a) Stdlib.Seq.t -> 'a t end +(** Modules with the signature [S_LWT] are Hashtbl-like with the following + differences: + + First, the module exports only a few functions in an attempt to limit the + likelihood of race-conditions. Of particular interest is the following: in + order to insert a value, one has to use `find_or_make` which either returns + an existing promise for a value bound to the given key, or makes such a + promise. It is not possible to insert another value for an existing key. + + Second, the table is automatically cleaned. Specifically, when a promise for + a value is fulfilled with an [Error _], the binding is removed. This leads + to the following behavior: + + [ + (* setup *) + let t = create 256 in + let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 0) in + + (* insert a first promise for a value *) + let p, r = Lwt.task () in + let i1 = find_or_make t 1 (fun () -> p) in + let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 1) in + + (* because the same key is used, the promise is not inserted. *) + let i2 = find_or_make t 1 (fun () -> assert false) in + let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 1) in + + (* when the original promise errors, the binding is removed *) + let () = Lwt.wakeup r (Error ..) in + let () = assert (fold_keys (fun _ acc -> succ acc) t 0 = 0) in + + (* and both the [find_or_make] promises have the error *) + let () = match Lwt.state i1 with + | Return (Error ..) -> () + | _ -> assert false + in + let () = match Lwt.state i2 with + | Return (Error ..) -> () + | _ -> assert false + in + ] + + This automatic cleaning relieves the user from the responsibility of + cleaning the table (which is another possible source of race condition). + + Third, every time a promise is removed from the table (be it by [clean], + [reset], or just [remove]), the promise is canceled. +*) module type S_LWT = sig type 'a tzresult -- GitLab From 63dbe6755e6a125f3a6dd73c92037773d3a1e142 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 3 Jun 2020 12:25:49 +0100 Subject: [PATCH 09/12] Lwtreslib: also test for lwt rejection clean-up --- src/lib_lwt_result_stdlib/test/test_hashtbl.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/lib_lwt_result_stdlib/test/test_hashtbl.ml b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml index d2614628ad5e..9808047f1600 100644 --- a/src/lib_lwt_result_stdlib/test/test_hashtbl.ml +++ b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml @@ -112,6 +112,8 @@ let test_self_clean _ _ = >>= fun _ -> IntLwtHashtbl.find_or_make t 5 (fun () -> Lwt.return (Error [])) >>= fun _ -> + IntLwtHashtbl.find_or_make t 6 (fun () -> Lwt.fail Not_found) + >>= fun _ -> let l = IntLwtHashtbl.length t in if not (l = 3) then Assert.fail "3" (Format.asprintf "%d" l) "length" else Lwt.return_unit -- GitLab From 7b1c4ff23c511a7e5f9248a8e6c2fe14eedb7dae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 3 Jun 2020 17:54:15 +0100 Subject: [PATCH 10/12] Lwtresstdlib: make the library less dependent on tezos' error monad Specifically, both the functors and sigs are independent. In the future, the functors and sigs can be released as external libraries and the instances can simply be made on the Tezos side. --- src/lib_lwt_result_stdlib/functors/dune | 4 +- src/lib_lwt_result_stdlib/functors/hashtbl.ml | 7 +- .../functors/hashtbl.mli | 5 +- src/lib_lwt_result_stdlib/functors/map.ml | 2 +- src/lib_lwt_result_stdlib/functors/map.mli | 2 +- src/lib_lwt_result_stdlib/functors/seq.ml | 5 +- src/lib_lwt_result_stdlib/functors/seq.mli | 3 +- src/lib_lwt_result_stdlib/functors/set.ml | 2 +- src/lib_lwt_result_stdlib/functors/set.mli | 2 +- src/lib_lwt_result_stdlib/lib/hashtbl.mli | 5 +- src/lib_lwt_result_stdlib/lib/map.mli | 3 +- src/lib_lwt_result_stdlib/lib/seq.ml | 8 +- src/lib_lwt_result_stdlib/lib/seq.mli | 5 +- src/lib_lwt_result_stdlib/lib/set.mli | 3 +- src/lib_lwt_result_stdlib/sigs/dune | 4 +- src/lib_lwt_result_stdlib/sigs/hashtbl.ml | 47 +++++--- src/lib_lwt_result_stdlib/sigs/map.ml | 21 +++- src/lib_lwt_result_stdlib/sigs/monad.ml | 110 ++++++++++++++++++ src/lib_lwt_result_stdlib/sigs/seq.ml | 99 ++++++++++------ src/lib_lwt_result_stdlib/sigs/set.ml | 18 ++- 20 files changed, 267 insertions(+), 88 deletions(-) create mode 100644 src/lib_lwt_result_stdlib/sigs/monad.ml diff --git a/src/lib_lwt_result_stdlib/functors/dune b/src/lib_lwt_result_stdlib/functors/dune index 470c866c324a..43330b85f435 100644 --- a/src/lib_lwt_result_stdlib/functors/dune +++ b/src/lib_lwt_result_stdlib/functors/dune @@ -1,8 +1,8 @@ (library (name functors) (public_name tezos-lwt-result-stdlib.functors) - (flags (:standard -open Tezos_error_monad)) - (libraries tezos-error-monad lwt tezos-lwt-result-stdlib.sigs)) + (flags (:standard)) + (libraries lwt tezos-lwt-result-stdlib.sigs)) (alias (name runtest_lint) diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml index 8dc9b2bc2904..5674bddbf4fa 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) = struct - module type S = Sigs.Hashtbl.S with type 'a tzresult := 'a Seq.Monad.tzresult + module type S = Sigs.Hashtbl.S with type error := Seq.Monad.out_error module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t = struct open Seq @@ -57,8 +57,7 @@ module Make (Seq : Sigs.Seq.S) = struct t end - module type S_LWT = - Sigs.Hashtbl.S_LWT with type 'a tzresult := 'a Seq.Monad.tzresult + module type S_LWT = Sigs.Hashtbl.S_LWT with type error := Seq.Monad.out_error module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t = struct @@ -68,7 +67,7 @@ module Make (Seq : Sigs.Seq.S) = struct type key = H.t - type 'a t = 'a Seq.Monad.tzresult Lwt.t T.t + type 'a t = ('a, Seq.Monad.out_error) result Lwt.t T.t let create n = T.create n diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.mli b/src/lib_lwt_result_stdlib/functors/hashtbl.mli index db699c2eb910..39c5b7db0591 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.mli @@ -24,12 +24,11 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) : sig - module type S = Sigs.Hashtbl.S with type 'a tzresult := 'a Seq.Monad.tzresult + module type S = Sigs.Hashtbl.S with type error := Seq.Monad.out_error module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t - module type S_LWT = - Sigs.Hashtbl.S_LWT with type 'a tzresult := 'a Seq.Monad.tzresult + module type S_LWT = Sigs.Hashtbl.S_LWT with type error := Seq.Monad.out_error module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t end diff --git a/src/lib_lwt_result_stdlib/functors/map.ml b/src/lib_lwt_result_stdlib/functors/map.ml index c9133163e8db..d5e43e1d51c5 100644 --- a/src/lib_lwt_result_stdlib/functors/map.ml +++ b/src/lib_lwt_result_stdlib/functors/map.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) = struct - module type S = Sigs.Map.S with type 'a tzresult := 'a Seq.Monad.tzresult + module type S = Sigs.Map.S with type error := Seq.Monad.out_error module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t = struct open Seq diff --git a/src/lib_lwt_result_stdlib/functors/map.mli b/src/lib_lwt_result_stdlib/functors/map.mli index be1a2a1cc134..423803dae6f1 100644 --- a/src/lib_lwt_result_stdlib/functors/map.mli +++ b/src/lib_lwt_result_stdlib/functors/map.mli @@ -24,7 +24,7 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) : sig - module type S = Sigs.Map.S with type 'a tzresult := 'a Seq.Monad.tzresult + module type S = Sigs.Map.S with type error := Seq.Monad.out_error module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t end diff --git a/src/lib_lwt_result_stdlib/functors/seq.ml b/src/lib_lwt_result_stdlib/functors/seq.ml index bd06fc634ba1..c74f9c68010a 100644 --- a/src/lib_lwt_result_stdlib/functors/seq.ml +++ b/src/lib_lwt_result_stdlib/functors/seq.ml @@ -23,9 +23,10 @@ (* *) (*****************************************************************************) -module Make (Monad : Tezos_error_monad.Sig.MONAD) : - Sigs.Seq.S with module Monad = Monad = struct +module Make (Monad : Sigs.Monad.S) : Sigs.Seq.S with module Monad = Monad = +struct module Monad = Monad + open Lwt.Infix open Monad include Stdlib.Seq diff --git a/src/lib_lwt_result_stdlib/functors/seq.mli b/src/lib_lwt_result_stdlib/functors/seq.mli index 052b83234d36..4e0911c165e3 100644 --- a/src/lib_lwt_result_stdlib/functors/seq.mli +++ b/src/lib_lwt_result_stdlib/functors/seq.mli @@ -23,5 +23,4 @@ (* *) (*****************************************************************************) -module Make (Monad : Tezos_error_monad.Sig.MONAD) : - Sigs.Seq.S with module Monad = Monad +module Make (Monad : Sigs.Monad.S) : Sigs.Seq.S with module Monad = Monad diff --git a/src/lib_lwt_result_stdlib/functors/set.ml b/src/lib_lwt_result_stdlib/functors/set.ml index c20ea9d01857..5a10e59eb9ba 100644 --- a/src/lib_lwt_result_stdlib/functors/set.ml +++ b/src/lib_lwt_result_stdlib/functors/set.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) = struct - module type S = Sigs.Set.S with type 'a tzresult := 'a Seq.Monad.tzresult + module type S = Sigs.Set.S with type error := Seq.Monad.out_error module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t = struct open Seq diff --git a/src/lib_lwt_result_stdlib/functors/set.mli b/src/lib_lwt_result_stdlib/functors/set.mli index ffec5a396af9..27f62475a57c 100644 --- a/src/lib_lwt_result_stdlib/functors/set.mli +++ b/src/lib_lwt_result_stdlib/functors/set.mli @@ -24,7 +24,7 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) : sig - module type S = Sigs.Set.S with type 'a tzresult := 'a Seq.Monad.tzresult + module type S = Sigs.Set.S with type error := Seq.Monad.out_error module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t end diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.mli b/src/lib_lwt_result_stdlib/lib/hashtbl.mli index 1ee1f1d98d86..e814f6a146c5 100644 --- a/src/lib_lwt_result_stdlib/lib/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.mli @@ -23,12 +23,11 @@ (* *) (*****************************************************************************) -module type S = - Sigs.Hashtbl.S with type 'a tzresult := 'a Error_monad.Monad.tzresult +module type S = Sigs.Hashtbl.S with type error := Error_monad.error list module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t module type S_LWT = - Sigs.Hashtbl.S_LWT with type 'a tzresult := 'a Error_monad.Monad.tzresult + Sigs.Hashtbl.S_LWT with type error := Error_monad.error list module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t diff --git a/src/lib_lwt_result_stdlib/lib/map.mli b/src/lib_lwt_result_stdlib/lib/map.mli index 275d5c8fa9f4..a6a303cfd664 100644 --- a/src/lib_lwt_result_stdlib/lib/map.mli +++ b/src/lib_lwt_result_stdlib/lib/map.mli @@ -23,7 +23,6 @@ (* *) (*****************************************************************************) -module type S = - Sigs.Map.S with type 'a tzresult := 'a Error_monad.Monad.tzresult +module type S = Sigs.Map.S with type error := Error_monad.error list module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t diff --git a/src/lib_lwt_result_stdlib/lib/seq.ml b/src/lib_lwt_result_stdlib/lib/seq.ml index e41e8875114e..4cf2b6719061 100644 --- a/src/lib_lwt_result_stdlib/lib/seq.ml +++ b/src/lib_lwt_result_stdlib/lib/seq.ml @@ -23,4 +23,10 @@ (* *) (*****************************************************************************) -include Functors.Seq.Make (Error_monad.Monad) +include Functors.Seq.Make (struct + type in_error = Error_monad.Core.error + + type out_error = Error_monad.Core.error list + + include Error_monad.Monad +end) diff --git a/src/lib_lwt_result_stdlib/lib/seq.mli b/src/lib_lwt_result_stdlib/lib/seq.mli index 4ee918039a36..d229db7c4077 100644 --- a/src/lib_lwt_result_stdlib/lib/seq.mli +++ b/src/lib_lwt_result_stdlib/lib/seq.mli @@ -23,4 +23,7 @@ (* *) (*****************************************************************************) -include Sigs.Seq.S with module Monad = Error_monad.Monad +include + Sigs.Seq.S + with type Monad.in_error = Error_monad.Monad.error + and type Monad.out_error = Error_monad.Monad.error list diff --git a/src/lib_lwt_result_stdlib/lib/set.mli b/src/lib_lwt_result_stdlib/lib/set.mli index 33cfbe5f7700..a9fae50ff217 100644 --- a/src/lib_lwt_result_stdlib/lib/set.mli +++ b/src/lib_lwt_result_stdlib/lib/set.mli @@ -23,7 +23,6 @@ (* *) (*****************************************************************************) -module type S = - Sigs.Set.S with type 'a tzresult := 'a Error_monad.Monad.tzresult +module type S = Sigs.Set.S with type error := Error_monad.error list module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t diff --git a/src/lib_lwt_result_stdlib/sigs/dune b/src/lib_lwt_result_stdlib/sigs/dune index 20c1eb1b92c2..b7c0d48a5e7d 100644 --- a/src/lib_lwt_result_stdlib/sigs/dune +++ b/src/lib_lwt_result_stdlib/sigs/dune @@ -1,8 +1,8 @@ (library (name sigs) (public_name tezos-lwt-result-stdlib.sigs) - (flags (:standard -open Tezos_error_monad)) - (libraries tezos-error-monad lwt)) + (flags (:standard)) + (libraries lwt)) (alias (name runtest_lint) diff --git a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml index ecc751ce1583..846fc42e1092 100644 --- a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -27,7 +27,7 @@ than raising [Not_found]) extensions of [Hashtbl.S] with some Lwt- and Error-aware traversal functions. *) module type S = sig - type 'a tzresult + type error type key @@ -57,26 +57,35 @@ module type S = sig val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t - val iter_e : (key -> 'a -> unit tzresult) -> 'a t -> unit tzresult + val iter_e : + (key -> 'a -> (unit, error) result) -> 'a t -> (unit, error) result val iter_es : - (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t val iter_ep : - (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit - val try_map_inplace : (key -> 'a -> 'a tzresult) -> 'a t -> unit + val try_map_inplace : (key -> 'a -> ('a, error) result) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_s : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t - val fold_e : (key -> 'a -> 'b -> 'b tzresult) -> 'a t -> 'b -> 'b tzresult + val fold_e : + (key -> 'a -> 'b -> ('b, error) result) -> 'a t -> 'b -> ('b, error) result val fold_es : - (key -> 'a -> 'b -> 'b tzresult Lwt.t) -> 'a t -> 'b -> 'b tzresult Lwt.t + (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> + 'a t -> + 'b -> + ('b, error) result Lwt.t val length : 'a t -> int @@ -144,7 +153,7 @@ end [reset], or just [remove]), the promise is canceled. *) module type S_LWT = sig - type 'a tzresult + type error type key @@ -157,27 +166,37 @@ module type S_LWT = sig val reset : 'a t -> unit val find_or_make : - 'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t + 'a t -> + key -> + (unit -> ('a, error) result Lwt.t) -> + ('a, error) result Lwt.t val remove : 'a t -> key -> unit - val find : 'a t -> key -> 'a tzresult Lwt.t option + val find : 'a t -> key -> ('a, error) result Lwt.t option val mem : 'a t -> key -> bool val iter_es : - (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t val iter_ep : - (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t val fold_es : - (key -> 'a -> 'b -> 'b tzresult Lwt.t) -> 'a t -> 'b -> 'b tzresult Lwt.t + (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> + 'a t -> + 'b -> + ('b, error) result Lwt.t val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_promises : - (key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b + (key -> ('a, error) result Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b diff --git a/src/lib_lwt_result_stdlib/sigs/map.ml b/src/lib_lwt_result_stdlib/sigs/map.ml index f17125697f16..3e73e3292374 100644 --- a/src/lib_lwt_result_stdlib/sigs/map.ml +++ b/src/lib_lwt_result_stdlib/sigs/map.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module type S = sig - type 'a tzresult + type error (* for substitution/constraint *) type key @@ -60,7 +60,8 @@ module type S = sig result of the iteration is [Ok ()]. If any of the applications results in [Error e] then the iteration stops and the result of the iteration is [Error e]. *) - val iter_e : (key -> 'a -> unit tzresult) -> 'a t -> unit tzresult + val iter_e : + (key -> 'a -> (unit, error) result) -> 'a t -> (unit, error) result val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t @@ -72,21 +73,26 @@ module type S = sig the applications results in [Error e] then the iteration stops and the result of the iteration is [Error e]. *) val iter_es : - (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t (** [iter_ep f m] applies [f] to the bindings of [m]. All the applications are done concurrently. If all the applications result in [Ok ()], then the result of the iteration is [Ok ()]. If any of the applications results in [Error e] then the result of the iteration is [Error e]. *) val iter_ep : - (key -> 'a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold_e f m init] is [f k1 d1 init >>? fun acc -> f k2 d2 acc >>? fun acc -> …] where [kN] is the key bound to [dN] in [m]. *) - val fold_e : (key -> 'a -> 'b -> 'b tzresult) -> 'a t -> 'b -> 'b tzresult + val fold_e : + (key -> 'a -> 'b -> ('b, error) result) -> 'a t -> 'b -> ('b, error) result val fold_s : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t @@ -94,7 +100,10 @@ module type S = sig [f k1 d1 init >>=? fun acc -> f k2 d2 acc >>=? fun acc -> …] where [kN] is the key bound to [dN] in [m]. *) val fold_es : - (key -> 'a -> 'b -> 'b tzresult Lwt.t) -> 'a t -> 'b -> 'b tzresult Lwt.t + (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> + 'a t -> + 'b -> + ('b, error) result Lwt.t val for_all : (key -> 'a -> bool) -> 'a t -> bool diff --git a/src/lib_lwt_result_stdlib/sigs/monad.ml b/src/lib_lwt_result_stdlib/sigs/monad.ml new file mode 100644 index 000000000000..107b4ef0ee08 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/monad.ml @@ -0,0 +1,110 @@ +(*****************************************************************************) +(* *) +(* 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 type S = sig + type in_error + + type out_error + + (** result monad *) + + val ok : 'a -> ('a, out_error) result + + val ok_unit : (unit, out_error) result + + val ok_none : ('a option, out_error) result + + val ok_some : 'a -> ('a option, out_error) result + + val ok_nil : ('a list, out_error) result + + val ok_true : (bool, out_error) result + + val ok_false : (bool, out_error) result + + val error : in_error -> ('a, out_error) result + + val ( >>? ) : + ('a, out_error) result -> + ('a -> ('b, out_error) result) -> + ('b, out_error) result + + val ( >|? ) : ('a, out_error) result -> ('a -> 'b) -> ('b, out_error) result + + (** lwt-result combined monad *) + + val return : 'a -> ('a, out_error) result Lwt.t + + val return_unit : (unit, out_error) result Lwt.t + + val return_none : ('a option, out_error) result Lwt.t + + val return_some : 'a -> ('a option, out_error) result Lwt.t + + val return_nil : ('a list, out_error) result Lwt.t + + val return_true : (bool, out_error) result Lwt.t + + val return_false : (bool, out_error) result Lwt.t + + val fail : in_error -> ('a, out_error) result Lwt.t + + val ( >>=? ) : + ('a, out_error) result Lwt.t -> + ('a -> ('b, out_error) result Lwt.t) -> + ('b, out_error) result Lwt.t + + val ( >|=? ) : + ('a, out_error) result Lwt.t -> ('a -> 'b) -> ('b, out_error) result Lwt.t + + (** Mixing operators *) + + (** All operators follow this naming convention: + - the first character is [>] + - the second character is [>] for [bind] and [|] for [map] + - 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. *) + + val ( >>?= ) : + ('a, out_error) result -> + ('a -> ('b, out_error) result Lwt.t) -> + ('b, out_error) result Lwt.t + + val ( >|?= ) : + ('a, out_error) result -> ('a -> 'b Lwt.t) -> ('b, out_error) result Lwt.t + + (** joins *) + val join : + (unit, out_error) result Lwt.t list -> (unit, out_error) result Lwt.t + + val all : + ('a, out_error) result Lwt.t list -> ('a list, out_error) result Lwt.t + + val both : + ('a, out_error) result Lwt.t -> + ('b, out_error) result Lwt.t -> + ('a * 'b, out_error) result Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/sigs/seq.ml b/src/lib_lwt_result_stdlib/sigs/seq.ml index ebd85a64b5e6..fc3e842f7caf 100644 --- a/src/lib_lwt_result_stdlib/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/sigs/seq.ml @@ -58,9 +58,9 @@ concurrently with a best-effort behaviour. *) module type S = sig - module Monad : Tezos_error_monad.Sig.MONAD + module Monad : Monad.S - open Monad + open Monad (* for [error] *) (** including the OCaml's {!Stdlib.Seq} module to share the {!Seq.t} type (including concrete definition) and to bring the existing functions. *) @@ -71,44 +71,55 @@ module type S = sig (** in-monad, preallocated empty/nil *) - val ok_empty : 'a t tzresult + val ok_empty : ('a t, out_error) result - val return_empty : 'a t tzresult Lwt.t + val return_empty : ('a t, out_error) result Lwt.t - val ok_nil : 'a node tzresult + val ok_nil : ('a node, out_error) result - val return_nil : 'a node tzresult Lwt.t + val return_nil : ('a node, out_error) result Lwt.t - (** Similar to {!fold_left} but wraps the traversal in {!tzresult}. The + (** Similar to {!fold_left} but wraps the traversal in {!result}. The traversal is interrupted if one of the step returns an [Error _]. *) - val fold_left_e : ('a -> 'b -> 'a tzresult) -> 'a -> 'b t -> 'a tzresult + val fold_left_e : + ('a -> 'b -> ('a, out_error) result) -> + 'a -> + 'b t -> + ('a, out_error) result (** Similar to {!fold_left} but wraps the traversing in {!Lwt}. Each step of the traversal is started after the previous one has resolved. The traversal is interrupted if one of the promise is rejected. *) val fold_left_s : ('a -> 'b -> 'a Lwt.t) -> 'a -> 'b t -> 'a Lwt.t - (** Similar to {!fold_left} but wraps the traversing in {!tzresult Lwt.t}. + (** Similar to {!fold_left} but wraps the traversing in [result Lwt.t]. Each step of the traversal is started after the previous one resolved. The traversal is interrupted if one of the step is rejected or is fulfilled with [Error _]. *) val fold_left_es : - ('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b t -> 'a tzresult Lwt.t + ('a -> 'b -> ('a, out_error) result Lwt.t) -> + 'a -> + 'b t -> + ('a, out_error) result Lwt.t - (** Similar to {!iter} but wraps the iteration in {!tzresult}. The iteration + (** Similar to {!iter} but wraps the iteration in {!result}. The iteration is interrupted if one of the step returns an [Error _]. *) - val iter_e : ('a -> unit tzresult) -> 'a t -> unit tzresult + val iter_e : + ('a -> (unit, out_error) result) -> 'a t -> (unit, out_error) result (** Similar to {!iter} but wraps the iteration in {!Lwt}. Each step of the iteration is started after the previous one resolved. The iteration is interrupted if one of the promise is rejected. *) val iter_s : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - (** Similar to {!iter} but wraps the iteration in {!tzresult Lwt.t}. Each step + (** Similar to {!iter} but wraps the iteration in [result Lwt.t]. Each step of the iteration is started after the previous one resolved. The iteration is interrupted if one of the promise is rejected of fulfilled with an [Error _]. *) - val iter_es : ('a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + val iter_es : + ('a -> (unit, out_error) result Lwt.t) -> + 'a t -> + (unit, out_error) result Lwt.t (** Similar to {!iter} but wraps the iteration in {!Lwt}. All the steps of the iteration are started concurrently. The promise [iter_p f s] @@ -117,7 +128,7 @@ module type S = sig them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t - (** Similar to {!iter} but wraps the iteration in {!tzresult Lwt.t}. All the + (** Similar to {!iter} but wraps the iteration in [result Lwt.t]. All the steps of the iteration are started concurrently. The promise [iter_ep] resolves once all the promises of the traversal resolve. At this point it either: @@ -125,9 +136,12 @@ module type S = sig - is fulfilled with [Error _] if at least one of the promises is, otherwise - is fulfilled with [Ok ()] if all the promises are. *) - val iter_ep : ('a -> unit tzresult Lwt.t) -> 'a t -> unit tzresult Lwt.t + val iter_ep : + ('a -> (unit, out_error) result Lwt.t) -> + 'a t -> + (unit, out_error) result Lwt.t - (** Similar to {!map} but wraps the transformation in {!tzresult}. The + (** Similar to {!map} but wraps the transformation in {!result}. The traversal is interrupted if any of the application returns an [Error _]. Note that, unlike {!map}, [map_e] is not lazy: it applies the @@ -135,7 +149,8 @@ module type S = sig is interrupted by an [Error _]) and does not terminate on infinite sequences (again, unless interrupted). Moreover [map_e] is not tail-recursive. *) - val map_e : ('a -> 'b tzresult) -> 'a t -> 'b t tzresult + val map_e : + ('a -> ('b, out_error) result) -> 'a t -> ('b t, out_error) result (** Similar to {!map} but wraps the transformation in {!Lwt}. Each transformation is done sequentially, only starting once the previous @@ -148,7 +163,7 @@ module type S = sig (again, unless interrupted). Moreover [map_s] is not tail-recursive. *) val map_s : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t - (** Similar to {!map} but wraps the transformation in {!tzresult Lwt.t}. Each + (** Similar to {!map} but wraps the transformation in [result Lwt.t]. Each transformation is done sequentially, only starting once the previous one has resolved. The traversal is interrupted if any of the promise is rejected or fulfilled with an [Error _]. @@ -158,7 +173,10 @@ module type S = sig interrupted by rejection or an [Error _]) and does not terminate on infinite sequences (again, unless interrupted). Moreover [map_es] is not tail-recursive. *) - val map_es : ('a -> 'b tzresult Lwt.t) -> 'a t -> 'b t tzresult Lwt.t + val map_es : + ('a -> ('b, out_error) result Lwt.t) -> + 'a t -> + ('b t, out_error) result Lwt.t (** Similar to {!map} but wraps the transformation in {!Lwt}. All the transformations are done concurrently. The promise [map_p f s] resolves @@ -171,7 +189,7 @@ module type S = sig *) val map_p : ('a -> 'b Lwt.t) -> 'a t -> 'b t Lwt.t - (** Similar to {!map} but wraps the transformation in {!tzresult Lwt}. All the + (** Similar to {!map} but wraps the transformation in [result Lwt]. All the transformations are done concurrently. The promise [map_p f s] resolves once all the promises of the traversal resolve. At this point it is rejected if any of the promises are, and otherwise it is resolved with @@ -182,13 +200,17 @@ module type S = sig transformation eagerly to all the elements of the sequence and does not terminate on infinite sequences. Moreover [map_p] is not tail-recursive. *) - val map_ep : ('a -> 'b tzresult Lwt.t) -> 'a t -> 'b t tzresult Lwt.t + val map_ep : + ('a -> ('b, out_error) result Lwt.t) -> + 'a t -> + ('b t, out_error) result Lwt.t - (** Similar to {!filter} but wraps the transformation in {!tzresult}. Note + (** Similar to {!filter} but wraps the transformation in [result]. Note that, unlike {!filter}, [filter_e] is not lazy: it applies the transformation immediately and does not terminate on infinite sequences. Moreover [filter_e] is not tail-recursive. *) - val filter_e : ('a -> bool tzresult) -> 'a t -> 'a t tzresult + val filter_e : + ('a -> (bool, out_error) result) -> 'a t -> ('a t, out_error) result (** Similar to {!filter} but wraps the transformation in {!Lwt.t}. Each test of the predicate is done sequentially, only starting once the @@ -197,25 +219,31 @@ module type S = sig infinite sequences. Moreover [filter_s] is not tail-recursive. *) val filter_s : ('a -> bool Lwt.t) -> 'a t -> 'a t Lwt.t - (** Similar to {!filter} but wraps the transformation in {!tzresult Lwt.t}. + (** Similar to {!filter} but wraps the transformation in [result Lwt.t]. Each test of the predicate is done sequentially, only starting once the previous one has resolved. Note that, unlike {!filter}, [filter_es] is not lazy: it applies the transformation immediately and does not terminate on infinite sequences. Moreover [filter_es] is not tail-recursive. *) - val filter_es : ('a -> bool tzresult Lwt.t) -> 'a t -> 'a t tzresult Lwt.t + val filter_es : + ('a -> (bool, out_error) result Lwt.t) -> + 'a t -> + ('a t, out_error) result Lwt.t - (** Similar to {!filter_map} but within [tzresult]. Not lazy and not + (** Similar to {!filter_map} but within [result]. Not lazy and not tail-recursive. *) - val filter_map_e : ('a -> 'b option tzresult) -> 'a t -> 'b t tzresult + val filter_map_e : + ('a -> ('b option, out_error) result) -> 'a t -> ('b t, out_error) result (** Similar to {!filter_map} but within [Lwt.t]. Not lazy and not tail-recursive. *) val filter_map_s : ('a -> 'b option Lwt.t) -> 'a t -> 'b t Lwt.t - (** Similar to {!filter_map} but within [tzresult Lwt.t]. Not lazy and not + (** Similar to {!filter_map} but within [result Lwt.t]. Not lazy and not tail-recursive. *) val filter_map_es : - ('a -> 'b option tzresult Lwt.t) -> 'a t -> 'b t tzresult Lwt.t + ('a -> ('b option, out_error) result Lwt.t) -> + 'a t -> + ('b t, out_error) result Lwt.t (** [find_first f t] is [Some x] where [x] is the first item in [t] such that [f x]. It is [None] if there are no such element. It does not terminate if @@ -223,14 +251,15 @@ module type S = sig val find_first : ('a -> bool) -> 'a t -> 'a option (** [find_first_e f t] is similar to {!find_first} but wraps the search within - {!tzresult}. Specifically, [find_first_e f t] is either + [result]. Specifically, [find_first_e f t] is either - [Ok (Some x)] if forall [y] before [x] [f y = Ok false] and [f x = Ok true], - [Error e] if there exists [x] such that forall [y] before [x] [f y = Ok false] and [f x = Error e], - [Ok None] otherwise and [t] is finite, - an expression that never returns otherwise. *) - val find_first_e : ('a -> bool tzresult) -> 'a t -> 'a option tzresult + val find_first_e : + ('a -> (bool, out_error) result) -> 'a t -> ('a option, out_error) result (** [find_first_s f t] is similar to {!find_first} but wrapped within [Lwt.t]. The search is identical to [find_first_e] but each @@ -238,8 +267,10 @@ module type S = sig val find_first_s : ('a -> bool Lwt.t) -> 'a t -> 'a option Lwt.t (** [find_first_es f t] is similar to {!find_first} but wrapped within - [tzresult Lwt.t]. The search is identical to [find_first_e] but each + [result Lwt.t]. The search is identical to [find_first_e] but each predicate is applied when the previous one has resolved. *) val find_first_es : - ('a -> bool tzresult Lwt.t) -> 'a t -> 'a option tzresult Lwt.t + ('a -> (bool, out_error) result Lwt.t) -> + 'a t -> + ('a option, out_error) result Lwt.t end diff --git a/src/lib_lwt_result_stdlib/sigs/set.ml b/src/lib_lwt_result_stdlib/sigs/set.ml index b08bfc3fa982..8646f5b2609e 100644 --- a/src/lib_lwt_result_stdlib/sigs/set.ml +++ b/src/lib_lwt_result_stdlib/sigs/set.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module type S = sig - type 'a tzresult + type error (* for substitution/constraint *) type elt @@ -58,26 +58,32 @@ module type S = sig val iter : (elt -> unit) -> t -> unit - val iter_e : (elt -> unit tzresult) -> t -> unit tzresult + val iter_e : (elt -> (unit, error) result) -> t -> (unit, error) result val iter_s : (elt -> unit Lwt.t) -> t -> unit Lwt.t val iter_p : (elt -> unit Lwt.t) -> t -> unit Lwt.t - val iter_es : (elt -> unit tzresult Lwt.t) -> t -> unit tzresult Lwt.t + val iter_es : + (elt -> (unit, error) result Lwt.t) -> t -> (unit, error) result Lwt.t - val iter_ep : (elt -> unit tzresult Lwt.t) -> t -> unit tzresult Lwt.t + val iter_ep : + (elt -> (unit, error) result Lwt.t) -> t -> (unit, error) result Lwt.t val map : (elt -> elt) -> t -> t val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - val fold_e : (elt -> 'a -> 'a tzresult) -> t -> 'a -> 'a tzresult + val fold_e : + (elt -> 'a -> ('a, error) result) -> t -> 'a -> ('a, error) result val fold_s : (elt -> 'a -> 'a Lwt.t) -> t -> 'a -> 'a Lwt.t val fold_es : - (elt -> 'a -> 'a tzresult Lwt.t) -> t -> 'a -> 'a tzresult Lwt.t + (elt -> 'a -> ('a, error) result Lwt.t) -> + t -> + 'a -> + ('a, error) result Lwt.t val for_all : (elt -> bool) -> t -> bool -- GitLab From e09afbc44887c23971a36bef03759fc9a182e659 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 4 Jun 2020 16:58:48 +0100 Subject: [PATCH 11/12] Lwtreslib: add documentation to sigs/monad.ml In particular, explain the difference between `in_error` and `out_error`. --- src/lib_lwt_result_stdlib/sigs/monad.ml | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/lib_lwt_result_stdlib/sigs/monad.ml b/src/lib_lwt_result_stdlib/sigs/monad.ml index 107b4ef0ee08..2af82478a70d 100644 --- a/src/lib_lwt_result_stdlib/sigs/monad.ml +++ b/src/lib_lwt_result_stdlib/sigs/monad.ml @@ -23,9 +23,30 @@ (* *) (*****************************************************************************) +(** Modules with the [S] signature are used to instantiate the other modules of + this library. [S] describes a generic Lwt-Result combined monad, the rest of + this library builds upon. *) module type S = sig + (** [in_error] are the errors as injected into the monad. In other words, + [in_error] is the type of values that are used in primitives that "raise" + an error. *) type in_error + (** [out_error] are the errors as received from the monad. In other words, + [out_error] is the type of values that are seen when matching on [Error _] + to, say, recover. + + The types [in_error] and [out_error] are kept separate (although they can + be equal) to support cases such as the following: + - [out_error] are richer than [in_error], such as by including a + timestamp, a filename, or some other such metadata. + - [out_error] is slightly different and [private] and [in_error] is simply + the type of argument to the functions that construct the private + [out_error]. + - [out_error] is a collection of [in_error] and additional functions (not + required by this library) allow additional manipulation. E.g., in the + case of Tezos: errors are built into traces that can be grown. + *) type out_error (** result monad *) -- GitLab From d8439a34d35d1bc647a8a5487ffca15f55c2e659 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 12/12] Error_monad: variants for parallel combinators {join,all,both}_{e,p,ep} --- src/lib_error_monad/monad_maker.ml | 34 ++++++++++++++--------- src/lib_error_monad/sig.ml | 23 ++++++++++++--- src/lib_lwt_result_stdlib/functors/seq.ml | 8 +++--- src/lib_lwt_result_stdlib/sigs/monad.ml | 21 ++++++++++++-- src/lib_p2p/test/process.ml | 8 +++--- 5 files changed, 66 insertions(+), 28 deletions(-) diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index 26fb20de5dee..8eee14d340bd 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -437,27 +437,29 @@ struct | h :: t -> fold_right_s f t init >>=? fun acc -> f h acc - let join ts = - let rec aux = function - | [] -> - ok_unit - | t :: ts -> - t >>? fun () -> aux ts - in - Lwt.all ts >|= aux + let join_p = Lwt.join + + let all_p = Lwt.all + + let both_p = Lwt.both - let all ts = + let rec join_e = function + | [] -> + 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 - Lwt.all ts >|= aux [] + aux [] ts - let both a b = - Lwt.both a b - >|= function + let both_e a b = + match (a, b) with | (Ok a, Ok b) -> Ok (a, b) | (Error err, Ok _) | (Ok _, Error err) -> @@ -466,6 +468,12 @@ struct (* 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 18ebd4f2b831..347de5dc1545 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -410,10 +410,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 : 'a tzresult Lwt.t list -> 'a list tzresult Lwt.t + val all_p : 'a Lwt.t list -> 'a list Lwt.t - val both : 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult 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_lwt_result_stdlib/functors/seq.ml b/src/lib_lwt_result_stdlib/functors/seq.ml index c74f9c68010a..c0ea1c04b5a2 100644 --- a/src/lib_lwt_result_stdlib/functors/seq.ml +++ b/src/lib_lwt_result_stdlib/functors/seq.ml @@ -86,7 +86,7 @@ struct let rec iter_p f seq acc = match seq () with | Nil -> - Lwt.join acc + join_p acc | Cons (item, seq) -> iter_p f seq (f item :: acc) in @@ -96,7 +96,7 @@ struct let rec iter_ep f seq acc = match seq () with | Nil -> - join acc + join_ep acc | Cons (item, seq) -> iter_ep f seq (f item :: acc) in @@ -130,10 +130,10 @@ struct map_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) let map_p f seq = - Lwt.all (fold_left (fun acc x -> f x :: acc) [] seq) >|= List.to_seq + all_p (fold_left (fun acc x -> f x :: acc) [] seq) >|= List.to_seq let map_ep f seq = - Monad.all (fold_left (fun acc x -> f x :: acc) [] seq) >|=? List.to_seq + all_ep (fold_left (fun acc x -> f x :: acc) [] seq) >|=? List.to_seq let rec filter_e f seq = match seq () with diff --git a/src/lib_lwt_result_stdlib/sigs/monad.ml b/src/lib_lwt_result_stdlib/sigs/monad.ml index 2af82478a70d..6920de28e070 100644 --- a/src/lib_lwt_result_stdlib/sigs/monad.ml +++ b/src/lib_lwt_result_stdlib/sigs/monad.ml @@ -118,13 +118,28 @@ module type S = sig ('a, out_error) result -> ('a -> 'b Lwt.t) -> ('b, out_error) result Lwt.t (** joins *) - val join : + val join_e : (unit, out_error) result list -> (unit, out_error) result + + val all_e : ('a, out_error) result list -> ('a list, out_error) result + + val both_e : + ('a, out_error) result -> + ('b, out_error) result -> + ('a * 'b, out_error) result + + 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 + + val join_ep : (unit, out_error) result Lwt.t list -> (unit, out_error) result Lwt.t - val all : + val all_ep : ('a, out_error) result Lwt.t list -> ('a list, out_error) result Lwt.t - val both : + val both_ep : ('a, out_error) result Lwt.t -> ('b, out_error) result Lwt.t -> ('a * 'b, out_error) result Lwt.t 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