diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index abcd9585ca2355c41f3ba76dab865a58eaa87451..581138fe4cfecb0d6fc1b75b448fcd5787680b08 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## @@ -886,6 +891,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/bin_client/main_client.ml b/src/bin_client/main_client.ml index 32c5fc0fa254676aed39eb9337a1ad8872e7504f..14c29a94a569abb3466b63ce8bff955eaaa9d59b 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_base/p2p_peer.mli b/src/lib_base/p2p_peer.mli index 7810d9add6cb72985adeeeda4f2c1a5aada04651..90db74a55fbd2f1f7cdaa103c0f8a6e7f547b6b3 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_clic/clic.ml b/src/lib_clic/clic.ml index e717ca18d9190b85f78b10fb527a35d61b092433..20ec7206631b0832b153f087243b99a1f0f1b2a6 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 65cc823287a68bf28746da19c1b7baa7032cf308..2004b0f2496371203c7d985ac272864c6775e574 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_crypto/dune b/src/lib_crypto/dune index cc86fd7b814309f0cd704bfcf4be661764a986b2..793b9a17e800637a0b03ae402aad12531065669e 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 7e4212b8f5e0557a2a7cad9b2b9010c676210092..268b1ef6d45a0c7ea2895d412193af639a9d7845 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 f7d5359f70d48633173d5be14862ca5018eed190..2a43d4d74d1a12bea5b51fa23a908269dfc6fdb4 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 3109fb2565f2356230e6880ac868632ec67656ea..cdc4ae0292ab7d22db95af9ed020335ae4c3cfbd 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_monad.ml b/src/lib_error_monad/error_monad.ml index 31e23872e7e505c6dd2b0377714f6b80035b6878..e6fd1df813ea5294d8ec1187d72ee82f1c2842c8 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 8ab19ed755e14244d425605041c290e2de47d5f8..6325b6707c6cee81a1652f191c2ea17f25b1fe12 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/error_table.ml b/src/lib_error_monad/error_table.ml deleted file mode 100644 index 6422e0fff378120a3c3e6268922889d51d64e18b..0000000000000000000000000000000000000000 --- 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 7594c352e52f901fadf59958ec7ff89290af1752..0000000000000000000000000000000000000000 --- 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/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index d0f4a5ed1cde43306491a938c72ce9a053af5ebd..8eee14d340bdd1b6081b4c69ca5a828ae9aafa69 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.( >|= ) @@ -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,42 @@ struct | h :: t -> fold_right_s f t init >>=? fun acc -> f h acc - let rec join = function + let join_p = Lwt.join + + let all_p = Lwt.all + + let both_p = Lwt.both + + let rec join_e = function | [] -> - return_unit - | t :: ts -> ( - t - >>= function - | Error _ as err -> - join ts >>=? fun () -> Lwt.return err - | Ok () -> - join ts ) + ok_unit + | t :: ts -> + t >>? fun () -> join_e ts + + let all_e ts = + let rec aux acc = function + | [] -> + Ok (List.rev acc) + | t :: ts -> + t >>? fun v -> aux (v :: acc) ts + in + aux [] ts + + let both_e a b = + match (a, b) with + | (Ok a, Ok b) -> + Ok (a, b) + | (Error err, Ok _) | (Ok _, Error err) -> + Error err + | (Error erra, Error errb) -> + (* Improve this once we improved the support for parallel traces *) + ignore errb ; Error erra + + let join_ep ts = all_p ts >|= join_e + + let all_ep ts = all_p ts >|= all_e + + let both_ep a b = both_p a b >|= fun (a, b) -> both_e a b let record_trace err result = match result with Ok _ as res -> res | Error errs -> Error (err :: errs) diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index 0eb0e5685512bc0a4830149ea70abd0b51429777..347de5dc1545577f6f41f7f715bbe64ad2e21642 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. @@ -389,10 +385,50 @@ 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 + (** A few aliases for Lwt functions *) + val join_p : unit Lwt.t list -> unit Lwt.t + + val all_p : 'a Lwt.t list -> 'a list Lwt.t + + val both_p : 'a Lwt.t -> 'b Lwt.t -> ('a * 'b) Lwt.t + + (** Similar functions in the error monad *) + val join_e : unit tzresult list -> unit tzresult + + val all_e : 'a tzresult list -> 'a list tzresult + + val both_e : 'a tzresult -> 'b tzresult -> ('a * 'b) tzresult + + (** Similar functions in the combined monad *) + val join_ep : unit tzresult Lwt.t list -> unit tzresult Lwt.t + + val all_ep : 'a tzresult Lwt.t list -> 'a list tzresult Lwt.t + + val both_ep : + 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t end diff --git a/src/lib_error_monad/test/dune b/src/lib_error_monad/test/dune deleted file mode 100644 index 34250ff973a66d39b71fc96a958c472e4ac80080..0000000000000000000000000000000000000000 --- 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_error_monad/tezos-error-monad.opam b/src/lib_error_monad/tezos-error-monad.opam index 53fa48272cb35f4c3f632dc9d717d7bbdad576f3..3df391ffb101ebde7c73410e9883f69a0aff9227 100644 --- a/src/lib_error_monad/tezos-error-monad.opam +++ b/src/lib_error_monad/tezos-error-monad.opam @@ -8,11 +8,11 @@ license: "MIT" depends: [ "tezos-tooling" { with-test } "dune" { >= "1.11" } + "ocaml" { >= "4.07" } "tezos-stdlib" "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_error_monad/test/.ocamlformat b/src/lib_lwt_result_stdlib/.ocamlformat similarity index 100% rename from src/lib_error_monad/test/.ocamlformat rename to src/lib_lwt_result_stdlib/.ocamlformat diff --git a/src/lib_lwt_result_stdlib/dune b/src/lib_lwt_result_stdlib/dune new file mode 100644 index 0000000000000000000000000000000000000000..bf5ef425ad8342c93ddc115febb0dcf59a48b577 --- /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 0000000000000000000000000000000000000000..f139b54d60939c562f4af88783f2af1fbba04c64 --- /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 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /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 0000000000000000000000000000000000000000..43330b85f435b34197da9a389ac8433e751ef7b2 --- /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)) + (libraries 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/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml new file mode 100644 index 0000000000000000000000000000000000000000..5674bddbf4fa2aa2946a23540e9059340d9c74ef --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -0,0 +1,140 @@ +(*****************************************************************************) +(* *) +(* 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 error := Seq.Monad.out_error + + 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 + + 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 + open Seq + open Seq.Monad + module T = Stdlib.Hashtbl.Make (H) + + type key = H.t + + type 'a t = ('a, Seq.Monad.out_error) result Lwt.t T.t + + let create n = T.create n + + let clear t = + T.iter (fun _ a -> Lwt.cancel a) t ; + T.clear t + + let reset t = + T.iter (fun _ a -> Lwt.cancel a) t ; + T.reset t + + let find_or_make t k make = + match T.find_opt t k with + | Some a -> + a + | None -> + 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 k + + let remove t 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 k + + 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) + + 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) + + 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 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 + init + + let length t = T.length t + + let stats t = T.stats 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 0000000000000000000000000000000000000000..39c5b7db0591da85bfad98fb22ce4b2d499b672e --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.mli @@ -0,0 +1,34 @@ +(*****************************************************************************) +(* *) +(* 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 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 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 new file mode 100644 index 0000000000000000000000000000000000000000..d5e43e1d51c5976014aa5f3ab0563106f0f035e6 --- /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 error := Seq.Monad.out_error + + 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 0000000000000000000000000000000000000000..423803dae6f124cc06290fd95e173bc269bfbdd0 --- /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 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 new file mode 100644 index 0000000000000000000000000000000000000000..c0ea1c04b5a27699917fe5630178d32c8f0c5026 --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/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. *) +(* *) +(*****************************************************************************) + +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 + + 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 -> + join_p 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_ep 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 = + all_p (fold_left (fun acc x -> f x :: acc) [] seq) >|= List.to_seq + + let map_ep f seq = + all_ep (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 0000000000000000000000000000000000000000..4e0911c165e3f7219bd8b66b3f6b4280f77035de --- /dev/null +++ b/src/lib_lwt_result_stdlib/functors/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. *) +(* *) +(*****************************************************************************) + +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 new file mode 100644 index 0000000000000000000000000000000000000000..5a10e59eb9ba145931f1961ec283b75050bc24e8 --- /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 error := Seq.Monad.out_error + + 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 0000000000000000000000000000000000000000..27f62475a57ce3eb971ab0d431e12ef4fb50a6ca --- /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 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/.ocamlformat b/src/lib_lwt_result_stdlib/lib/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /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 0000000000000000000000000000000000000000..989575c402caf06ae8282e4162c3213c43d641e4 --- /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/hashtbl.ml b/src/lib_lwt_result_stdlib/lib/hashtbl.ml new file mode 100644 index 0000000000000000000000000000000000000000..13033733a7702ccfece8ceb069ff2e437a92db45 --- /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 0000000000000000000000000000000000000000..e814f6a146c5255541d3d9badfb6aa63fc95a71c --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.mli @@ -0,0 +1,33 @@ +(*****************************************************************************) +(* *) +(* 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 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 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.ml b/src/lib_lwt_result_stdlib/lib/map.ml new file mode 100644 index 0000000000000000000000000000000000000000..634fa4b2dc02df4c963f43ecfc6590cb998ed976 --- /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 0000000000000000000000000000000000000000..a6a303cfd6642aed7eea1ea96d664a44134ab1c1 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/map.mli @@ -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 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 new file mode 100644 index 0000000000000000000000000000000000000000..4cf2b6719061af6f98cd0f19489c4312c6c04c58 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/seq.ml @@ -0,0 +1,32 @@ +(*****************************************************************************) +(* *) +(* 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 (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 new file mode 100644 index 0000000000000000000000000000000000000000..d229db7c407700b4c9615b2188ed86d210bca419 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/seq.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. *) +(* *) +(*****************************************************************************) + +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.ml b/src/lib_lwt_result_stdlib/lib/set.ml new file mode 100644 index 0000000000000000000000000000000000000000..81203765bec47ca6ee64b57b8b7164a995eb75fe --- /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 0000000000000000000000000000000000000000..a9fae50ff21757fc499e8eaea06e4094b569cb61 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lib/set.mli @@ -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 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/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml new file mode 100644 index 0000000000000000000000000000000000000000..a40eb489f321b197f2df4b162e9a0ee62c44b9f7 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -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 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 new file mode 100644 index 0000000000000000000000000000000000000000..4f2865c1862c0f6b5bdf0f46b159051490fd96c1 --- /dev/null +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -0,0 +1,54 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** [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 + +module Map : module type of Lib.Map + +module Hashtbl : module type of Lib.Hashtbl diff --git a/src/lib_lwt_result_stdlib/sigs/.ocamlformat b/src/lib_lwt_result_stdlib/sigs/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /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 0000000000000000000000000000000000000000..b7c0d48a5e7d0860b316c321aad6b3b42b3a2e81 --- /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)) + (libraries 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/hashtbl.ml b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml new file mode 100644 index 0000000000000000000000000000000000000000..846fc42e10922f01cf68979bb30dd2b583ffb489 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -0,0 +1,206 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** 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 error + + 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, error) result) -> 'a t -> (unit, error) result + + val iter_es : + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t + + val iter_ep : + (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, 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, error) result) -> 'a t -> 'b -> ('b, error) result + + val fold_es : + (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> + 'a t -> + 'b -> + ('b, error) result 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 + +(** 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 error + + 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, error) result Lwt.t) -> + ('a, error) result Lwt.t + + val remove : 'a t -> key -> unit + + val find : 'a t -> key -> ('a, error) result Lwt.t option + + val mem : 'a t -> key -> bool + + val iter_es : + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t + + val iter_ep : + (key -> 'a -> (unit, error) result Lwt.t) -> + 'a t -> + (unit, error) result Lwt.t + + val fold_es : + (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, error) result 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/sigs/map.ml b/src/lib_lwt_result_stdlib/sigs/map.ml new file mode 100644 index 0000000000000000000000000000000000000000..3e73e329237446319a33e67bbd775b351ce78871 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/map.ml @@ -0,0 +1,145 @@ +(*****************************************************************************) +(* *) +(* 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 error (* for substitution/constraint *) + + 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, error) result) -> 'a t -> (unit, error) result + + 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, 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, 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, error) result) -> 'a t -> 'b -> ('b, error) result + + 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, error) result Lwt.t) -> + 'a t -> + 'b -> + ('b, error) result 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/monad.ml b/src/lib_lwt_result_stdlib/sigs/monad.ml new file mode 100644 index 0000000000000000000000000000000000000000..6920de28e07017ad5b646f5ea82051107cf4f020 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/monad.ml @@ -0,0 +1,146 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** 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 *) + + 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_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_ep : + ('a, out_error) result Lwt.t list -> ('a list, out_error) result Lwt.t + + val both_ep : + ('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 new file mode 100644 index 0000000000000000000000000000000000000000..fc3e842f7cafe662dbe4f1bb0d1d8c4b2478069c --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/seq.ml @@ -0,0 +1,276 @@ +(*****************************************************************************) +(* *) +(* 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 : Monad.S + + 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. *) + 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, out_error) result + + val return_empty : ('a t, out_error) result Lwt.t + + val ok_nil : ('a node, out_error) result + + val return_nil : ('a node, out_error) result Lwt.t + + (** 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, 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 [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, out_error) result Lwt.t) -> + 'a -> + 'b t -> + ('a, out_error) result Lwt.t + + (** 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, 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 [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, 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] + 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 [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: + - 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, out_error) result Lwt.t) -> + 'a t -> + (unit, out_error) result Lwt.t + + (** 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 + 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, 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 + 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 [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 _]. + + 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, 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 + 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 [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 + [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, out_error) result Lwt.t) -> + 'a t -> + ('b t, out_error) result Lwt.t + + (** 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, 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 + 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 [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, out_error) result Lwt.t) -> + 'a t -> + ('a t, out_error) result Lwt.t + + (** Similar to {!filter_map} but within [result]. Not lazy and not + tail-recursive. *) + 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 [result Lwt.t]. Not lazy and not + tail-recursive. *) + val filter_map_es : + ('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 + 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 + [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, 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 + 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 + [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, 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 new file mode 100644 index 0000000000000000000000000000000000000000..8646f5b2609edf1550e351c9764062f93771be84 --- /dev/null +++ b/src/lib_lwt_result_stdlib/sigs/set.ml @@ -0,0 +1,123 @@ +(*****************************************************************************) +(* *) +(* 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 error (* for substitution/constraint *) + + 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, 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, error) result Lwt.t) -> t -> (unit, error) result 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, 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, error) result Lwt.t) -> + t -> + 'a -> + ('a, error) result 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/test/.ocamlformat b/src/lib_lwt_result_stdlib/test/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /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 0000000000000000000000000000000000000000..2eaac865f2858267d80f73732ea31457b1d6006e --- /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 942999e18c3ca452cf650e89bcfbea0658902499..9808047f16005bd62a9728ddf4e3f05310b9e4db 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,88 @@ 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 + 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 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 +137,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 +184,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 new file mode 100644 index 0000000000000000000000000000000000000000..6fb5f31fa4f55c8beb29b2a71e955e2c374164a7 --- /dev/null +++ b/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam @@ -0,0 +1,20 @@ +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" + "alcotest-lwt" { with-test & >= "1.1.0" } +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] +synopsis: "Tezos: error-aware stdlib replacement" diff --git a/src/lib_p2p/test/process.ml b/src/lib_p2p/test/process.ml index 7a4bdb1d85f4622acca09499461fabd770501153..3c57ddd8a3b5124fb9ebcd18a8d810200ad9fb2d 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 !" diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index dc9cffd533d45534b48ee282576f05e16849d346..7a5e890f48ca0cbc27c408bd38d22d96d4dc0aca 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 36b58bb379ecc3c1244633fdbcb0d586ba632c9f..52ea0dfbf8a1d19635535c1b333c72059db1b3cb 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_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index 68ce570163b2e56b4ca75c3ad522062d77363f83..099e3163ead08a0e9593ad6f06340bb189c31df5 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 -> diff --git a/src/lib_signer_backends/unix/with_ledger.ml b/src/lib_signer_backends/unix/with_ledger.ml index 0fdd1212ceef30aeab8223441f25ddc57a671bee..e0036acae38f605d2eb40d9c2da9d78410442f3b 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 a2d853369d199cf89084848cd7a300e9777c07cb..32656ded1b594ed8c54d9841ef34734ab6478492 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 17fbb49634b1db4d546badcff52c02bb442fe897..6471228c7b89f0f0b5b2ef611cd970775471d89c 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 46b35a1830997f9b2c81eef125f9c2d42a0a4f17..64b5ef586c36a5139982cdbbac694bdcaaf50186 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 ece0796c6f127e43c1ac5c7cc616aa17a3d1b4fd..6d47e8b8d074fa38502235676d3d0f0b3596f9fe 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 b36644df4fdda402a89470eea46636e2f7aff6a7..56d92a5158604de48ab167af4027b3f7ebeb08b8 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 11de707be2430fb693e114a2a3682dceacd38d26..f66c04e03ba3f5b8badc21745769bd1835f26ee3 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 ece0796c6f127e43c1ac5c7cc616aa17a3d1b4fd..6d47e8b8d074fa38502235676d3d0f0b3596f9fe 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 b36644df4fdda402a89470eea46636e2f7aff6a7..56d92a5158604de48ab167af4027b3f7ebeb08b8 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 b64a4fc6910e45fce1812ec22cb00ab77ef1eb35..77c79e43848f5f6ec409a066a41a3091c7aadefe 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}