diff --git a/src/lib_base/dune b/src/lib_base/dune index 513e9a729c4e3a6fd1e301e7e61238ac37fab484..34a91adc80854ea9c53fe9ea425b193a7b7fe600 100644 --- a/src/lib_base/dune +++ b/src/lib_base/dune @@ -5,7 +5,7 @@ -open Tezos_crypto -open Data_encoding -open Tezos_error_monad - -open Tezos_lwt_result_stdlib.Lwtreslib + -open Tezos_error_monad.TzLwtreslib -open Tezos_rpc -open Tezos_clic -open Tezos_micheline @@ -15,7 +15,6 @@ tezos-crypto data-encoding tezos-error-monad - tezos-lwt-result-stdlib tezos-event-logging tezos-rpc tezos-clic diff --git a/src/lib_base/p2p_peer.mli b/src/lib_base/p2p_peer.mli index 90db74a55fbd2f1f7cdaa103c0f8a6e7f547b6b3..1ee648ac8906ab402cc10e0c5caf4d929b98c3b8 100644 --- a/src/lib_base/p2p_peer.mli +++ b/src/lib_base/p2p_peer.mli @@ -29,7 +29,7 @@ module Set = Id.Set module Table = Id.Table module Error_table : - Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.S_LWT with type key = Table.key + Tezos_error_monad.TzLwtreslib.Hashtbl.S_ES with type key = Table.key module Filter : sig type t = Accepted | Running | Disconnected diff --git a/src/lib_base/tezos-base.opam b/src/lib_base/tezos-base.opam index cd328561e97bacfd651e41b6dba42e9f9109cefb..d147edffde1ad0e23dae23ffe6b9651a35ceeae2 100644 --- a/src/lib_base/tezos-base.opam +++ b/src/lib_base/tezos-base.opam @@ -12,7 +12,6 @@ depends: [ "tezos-crypto" "data-encoding" { >= "0.3" & < "0.4" } "tezos-error-monad" - "tezos-lwt-result-stdlib" "tezos-event-logging" "tezos-micheline" "tezos-rpc" diff --git a/src/lib_base/tzPervasives.ml b/src/lib_base/tzPervasives.ml index 766d6c7e71372bc6aa752b8919ea7591d7573cd4..838cd4bca718722bd8343d94e075c36b1ea3334e 100644 --- a/src/lib_base/tzPervasives.ml +++ b/src/lib_base/tzPervasives.ml @@ -30,25 +30,18 @@ include Tezos_clic include Tezos_crypto include Tezos_micheline module Data_encoding = Data_encoding -module Seq = Tezos_lwt_result_stdlib.Lwtreslib.Seq -module Map = Tezos_lwt_result_stdlib.Lwtreslib.Map -module Set = Tezos_lwt_result_stdlib.Lwtreslib.Set -module Hashtbl = Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl -module Option = Tezos_lwt_result_stdlib.Lwtreslib.Option +include Tezos_error_monad.TzLwtreslib module List = struct include Tezos_stdlib.TzList - include Tezos_lwt_result_stdlib.Lwtreslib.List + include Tezos_error_monad.TzLwtreslib.List end -module Result = Tezos_lwt_result_stdlib.Lwtreslib.Result -module WithExceptions = Tezos_lwt_result_stdlib.Lwtreslib.WithExceptions - module String = struct include String include Tezos_stdlib.TzString - module Hashtbl = Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.MakeSeeded (struct + module Hashtbl = Tezos_error_monad.TzLwtreslib.Hashtbl.MakeSeeded (struct type t = string let equal = String.equal diff --git a/src/lib_base/tzPervasives.mli b/src/lib_base/tzPervasives.mli index 42aad18d2b8ed5c3466a00f9cc05350a7da4345c..40c8e6dc069de7a5b8ba6ad3a3ecfdc5850b3ad6 100644 --- a/src/lib_base/tzPervasives.mli +++ b/src/lib_base/tzPervasives.mli @@ -38,28 +38,22 @@ include module type of Tezos_clic include module type of Tezos_crypto module Data_encoding = Data_encoding -module Seq = Tezos_lwt_result_stdlib.Lwtreslib.Seq -module Map = Tezos_lwt_result_stdlib.Lwtreslib.Map -module Set = Tezos_lwt_result_stdlib.Lwtreslib.Set -module Hashtbl = Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl -module Option = Tezos_lwt_result_stdlib.Lwtreslib.Option + +include module type of Tezos_error_monad.TzLwtreslib module List : sig include module type of Tezos_stdlib.TzList - include module type of Tezos_lwt_result_stdlib.Lwtreslib.List + include module type of Tezos_error_monad.TzLwtreslib.List end -module Result = Tezos_lwt_result_stdlib.Lwtreslib.Result -module WithExceptions = Tezos_lwt_result_stdlib.Lwtreslib.WithExceptions - module String : sig include module type of String include module type of Tezos_stdlib.TzString module Hashtbl : - Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.SeededS with type key = t + Tezos_error_monad.TzLwtreslib.Hashtbl.SeededS with type key = t end module Time = Time diff --git a/src/lib_base/unix/socket.ml b/src/lib_base/unix/socket.ml index 7dd34bd78538274c92ab4d2bb0669818b788ae15..148efc44943ed0e97307289811aeb9c3455db0eb 100644 --- a/src/lib_base/unix/socket.ml +++ b/src/lib_base/unix/socket.ml @@ -112,7 +112,7 @@ let bind ?(backlog = 10) = function Lwt_unix.listen sock backlog ; return sock in - Tezos_lwt_result_stdlib.Lwtreslib.List.map_es do_bind addrs ) + Tezos_error_monad.TzLwtreslib.List.map_es do_bind addrs ) (* To get the encoding/decoding errors into scope. *) open Data_encoding_wrapper diff --git a/src/lib_clic/dune b/src/lib_clic/dune index 5108619e722668e7d4ff0149abe24554740febc1..5895260415f0b23c833eaac1a5ca2faed7744d18 100644 --- a/src/lib_clic/dune +++ b/src/lib_clic/dune @@ -3,7 +3,7 @@ (public_name tezos-clic) (flags (:standard -open Tezos_stdlib -open Tezos_error_monad - -open Tezos_lwt_result_stdlib.Lwtreslib + -open Tezos_error_monad.TzLwtreslib )) (libraries tezos-stdlib lwt diff --git a/src/lib_clic/unix/dune b/src/lib_clic/unix/dune index 8d472a1c8dd46ee78f31d0bc8a16c8bf015420ea..7682228f3362aabc876ec8551fe099f816ba051c 100644 --- a/src/lib_clic/unix/dune +++ b/src/lib_clic/unix/dune @@ -4,7 +4,7 @@ (flags (:standard -open Tezos_stdlib -open Tezos_clic -open Tezos_error_monad - -open Tezos_lwt_result_stdlib.Lwtreslib + -open Tezos_error_monad.TzLwtreslib )) (libraries tezos-clic tezos-stdlib-unix diff --git a/src/lib_crypto/dune b/src/lib_crypto/dune index 0c13bc2dc1e4d33658f716a48650e3f16f1dd56c..7c369509ae377f80bbed3750e7478bc6f5db14fd 100644 --- a/src/lib_crypto/dune +++ b/src/lib_crypto/dune @@ -4,7 +4,7 @@ (flags (:standard -open Tezos_stdlib -open Data_encoding -open Tezos_error_monad - -open Tezos_lwt_result_stdlib.Lwtreslib + -open Tezos_error_monad.TzLwtreslib -open Tezos_rpc)) (libraries data-encoding tezos-lwt-result-stdlib diff --git a/src/lib_crypto/helpers.ml b/src/lib_crypto/helpers.ml index e1be57168f1dcf5b897fddc7b8080378dc6dbb25..1e84160d81b125d9b8f4e4a60f3c18d0f5f11e6d 100644 --- a/src/lib_crypto/helpers.ml +++ b/src/lib_crypto/helpers.ml @@ -261,7 +261,7 @@ struct end module Error_table = struct - include Hashtbl.Make_Lwt (H) + include Tezos_error_monad.TzLwtreslib.Hashtbl.Make_es (H) end module WeakRingTable = struct diff --git a/src/lib_crypto/s.ml b/src/lib_crypto/s.ml index 90f128c6fb18c2ea7d09398be4d64772b268eba1..f71e8f896e4acc28bd90a53add8bed61a901985b 100644 --- a/src/lib_crypto/s.ml +++ b/src/lib_crypto/s.ml @@ -228,7 +228,7 @@ module type INDEXES = sig end module Error_table : sig - include Tezos_lwt_result_stdlib.Lwtreslib.Hashtbl.S_LWT with type key = t + include Tezos_error_monad.TzLwtreslib.Hashtbl.S_ES with type key = t end module WeakRingTable : sig diff --git a/src/lib_crypto/test/dune b/src/lib_crypto/test/dune index f577a8fa13ac4af7fce5620ab5e13ef649f7cf81..76c6efcdd72a8eadb41d26dba5fe921aecb429bd 100644 --- a/src/lib_crypto/test/dune +++ b/src/lib_crypto/test/dune @@ -20,7 +20,7 @@ crowbar) (flags (:standard -open Tezos_stdlib -open Tezos_crypto - -open Tezos_lwt_result_stdlib.Lwtreslib + -open Tezos_error_monad.TzLwtreslib -open Data_encoding))) (rule diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.ml b/src/lib_error_monad/TzLwtreslib.ml similarity index 93% rename from src/lib_lwt_result_stdlib/lib/hashtbl.ml rename to src/lib_error_monad/TzLwtreslib.ml index 13033733a7702ccfece8ceb069ff2e437a92db45..42dddd570828dc261aaba70116dc368b2b5c3b67 100644 --- a/src/lib_lwt_result_stdlib/lib/hashtbl.ml +++ b/src/lib_error_monad/TzLwtreslib.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) +(* Copyright (c) 2021 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Functors.Hashtbl.Make (Seq) +include Tezos_lwt_result_stdlib.Lwtreslib.Traced (TzTrace) diff --git a/src/lib_error_monad/TzLwtreslib.mli b/src/lib_error_monad/TzLwtreslib.mli new file mode 100644 index 0000000000000000000000000000000000000000..8be42ef5a62cec4b15d6ce2d45a5b3d0a10de9ac --- /dev/null +++ b/src/lib_error_monad/TzLwtreslib.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 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 module type of Tezos_lwt_result_stdlib.Lwtreslib.Traced (TzTrace) diff --git a/src/lib_error_monad/TzTrace.ml b/src/lib_error_monad/TzTrace.ml index 92d4d91772ebeb07ddc55154b6a349dac1f3b41a..9999830cd4b903ddb3117d6f52887624b9f7fd7a 100644 --- a/src/lib_error_monad/TzTrace.ml +++ b/src/lib_error_monad/TzTrace.ml @@ -30,10 +30,14 @@ let make err = [err] let cons err trace = err :: trace +let cons_list err errs = err :: errs + (* This is temporary. Eventually, the traces might have a more structured semantic. *) let conp trace _trace = trace +let conp_list tr _trs = tr + let pp_print pp_error ppf = function | [] -> assert false diff --git a/src/lib_error_monad/dune b/src/lib_error_monad/dune index 66e4e08aa9e4b6d0c1a1a84138f454f6a86cf143..0fe721047cd14222e2473c9c8b1d9033a399c0b6 100644 --- a/src/lib_error_monad/dune +++ b/src/lib_error_monad/dune @@ -7,7 +7,9 @@ (libraries tezos-stdlib data-encoding lwt-canceler - lwt)) + lwt + tezos-lwt-result-stdlib + )) (rule (alias runtest_lint) diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index c4e68def9fd18a8f849405f17f5eb33f4de59865..85895a8c15478c96f815f45d405d79f6fdfa7e22 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -185,9 +185,33 @@ module type TRACE = sig | Ok handle -> Ok handle | Error error -> Error (cons error trace) ] - *) + + When you are within the error monad itself, you should build traces using + the [record_trace], [trace], [record_trace_eval] and [trace_eval] + functions directly. You should rarely need to build traces manually using + [cons]. This here function can be useful in the case where you are at the + interface of the error monad. *) val cons : 'error -> 'error trace -> 'error trace + (** [cons_list error errors] is the sequential composition of all the errors + passed as parameters. It is equivalent to folding [cons] over + [List.rev error :: errors] but more efficient. + + Note that [error] and [errors] are separated as parameters to enforce that + empty traces cannot be constructed. The recommended use is: +{[ + match all_errors with + | [] -> Ok () (* or something else depending on the context *) + | error :: errors -> Error (cons_list error errors) +]} + + When you are within the error monad itself, you should build traces using + the [record_trace], [trace], [record_trace_eval] and [trace_eval] + functions directly. You should rarely need to build traces manually using + [cons_list]. This here function can be useful in the case where you are at + the interface of the error monad. *) + val cons_list : 'error -> 'error list -> 'error trace + (** [conp t1 t2] (construct parallel) construct a parallel trace. This is for tracing events/failure/things that happen concurrently, in parallel, or simply independently of each other. E.g., @@ -200,9 +224,31 @@ module type TRACE = sig | Error trace, Ok _ | Ok _, Error trace -> Error trace | Error trace1, Error trace2 -> Error (conp trace1 trace2) ] - *) + + When you are within the error monad itself, you should rarely need to + build traces manually using [conp]. The result-concurrent traversors will + return parallel traces when appropriate, and so will [join_e], [join_ep], + [both_e], [both_ep], [all_e] and [all_ep]. *) val conp : 'error trace -> 'error trace -> 'error trace + (** [conp_list trace traces] is the parallel composition of all the traces + passed as parameters. It is equivalent to [List.fold_left conp trace traces] + but more efficient. + + Note that [trace] and [traces] are separated as parameters to enforce that + empty traces cannot be constructed. The recommended use is: +{[ + match all_traces with + | [] -> Ok () (* or something else depending on the context *) + | trace :: traces -> Error (conp_list trace traces) +]} + + When you are within the error monad itself, you should rarely need to + build traces manually using [conp]. The result-concurrent traversors will + return parallel traces when appropriate, and so will [join_e], [join_ep], + [both_e], [both_ep], [all_e] and [all_ep]. *) + val conp_list : 'err trace -> 'err trace list -> 'err trace + (** [pp_print] pretty-prints a trace of errors *) val pp_print : (Format.formatter -> 'err -> unit) -> diff --git a/src/lib_error_monad/tezos-error-monad.opam b/src/lib_error_monad/tezos-error-monad.opam index fc379ace09dce3e9f464011b7df53e008c354286..432fb52e294e7506b3c3ba73c31faf894cd0816e 100644 --- a/src/lib_error_monad/tezos-error-monad.opam +++ b/src/lib_error_monad/tezos-error-monad.opam @@ -13,6 +13,7 @@ depends: [ "data-encoding" { >= "0.3" & < "0.4" } "lwt" "lwt-canceler" { >= "0.3" & < "0.4" } + "tezos-lwt-result-stdlib" "alcotest-lwt" { with-test & >= "1.1.0" } ] build: [ diff --git a/src/lib_event_logging/dune b/src/lib_event_logging/dune index 53b5bd298993feec7e358df7fdaf0808454d6c4f..0c4375f9db67e434569cf77074d414b63a063c54 100644 --- a/src/lib_event_logging/dune +++ b/src/lib_event_logging/dune @@ -4,7 +4,7 @@ (flags (:standard -open Tezos_stdlib -open Data_encoding -open Tezos_error_monad - -open Tezos_lwt_result_stdlib.Lwtreslib + -open Tezos_error_monad.TzLwtreslib )) (libraries tezos-stdlib data-encoding diff --git a/src/lib_lwt_result_stdlib/README.md b/src/lib_lwt_result_stdlib/README.md new file mode 100644 index 0000000000000000000000000000000000000000..d0253548a5f71d199bfa8b6b4a7cb6925cbfe2b3 --- /dev/null +++ b/src/lib_lwt_result_stdlib/README.md @@ -0,0 +1,83 @@ +# Lwtreslib: an Lwt- and Result-friendly addition/replacement for the Stdlib + +The OCaml's Stdlib modules are orthogonal: each define their own datatype and a +set of functions operating on this datatype. `Result` for `result`, `Option` +for `option`, `List` for `list`, etc. This orthogonality provides a high +expressive power for a low lines-of-code count. E.g., + +``` +let fold f init xs = + List.fold_left + (fun acc x -> Result.bind acc (fun acc -> f acc x)) + (Result.ok init) + xs +``` + +However, in code-bases that make heavy uses of some datatypes, a little more +integration is welcome. For example, in code bases that use the `result` type +pervasively, the `fold` function above should be available in a module of +list-traversing functions. + +Lwtreslib is a library that supplement some of the OCaml's Stdlib modules with a +tight integration of Lwt and Result. It focuses on data-structures that can be +traversed (iterated, mapped, folded, what have you). + + +## Design principles + +1. Exception-safety + + The functions exported by Lwtreslib do not raise exceptions. These functions + may return `option` or `result` to indicate that some error happened during + traversal, and they may propagate `result`. + + (For convenience, the module `WithExceptions` provides a few + exception-raising functions because they are convenient in specific + contexts.) + +2. Consistency + + Exported functions and values have consistent names that reflect their + consistent semantic. + + +## Reading guide + +The sources of Lwtreslib are organised as follow: + +- `bare/` contains the sources for a bare-bones implementation of Lwtreslib that + provides monadic combinators and collection traversals. + + - `bare/sigs/` contains the sources for the signatures of all the modules + exported by `bare/` + - `bare/functor_outputs` contains the sources for the signatures of all the + modules constructed by functors exported by `bare/` + - `bare/structs` contains the sources for of all the modules exported by + `bare/` + +- `examples/traces/` contains multiple example implementation of traces. A trace + is a data-structure that holds multiple errors organised in a way that + reflects the way the errors happened. Specifically, errors can be stringed + together to represent that the control flow traversed multiple points, or they + can be held side-by-side to indicate that they happen in to simultaneously + evaluating promises. + + The code in this directory is meant more as examples than fully-fledged + traces, but they can also be used for prototyping or as a basis for a more + complete trace implementation. + +- `traced/` contains the sources for a trace-enabled implementation of Lwtreslib + that provides monadic combinators and collection traversals. This + implementation provides all the functionality of `bare/` with added support + for traces (i.e., structured collections of errors). + + - `traced/sigs/` contains the sources for the signatures of all the modules + exported by `traced/` + - `traced/functor_outputs` contains the sources for the signatures of all + the modules constructed by functors exported by `bare/` + - `traced/structs` contains the sources for of all the modules exported by + `bare/`. These modules are functorised over the implementation of a trace. + The file `traced/structs/structs.ml` contains an all-in-one functor for + instantiating all of the modules. + +- `test/` contains code to test the library. diff --git a/src/lib_lwt_result_stdlib/functors/.ocamlformat b/src/lib_lwt_result_stdlib/bare/.ocamlformat similarity index 100% rename from src/lib_lwt_result_stdlib/functors/.ocamlformat rename to src/lib_lwt_result_stdlib/bare/.ocamlformat diff --git a/src/lib_lwt_result_stdlib/lib/.ocamlformat b/src/lib_lwt_result_stdlib/bare/functor_outputs/.ocamlformat similarity index 100% rename from src/lib_lwt_result_stdlib/lib/.ocamlformat rename to src/lib_lwt_result_stdlib/bare/functor_outputs/.ocamlformat diff --git a/src/lib_lwt_result_stdlib/sigs/dune b/src/lib_lwt_result_stdlib/bare/functor_outputs/dune similarity index 61% rename from src/lib_lwt_result_stdlib/sigs/dune rename to src/lib_lwt_result_stdlib/bare/functor_outputs/dune index e02303d211d63846da51daaa9980c4541ffc2d96..f9700863b24c06b42165dfeb10ec91afd03ac77a 100644 --- a/src/lib_lwt_result_stdlib/sigs/dune +++ b/src/lib_lwt_result_stdlib/bare/functor_outputs/dune @@ -1,7 +1,6 @@ (library - (name sigs) - (public_name tezos-lwt-result-stdlib.sigs) - (flags (:standard)) + (name bare_functor_outputs) + (public_name tezos-lwt-result-stdlib.bare.functor-outputs) (libraries lwt)) (rule diff --git a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/bare/functor_outputs/hashtbl.ml similarity index 83% rename from src/lib_lwt_result_stdlib/sigs/hashtbl.ml rename to src/lib_lwt_result_stdlib/bare/functor_outputs/hashtbl.ml index e49a2564715606aaf1bfe5c3cf8e64c392c61a5c..e70eb141dc7462a5adce5fbc13c7f271f745519a 100644 --- a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/bare/functor_outputs/hashtbl.ml @@ -23,12 +23,15 @@ (* *) (*****************************************************************************) -(** Hashtbls 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. *) +(** Hashtables with the signature [S] are exception-safe replacements for + hashtables with the {!Stdlib.Hashtbl.S} signature with Lwt- and result-aware + traversal functions. + + See {!Lwtreslib}'s introductory documentation for explanations regarding + [_e]-, [_s]-, [_es]-, [_p]-, and [_ep]-suffixed functions and exception + safety. See {!Stdlib.Hashtbl.S} for explanations regarding OCaml's + hashtables in general. *) module type S = sig - type 'error trace - type key type 'a t @@ -68,9 +71,9 @@ module type S = sig (unit, 'trace) result Lwt.t val iter_ep : - (key -> 'a -> (unit, 'error trace) result Lwt.t) -> + (key -> 'a -> (unit, 'error) result Lwt.t) -> 'a t -> - (unit, 'error trace) result Lwt.t + (unit, 'error list) result Lwt.t val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit @@ -109,9 +112,15 @@ module type S = sig val of_seq : (key * 'a) Stdlib.Seq.t -> 'a t end -module type SeededS = sig - type 'error trace +(** Hashtables with the signature [SeededS] are exception-safe replacements for + hashtables with the {!Stdlib.Hashtbl.SeededS} signature with Lwt- and + result-aware traversal functions. + See {!Lwtreslib}'s introductory documentation for explanations regarding + [_e]-, [_s]-, [_es]-, [_p]-, and [_ep]-suffixed functions and exception + safety. See {!Stdlib.Hashtbl.SeededS} for explanations regarding OCaml's + seeded hashtables in general. *) +module type SeededS = sig type key type 'a t @@ -152,9 +161,9 @@ module type SeededS = sig (unit, 'trace) result Lwt.t val iter_ep : - (key -> 'a -> (unit, 'error trace) result Lwt.t) -> + (key -> 'a -> (unit, 'error) result Lwt.t) -> 'a t -> - (unit, 'error trace) result Lwt.t + (unit, 'error list) result Lwt.t val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit @@ -193,7 +202,7 @@ module type SeededS = sig val of_seq : (key * 'a) Stdlib.Seq.t -> 'a t end -(** Modules with the signature [S_LWT] are Hashtbl-like with the following +(** Hashtables with the signature [S_ES] are Hashtbl-like with the following differences: First, the module exports only a few functions in an attempt to limit the @@ -209,34 +218,34 @@ end 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 (length t = 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 (length t = 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 (length t = 1) in - - (* when the original promise errors, the binding is removed *) - let () = Lwt.wakeup r (Error ..) in - let () = assert (length t = 0) in - - (* and both [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 - ] +{[ +(* setup *) +let t = create 256 in +let () = assert (length t = 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 (length t = 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 (length t = 1) in + +(* when the original promise errors, the binding is removed *) +let () = Lwt.wakeup r (Error ..) in +let () = assert (length t = 0) in + +(* and both [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). @@ -246,9 +255,7 @@ end 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 trace - +module type S_ES = sig type key type ('a, 'trace) t @@ -293,8 +300,8 @@ module type S_LWT = sig Specifically, for each binding [(k, p)] it waits for [p] to be fulfilled with [Ok v] and calls [f k v]. If [p] fulfills with [Error _] or is - rejected, then no call is made for this binding. Note however that an - [Error]/rejection in one promise returned by [f] interrupts the + rejected, then no call to [f] is made for this binding. Note however that + an [Error]/rejection in one promise returned by [f] interrupts the iteration. It processes bindings one after the other: it waits for both the bound @@ -318,9 +325,9 @@ module type S_LWT = sig It processes all bindings concurrently: it concurrently waits for all the bound promises to resolve and calls [f] as they resolve. *) val iter_with_waiting_ep : - (key -> 'a -> (unit, 'error trace) result Lwt.t) -> - ('a, 'error trace) t -> - (unit, 'error trace) result Lwt.t + (key -> 'a -> (unit, 'error) result Lwt.t) -> + ('a, 'error) t -> + (unit, 'error list) result Lwt.t (** [fold_with_waiting_es f tbl init] folds [init] with [f] over the bindings in [tbl]. diff --git a/src/lib_lwt_result_stdlib/sigs/map.ml b/src/lib_lwt_result_stdlib/bare/functor_outputs/map.ml similarity index 91% rename from src/lib_lwt_result_stdlib/sigs/map.ml rename to src/lib_lwt_result_stdlib/bare/functor_outputs/map.ml index 4ebea2f0c97ed8a2ad42fde51d018dddb05d2d98..59e7aca24e8ea4d1bc8b09731ad86eb6fe502092 100644 --- a/src/lib_lwt_result_stdlib/sigs/map.ml +++ b/src/lib_lwt_result_stdlib/bare/functor_outputs/map.ml @@ -23,9 +23,15 @@ (* *) (*****************************************************************************) +(** Maps with the signature [S] are exception-safe replacements for + maps with the {!Stdlib.Map.S} signature with Lwt- and result-aware + traversal functions. + + See {!Lwtreslib}'s introductory documentation for explanations regarding + [_e]-, [_s]-, [_es]-, [_p]-, and [_ep]-suffixed functions and exception + safety. See {!Stdlib.Map.S} for explanations regarding OCaml's + maps in general. *) module type S = sig - type 'error trace - type key type +'a t @@ -84,9 +90,9 @@ module type S = sig 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 trace) result Lwt.t) -> + (key -> 'a -> (unit, 'error) result Lwt.t) -> 'a t -> - (unit, 'error trace) result Lwt.t + (unit, 'error list) result Lwt.t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b diff --git a/src/lib_lwt_result_stdlib/sigs/set.ml b/src/lib_lwt_result_stdlib/bare/functor_outputs/set.ml similarity index 88% rename from src/lib_lwt_result_stdlib/sigs/set.ml rename to src/lib_lwt_result_stdlib/bare/functor_outputs/set.ml index e473531acd37141b7ca9e43bf565366ffca96a89..3a9fcf64a75ae1f35b05ebff9d0a9ab5a07ee4ed 100644 --- a/src/lib_lwt_result_stdlib/sigs/set.ml +++ b/src/lib_lwt_result_stdlib/bare/functor_outputs/set.ml @@ -23,9 +23,15 @@ (* *) (*****************************************************************************) +(** Sets with the signature [S] are exception-safe replacements for + sets with the {!Stdlib.Set.S} signature with Lwt- and result-aware + traversal functions. + + See {!Lwtreslib}'s introductory documentation for explanations regarding + [_e]-, [_s]-, [_es]-, [_p]-, and [_ep]-suffixed functions and exception + safety. See {!Stdlib.Set.S} for explanations regarding OCaml's + sets in general. *) module type S = sig - type 'error trace - type elt type t @@ -70,9 +76,9 @@ module type S = sig (elt -> (unit, 'trace) result Lwt.t) -> t -> (unit, 'trace) result Lwt.t val iter_ep : - (elt -> (unit, 'error trace) result Lwt.t) -> + (elt -> (unit, 'error) result Lwt.t) -> t -> - (unit, 'error trace) result Lwt.t + (unit, 'error list) result Lwt.t val map : (elt -> elt) -> t -> t diff --git a/src/lib_lwt_result_stdlib/sigs/.ocamlformat b/src/lib_lwt_result_stdlib/bare/sigs/.ocamlformat similarity index 100% rename from src/lib_lwt_result_stdlib/sigs/.ocamlformat rename to src/lib_lwt_result_stdlib/bare/sigs/.ocamlformat diff --git a/src/lib_lwt_result_stdlib/bare/sigs/dune b/src/lib_lwt_result_stdlib/bare/sigs/dune new file mode 100644 index 0000000000000000000000000000000000000000..989a41f74988119e5807e01b5c490969736b5fa1 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/sigs/dune @@ -0,0 +1,9 @@ +(library + (name bare_sigs) + (public_name tezos-lwt-result-stdlib.bare.sigs) + (libraries lwt tezos-lwt-result-stdlib.bare.functor-outputs)) + +(rule + (alias 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.mli b/src/lib_lwt_result_stdlib/bare/sigs/hashtbl.ml similarity index 75% rename from src/lib_lwt_result_stdlib/functors/hashtbl.mli rename to src/lib_lwt_result_stdlib/bare/sigs/hashtbl.ml index a170341e49190538523a1cdd3b7c0bb7490200cc..6aa329bcac554144b8e0a811ade5c25203c45bdf 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/bare/sigs/hashtbl.ml @@ -23,10 +23,15 @@ (* *) (*****************************************************************************) -module Make (Seq : Sigs.Seq.S) : sig - (** Polymorphic hashing re-exported. These functions are meant to be passed to - the [Make] and [MakeSeeded] functors (below). Check {!Stdlib.Hashtbl} for - documentation. *) +(** In Lwtreslib, like in the Stdlib, the Hashtbl module exports mainly functors + to instantiate hashtables with known-type keys. As a result, the bulk of the + documentation for hashtables is located within the module types returned by + the functors: in {!Bare_functor_outputs.Hashtbl}. + + Note the presence of [Make_es] which deviates from the Stdlib to provide + specialised convenience for tables of elements the initialisation of which + may take time and may fail. *) +module type S = sig val hash : 'a -> int val seeded_hash : int -> 'a -> int @@ -35,19 +40,16 @@ module Make (Seq : Sigs.Seq.S) : sig val seeded_hash_param : meaningful:int -> total:int -> int -> 'a -> int - module type S = - Sigs.Hashtbl.S with type 'error trace := 'error Seq.Monad.trace + module type S = Bare_functor_outputs.Hashtbl.S module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t - module type SeededS = - Sigs.Hashtbl.SeededS with type 'error trace := 'error Seq.Monad.trace + module type SeededS = Bare_functor_outputs.Hashtbl.SeededS module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : SeededS with type key = H.t - module type S_LWT = - Sigs.Hashtbl.S_LWT with type 'error trace := 'error Seq.Monad.trace + module type S_ES = Bare_functor_outputs.Hashtbl.S_ES - module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t + module Make_es (H : Stdlib.Hashtbl.HashedType) : S_ES with type key = H.t end diff --git a/src/lib_lwt_result_stdlib/sigs/list.ml b/src/lib_lwt_result_stdlib/bare/sigs/list.ml similarity index 90% rename from src/lib_lwt_result_stdlib/sigs/list.ml rename to src/lib_lwt_result_stdlib/bare/sigs/list.ml index 86970a6e5d4f16fce5365eaff497117ed6d90a8f..b5ee561c6ad97b1b5dcc775fad67679bb17c2ded 100644 --- a/src/lib_lwt_result_stdlib/sigs/list.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/list.ml @@ -25,38 +25,36 @@ (** {1 List} - A wrapper around {!Stdlib.List} that includes lwt-, error- and - lwt-error-aware traversal functions. + A replacement for {!Stdlib.List} which: + - replaces the exception-raising functions by exception-safe variants, + - provides Lwt-, result- and Lwt-result-aware traversors. - Supersedes {!Stdlib.List} and {!Lwt_list} both. + [List] is intended to shadow both {!Stdlib.List} and {!Lwt_list}. *) -*) - -(** - {2 Basics} +(** {2 Basics} - This follows the design principles and semantic described in {!Sigs.Seq}. In - a nutshell: + Checkout {!Lwtreslib} for an introduction to the naming and semantic + convention of Lwtreslib. In a nutshell: - Stdlib functions that raise exceptions are replaced by safe variants (typically returning [option]). - - The [_e] suffix is for error-aware traversors, [_s] and [_p] are for - lwt-aware, and [_es] and [_ep] are for lwt-error-aware. + - The [_e] suffix is for result-aware traversors ("e" stands for "error"), + [_s] and [_p] are for Lwt-aware, and [_es] and [_ep] are for + Lwt-result-aware. - [_e], [_s], and [_es] traversors are {i fail-early}: they stop traversal as soon as a failure ([Error] or [Fail]) occurs; [_p] and [_ep] traversors are {i best-effort}: they only resolve once all of the - intermediate promises have even if a failure occurs. - -*) - -(** + intermediate promises have, even if a failure occurs. *) - {2 Double-traversal and combine} +(** {2 Double-traversal and combine} Note that double-list traversors ([iter2], [map2], etc., and also [combine]) take an additional [when_different_lengths] parameter. This is to control the error that is returned when the two lists passed as arguments have different lengths. + This mechanism is a replacement for {!Stdlib.List.iter2} (etc.) raising + [Invalid_argument]. + Note that, as per the fail-early behaviour mentioned above, [_e], [_s], and [_es] traversors will have already processed the common-prefix before the error is returned. @@ -64,8 +62,7 @@ Because the best-effort behaviour of [_p] and [_ep] is unsatisfying for this failure case, double parallel traversors are omitted from this library. (Specifically, it is not obvious whether nor how the - [when_different_lengths] error should be composed with the other errors, - what shape the trace should have.) + [when_different_lengths] error should be composed with the other errors.) To obtain a different behaviour for sequential traversors, or to process two lists in parallel, you can use {!combine} or any of the alternative that @@ -80,19 +77,13 @@ of the processing starts. Whilst this is still within the fail-early behaviour, it may be surprising enough that it requires mentioning here. - Because they return early, {!for_all2} and {!exists2} and all their variants - may return [Ok _] even tough the arguments have different lengths. - - + Because they may return early, {!for_all2} and {!exists2} and all their + variants may return [Ok _] even tough the arguments have different lengths. *) -(** {2 S} *) module type S = sig (** {3 Boilerplate} *) - (** For substituting based on the {!Sigs.Trace} type. *) - type 'error trace - (** Include the legacy list. Functions that raise exceptions are shadowed below. *) include @@ -120,7 +111,8 @@ module type S = sig (** {4 Safe lookups, scans, retrievals} - Return option rather than raise [Not_found] or [Invalid_argument _] *) + Return option rather than raise [Not_found], [Failure _], or + [Invalid_argument _] *) (** [hd xs] is the head (first element) of the list or [None] if the list is empty. *) @@ -164,8 +156,7 @@ module type S = sig (** {4 Initialisation} *) (** [init ~when_negative_length n f] is [Error when_negative_length] if [n] is - strictly negative and - [Ok] {!Stdlib.List.init n f} otherwise. *) + strictly negative and [Ok (Stdlib.List.init n f)] otherwise. *) val init : when_negative_length:'trace -> int -> @@ -264,8 +255,8 @@ module type S = sig (** {3 Monad-aware variants} The functions below are strict extensions of the standard {!Stdlib.List} - module. It is for error-, lwt- and lwt-error-aware variants. The meaning - of the suffix is as described above and in {!Sigs.Seq}. *) + module. It is for result-, lwt- and lwt-result-aware variants. The meaning + of the suffix is as described above, in {!Lwtreslib}, and in {!Sigs.Seq}. *) (** {4 Initialisation variants} @@ -291,18 +282,18 @@ module type S = sig (int -> ('a, 'trace) result Lwt.t) -> ('a list, 'trace) result Lwt.t + val init_ep : + when_negative_length:'error -> + int -> + (int -> ('a, 'error) result Lwt.t) -> + ('a list, 'error list) result Lwt.t + val init_p : when_negative_length:'trace -> int -> (int -> 'a Lwt.t) -> ('a list, 'trace) result Lwt.t - val init_ep : - when_negative_length:'error -> - int -> - (int -> ('a, 'error trace) result Lwt.t) -> - ('a list, 'error trace) result Lwt.t - (** {4 Query variants} *) val find_e : @@ -350,12 +341,12 @@ module type S = sig 'a list -> ('a list, 'trace) result Lwt.t - val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t - val filter_ep : - ('a -> (bool, 'error trace) result Lwt.t) -> + ('a -> (bool, 'trace) result Lwt.t) -> 'a list -> - ('a list, 'error trace) result Lwt.t + ('a list, 'trace list) result Lwt.t + + val filter_p : ('a -> bool Lwt.t) -> 'a list -> 'a list Lwt.t val rev_partition_result : ('a, 'b) result list -> 'a list * 'b list @@ -386,12 +377,12 @@ module type S = sig 'a list -> ('a list * 'a list, 'trace) result Lwt.t - val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t - val partition_ep : - ('a -> (bool, 'error trace) result Lwt.t) -> + ('a -> (bool, 'trace) result Lwt.t) -> 'a list -> - ('a list * 'a list, 'error trace) result Lwt.t + ('a list * 'a list, 'trace list) result Lwt.t + + val partition_p : ('a -> bool Lwt.t) -> 'a list -> ('a list * 'a list) Lwt.t (** {4 Traversal variants} *) @@ -405,12 +396,12 @@ module type S = sig 'a list -> (unit, 'trace) result Lwt.t - val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t - val iter_ep : - ('a -> (unit, 'error trace) result Lwt.t) -> + ('a -> (unit, 'trace) result Lwt.t) -> 'a list -> - (unit, 'error trace) result Lwt.t + (unit, 'trace list) result Lwt.t + + val iter_p : ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t val iteri_e : (int -> 'a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result @@ -422,12 +413,12 @@ module type S = sig 'a list -> (unit, 'trace) result Lwt.t - val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t - val iteri_ep : - (int -> 'a -> (unit, 'error trace) result Lwt.t) -> + (int -> 'a -> (unit, 'trace) result Lwt.t) -> 'a list -> - (unit, 'error trace) result Lwt.t + (unit, 'trace list) result Lwt.t + + val iteri_p : (int -> 'a -> unit Lwt.t) -> 'a list -> unit Lwt.t val map_e : ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result @@ -439,12 +430,12 @@ module type S = sig 'a list -> ('b list, 'trace) result Lwt.t - val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - val map_ep : - ('a -> ('b, 'error trace) result Lwt.t) -> + ('a -> ('b, 'trace) result Lwt.t) -> 'a list -> - ('b list, 'error trace) result Lwt.t + ('b list, 'trace list) result Lwt.t + + val map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val mapi_e : (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result @@ -456,12 +447,12 @@ module type S = sig 'a list -> ('b list, 'trace) result Lwt.t - val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - val mapi_ep : - (int -> 'a -> ('b, 'error trace) result Lwt.t) -> + (int -> 'a -> ('b, 'trace) result Lwt.t) -> 'a list -> - ('b list, 'error trace) result Lwt.t + ('b list, 'trace list) result Lwt.t + + val mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list @@ -475,12 +466,12 @@ module type S = sig 'a list -> ('b list, 'trace) result Lwt.t - val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - val rev_map_ep : - ('a -> ('b, 'error trace) result Lwt.t) -> + ('a -> ('b, 'trace) result Lwt.t) -> 'a list -> - ('b list, 'error trace) result Lwt.t + ('b list, 'trace list) result Lwt.t + + val rev_map_p : ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val rev_mapi_e : (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result @@ -492,12 +483,12 @@ module type S = sig 'a list -> ('b list, 'trace) result Lwt.t - val rev_mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t - val rev_mapi_ep : - (int -> 'a -> ('b, 'error trace) result Lwt.t) -> + (int -> 'a -> ('b, 'trace) result Lwt.t) -> 'a list -> - ('b list, 'error trace) result Lwt.t + ('b list, 'trace list) result Lwt.t + + val rev_mapi_p : (int -> 'a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t val rev_filter_map : ('a -> 'b option) -> 'a list -> 'b list @@ -521,12 +512,12 @@ module type S = sig 'a list -> ('b list, 'trace) result Lwt.t - val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t - val filter_map_ep : - ('a -> ('b option, 'error trace) result Lwt.t) -> + ('a -> ('b option, 'trace) result Lwt.t) -> 'a list -> - ('b list, 'error trace) result Lwt.t + ('b list, 'trace list) result Lwt.t + + val filter_map_p : ('a -> 'b option Lwt.t) -> 'a list -> 'b list Lwt.t val fold_left_e : ('a -> 'b -> ('a, 'trace) result) -> 'a -> 'b list -> ('a, 'trace) result @@ -684,12 +675,12 @@ module type S = sig 'a list -> (bool, 'trace) result Lwt.t - val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t - val for_all_ep : - ('a -> (bool, 'error trace) result Lwt.t) -> + ('a -> (bool, 'trace) result Lwt.t) -> 'a list -> - (bool, 'error trace) result Lwt.t + (bool, 'trace list) result Lwt.t + + val for_all_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t val exists_e : ('a -> (bool, 'trace) result) -> 'a list -> (bool, 'trace) result @@ -701,12 +692,12 @@ module type S = sig 'a list -> (bool, 'trace) result Lwt.t - val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t - val exists_ep : - ('a -> (bool, 'error trace) result Lwt.t) -> + ('a -> (bool, 'trace) result Lwt.t) -> 'a list -> - (bool, 'error trace) result Lwt.t + (bool, 'trace list) result Lwt.t + + val exists_p : ('a -> bool Lwt.t) -> 'a list -> bool Lwt.t (** {4 Double-scanning variants} diff --git a/src/lib_lwt_result_stdlib/bare/sigs/map.ml b/src/lib_lwt_result_stdlib/bare/sigs/map.ml new file mode 100644 index 0000000000000000000000000000000000000000..ff6bfc431fe38f4b2572cc0e7b5a70a00dddda7a --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/sigs/map.ml @@ -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. *) +(* *) +(*****************************************************************************) + +(** In Lwtreslib, like in the Stdlib, the Map module exports a functor + to instantiate maps with known-type keys. As a result, the bulk of the + documentation for maps is located within the module types returned by + the functors: in {!Bare_functor_outputs.Map}. *) +module type S = sig + module type S = Bare_functor_outputs.Map.S + + module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t +end diff --git a/src/lib_lwt_result_stdlib/bare/sigs/monad.ml b/src/lib_lwt_result_stdlib/bare/sigs/monad.ml new file mode 100644 index 0000000000000000000000000000000000000000..81df6077f1ebf169b9a3268c7350fe04a402be90 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/sigs/monad.ml @@ -0,0 +1,228 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** {1 Lwt, result, and Lwt-result monad operators} + + This module provides the necessary functions and operators to use Lwt, + result and Lwt-result as a monad. + + {2 Basics} + + The three, tiered monads have each their full set of operators: + + The Lwt monad: + {ul + {li {!Lwt.return} for return,} + {li {!Lwt.bind} or {!(>>=)} for bind, and} + {li {!Lwt.map} or {!(>|=)} for map.} + } + + The result monad: + {ul + {li {!Result.ok} or {!ok} for return,} + {li {!Result.bind} or {!(>>?)} for bind, and} + {li {!Result.map} {!(>|?)} for map.} + } + In addition, {!Result.error} or {!error} is for failures within the result + monad. + + The Lwt-result monad: + {ul + {li {!return} or {!Lwt.return_ok} for return,} + {li {!(>>=?)} for bind, and} + {li {!(>|=?)} for map.} + } + In addition, {!fail} is for the failure within the Lwt-result combined + monad. + + Note that future improvements are planned to (a) make those more uniform, + (b) allow the opening of selected infix operators only, and (c) provide + [let*]-binds. + + {2 Preallocated values} + + The module also provides preallocated values for the common types: + + - {!unit_s} (resp {!unit_e}) (resp {!unit_es}) is [Lwt.return ()] (resp + [Ok ()]) (resp [Lwt.return (Ok ())]), + - {!none_s} (resp {!none_e}) (resp {!none_es}) is [Lwt.return None] (resp + [Ok None]) (resp [Lwt.return (Ok None)]), + - etc. (see full inventory below) + + Note that some of these values are also available in their dedicated + modules. E.g., [none_*] are available in {!Option}. + + {2 Joins} + + The {!join_p} function takes a list of promises [ps] and returns a single + promise [p] that resolves with [()] when all the promises of [ps] have + resolved. + + The {!all_p} function takes a list of promises [ps] and returns a single + promise [p] that resolves when all the promises of [ps] have resolved. The + value [p] resolves to is the list of values the promises of [ps] resolve to. + The order is preserved. + + The {!both_p} function takes two promises [p1] and [p2] and returns a single + promise [p] that resolves when both promises [p1] and [p2] have resolved. + The value [p] resolves to is the tuple of values the promises [p1] and [p2] + resolve to. + + Note that like all [_p] functions, these functions have a best-effort + semantic: they only resolve once all the underlying promises have resolved. + + The [_e] variants are equivalent for the result monad: the final result is + [Ok] if all the underlying results are [Ok]. + + The [_es] variants are equivalent for the Lwt-result monad: the final + promise resolves to [Ok] if all the underlying promise resolve to [Ok]. + + *) + +module type S = sig + (** lwt monad *) + + val ( >>= ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t + + val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t + + (** result monad *) + + val ok : 'a -> ('a, 'trace) result + + val error : 'error -> ('a, 'error) result + + val ( >>? ) : + ('a, 'trace) result -> ('a -> ('b, 'trace) result) -> ('b, 'trace) result + + val ( >|? ) : ('a, 'trace) result -> ('a -> 'b) -> ('b, 'trace) result + + (** lwt-result combined monad *) + + val ok_s : 'a -> ('a, 'trace) result Lwt.t + + val return : 'a -> ('a, 'trace) result Lwt.t + + val error_s : 'error -> ('a, 'error) result Lwt.t + + val fail : 'error -> ('a, 'error) result Lwt.t + + val ( >>=? ) : + ('a, 'trace) result Lwt.t -> + ('a -> ('b, 'trace) result Lwt.t) -> + ('b, 'trace) result Lwt.t + + val ( >|=? ) : + ('a, 'trace) result Lwt.t -> ('a -> 'b) -> ('b, 'trace) 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, 'trace) result -> + ('a -> ('b, 'trace) result Lwt.t) -> + ('b, 'trace) result Lwt.t + + val ( >|?= ) : + ('a, 'trace) result -> ('a -> 'b Lwt.t) -> ('b, 'trace) result Lwt.t + + (** preallocated in-monad values *) + + val unit_s : unit Lwt.t + + val unit_e : (unit, 'trace) result + + val unit_es : (unit, 'trace) result Lwt.t + + val none_s : 'a option Lwt.t + + val none_e : ('a option, 'trace) result + + val none_es : ('a option, 'trace) result Lwt.t + + val some_s : 'a -> 'a option Lwt.t + + val some_e : 'a -> ('a option, 'trace) result + + val some_es : 'a -> ('a option, 'trace) result Lwt.t + + val nil_s : 'a list Lwt.t + + val nil_e : ('a list, 'trace) result + + val nil_es : ('a list, 'trace) result Lwt.t + + val true_s : bool Lwt.t + + val true_e : (bool, 'trace) result + + val true_es : (bool, 'trace) result Lwt.t + + val false_s : bool Lwt.t + + val false_e : (bool, 'trace) result + + val false_es : (bool, 'trace) result Lwt.t + + (** additional preallocated in-monad values + + this is for backwards compatibility and for similarity with Lwt *) + + val ok_unit : (unit, 'error) result + + val return_unit : (unit, 'error) result Lwt.t + + (** joins *) + + 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_e : (unit, 'trace) result list -> (unit, 'trace list) result + + val all_e : ('a, 'trace) result list -> ('a list, 'trace list) result + + val both_e : + ('a, 'trace) result -> ('b, 'trace) result -> ('a * 'b, 'trace list) result + + val join_ep : + (unit, 'trace) result Lwt.t list -> (unit, 'trace list) result Lwt.t + + val all_ep : + ('a, 'trace) result Lwt.t list -> ('a list, 'trace list) result Lwt.t + + val both_ep : + ('a, 'trace) result Lwt.t -> + ('b, 'trace) result Lwt.t -> + ('a * 'b, 'trace list) result Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/sigs/option.ml b/src/lib_lwt_result_stdlib/bare/sigs/option.ml similarity index 78% rename from src/lib_lwt_result_stdlib/sigs/option.ml rename to src/lib_lwt_result_stdlib/bare/sigs/option.ml index b17111e31e77990f88a5fb047b2f86d48f9a95ac..daea0a6b9c6858ed4988735d4ac8a11e07691ff8 100644 --- a/src/lib_lwt_result_stdlib/sigs/option.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/option.ml @@ -23,12 +23,12 @@ (* *) (*****************************************************************************) -(** A wrapper around {!Stdlib.Option} that includes lwt-, error- and - lwt-error-aware traversal functions. - - See {!Seq} for general description of traversors, the meaning of [_s], [_e], - and [_es] suffixes. *) +(** A replacement for {!Stdlib.Option} which + - is exception-safe, + - includes Lwt-, result-, and Lwt-result-aware traversors. + See {!Lwtreslib} and {!Seq} for general description of traversors and the + meaning of [_s], [_e], and [_es] suffixes. *) module type S = sig type 'a t = 'a option = None | Some of 'a @@ -44,8 +44,36 @@ module type S = sig val some_unit : unit option + val some_unit_e : (unit option, 'error) result + + val some_unit_s : unit option Lwt.t + + val some_unit_es : (unit option, 'error) result Lwt.t + val some_nil : 'a list option + val some_nil_e : ('a list option, 'error) result + + val some_nil_s : 'a list option Lwt.t + + val some_nil_es : ('a list option, 'error) result Lwt.t + + val some_true : bool option + + val some_true_e : (bool option, 'error) result + + val some_true_s : bool option Lwt.t + + val some_true_es : (bool option, 'error) result Lwt.t + + val some_false : bool option + + val some_false_e : (bool option, 'error) result + + val some_false_s : bool option Lwt.t + + val some_false_es : (bool option, 'error) result Lwt.t + val some_e : 'a -> ('a option, 'trace) result val some_s : 'a -> 'a option Lwt.t @@ -64,6 +92,9 @@ module type S = sig val join : 'a option option -> 'a option + (** [either] picks the first [Some _] value of its arguments if any. + More formally, [either (Some x) _] is [Some x], [either None (Some y)] is + [Some y], and [either None None] is [None]. *) val either : 'a option -> 'a option -> 'a option val map : ('a -> 'b) -> 'a option -> 'b option diff --git a/src/lib_lwt_result_stdlib/sigs/result.ml b/src/lib_lwt_result_stdlib/bare/sigs/result.ml similarity index 94% rename from src/lib_lwt_result_stdlib/sigs/result.ml rename to src/lib_lwt_result_stdlib/bare/sigs/result.ml index a1e9672f303fef87c67da9d795f540f256ab73e0..be7b4bcfa4df47c03981b1c47e74dee4d3403ab7 100644 --- a/src/lib_lwt_result_stdlib/sigs/result.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/result.ml @@ -23,12 +23,12 @@ (* *) (*****************************************************************************) -(** A wrapper around {!Stdlib.Result} that includes lwt-, error- and - lwt-error-aware traversal functions. - - See {!Seq} for general description of traversors, the meaning of [_s], [_e], - and [_es] suffixes. *) +(** A replacement for {!Stdlib.Result} which + - is exception-safe, + - includes Lwt-, result-, and Lwt-result-aware traversors. + See {!Lwtreslib} and {!Seq} for general description of traversors and the + meaning of [_s], [_e], and [_es] suffixes. *) module type S = sig type ('a, 'e) t = ('a, 'e) result = Ok of 'a | Error of 'e (***) diff --git a/src/lib_lwt_result_stdlib/sigs/seq.ml b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml similarity index 89% rename from src/lib_lwt_result_stdlib/sigs/seq.ml rename to src/lib_lwt_result_stdlib/bare/sigs/seq.ml index 02d3cd2d888e31135ea5ad1543779255043ed37c..4d397fcd44311cbc94a42412a8c0bbd1bf4c4972 100644 --- a/src/lib_lwt_result_stdlib/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/seq.ml @@ -23,19 +23,26 @@ (* *) (*****************************************************************************) -(** A wrapper around {!Stdlib.Seq} that includes lwt-, error- and - lwt-error-aware traversal functions. +(** {1 Seq} - 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 _]). + A replacement for {!Stdlib.Seq} which + - is exception-safe, + - includes Lwt-, result- and Lwt-result-aware traversal functions. - 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. + See {!Lwtreslib} for a general description of traversors and the meaning for + the name suffixes. A full description is also below. + + All traversal functions that are suffixed with [_e] are within the result + monad. Note that these 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 the Lwt + monad. 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 @@ -57,11 +64,14 @@ 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]/[trace] *) +(** {2 Special consideration} + Because of the type of {!Stdlib.Seq.t}, some interactions with Lwt are not + possible. Specifically, note that the type includes the variant + [Cons of (unit -> ('a * 'a t))] which is not within Lwt. *) + +module type S = sig (** including the OCaml's {!Stdlib.Seq} module to share the {!Seq.t} type (including concrete definition) and to bring the existing functions. *) include @@ -71,13 +81,17 @@ module type S = sig (** in-monad, preallocated empty/nil *) - val ok_empty : ('a t, 'trace) result + val empty_e : ('a t, 'trace) result + + val empty_s : 'a t Lwt.t - val return_empty : ('a t, 'trace) result Lwt.t + val empty_es : ('a t, 'trace) result Lwt.t - val ok_nil : ('a node, 'trace) result + val nil_e : ('a node, 'trace) result - val return_nil : ('a node, 'trace) result Lwt.t + val nil_s : 'a node Lwt.t + + val nil_es : ('a node, 'trace) 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 _]. *) @@ -115,13 +129,6 @@ module type S = sig val iter_es : ('a -> (unit, 'trace) result Lwt.t) -> 'a t -> (unit, 'trace) 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 @@ -131,9 +138,16 @@ module type S = sig otherwise - is fulfilled with [Ok ()] if all the promises are. *) val iter_ep : - ('a -> (unit, 'error trace) result Lwt.t) -> + ('a -> (unit, 'trace) result Lwt.t) -> 'a t -> - (unit, 'error trace) result Lwt.t + (unit, 'trace list) 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 {!map} but wraps the transformation in {!result}. The traversal is interrupted if any of the application returns an [Error _]. @@ -169,17 +183,6 @@ module type S = sig val map_es : ('a -> ('b, 'trace) result Lwt.t) -> 'a t -> ('b t, 'trace) 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 @@ -192,9 +195,20 @@ module type S = sig terminate on infinite sequences. Moreover [map_p] is not tail-recursive. *) val map_ep : - ('a -> ('b, 'error trace) result Lwt.t) -> + ('a -> ('b, 'trace) result Lwt.t) -> 'a t -> - ('b t, 'error trace) result Lwt.t + ('b t, 'trace list) 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 {!filter} but wraps the transformation in [result]. Note that, unlike {!filter}, [filter_e] is not lazy: it applies the diff --git a/src/lib_lwt_result_stdlib/bare/sigs/set.ml b/src/lib_lwt_result_stdlib/bare/sigs/set.ml new file mode 100644 index 0000000000000000000000000000000000000000..9cef666415c670afb47db4de71029b96b6bc8ff7 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/sigs/set.ml @@ -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. *) +(* *) +(*****************************************************************************) + +(** In Lwtreslib, like in the Stdlib, the Set module exports mainly functors + to instantiate sets with known-type keys. As a result, the bulk of the + documentation for sets is located within the module types returned by + the functors: in {!Bare_functor_outputs.Set}. *) +module type S = sig + module type S = Bare_functor_outputs.Set.S + + module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t +end diff --git a/src/lib_lwt_result_stdlib/sigs/withExceptions.ml b/src/lib_lwt_result_stdlib/bare/sigs/withExceptions.ml similarity index 92% rename from src/lib_lwt_result_stdlib/sigs/withExceptions.ml rename to src/lib_lwt_result_stdlib/bare/sigs/withExceptions.ml index ba3e7e0a43394417fa5ee1973af7b8bfa2df1ba4..70e56ecc5a85733d458916a7ade95e29a86435e7 100644 --- a/src/lib_lwt_result_stdlib/sigs/withExceptions.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/withExceptions.ml @@ -23,14 +23,13 @@ (* *) (*****************************************************************************) -(** Functions that raise exceptions are hidden in the main modules of Lwtreslib +(** Functions that raise exceptions are hidden by the main modules of Lwtreslib but available here. These functions are either: very practical or are safe in some specific uses (e.g., [List.init] when used with a literal length). Functions that take a [loc] parameter raise {!Invalid_argument} with the - location included in the exception's message. -*) - + location included in the exception's message. It is intended to be used with + the {!__LOC__} value, but it can be used with different messages. *) module type S = sig module Option : sig val get : loc:string -> 'a option -> 'a diff --git a/src/lib_lwt_result_stdlib/bare/structs/.ocamlformat b/src/lib_lwt_result_stdlib/bare/structs/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/.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/bare/structs/dune b/src/lib_lwt_result_stdlib/bare/structs/dune new file mode 100644 index 0000000000000000000000000000000000000000..ef599e5157dcce0e63957ff824e412ec06b7deb3 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/dune @@ -0,0 +1,9 @@ +(library + (name bare_structs) + (public_name tezos-lwt-result-stdlib.bare.structs) + (libraries lwt tezos-lwt-result-stdlib.bare.sigs)) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml b/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml new file mode 100644 index 0000000000000000000000000000000000000000..2c92b53aced9065a7d3f072101648d6d311db76a --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml @@ -0,0 +1,219 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +let hash = Stdlib.Hashtbl.hash + +let seeded_hash = Stdlib.Hashtbl.seeded_hash + +let hash_param ~meaningful ~total v = + Stdlib.Hashtbl.hash_param meaningful total v + +let seeded_hash_param ~meaningful ~total seed v = + Stdlib.Hashtbl.seeded_hash_param meaningful total seed v + +module type S = Bare_functor_outputs.Hashtbl.S + +module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t = struct + open Seq + module Legacy = Stdlib.Hashtbl.Make (H) + include Legacy + + 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 SeededS = Bare_functor_outputs.Hashtbl.SeededS + +module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : + SeededS with type key = H.t = struct + open Seq + module Legacy = Stdlib.Hashtbl.MakeSeeded (H) + include Legacy + + 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_ep f t = iter_ep (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 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_ES = Bare_functor_outputs.Hashtbl.S_ES + +module Make_es (H : Stdlib.Hashtbl.HashedType) : S_ES with type key = H.t = +struct + (* This [_es] overlay on top of Hashtables prevents programmers from shooting + themselves in the feet with some common errors. Specifically, it prevents + race-conditions whereby the same key is bound again before the promise it + is already bound to resolves. + + More details in the interface: {!Bare_functor_outputs.Hashtbl.S_ES} + + To achieve this, the library maintains the following invariant: + - at any point in time, keys are associated to at most one promise *) + + open Seq + open Monad + module T = Stdlib.Hashtbl.Make (H) + + type key = H.t + + type ('a, 'trace) t = ('a, 'trace) 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) ; + (* NOTE: we still need to call [T.remove] in case the promise is not + cancelable (in which case it is not rejected and thus not removed) *) + T.remove t k + + let mem t k = T.mem t k + + let iter_with_waiting_es f t = + iter_es + (fun (k, p) -> + Lwt.try_bind + (fun () -> p) + (function Error _ -> unit_es | Ok v -> f k v) + (fun _ -> unit_es)) + (T.to_seq t) + + let fold_with_waiting_es f t init = + fold_left_es + (fun acc (k, p) -> + Lwt.try_bind + (fun () -> p) + (function Error _ -> return acc | Ok v -> f k v acc) + (fun _ -> return 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 iter_with_waiting_ep f t = + Monad.join_ep + @@ fold_promises + (fun k p acc -> + let promise = + Lwt.try_bind + (fun () -> p) + (function Error _ -> Monad.unit_es | Ok v -> f k v) + (fun _ -> Monad.unit_es) + in + promise :: acc) + t + [] + + let length t = T.length t + + let stats t = T.stats t +end diff --git a/src/lib_lwt_result_stdlib/bare/structs/hashtbl.mli b/src/lib_lwt_result_stdlib/bare/structs/hashtbl.mli new file mode 100644 index 0000000000000000000000000000000000000000..92f440d7411b4ac7b120c1c1deaaa5eef4586dae --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/hashtbl.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Bare_sigs.Hashtbl.S diff --git a/src/lib_lwt_result_stdlib/bare/structs/list.ml b/src/lib_lwt_result_stdlib/bare/structs/list.ml new file mode 100644 index 0000000000000000000000000000000000000000..0782db25703fa6625a67d77827bdc294a7eb5ae6 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/list.ml @@ -0,0 +1,1138 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Monad +module Legacy = Stdlib.List +include Legacy + +let nil = [] + +let nil_e = Ok [] + +let nil_s = Lwt.return_nil + +let nil_es = Lwt.return nil_e + +let hd = function x :: _ -> Some x | [] -> None + +let tl = function _ :: xs -> Some xs | [] -> None + +let nth xs n = + if n < 0 then None + else + let rec aux xs n = + match (xs, n) with + | ([], _) -> + None + | (x :: _, 0) -> + Some x + | (_ :: xs, n) -> + (aux [@ocaml.tailcall]) xs (n - 1) + in + aux xs n + +let rec last hd = function + | [] -> + hd + | [last] -> + last + | hd :: (_ :: _ as tl) -> + (last [@ocaml.tailcall]) hd tl + +let last_opt = function [] -> None | hd :: tl -> Some (last hd tl) + +let find = find_opt + +let rec iter2 ~when_different_lengths f xs ys = + (* NOTE: We could do the following but we would need to assume [f] does not + raise [Invalid_argument] + [try + Ok (iter2 f xs ys) + with Invalid_argument _ -> + Error when_different_lengths] + The same remark applies to the other 2-list iterators. + *) + match (xs, ys) with + | ([], []) -> + Monad.unit_e + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + f x y ; + (iter2 [@ocaml.tailcall]) ~when_different_lengths f xs ys + +let rev_map2 ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Ok zs + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + let z = f x y in + (aux [@ocaml.tailcall]) (z :: zs) xs ys + in + aux [] xs ys + +let map2 ~when_different_lengths f xs ys = + rev_map2 ~when_different_lengths f xs ys >|? rev + +let fold_left2 ~when_different_lengths f a xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Ok acc + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + let acc = f acc x y in + (aux [@ocaml.tailcall]) acc xs ys + in + aux a xs ys + +let fold_right2 ~when_different_lengths f xs ys a = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok a + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> + aux xs ys >|? fun acc -> f x y acc + in + aux xs ys + +let for_all2 ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok true + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> ( + match f x y with + | true -> + (aux [@ocaml.tailcall]) xs ys + | false -> + Ok false ) + in + aux xs ys + +let exists2 ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok false + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | (x :: xs, y :: ys) -> ( + match f x y with + | true -> + Ok true + | false -> + (aux [@ocaml.tailcall]) xs ys ) + in + aux xs ys + +let assoc = assoc_opt + +let assq = assq_opt + +let init ~when_negative_length l f = + if l < 0 then Error when_negative_length + else if l = 0 then nil_e + else Ok (Legacy.init l f) + +let init_e ~when_negative_length l f = + let rec aux acc i = + if i >= l then Ok (rev acc) + else f i >>? fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) + in + if l < 0 then Error when_negative_length + else if l = 0 then nil_e + else aux [] 0 + +let init_s ~when_negative_length l f = + let rec aux acc i = + if i >= l then Lwt.return (Ok (rev acc)) + else f i >>= fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error when_negative_length) + else if l = 0 then nil_es + else Lwt.apply f 0 >>= fun v -> aux [v] 1 + +let init_es ~when_negative_length l f = + let rec aux acc i = + if i >= l then Lwt.return (Ok (rev acc)) + else f i >>=? fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error when_negative_length) + else if l = 0 then nil_es + else Lwt.apply f 0 >>=? fun v -> aux [v] 1 + +let init_ep ~when_negative_length l f = + let rec aux acc i = + if i >= l then all_ep (rev acc) + else (aux [@ocaml.tailcall]) (Lwt.apply f i :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error [when_negative_length]) + else if l = 0 then nil_es + else aux [] 0 + +let init_p ~when_negative_length l f = + let rec aux acc i = + if i >= l then all_p (rev acc) >>= fun xs -> Lwt.return (Ok xs) + else (aux [@ocaml.tailcall]) (Lwt.apply f i :: acc) (i + 1) + in + if l < 0 then Lwt.return (Error when_negative_length) + else if l = 0 then nil_es + else aux [] 0 + +let rec find_e f = function + | [] -> + none_e + | x :: xs -> ( + f x + >>? function + | true -> Ok (Some x) | false -> (find_e [@ocaml.tailcall]) f xs ) + +let rec find_s f = function + | [] -> + none_s + | x :: xs -> ( + f x + >>= function + | true -> Lwt.return (Some x) | false -> (find_s [@ocaml.tailcall]) f xs + ) + +let find_s f = function + | [] -> + none_s + | x :: xs -> ( + Lwt.apply f x + >>= function + | true -> Lwt.return (Some x) | false -> (find_s [@ocaml.tailcall]) f xs + ) + +let rec find_es f = function + | [] -> + none_es + | x :: xs -> ( + f x + >>=? function + | true -> + Lwt.return (Ok (Some x)) + | false -> + (find_es [@ocaml.tailcall]) f xs ) + +let find_es f = function + | [] -> + none_es + | x :: xs -> ( + Lwt.apply f x + >>=? function + | true -> + Lwt.return (Ok (Some x)) + | false -> + (find_es [@ocaml.tailcall]) f xs ) + +let rev_filter f xs = + fold_left (fun rev_xs x -> if f x then x :: rev_xs else rev_xs) [] xs + +let rev_filter_e f xs = + let rec aux acc = function + | [] -> + Ok acc + | x :: xs -> ( + f x + >>? function + | true -> + (aux [@ocaml.tailcall]) (x :: acc) xs + | false -> + (aux [@ocaml.tailcall]) acc xs ) + in + aux [] xs + +let rev_filter_some oxs = + let rec aux xs = function + | [] -> + xs + | Some x :: oxs -> + (aux [@ocaml.tailcall]) (x :: xs) oxs + | None :: oxs -> + (aux [@ocaml.tailcall]) xs oxs + in + aux [] oxs + +let filter_some oxs = rev_filter_some oxs |> rev + +let rev_filter_ok rxs = + let rec aux xs = function + | [] -> + xs + | Ok x :: rxs -> + (aux [@ocaml.tailcall]) (x :: xs) rxs + | Error _ :: rxs -> + (aux [@ocaml.tailcall]) xs rxs + in + aux [] rxs + +let filter_ok rxs = rev_filter_ok rxs |> rev + +let rev_filter_error rxs = + let rec aux xs = function + | [] -> + xs + | Error x :: rxs -> + (aux [@ocaml.tailcall]) (x :: xs) rxs + | Ok _ :: rxs -> + (aux [@ocaml.tailcall]) xs rxs + in + aux [] rxs + +let filter_error rxs = rev_filter_error rxs |> rev + +let filter_e f xs = rev_filter_e f xs >|? rev + +let rev_filter_s f xs = + let rec aux acc = function + | [] -> + Lwt.return acc + | x :: xs -> ( + f x + >>= function + | true -> + (aux [@ocaml.tailcall]) (x :: acc) xs + | false -> + (aux [@ocaml.tailcall]) acc xs ) + in + match xs with + | [] -> + Lwt.return [] + | x :: xs -> ( + Lwt.apply f x + >>= function + | true -> + (aux [@ocaml.tailcall]) [x] xs + | false -> + (aux [@ocaml.tailcall]) [] xs ) + +let filter_s f xs = rev_filter_s f xs >|= rev + +let rev_filter_es f xs = + let rec aux acc = function + | [] -> + Lwt.return (Ok acc) + | x :: xs -> ( + f x + >>=? function + | true -> + (aux [@ocaml.tailcall]) (x :: acc) xs + | false -> + (aux [@ocaml.tailcall]) acc xs ) + in + match xs with + | [] -> + Lwt.return (Ok []) + | x :: xs -> ( + Lwt.apply f x >>=? function true -> aux [x] xs | false -> aux [] xs ) + +let filter_es f xs = rev_filter_es f xs >|=? rev + +let rec iter_e f = function + | [] -> + unit_e + | h :: t -> + f h >>? fun () -> (iter_e [@ocaml.tailcall]) f t + +let rec iter_s f = function + | [] -> + unit_s + | h :: t -> + f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t + +let iter_s f = function + | [] -> + unit_s + | h :: t -> + Lwt.apply f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t + +let rec iter_es f = function + | [] -> + unit_es + | h :: t -> + f h >>=? fun () -> (iter_es [@ocaml.tailcall]) f t + +let iter_es f = function + | [] -> + unit_es + | h :: t -> + Lwt.apply f h >>=? fun () -> (iter_es [@ocaml.tailcall]) f t + +let iter_ep f l = join_ep (rev_map (Lwt.apply f) l) + +let iter_p f l = join_p (rev_map (Lwt.apply f) l) + +let iteri_e f l = + let rec aux i = function + | [] -> + unit_e + | x :: xs -> + f i x >>? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs + in + aux 0 l + +let lwt_apply2 f x y = try f x y with exc -> Lwt.fail exc + +let iteri_s f l = + let rec aux i = function + | [] -> + unit_s + | x :: xs -> + f i x >>= fun () -> (aux [@ocaml.tailcall]) (i + 1) xs + in + match l with + | [] -> + unit_s + | x :: xs -> + lwt_apply2 f 0 x >>= fun () -> aux 1 xs + +let iteri_es f l = + let rec aux i = function + | [] -> + unit_es + | x :: xs -> + f i x >>=? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs + in + match l with + | [] -> + unit_es + | x :: xs -> + lwt_apply2 f 0 x >>=? fun () -> aux 1 xs + +let iteri_ep f l = join_ep (mapi (lwt_apply2 f) l) + +let iteri_p f l = join_p (mapi (lwt_apply2 f) l) + +let rev_map_e f l = + let rec aux ys = function + | [] -> + Ok ys + | x :: xs -> + f x >>? fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs + in + aux [] l + +let map_e f l = rev_map_e f l >|? rev + +let rev_map_s f l = + let rec aux ys = function + | [] -> + Lwt.return ys + | x :: xs -> + f x >>= fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs + in + match l with + | [] -> + Lwt.return [] + | x :: xs -> + Lwt.apply f x >>= fun y -> aux [y] xs + +let map_s f l = rev_map_s f l >|= rev + +let rev_map_es f l = + let rec aux ys = function + | [] -> + return ys + | x :: xs -> + f x >>=? fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs + in + match l with + | [] -> + return [] + | x :: xs -> + Lwt.apply f x >>=? fun y -> aux [y] xs + +let rev_map_ep f l = all_ep @@ rev_map (Lwt.apply f) l + +let map_es f l = rev_map_es f l >|=? rev + +let map_ep f l = rev_map_ep f l >|=? rev + +let rev_map_p f l = all_p @@ rev_map (Lwt.apply f) l + +let map_p f l = rev_map_p f l >|= rev + +let rev_mapi_e f l = + let rec aux i ys = function + | [] -> + Ok ys + | x :: xs -> + f i x >>? fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs + in + aux 0 [] l + +let mapi_e f l = rev_mapi_e f l >|? rev + +let rev_mapi_s f l = + let rec aux i ys = function + | [] -> + Lwt.return ys + | x :: xs -> + f i x >>= fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs + in + match l with + | [] -> + Lwt.return [] + | x :: xs -> + lwt_apply2 f 0 x >>= fun y -> aux 1 [y] xs + +let mapi_s f l = rev_mapi_s f l >|= rev + +let rev_mapi_es f l = + let rec aux i ys = function + | [] -> + return ys + | x :: xs -> + f i x >>=? fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs + in + match l with + | [] -> + return [] + | x :: xs -> + lwt_apply2 f 0 x >>=? fun y -> aux 1 [y] xs + +let mapi_es f l = rev_mapi_es f l >|=? rev + +let rev_mapi f l = + let rec aux i ys = function + | [] -> + ys + | x :: xs -> + (aux [@ocaml.tailcall]) (i + 1) (f i x :: ys) xs + in + aux 0 [] l + +let rev_mapi_p f l = all_p @@ rev_mapi f l + +let rev_mapi_ep f l = all_ep @@ rev_mapi f l + +let mapi_p f l = rev_mapi_p f l >|= rev + +let mapi_ep f l = rev_mapi_ep f l >|=? rev + +let rec fold_left_e f acc = function + | [] -> + Ok acc + | x :: xs -> + f acc x >>? fun acc -> (fold_left_e [@ocaml.tailcall]) f acc xs + +let rec fold_left_s f acc = function + | [] -> + Lwt.return acc + | x :: xs -> + f acc x >>= fun acc -> (fold_left_s [@ocaml.tailcall]) f acc xs + +let fold_left_s f acc = function + | [] -> + Lwt.return acc + | x :: xs -> + lwt_apply2 f acc x >>= fun acc -> fold_left_s f acc xs + +let rec fold_left_es f acc = function + | [] -> + return acc + | x :: xs -> + f acc x >>=? fun acc -> (fold_left_es [@ocaml.tailcall]) f acc xs + +let fold_left_es f acc = function + | [] -> + return acc + | x :: xs -> + lwt_apply2 f acc x >>=? fun acc -> fold_left_es f acc xs + +let filter_p f l = + rev_map_p (fun x -> f x >|= fun b -> if b then Some x else None) l + >|= rev_filter_some + +let filter_ep f l = + rev_map_ep (fun x -> f x >|=? fun b -> if b then Some x else None) l + >|=? rev_filter_some + +let rev_filter_map f l = + fold_left + (fun acc x -> match f x with None -> acc | Some y -> y :: acc) + [] + l + +let filter_map f l = rev_filter_map f l |> rev + +let rev_filter_map_e f l = + fold_left_e + (fun acc x -> f x >|? function None -> acc | Some y -> y :: acc) + [] + l + +let filter_map_e f l = rev_filter_map_e f l >|? rev + +let rev_filter_map_s f l = + fold_left_s + (fun acc x -> f x >|= function None -> acc | Some y -> y :: acc) + [] + l + +let filter_map_s f l = rev_filter_map_s f l >|= rev + +let rev_filter_map_es f l = + fold_left_es + (fun acc x -> f x >|=? function None -> acc | Some y -> y :: acc) + [] + l + +let filter_map_es f l = rev_filter_map_es f l >|=? rev + +let filter_map_ep f l = rev_map_ep f l >|=? rev_filter_some + +let filter_map_p f l = rev_map_p f l >|= rev_filter_some + +let rec fold_right_e f l acc = + match l with + | [] -> + Ok acc + | x :: xs -> + fold_right_e f xs acc >>? fun acc -> f x acc + +let rec fold_right_s f l acc = + match l with + | [] -> + Lwt.return acc + | x :: xs -> + fold_right_s f xs acc >>= fun acc -> f x acc + +let rec fold_right_es f l acc = + match l with + | [] -> + return acc + | x :: xs -> + fold_right_es f xs acc >>=? fun acc -> f x acc + +let rev_map2_e ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Ok zs + | (x :: xs, y :: ys) -> + f x y >>? fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux [] xs ys + +let rev_map2_s ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok zs) + | (x :: xs, y :: ys) -> + f x y >>= fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok []) + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>= fun z -> aux [z] xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + +let rev_map2_es ~when_different_lengths f xs ys = + let rec aux zs xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok zs) + | (x :: xs, y :: ys) -> + f x y >>=? fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok []) + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>=? fun z -> aux [z] xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + +let map2_e ~when_different_lengths f xs ys = + rev_map2_e ~when_different_lengths f xs ys >|? rev + +let map2_s ~when_different_lengths f xs ys = + rev_map2_s ~when_different_lengths f xs ys >|=? rev + +let map2_es ~when_different_lengths f xs ys = + rev_map2_es ~when_different_lengths f xs ys >|=? rev + +let iter2_e ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + unit_e + | (x :: xs, y :: ys) -> + f x y >>? fun () -> (aux [@ocaml.tailcall]) xs ys + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux xs ys + +let iter2_s ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok ()) + | (x :: xs, y :: ys) -> + f x y >>= fun () -> (aux [@ocaml.tailcall]) xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok ()) + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>= fun () -> aux xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + +let iter2_es ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Monad.unit_es + | (x :: xs, y :: ys) -> + f x y >>=? fun () -> (aux [@ocaml.tailcall]) xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Monad.unit_es + | (x :: xs, y :: ys) -> + lwt_apply2 f x y >>=? fun () -> aux xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + +let fold_left2_e ~when_different_lengths f init xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Ok acc + | (x :: xs, y :: ys) -> + f acc x y >>? fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux init xs ys + +let lwt_apply3 f a x y = try f a x y with exc -> Lwt.fail exc + +let fold_left2_s ~when_different_lengths f init xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok acc) + | (x :: xs, y :: ys) -> + f acc x y >>= fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + lwt_apply3 f init x y >>= fun acc -> aux acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + +let fold_left2_es ~when_different_lengths f init xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok acc) + | (x :: xs, y :: ys) -> + f acc x y >>=? fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + in + match (xs, ys) with + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + lwt_apply3 f init x y >>=? fun acc -> (aux [@ocaml.tailcall]) acc xs ys + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + +let fold_right2_e ~when_different_lengths f xs ys init = + let rec aux xs ys = + match (xs, ys) with + | ([], []) -> + Ok init + | (x :: xs, y :: ys) -> + aux xs ys >>? fun acc -> f x y acc + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + in + aux xs ys + +let fold_right2_s ~when_different_lengths f xs ys init = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + (* We could use a specific operator for that. It'd need the following type + ('a, 'err) result Lwt.t -> ('a -> 'b Lwt.t) -> ('b, 'err) result Lwt.t + *) + aux xs ys >>=? fun acc -> f x y acc >|= ok + in + aux xs ys + +let fold_right2_es ~when_different_lengths f xs ys init = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + Lwt.return (Ok init) + | (x :: xs, y :: ys) -> + aux xs ys >>=? fun acc -> f x y acc + in + aux xs ys + +let rec for_all_e f = function + | [] -> + true_e + | x :: xs -> ( + f x + >>? function + | true -> (for_all_e [@ocaml.tailcall]) f xs | false -> false_e ) + +let rec for_all_s f = function + | [] -> + true_s + | x :: xs -> ( + f x + >>= function + | true -> (for_all_s [@ocaml.tailcall]) f xs | false -> false_s ) + +let for_all_s f = function + | [] -> + true_s + | x :: xs -> ( + Lwt.apply f x + >>= function + | true -> (for_all_s [@ocaml.tailcall]) f xs | false -> false_s ) + +let rec for_all_es f = function + | [] -> + true_es + | x :: xs -> ( + f x + >>=? function + | true -> (for_all_es [@ocaml.tailcall]) f xs | false -> false_es ) + +let for_all_es f = function + | [] -> + true_es + | x :: xs -> ( + Lwt.apply f x + >>=? function + | true -> (for_all_es [@ocaml.tailcall]) f xs | false -> false_es ) + +let for_all_ep f l = rev_map_ep f l >|=? for_all Fun.id + +let for_all_p f l = rev_map_p f l >|= for_all Fun.id + +let rec exists_e f = function + | [] -> + false_e + | x :: xs -> ( + f x + >>? function + | false -> (exists_e [@ocaml.tailcall]) f xs | true -> true_e ) + +let rec exists_s f = function + | [] -> + false_s + | x :: xs -> ( + f x + >>= function + | false -> (exists_s [@ocaml.tailcall]) f xs | true -> true_s ) + +let exists_s f = function + | [] -> + false_s + | x :: xs -> ( + Lwt.apply f x >>= function false -> exists_s f xs | true -> true_s ) + +let rec exists_es f = function + | [] -> + false_es + | x :: xs -> ( + f x + >>=? function + | false -> (exists_es [@ocaml.tailcall]) f xs | true -> true_es ) + +let exists_es f = function + | [] -> + false_es + | x :: xs -> ( + Lwt.apply f x >>=? function false -> exists_es f xs | true -> true_es ) + +let exists_ep f l = rev_map_ep f l >|=? exists Fun.id + +let exists_p f l = rev_map_p f l >|= exists Fun.id + +let for_all2_e ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | ([], []) -> + true_e + | (x :: xs, y :: ys) -> ( + f x y + >>? function true -> (aux [@ocaml.tailcall]) xs ys | false -> false_e ) + in + aux xs ys + +let for_all2_s ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + true_es + | (x :: xs, y :: ys) -> ( + f x y + >>= function + | true -> (aux [@ocaml.tailcall]) xs ys | false -> false_es ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + true_es + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y >>= function true -> aux xs ys | false -> false_es ) + +let for_all2_es ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + true_es + | (x :: xs, y :: ys) -> ( + f x y + >>=? function + | true -> (aux [@ocaml.tailcall]) xs ys | false -> false_es ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + true_es + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y >>=? function true -> aux xs ys | false -> false_es ) + +let exists2_e ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + Error when_different_lengths + | ([], []) -> + false_e + | (x :: xs, y :: ys) -> ( + f x y + >>? function false -> (aux [@ocaml.tailcall]) xs ys | true -> true_e ) + in + aux xs ys + +let exists2_s ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + false_es + | (x :: xs, y :: ys) -> ( + f x y + >>= function false -> (aux [@ocaml.tailcall]) xs ys | true -> true_es ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + false_es + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y >>= function false -> aux xs ys | true -> true_es ) + +let exists2_es ~when_different_lengths f xs ys = + let rec aux xs ys = + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + false_es + | (x :: xs, y :: ys) -> ( + f x y + >>=? function + | false -> (aux [@ocaml.tailcall]) xs ys | true -> true_es ) + in + match (xs, ys) with + | ([], _ :: _) | (_ :: _, []) -> + fail when_different_lengths + | ([], []) -> + false_es + | (x :: xs, y :: ys) -> ( + lwt_apply2 f x y >>=? function false -> aux xs ys | true -> true_es ) + +let rev_partition_result xs = + let rec aux oks errors = function + | [] -> + (oks, errors) + | Ok ok :: xs -> + (aux [@ocaml.tailcall]) (ok :: oks) errors xs + | Error error :: xs -> + (aux [@ocaml.tailcall]) oks (error :: errors) xs + in + aux [] [] xs + +let partition_result xs = + let (rev_oks, rev_errors) = rev_partition_result xs in + (rev rev_oks, rev rev_errors) + +let rev_partition_e f l = + let rec aux trues falses = function + | [] -> + Ok (trues, falses) + | x :: xs -> + f x + >>? fun b -> + if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + aux [] [] l + +let partition_e f l = + rev_partition_e f l >|? fun (trues, falses) -> (rev trues, rev falses) + +let rev_partition_s f l = + let rec aux trues falses = function + | [] -> + Lwt.return (trues, falses) + | x :: xs -> + f x + >>= fun b -> + if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + match l with + | [] -> + Lwt.return ([], []) + | x :: xs -> + Lwt.apply f x >>= fun b -> if b then aux [x] [] xs else aux [] [x] xs + +let partition_s f l = + rev_partition_s f l >|= fun (trues, falses) -> (rev trues, rev falses) + +let rev_partition_es f l = + let rec aux trues falses = function + | [] -> + return (trues, falses) + | x :: xs -> + f x + >>=? fun b -> + if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs + else (aux [@ocaml.tailcall]) trues (x :: falses) xs + in + match l with + | [] -> + return ([], []) + | x :: xs -> + Lwt.apply f x >>=? fun b -> if b then aux [x] [] xs else aux [] [x] xs + +let partition_es f l = + rev_partition_es f l >|=? fun (trues, falses) -> (rev trues, rev falses) + +let partition_ep f l = + rev_map_ep (fun x -> f x >|=? fun b -> (b, x)) l + >|=? fun bxs -> + fold_left + (fun (trues, falses) (b, x) -> + if b then (x :: trues, falses) else (trues, x :: falses)) + ([], []) + bxs + +let partition_p f l = + rev_map_p (fun x -> f x >|= fun b -> (b, x)) l + >|= fun bxs -> + fold_left + (fun (trues, falses) (b, x) -> + if b then (x :: trues, falses) else (trues, x :: falses)) + ([], []) + bxs + +let combine ~when_different_lengths xs ys = + map2 ~when_different_lengths (fun x y -> (x, y)) xs ys + +let rev_combine ~when_different_lengths xs ys = + rev_map2 ~when_different_lengths (fun x y -> (x, y)) xs ys + +let combine_with_leftovers xs ys = + let rec aux rev_combined xs ys = + match (xs, ys) with + | ([], []) -> + (rev rev_combined, None) + | ((_ :: _ as left), []) -> + (rev rev_combined, Some (`Left left)) + | ([], (_ :: _ as right)) -> + (rev rev_combined, Some (`Right right)) + | (x :: xs, y :: ys) -> + (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys + in + aux [] xs ys + +let combine_drop xs ys = + let rec aux rev_combined xs ys = + match (xs, ys) with + | (x :: xs, y :: ys) -> + (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys + | ([], []) | (_ :: _, []) | ([], _ :: _) -> + rev rev_combined + in + aux [] xs ys diff --git a/src/lib_lwt_result_stdlib/functors/option.mli b/src/lib_lwt_result_stdlib/bare/structs/list.mli similarity index 98% rename from src/lib_lwt_result_stdlib/functors/option.mli rename to src/lib_lwt_result_stdlib/bare/structs/list.mli index 381be8e6bbb3b9affe45a42a527ec1aadbdc4368..dc1778bae7c06cf71d09801039611181a8dc7d65 100644 --- a/src/lib_lwt_result_stdlib/functors/option.mli +++ b/src/lib_lwt_result_stdlib/bare/structs/list.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -module M : Sigs.Option.S +include Bare_sigs.List.S diff --git a/src/lib_lwt_result_stdlib/functors/set.ml b/src/lib_lwt_result_stdlib/bare/structs/map.ml similarity index 67% rename from src/lib_lwt_result_stdlib/functors/set.ml rename to src/lib_lwt_result_stdlib/bare/structs/map.ml index 18bc50ab0ec76ed0c103a8e8d9e091e433756bc7..fdbba25c2b4795b1c175dc215be1a5f1b36e84b9 100644 --- a/src/lib_lwt_result_stdlib/functors/set.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/map.ml @@ -23,40 +23,41 @@ (* *) (*****************************************************************************) -module Make (Seq : Sigs.Seq.S) = struct - module type S = Sigs.Set.S with type 'error trace := 'error Seq.Monad.trace +module type S = Bare_functor_outputs.Map.S - module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t = struct - open Seq - module Legacy = Stdlib.Set.Make (Ord) - include Legacy +module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t = struct + open Seq + module Legacy = Stdlib.Map.Make (Ord) + include Legacy - let iter_e f t = iter_e f (to_seq t) + let iter_e f t = iter_e (fun (k, v) -> f k v) (to_seq t) - let iter_s f t = iter_s f (to_seq t) + let iter_s f t = iter_s (fun (k, v) -> f k v) (to_seq t) - let iter_p f t = iter_p f (to_seq t) + let iter_es f t = iter_es (fun (k, v) -> f k v) (to_seq t) - let iter_es f t = iter_es f (to_seq t) + let iter_ep f t = iter_ep (fun (k, v) -> f k v) (to_seq t) - let iter_ep f t = iter_ep f (to_seq t) + let iter_p f t = iter_p (fun (k, v) -> f k v) (to_seq t) - let fold_e f t init = fold_left_e (fun acc e -> f e acc) init (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 e -> f e 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 e -> f e 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_elt = min_elt_opt + let min_binding = min_binding_opt - let max_elt = max_elt_opt + let max_binding = max_binding_opt - let choose = choose_opt + let choose = choose_opt - let find = find_opt + let find = find_opt - let find_first = find_first_opt + let find_first = find_first_opt - let find_last = find_last_opt - end + let find_last = find_last_opt end diff --git a/src/lib_lwt_result_stdlib/lib/result.mli b/src/lib_lwt_result_stdlib/bare/structs/map.mli similarity index 98% rename from src/lib_lwt_result_stdlib/lib/result.mli rename to src/lib_lwt_result_stdlib/bare/structs/map.mli index 08d556fa6395e7899d9a3ce689984c15863e6f8c..53241a93d351a7a693c75c48f25d9a621bde0c11 100644 --- a/src/lib_lwt_result_stdlib/lib/result.mli +++ b/src/lib_lwt_result_stdlib/bare/structs/map.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Sigs.Result.S +include Bare_sigs.Map.S diff --git a/src/lib_lwt_result_stdlib/bare/structs/monad.ml b/src/lib_lwt_result_stdlib/bare/structs/monad.ml new file mode 100644 index 0000000000000000000000000000000000000000..3ed5b2701f38745f590849d97568d19d31221e22 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/monad.ml @@ -0,0 +1,163 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 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. *) +(* *) +(*****************************************************************************) + +(** Lwt monad *) + +let ( >>= ) = Lwt.( >>= ) + +let ( >|= ) = Lwt.( >|= ) + +(** result monad *) + +let ok x = Ok x + +let error e = Error e + +let ( >>? ) v f = match v with Ok v -> f v | Error _ as error -> error + +let ( >|? ) v f = match v with Ok v -> Ok (f v) | Error _ as error -> error + +(** lwt-result combined monad *) + +let ok_s v = Lwt.return (Ok v) + +let return = ok_s + +let error_s v = Lwt.return (Error v) + +let fail = error_s + +let ( >>=? ) v f = + v >>= function Error _ as err -> Lwt.return err | Ok v -> f v + +let ( >|=? ) v f = v >>=? fun v -> Lwt.return (Ok (f v)) + +(** 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. *) + +let ( >>?= ) v f = match v with Error _ as e -> Lwt.return e | Ok v -> f v + +let ( >|?= ) v f = + match v with + | Error _ as e -> + Lwt.return e + | Ok v -> + f v >>= fun v -> Lwt.return (Ok v) + +let unit_s = Lwt.return_unit + +let unit_e = Ok () + +let ok_unit = unit_e + +let unit_es = Lwt.return unit_e + +let return_unit = unit_es + +let none_s = Lwt.return_none + +let none_e = Ok None + +let none_es = Lwt.return none_e + +let some_s x = Lwt.return (Some x) + +let some_e x = Ok (Some x) + +let some_es x = Lwt.return (Ok (Some x)) + +let nil_s = Lwt.return_nil + +let nil_e = Ok [] + +let nil_es = Lwt.return nil_e + +let true_s = Lwt.return_true + +let true_e = Ok true + +let true_es = Lwt.return true_e + +let false_s = Lwt.return_false + +let false_e = Ok false + +let false_es = Lwt.return false_e + +(* joins *) + +let join_p = Lwt.join + +let all_p = Lwt.all + +let both_p = Lwt.both + +let rec join_e_errors errors = function + | Ok _ :: ts -> + join_e_errors errors ts + | Error error :: ts -> + join_e_errors (error :: errors) ts + | [] -> + Error errors + +let rec join_e = function + | [] -> + unit_e + | Ok () :: ts -> + join_e ts + | Error error :: ts -> + join_e_errors [error] ts + +let all_e ts = + let rec aux acc = function + | [] -> + Ok (Stdlib.List.rev acc) + | Ok v :: ts -> + aux (v :: acc) ts + | Error error :: ts -> + join_e_errors [error] 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) -> + Error [erra; errb] + +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 diff --git a/src/lib_lwt_result_stdlib/bare/structs/monad.mli b/src/lib_lwt_result_stdlib/bare/structs/monad.mli new file mode 100644 index 0000000000000000000000000000000000000000..d0603b9fa6d497529ed70fb672f4b32baf114621 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/monad.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 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 Bare_sigs.Monad.S diff --git a/src/lib_lwt_result_stdlib/bare/structs/option.ml b/src/lib_lwt_result_stdlib/bare/structs/option.ml new file mode 100644 index 0000000000000000000000000000000000000000..edc5181d2b3d77e9fb7d2bf96eb89e0a14d370cb --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/option.ml @@ -0,0 +1,99 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Monad +include Stdlib.Option + +let some_unit = Some () + +let some_unit_e = Ok some_unit + +let some_unit_s = Lwt.return some_unit + +let some_unit_es = Lwt.return some_unit_e + +let some_nil = Some [] + +let some_nil_e = Ok some_nil + +let some_nil_s = Lwt.return some_nil + +let some_nil_es = Lwt.return some_nil_e + +let some_true = Some true + +let some_true_e = Ok some_true + +let some_true_s = Lwt.return some_true + +let some_true_es = Lwt.return some_true_e + +let some_false = Some false + +let some_false_e = Ok some_false + +let some_false_s = Lwt.return some_false + +let some_false_es = Lwt.return some_false_e + +let some_e v = Ok (Some v) + +let some_s v = Lwt.return (Some v) + +let some_es v = Lwt.return (Ok (Some v)) + +let none_e = Ok None + +let none_s = Lwt.return None + +let none_es = Lwt.return none_e + +let value_e o ~error = to_result ~none:error o + +let value_f o ~default = match o with None -> default () | Some v -> v + +let value_fe o ~error = + match o with None -> Error (error ()) | Some v -> Ok v + +let either oa ob = match oa with Some _ -> oa | None -> ob + +let map_s f o = + match o with None -> Lwt.return_none | Some v -> f v >>= Lwt.return_some + +let map_e f o = match o with None -> none_e | Some v -> Result.map some (f v) + +let map_es f o = match o with None -> none_es | Some v -> f v >|=? some + +let fold_s ~none ~some = function None -> Lwt.return none | Some v -> some v + +let fold_f ~none ~some = function None -> none () | Some v -> some v + +let iter_s f = function None -> Lwt.return_unit | Some v -> f v + +let iter_e f = function None -> Ok () | Some v -> f v + +let iter_es f = function None -> Lwt.return_ok () | Some v -> f v + +let of_result = function Ok v -> Some v | Error _ -> None diff --git a/src/lib_lwt_result_stdlib/lib/option.ml b/src/lib_lwt_result_stdlib/bare/structs/option.mli similarity index 98% rename from src/lib_lwt_result_stdlib/lib/option.ml rename to src/lib_lwt_result_stdlib/bare/structs/option.mli index 0d3338c7c2ba317d17f26baac81dcd55f4503ea0..d2b466d7d28f0dab48ce67657cb38b4141888b2e 100644 --- a/src/lib_lwt_result_stdlib/lib/option.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/option.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Functors.Option.M +include Bare_sigs.Option.S diff --git a/src/lib_lwt_result_stdlib/bare/structs/result.ml b/src/lib_lwt_result_stdlib/bare/structs/result.ml new file mode 100644 index 0000000000000000000000000000000000000000..6fb5d39f5347b53fe07dfa12896085719f5c7b62 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/result.ml @@ -0,0 +1,126 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Lwt.Infix + +type ('a, 'e) t = ('a, 'e) result = Ok of 'a | Error of 'e + +let ok x = Ok x + +let ok_s x = Lwt.return (Ok x) + +let error x = Error x + +let error_s x = Lwt.return (Error x) + +let value r ~default = match r with Ok v -> v | Error _ -> default + +let value_f r ~default = match r with Ok v -> v | Error _ -> default () + +let bind r f = match r with Ok v -> f v | Error _ as error -> error + +let bind_s r f = + match r with Ok v -> f v | Error _ as error -> Lwt.return error + +let bind_error r f = match r with Ok _ as ok -> ok | Error e -> f e + +let bind_error_s r f = + match r with Ok _ as ok -> Lwt.return ok | Error e -> f e + +let join = function + | (Error _ as error) | Ok (Error _ as error) -> + error + | Ok (Ok _ as ok) -> + ok + +let map f = function Ok v -> Ok (f v) | Error _ as error -> error + +let map_e f r = bind r f + +let map_s f = function + | Ok v -> + f v >>= fun v -> Lwt.return (Ok v) + | Error _ as error -> + Lwt.return error + +let map_es f r = bind_s r f + +let map_error f = function Ok _ as ok -> ok | Error e -> Error (f e) + +let map_error_e f r = bind_error r f + +let map_error_s f = function + | Ok v -> + Lwt.return (Ok v) + | Error e -> + f e >>= fun e -> Lwt.return (Error e) + +let map_error_es f r = bind_error_s r f + +let fold ~ok ~error = function Ok v -> ok v | Error e -> error e + +let iter f = function Ok v -> f v | Error _ -> () + +let iter_s f = function Ok v -> f v | Error _ -> Lwt.return_unit + +let iter_error f = function Ok _ -> () | Error e -> f e + +let iter_error_s f = function Ok _ -> Lwt.return_unit | Error e -> f e + +let is_ok = function Ok _ -> true | Error _ -> false + +let is_error = function Ok _ -> false | Error _ -> true + +let equal ~ok ~error x y = + match (x, y) with + | (Ok x, Ok y) -> + ok x y + | (Error x, Error y) -> + error x y + | (Ok _, Error _) | (Error _, Ok _) -> + false + +let compare ~ok ~error x y = + match (x, y) with + | (Ok x, Ok y) -> + ok x y + | (Error x, Error y) -> + error x y + | (Ok _, Error _) -> + -1 + | (Error _, Ok _) -> + 1 + +let to_option = function Ok v -> Some v | Error _ -> None + +let of_option ~error = function Some v -> Ok v | None -> Error error + +let to_list = function Ok v -> [v] | Error _ -> [] + +let to_seq = function + | Ok v -> + Stdlib.Seq.return v + | Error _ -> + Stdlib.Seq.empty diff --git a/src/lib_lwt_result_stdlib/bare/structs/result.mli b/src/lib_lwt_result_stdlib/bare/structs/result.mli new file mode 100644 index 0000000000000000000000000000000000000000..92d7888038d27c61be33be9c8e977d1c8171cf98 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/result.mli @@ -0,0 +1,26 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +include Bare_sigs.Result.S diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq.ml b/src/lib_lwt_result_stdlib/bare/structs/seq.ml new file mode 100644 index 0000000000000000000000000000000000000000..20c7e88f8c8939497521da6778b11db52dc81450 --- /dev/null +++ b/src/lib_lwt_result_stdlib/bare/structs/seq.ml @@ -0,0 +1,359 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Monad +include Stdlib.Seq + +let nil_e = Ok Nil + +let nil_s = Lwt.return Nil + +let nil_es = Lwt.return nil_e + +let empty_e = Ok empty + +let empty_s = Lwt.return empty + +let empty_es = Lwt.return empty_e + +(* Like Lwt.apply but specialised for three parameters *) +let apply3 f x y = try f x y with exn -> Lwt.fail exn + +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 fold_left_s f acc seq = + match seq () with + | Nil -> + Lwt.return acc + | Cons (item, seq) -> + apply3 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 fold_left_es f acc seq = + match seq () with + | Nil -> + Monad.return acc + | Cons (item, seq) -> + apply3 f acc item >>=? fun acc -> fold_left_es f acc seq + +let rec iter_e f seq = + match seq () with + | Nil -> + unit_e + | Cons (item, seq) -> + f item >>? fun () -> iter_e f seq + +let rec iter_s f seq = + match seq () with + | Nil -> + unit_s + | Cons (item, seq) -> + f item >>= fun () -> iter_s f seq + +let iter_s f seq = + match seq () with + | Nil -> + unit_s + | Cons (item, seq) -> + Lwt.apply f item >>= fun () -> iter_s f seq + +let rec iter_es f seq = + match seq () with + | Nil -> + unit_es + | Cons (item, seq) -> + f item >>=? fun () -> iter_es f seq + +let iter_es f seq = + match seq () with + | Nil -> + unit_es + | Cons (item, seq) -> + Lwt.apply f item >>=? fun () -> iter_es f seq + +let iter_ep f seq = + let rec iter_ep f seq (acc : (unit, 'error) result Lwt.t list) = + match seq () with + | Nil -> + join_ep acc + | Cons (item, seq) -> + iter_ep f seq (Lwt.apply f item :: acc) + in + iter_ep 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 (Lwt.apply f item :: acc) + in + iter_p f seq [] + +let rec map_e f seq = + match seq () with + | Nil -> + empty_e + | 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 -> + empty_s + | Cons (item, seq) -> + f item + >>= fun item -> + map_s f seq >>= fun seq -> Lwt.return (fun () -> Cons (item, seq)) + +let map_s f seq = + match seq () with + | Nil -> + empty_s + | Cons (item, seq) -> + Lwt.apply 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 -> + empty_es + | Cons (item, seq) -> + f item + >>=? fun item -> + map_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) + +let map_es f seq = + match seq () with + | Nil -> + empty_es + | Cons (item, seq) -> + Lwt.apply f item + >>=? fun item -> + map_es f seq >>=? fun seq -> Monad.return (fun () -> Cons (item, seq)) + +let map_ep f seq = + all_ep (fold_left (fun acc x -> Lwt.apply f x :: acc) [] seq) + >|=? (* this is equivalent to rev |> to_seq but more direct *) + Stdlib.List.fold_left (fun s x () -> Cons (x, s)) empty + +let map_p f seq = + all_p (fold_left (fun acc x -> Lwt.apply f x :: acc) [] seq) + >|= (* this is equivalent to rev |> to_seq but more direct *) + Stdlib.List.fold_left (fun s x () -> Cons (x, s)) empty + +let rec filter_e f seq = + match seq () with + | Nil -> + empty_e + | 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 -> + empty_s + | 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 filter_s f seq = + match seq () with + | Nil -> + empty_s + | Cons (item, seq) -> ( + Lwt.apply 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 -> + empty_es + | 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 filter_es f seq = + match seq () with + | Nil -> + empty_es + | Cons (item, seq) -> ( + Lwt.apply 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 -> + empty_e + | 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 -> + empty_s + | 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 filter_map_s f seq = + match seq () with + | Nil -> + empty_s + | Cons (item, seq) -> ( + Lwt.apply 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 -> + empty_es + | 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 filter_map_es f seq = + match seq () with + | Nil -> + empty_es + | Cons (item, seq) -> ( + Lwt.apply 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 f seq = + match seq () with + | Nil -> + None + | Cons (item, seq) -> + if f item then Some item else find f seq + +let rec find_e f seq = + match seq () with + | Nil -> + none_e + | Cons (item, seq) -> ( + f item >>? function true -> some_e item | false -> find_e f seq ) + +let rec find_s f seq = + match seq () with + | Nil -> + none_s + | Cons (item, seq) -> ( + f item >>= function true -> some_s item | false -> find_s f seq ) + +let find_s f seq = + match seq () with + | Nil -> + none_s + | Cons (item, seq) -> ( + Lwt.apply f item + >>= function true -> some_s item | false -> find_s f seq ) + +let rec find_es f seq = + match seq () with + | Nil -> + none_es + | Cons (item, seq) -> ( + f item >>=? function true -> some_es item | false -> find_es f seq ) + +let find_es f seq = + match seq () with + | Nil -> + none_es + | Cons (item, seq) -> ( + Lwt.apply f item + >>=? function true -> some_es item | false -> find_es f seq ) diff --git a/src/lib_lwt_result_stdlib/lib/option.mli b/src/lib_lwt_result_stdlib/bare/structs/seq.mli similarity index 98% rename from src/lib_lwt_result_stdlib/lib/option.mli rename to src/lib_lwt_result_stdlib/bare/structs/seq.mli index 056121c7d12e58e2ed8cb27349d6e338be4e67f5..920dc8493cd98a36a084fc91d4f16277b53635ab 100644 --- a/src/lib_lwt_result_stdlib/lib/option.mli +++ b/src/lib_lwt_result_stdlib/bare/structs/seq.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Sigs.Option.S +include Bare_sigs.Seq.S diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.mli b/src/lib_lwt_result_stdlib/bare/structs/set.ml similarity index 70% rename from src/lib_lwt_result_stdlib/lib/hashtbl.mli rename to src/lib_lwt_result_stdlib/bare/structs/set.ml index 7c6a9ee1609804eff3c8d0550f8ff1bfe995cb5b..61a5b88416f5c3e73951c75905ab50e5d016e286 100644 --- a/src/lib_lwt_result_stdlib/lib/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/bare/structs/set.ml @@ -23,26 +23,38 @@ (* *) (*****************************************************************************) -val hash : 'a -> int +module type S = Bare_functor_outputs.Set.S -val seeded_hash : int -> 'a -> int +module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t = struct + open Seq + module Legacy = Stdlib.Set.Make (Ord) + include Legacy -val hash_param : meaningful:int -> total:int -> 'a -> int + let iter_e f t = iter_e f (to_seq t) -val seeded_hash_param : meaningful:int -> total:int -> int -> 'a -> int + let iter_s f t = iter_s f (to_seq t) -module type S = - Sigs.Hashtbl.S with type 'error trace := 'error Error_monad.trace + let iter_p f t = iter_p f (to_seq t) -module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t + let iter_es f t = iter_es f (to_seq t) -module type SeededS = - Sigs.Hashtbl.SeededS with type 'error trace := 'error Error_monad.trace + let iter_ep f t = iter_ep f (to_seq t) -module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : - SeededS with type key = H.t + let fold_e f t init = fold_left_e (fun acc e -> f e acc) init (to_seq t) -module type S_LWT = - Sigs.Hashtbl.S_LWT with type 'error trace := 'error Seq.Monad.trace + let fold_s f t init = fold_left_s (fun acc e -> f e acc) init (to_seq t) -module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.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 diff --git a/src/lib_lwt_result_stdlib/functors/result.mli b/src/lib_lwt_result_stdlib/bare/structs/set.mli similarity index 98% rename from src/lib_lwt_result_stdlib/functors/result.mli rename to src/lib_lwt_result_stdlib/bare/structs/set.mli index 4a9bca781ccd89668c9ada6c1cfacfd3454da1b9..9978523e03e8ef9610c2ebdef9ba5bc7da28750b 100644 --- a/src/lib_lwt_result_stdlib/functors/result.mli +++ b/src/lib_lwt_result_stdlib/bare/structs/set.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -module M : Sigs.Result.S +include Bare_sigs.Set.S diff --git a/src/lib_lwt_result_stdlib/functors/option.ml b/src/lib_lwt_result_stdlib/bare/structs/withExceptions.ml similarity index 57% rename from src/lib_lwt_result_stdlib/functors/option.ml rename to src/lib_lwt_result_stdlib/bare/structs/withExceptions.ml index cdf2fe687a8da63e816e3676f0a241ac583428e3..44f8a035dd594a32dff205ed0a712a4621ee969f 100644 --- a/src/lib_lwt_result_stdlib/functors/option.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/withExceptions.ml @@ -23,63 +23,61 @@ (* *) (*****************************************************************************) -module M : Sigs.Option.S = struct - open Lwt.Infix - include Stdlib.Option +let invalid name loc = + Invalid_argument (Printf.sprintf "%s called from %s" name loc) - let some_unit = Some () - - let some_nil = Some [] - - let some_e v = Ok (Some v) - - let some_s v = Lwt.return (Some v) - - let some_es v = Lwt.return (Ok (Some v)) - - let none_e = Ok None - - let none_s = Lwt.return None - - let none_es = Lwt.return none_e - - let value_e o ~error = to_result ~none:error o - - let value_f o ~default = match o with None -> default () | Some v -> v - - let value_fe o ~error = - match o with None -> Error (error ()) | Some v -> Ok v - - let either oa ob = match oa with Some _ -> oa | None -> ob - - let map_s f o = - match o with None -> Lwt.return_none | Some v -> f v >>= Lwt.return_some - - let map_e f o = - match o with None -> none_e | Some v -> Result.M.map some (f v) - - let map_es f o = - match o with - | None -> - none_es +module Option = struct + let get ~loc = function | Some v -> - (* TODO: when the monad becomes independent from the functors - applications, use a monad-like bind ([>|=?]).*) - Lwt.map (Result.M.map some) (f v) - - let fold_s ~none ~some = function + v | None -> - Lwt.return none - | Some v -> - some v + raise (invalid "Lwtreslib.WithExceptions.Option.get" loc) + + let to_exn ~none = function Some v -> v | None -> raise none - let fold_f ~none ~some = function None -> none () | Some v -> some v + let to_exn_f ~none = function Some v -> v | None -> raise (none ()) +end - let iter_s f = function None -> Lwt.return_unit | Some v -> f v +module Result = struct + let get_ok ~loc = function + | Ok v -> + v + | Error _ -> + raise (invalid "Lwtreslib.WithExceptions.Result.get_ok" loc) - let iter_e f = function None -> Ok () | Some v -> f v + let get_error ~loc = function + | Error e -> + e + | Ok _ -> + raise (invalid "Lwtreslib.WithExceptions.Result.get_error" loc) - let iter_es f = function None -> Lwt.return_ok () | Some v -> f v + let to_exn = function Ok v -> v | Error exc -> raise exc + + let to_exn_f ~error = function Ok v -> v | Error b -> raise (error b) +end - let of_result = function Ok v -> Some v | Error _ -> None +module List = struct + let rev_combine ~loc xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + acc + | (x :: xs, y :: ys) -> + aux ((x, y) :: acc) xs ys + | ([], _ :: _) | (_ :: _, []) -> + raise (invalid "Lwtreslib.WithExceptions.List.rev_combine" loc) + in + aux [] xs ys + + let combine ~loc xs ys = + let rec aux acc xs ys = + match (xs, ys) with + | ([], []) -> + acc + | (x :: xs, y :: ys) -> + aux ((x, y) :: acc) xs ys + | ([], _ :: _) | (_ :: _, []) -> + raise (invalid "Lwtreslib.WithExceptions.List.combine" loc) + in + Stdlib.List.rev (aux [] xs ys) end diff --git a/src/lib_lwt_result_stdlib/functors/withExceptions.mli b/src/lib_lwt_result_stdlib/bare/structs/withExceptions.mli similarity index 98% rename from src/lib_lwt_result_stdlib/functors/withExceptions.mli rename to src/lib_lwt_result_stdlib/bare/structs/withExceptions.mli index 7647f40b33fa76936fb54ac3b1c288ddb44d35f3..78a4c2a5ac4bd9625fb21f76513d171aa23e24cd 100644 --- a/src/lib_lwt_result_stdlib/functors/withExceptions.mli +++ b/src/lib_lwt_result_stdlib/bare/structs/withExceptions.mli @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -module M : Sigs.WithExceptions.S +include Bare_sigs.WithExceptions.S diff --git a/src/lib_lwt_result_stdlib/dune b/src/lib_lwt_result_stdlib/dune index 177e327e0a62ced541283b15c039f5336fa494f8..c4a8e62ec454de2dbc74e5d42a991f372220883f 100644 --- a/src/lib_lwt_result_stdlib/dune +++ b/src/lib_lwt_result_stdlib/dune @@ -1,12 +1,12 @@ (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)) + (libraries lwt + tezos-lwt-result-stdlib.bare.sigs + tezos-lwt-result-stdlib.bare.structs + tezos-lwt-result-stdlib.traced.sigs + tezos-lwt-result-stdlib.traced.structs + )) (rule (alias runtest_lint) diff --git a/src/lib_lwt_result_stdlib/examples/traces/.ocamlformat b/src/lib_lwt_result_stdlib/examples/traces/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_lwt_result_stdlib/examples/traces/.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/examples/traces/dune b/src/lib_lwt_result_stdlib/examples/traces/dune new file mode 100644 index 0000000000000000000000000000000000000000..31f92dc0314ac71cd9a38b8580c737c329365c8d --- /dev/null +++ b/src/lib_lwt_result_stdlib/examples/traces/dune @@ -0,0 +1,9 @@ +(library + (name traces) + (public_name tezos-lwt-result-stdlib.examples.traces) + (libraries lwt tezos-lwt-result-stdlib.bare.structs tezos-lwt-result-stdlib.traced.sigs)) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/examples/traces/traces.ml b/src/lib_lwt_result_stdlib/examples/traces/traces.ml new file mode 100644 index 0000000000000000000000000000000000000000..4633e07e79a5cf0ebdd2409701c1af557f4b6b1a --- /dev/null +++ b/src/lib_lwt_result_stdlib/examples/traces/traces.ml @@ -0,0 +1,401 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 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 = Traced_sigs.Trace.S + +module type EXTENDED = sig + include S + + val pp : + (Format.formatter -> 'err -> unit) -> + Format.formatter -> + 'err trace -> + unit + + val pp_top : + (Format.formatter -> 'err -> unit) -> + Format.formatter -> + 'err trace -> + unit + + val fold : ('a -> 'error -> 'a) -> 'a -> 'error trace -> 'a + + val salvage : + ('error -> 'a option) -> 'error trace -> ('a, 'error trace) result + + val salvage_s : + ('error -> 'a Lwt.t option) -> + 'error trace -> + ('a, 'error trace) result Lwt.t + + val salvage_e : + ('error -> ('a, 'error trace) result option) -> + 'error trace -> + ('a, 'error trace) result + + val salvage_es : + ('error -> ('a, 'error trace) result Lwt.t option) -> + 'error trace -> + ('a, 'error trace) result Lwt.t + + val recover : + ('error -> 'a option) -> ('error trace -> 'a) -> 'error trace -> 'a + + val recover_s : + ('error -> 'a Lwt.t option) -> + ('error trace -> 'a Lwt.t) -> + 'error trace -> + 'a Lwt.t + + val recover_e : + ('error -> ('a, 'error trace) result option) -> + ('error trace -> ('a, 'error trace) result) -> + 'error trace -> + ('a, 'error trace) result + + val recover_es : + ('error -> ('a, 'error trace) result Lwt.t option) -> + ('error trace -> ('a, 'error trace) result Lwt.t) -> + 'error trace -> + ('a, 'error trace) result Lwt.t + + val wrap : ('a -> 'b) -> 'a trace -> 'b trace +end + +module SingletonR : EXTENDED = struct + type 'error trace = 'error + + let make e = e + + let cons e _ = e + + let cons_list e _ = e + + let conp e _ = e + + let conp_list e _ = e + + let pp pp_error fmt e = pp_error fmt e + + let pp_top pp_error fmt e = pp_error fmt e + + let fold f acc e = f acc e + + open Bare_structs.Monad + + let salvage f e = match f e with None -> Error e | Some x -> Ok x + + let salvage_s f e = + match f e with + | None -> + Lwt.return (Error e) + | Some x -> + x >>= Lwt.return_ok + + let salvage_e f e = match f e with None -> Error e | Some x -> x + + let salvage_es f e = + match f e with None -> Lwt.return (Error e) | Some x -> x + + let recover f g e = match f e with None -> g e | Some x -> x + + let recover_s f g e = recover f g e + + let recover_e f g e = recover f g e + + let recover_es f g e = recover f g e + + let wrap f e = f e +end + +module SingletonL : EXTENDED = struct + type 'error trace = 'error + + let make e = e + + let cons e _ = e + + let cons_list e _ = e + + let conp _ e = e + + let rec conp_list e = function [] -> e | e :: es -> conp_list e es + + let pp pp_error fmt e = pp_error fmt e + + let pp_top pp_error fmt e = pp_error fmt e + + let fold f acc e = f acc e + + open Bare_structs.Monad + + let salvage f e = match f e with None -> Error e | Some x -> Ok x + + let salvage_s f e = + match f e with + | None -> + Lwt.return (Error e) + | Some x -> + x >>= Lwt.return_ok + + let salvage_e f e = match f e with None -> Error e | Some x -> x + + let salvage_es f e = + match f e with None -> Lwt.return (Error e) | Some x -> x + + let recover f g e = match f e with None -> g e | Some x -> x + + let recover_s f g e = recover f g e + + let recover_e f g e = recover f g e + + let recover_es f g e = recover f g e + + let wrap f e = f e +end + +module SingletonND : EXTENDED = struct + let prng = Random.State.make_self_init () + + let either a b = if Random.State.bool prng then a else b + + let rec any e = function + | [] -> + e + | x :: xs -> + if Random.State.bool prng then e else any x xs + + type 'error trace = 'error + + let make e = e + + let cons = either + + let cons_list = any + + let conp = either + + let conp_list = any + + let pp pp_error fmt e = pp_error fmt e + + let pp_top pp_error fmt e = pp_error fmt e + + let fold f acc e = f acc e + + open Bare_structs.Monad + + let salvage f e = match f e with None -> Error e | Some x -> Ok x + + let salvage_s f e = + match f e with + | None -> + Lwt.return (Error e) + | Some x -> + x >>= Lwt.return_ok + + let salvage_e f e = match f e with None -> Error e | Some x -> x + + let salvage_es f e = + match f e with None -> Lwt.return (Error e) | Some x -> x + + let recover f g e = match f e with None -> g e | Some x -> x + + let recover_s f g e = recover f g e + + let recover_e f g e = recover f g e + + let recover_es f g e = recover f g e + + let wrap f e = f e +end + +module Flat : EXTENDED = struct + type 'error trace = 'error list + + let make e = [e] + + let cons e t = e :: t + + let cons_list e es = e :: es + + let conp el er = el @ er + + let conp_list e es = Stdlib.List.flatten (e :: es) + + let pp pp_error fmt t = + Format.pp_print_list ~pp_sep:Format.pp_print_cut pp_error fmt t + + let pp_top pp_error fmt t = + let e = Stdlib.List.hd t in + pp_error fmt e + + let fold f acc e = Stdlib.List.fold_left f acc e + + open Bare_structs.Monad + + let salvage f t = + let e = Stdlib.List.hd t in + match f e with None -> Error t | Some x -> Ok x + + let salvage_s f t = + let e = Stdlib.List.hd t in + match f e with + | None -> + Lwt.return (Error t) + | Some x -> + x >>= Lwt.return_ok + + let salvage_e f t = + let e = Stdlib.List.hd t in + match f e with None -> Error t | Some x -> x + + let salvage_es f t = + let e = Stdlib.List.hd t in + match f e with None -> Lwt.return (Error t) | Some x -> x + + let recover f g t = + let e = Stdlib.List.hd t in + match f e with None -> g t | Some x -> x + + let recover_s f g t = recover f g t + + let recover_e f g t = recover f g t + + let recover_es f g t = recover f g t + + let wrap f t = Stdlib.List.map f t +end + +module Full : EXTENDED = struct + type 'a tree = + | Par of 'a tree list (* invariant: never empty *) + | Seq of 'a * 'a tree + | Singl of 'a + + type 'error trace = 'error tree + + let make e = Singl e + + let cons e t = Seq (e, t) + + let cons_list e es = + match List.rev es with + | [] -> + Singl e + | [ee] -> + Seq (e, Singl ee) + | last :: rev_es -> + Seq (e, List.fold_left (fun acc e -> Seq (e, acc)) (Singl last) rev_es) + + let conp el = function Par er -> Par (el :: er) | _ as er -> Par [el; er] + + let conp_list e es = Par (e :: es) + + (* TODO: use the printbox package instead *) + let rec pp pp_error fmt = function + | Par ts -> + Format.pp_open_vbox fmt 2 ; + List.iter (pp pp_error fmt) ts ; + Format.pp_close_box fmt () + | Seq (e, t) -> + pp_error fmt e ; + Format.pp_force_newline fmt () ; + pp pp_error fmt t + | Singl e -> + pp_error fmt e + + let rec pp_top pp_error fmt = function + | Par ts -> + Format.pp_open_vbox fmt 2 ; + List.iter (pp_top pp_error fmt) ts ; + Format.pp_close_box fmt () + | Seq (e, _) | Singl e -> + pp_error fmt e + + let rec fold f acc = function + | Par ts -> + List.fold_left (fold f) acc ts + | Seq (e, t) -> + fold f (f acc e) t + | Singl e -> + f acc e + + open Bare_structs.Monad + + let pre_salvage f t = + let rec aux_t = function + | Par ts -> + aux_par ts + | Seq (e, _) | Singl e -> + f e + and aux_par = function + | [] -> + None + | t :: ts -> ( + match aux_t t with + | Some _ as salvaged -> + salvaged + | None -> + aux_par ts ) + in + aux_t t + + let salvage f t = + match pre_salvage f t with Some x -> Ok x | None -> Error t + + let salvage_s f t = + match pre_salvage f t with + | Some x -> + x >>= fun x -> Lwt.return (Ok x) + | None -> + Lwt.return (Error t) + + let salvage_e f t = + match pre_salvage f t with Some x -> x | None -> Error t + + let salvage_es f t = + match pre_salvage f t with + | Some x -> + x >>= fun x -> Lwt.return x + | None -> + Lwt.return (Error t) + + let recover f g t = match pre_salvage f t with Some x -> x | None -> g t + + let recover_s f g t = recover f g t + + let recover_e f g t = recover f g t + + let recover_es f g t = recover f g t + + let rec wrap f = function + | Par ts -> + Par (List.map (wrap f) ts) + | Seq (e, t) -> + Seq (f e, wrap f t) + | Singl e -> + Singl (f e) +end diff --git a/src/lib_lwt_result_stdlib/examples/traces/traces.mli b/src/lib_lwt_result_stdlib/examples/traces/traces.mli new file mode 100644 index 0000000000000000000000000000000000000000..859bdaf96b48683f8eedd6e0efe80e5298b08857 --- /dev/null +++ b/src/lib_lwt_result_stdlib/examples/traces/traces.mli @@ -0,0 +1,105 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 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 = Traced_sigs.Trace.S + +module type EXTENDED = sig + include S + + val pp : + (Format.formatter -> 'err -> unit) -> + Format.formatter -> + 'err trace -> + unit + + val pp_top : + (Format.formatter -> 'err -> unit) -> + Format.formatter -> + 'err trace -> + unit + + val fold : ('a -> 'error -> 'a) -> 'a -> 'error trace -> 'a + + val salvage : + ('error -> 'a option) -> 'error trace -> ('a, 'error trace) result + + val salvage_s : + ('error -> 'a Lwt.t option) -> + 'error trace -> + ('a, 'error trace) result Lwt.t + + val salvage_e : + ('error -> ('a, 'error trace) result option) -> + 'error trace -> + ('a, 'error trace) result + + val salvage_es : + ('error -> ('a, 'error trace) result Lwt.t option) -> + 'error trace -> + ('a, 'error trace) result Lwt.t + + val recover : + ('error -> 'a option) -> ('error trace -> 'a) -> 'error trace -> 'a + + val recover_s : + ('error -> 'a Lwt.t option) -> + ('error trace -> 'a Lwt.t) -> + 'error trace -> + 'a Lwt.t + + val recover_e : + ('error -> ('a, 'error trace) result option) -> + ('error trace -> ('a, 'error trace) result) -> + 'error trace -> + ('a, 'error trace) result + + val recover_es : + ('error -> ('a, 'error trace) result Lwt.t option) -> + ('error trace -> ('a, 'error trace) result Lwt.t) -> + 'error trace -> + ('a, 'error trace) result Lwt.t + + val wrap : ('a -> 'b) -> 'a trace -> 'b trace +end + +(** [Singleton] is a trace implementation where a trace carries exactly one + error. Additional information is discarded. The different variant discard + additional information in different unspecified way. This is useful for + testing purpose if you need to check that you do not depend on some + unspecified behaviour. [SingletonND] is even non-deterministic. *) +module SingletonR : EXTENDED + +module SingletonL : EXTENDED + +module SingletonND : EXTENDED + +(** [Flat] is a trace implementation where a trace carries a flat collection of + errors. No error is discarded, but the structure (parallel vs sequential) + is. *) +module Flat : EXTENDED + +(** [Full] is a trace implementation where a trace carries a structured + collection of errors. No error is discarded, nor is the structure. *) +module Full : EXTENDED diff --git a/src/lib_lwt_result_stdlib/functors/dune b/src/lib_lwt_result_stdlib/functors/dune deleted file mode 100644 index 0047954b6b69f5085e3823549cae3529593037fd..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/functors/dune +++ /dev/null @@ -1,10 +0,0 @@ -(library - (name functors) - (public_name tezos-lwt-result-stdlib.functors) - (flags (:standard)) - (libraries lwt tezos-lwt-result-stdlib.sigs)) - -(rule - (alias 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 deleted file mode 100644 index 11f0d87ae4eb7875374365bd0e89d0fe94432025..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.ml +++ /dev/null @@ -1,209 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - let hash = Stdlib.Hashtbl.hash - - let seeded_hash = Stdlib.Hashtbl.seeded_hash - - let hash_param ~meaningful ~total v = - Stdlib.Hashtbl.hash_param meaningful total v - - let seeded_hash_param ~meaningful ~total seed v = - Stdlib.Hashtbl.seeded_hash_param meaningful total seed v - - module type S = - Sigs.Hashtbl.S with type 'error trace := 'error Seq.Monad.trace - - module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t = struct - open Seq - module Legacy = Stdlib.Hashtbl.Make (H) - include Legacy - - 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 SeededS = - Sigs.Hashtbl.SeededS with type 'error trace := 'error Seq.Monad.trace - - module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : - SeededS with type key = H.t = struct - open Seq - module Legacy = Stdlib.Hashtbl.MakeSeeded (H) - include Legacy - - 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 trace := 'error Seq.Monad.trace - - 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, 'trace) t = ('a, 'trace) 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) ; - (* NOTE: we still need to call [T.remove] in case the promise is not - cancelable (in which case it is not rejected and thus not removed) *) - T.remove t k - - let mem t k = T.mem t k - - let iter_with_waiting_es f t = - iter_es - (fun (k, p) -> - Lwt.try_bind - (fun () -> p) - (function Error _ -> Monad.return_unit | Ok v -> f k v) - (fun _ -> Monad.return_unit)) - (T.to_seq t) - - let iter_with_waiting_ep f t = - iter_ep - (fun (k, p) -> - Lwt.try_bind - (fun () -> p) - (function Error _ -> Monad.return_unit | Ok v -> f k v) - (fun _ -> Monad.return_unit)) - (T.to_seq t) - - let fold_with_waiting_es f t init = - fold_left_es - (fun acc (k, p) -> - Lwt.try_bind - (fun () -> p) - (function Error _ -> return acc | Ok v -> f k v acc) - (fun _ -> return 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/list.ml b/src/lib_lwt_result_stdlib/functors/list.ml deleted file mode 100644 index d015e5a1e8ec368f2c8e14cce28bc613f8f01e2c..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/functors/list.ml +++ /dev/null @@ -1,1176 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -module Make (Monad : Sigs.Monad.S) : - Sigs.List.S with type 'error trace := 'error Monad.trace = struct - open Lwt.Infix - open Monad - module Legacy = Stdlib.List - include Legacy - - let nil = [] - - let nil_e = Ok [] - - let nil_s = Lwt.return_nil - - let nil_es = Lwt.return nil_e - - let hd = function x :: _ -> Some x | [] -> None - - let tl = function _ :: xs -> Some xs | [] -> None - - let nth xs n = - if n < 0 then None - else - let rec aux xs n = - match (xs, n) with - | ([], _) -> - None - | (x :: _, 0) -> - Some x - | (_ :: xs, n) -> - (aux [@ocaml.tailcall]) xs (n - 1) - in - aux xs n - - let rec last hd = function - | [] -> - hd - | [last] -> - last - | hd :: (_ :: _ as tl) -> - (last [@ocaml.tailcall]) hd tl - - let last_opt = function [] -> None | hd :: tl -> Some (last hd tl) - - let find = find_opt - - let rec iter2 ~when_different_lengths f xs ys = - (* NOTE: We could do the following but we would need to assume [f] does not - raise [Invalid_argument] - [try - Ok (iter2 f xs ys) - with Invalid_argument _ -> - Error when_different_lengths] - The same remark applies to the other 2-list iterators. - *) - match (xs, ys) with - | ([], []) -> - ok_unit - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - | (x :: xs, y :: ys) -> - f x y ; - (iter2 [@ocaml.tailcall]) ~when_different_lengths f xs ys - - let rev_map2 ~when_different_lengths f xs ys = - let rec aux zs xs ys = - match (xs, ys) with - | ([], []) -> - Ok zs - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - | (x :: xs, y :: ys) -> - let z = f x y in - (aux [@ocaml.tailcall]) (z :: zs) xs ys - in - aux [] xs ys - - let map2 ~when_different_lengths f xs ys = - rev_map2 ~when_different_lengths f xs ys >|? rev - - let fold_left2 ~when_different_lengths f a xs ys = - let rec aux acc xs ys = - match (xs, ys) with - | ([], []) -> - Ok acc - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - | (x :: xs, y :: ys) -> - let acc = f acc x y in - (aux [@ocaml.tailcall]) acc xs ys - in - aux a xs ys - - let fold_right2 ~when_different_lengths f xs ys a = - let rec aux xs ys = - match (xs, ys) with - | ([], []) -> - Ok a - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - | (x :: xs, y :: ys) -> - aux xs ys >|? fun acc -> f x y acc - in - aux xs ys - - let for_all2 ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], []) -> - Ok true - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - | (x :: xs, y :: ys) -> ( - match f x y with - | true -> - (aux [@ocaml.tailcall]) xs ys - | false -> - Ok false ) - in - aux xs ys - - let exists2 ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], []) -> - Ok false - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - | (x :: xs, y :: ys) -> ( - match f x y with - | true -> - Ok true - | false -> - (aux [@ocaml.tailcall]) xs ys ) - in - aux xs ys - - let assoc = assoc_opt - - let assq = assq_opt - - let init ~when_negative_length l f = - if l < 0 then Error when_negative_length - else if l = 0 then nil_e - else Ok (Legacy.init l f) - - let init_e ~when_negative_length l f = - let rec aux acc i = - if i >= l then Ok (rev acc) - else f i >>? fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) - in - if l < 0 then Error when_negative_length - else if l = 0 then nil_e - else aux [] 0 - - let init_s ~when_negative_length l f = - let rec aux acc i = - if i >= l then Lwt.return (Ok (rev acc)) - else f i >>= fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) - in - if l < 0 then Lwt.return (Error when_negative_length) - else if l = 0 then nil_es - else Lwt.apply f 0 >>= fun v -> aux [v] 1 - - let init_es ~when_negative_length l f = - let rec aux acc i = - if i >= l then Lwt.return (Ok (rev acc)) - else f i >>=? fun v -> (aux [@ocaml.tailcall]) (v :: acc) (i + 1) - in - if l < 0 then Lwt.return (Error when_negative_length) - else if l = 0 then nil_es - else Lwt.apply f 0 >>=? fun v -> aux [v] 1 - - let init_p ~when_negative_length l f = - let rec aux acc i = - if i >= l then all_p (rev acc) >>= fun xs -> Lwt.return (Ok xs) - else (aux [@ocaml.tailcall]) (Lwt.apply f i :: acc) (i + 1) - in - if l < 0 then Lwt.return (Error when_negative_length) - else if l = 0 then nil_es - else aux [] 0 - - let init_ep ~when_negative_length l f = - let rec aux acc i = - if i >= l then all_ep (rev acc) - else (aux [@ocaml.tailcall]) (Lwt.apply f i :: acc) (i + 1) - in - if l < 0 then Lwt.return (Error (Monad.make when_negative_length)) - else if l = 0 then nil_es - else aux [] 0 - - let rec find_e f = function - | [] -> - ok_none - | x :: xs -> ( - f x - >>? function - | true -> Ok (Some x) | false -> (find_e [@ocaml.tailcall]) f xs ) - - let rec find_s f = function - | [] -> - Lwt.return_none - | x :: xs -> ( - f x - >>= function - | true -> - Lwt.return (Some x) - | false -> - (find_s [@ocaml.tailcall]) f xs ) - - let find_s f = function - | [] -> - Lwt.return_none - | x :: xs -> ( - Lwt.apply f x - >>= function - | true -> - Lwt.return (Some x) - | false -> - (find_s [@ocaml.tailcall]) f xs ) - - let rec find_es f = function - | [] -> - return_none - | x :: xs -> ( - f x - >>=? function - | true -> - Lwt.return (Ok (Some x)) - | false -> - (find_es [@ocaml.tailcall]) f xs ) - - let find_es f = function - | [] -> - return_none - | x :: xs -> ( - Lwt.apply f x - >>=? function - | true -> - Lwt.return (Ok (Some x)) - | false -> - (find_es [@ocaml.tailcall]) f xs ) - - let rev_filter f xs = - fold_left (fun rev_xs x -> if f x then x :: rev_xs else rev_xs) [] xs - - let rev_filter_e f xs = - let rec aux acc = function - | [] -> - Ok acc - | x :: xs -> ( - f x - >>? function - | true -> - (aux [@ocaml.tailcall]) (x :: acc) xs - | false -> - (aux [@ocaml.tailcall]) acc xs ) - in - aux [] xs - - let rev_filter_some oxs = - let rec aux xs = function - | [] -> - xs - | Some x :: oxs -> - (aux [@ocaml.tailcall]) (x :: xs) oxs - | None :: oxs -> - (aux [@ocaml.tailcall]) xs oxs - in - aux [] oxs - - let filter_some oxs = rev_filter_some oxs |> rev - - let rev_filter_ok rxs = - let rec aux xs = function - | [] -> - xs - | Ok x :: rxs -> - (aux [@ocaml.tailcall]) (x :: xs) rxs - | Error _ :: rxs -> - (aux [@ocaml.tailcall]) xs rxs - in - aux [] rxs - - let filter_ok rxs = rev_filter_ok rxs |> rev - - let rev_filter_error rxs = - let rec aux xs = function - | [] -> - xs - | Error x :: rxs -> - (aux [@ocaml.tailcall]) (x :: xs) rxs - | Ok _ :: rxs -> - (aux [@ocaml.tailcall]) xs rxs - in - aux [] rxs - - let filter_error rxs = rev_filter_error rxs |> rev - - let filter_e f xs = rev_filter_e f xs >|? rev - - let rev_filter_s f xs = - let rec aux acc = function - | [] -> - Lwt.return acc - | x :: xs -> ( - f x - >>= function - | true -> - (aux [@ocaml.tailcall]) (x :: acc) xs - | false -> - (aux [@ocaml.tailcall]) acc xs ) - in - match xs with - | [] -> - Lwt.return [] - | x :: xs -> ( - Lwt.apply f x - >>= function - | true -> - (aux [@ocaml.tailcall]) [x] xs - | false -> - (aux [@ocaml.tailcall]) [] xs ) - - let filter_s f xs = rev_filter_s f xs >|= rev - - let rev_filter_es f xs = - let rec aux acc = function - | [] -> - Lwt.return (Ok acc) - | x :: xs -> ( - f x - >>=? function - | true -> - (aux [@ocaml.tailcall]) (x :: acc) xs - | false -> - (aux [@ocaml.tailcall]) acc xs ) - in - match xs with - | [] -> - Lwt.return (Ok []) - | x :: xs -> ( - Lwt.apply f x >>=? function true -> aux [x] xs | false -> aux [] xs ) - - let filter_es f xs = rev_filter_es f xs >|=? rev - - let rec iter_e f = function - | [] -> - ok_unit - | h :: t -> - f h >>? fun () -> (iter_e [@ocaml.tailcall]) f t - - let rec iter_s f = function - | [] -> - Lwt.return_unit - | h :: t -> - f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t - - let iter_s f = function - | [] -> - Lwt.return_unit - | h :: t -> - Lwt.apply f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t - - let rec iter_es f = function - | [] -> - return_unit - | h :: t -> - f h >>=? fun () -> (iter_es [@ocaml.tailcall]) f t - - let iter_es f = function - | [] -> - return_unit - | h :: t -> - Lwt.apply f h >>=? fun () -> (iter_es [@ocaml.tailcall]) f t - - let iter_p f l = join_p (rev_map (Lwt.apply f) l) - - let iter_ep f l = join_ep (rev_map (Lwt.apply f) l) - - let iteri_e f l = - let rec aux i = function - | [] -> - ok_unit - | x :: xs -> - f i x >>? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs - in - aux 0 l - - let lwt_apply2 f x y = try f x y with exc -> Lwt.fail exc - - let iteri_s f l = - let rec aux i = function - | [] -> - Lwt.return_unit - | x :: xs -> - f i x >>= fun () -> (aux [@ocaml.tailcall]) (i + 1) xs - in - match l with - | [] -> - Lwt.return_unit - | x :: xs -> - lwt_apply2 f 0 x >>= fun () -> aux 1 xs - - let iteri_es f l = - let rec aux i = function - | [] -> - return_unit - | x :: xs -> - f i x >>=? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs - in - match l with - | [] -> - return_unit - | x :: xs -> - lwt_apply2 f 0 x >>=? fun () -> aux 1 xs - - let iteri_p f l = join_p (mapi (lwt_apply2 f) l) - - let iteri_ep f l = join_ep (mapi (lwt_apply2 f) l) - - let rev_map_e f l = - let rec aux ys = function - | [] -> - Ok ys - | x :: xs -> - f x >>? fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs - in - aux [] l - - let map_e f l = rev_map_e f l >|? rev - - let rev_map_s f l = - let rec aux ys = function - | [] -> - Lwt.return ys - | x :: xs -> - f x >>= fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs - in - match l with - | [] -> - Lwt.return [] - | x :: xs -> - Lwt.apply f x >>= fun y -> aux [y] xs - - let map_s f l = rev_map_s f l >|= rev - - let rev_map_es f l = - let rec aux ys = function - | [] -> - return ys - | x :: xs -> - f x >>=? fun y -> (aux [@ocaml.tailcall]) (y :: ys) xs - in - match l with - | [] -> - return [] - | x :: xs -> - Lwt.apply f x >>=? fun y -> aux [y] xs - - let map_es f l = rev_map_es f l >|=? rev - - let rev_map_p f l = all_p @@ rev_map (Lwt.apply f) l - - let map_p f l = rev_map_p f l >|= rev - - let rev_map_ep f l = all_ep @@ rev_map (Lwt.apply f) l - - let map_ep f l = rev_map_ep f l >|=? rev - - let rev_mapi_e f l = - let rec aux i ys = function - | [] -> - Ok ys - | x :: xs -> - f i x >>? fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs - in - aux 0 [] l - - let mapi_e f l = rev_mapi_e f l >|? rev - - let rev_mapi_s f l = - let rec aux i ys = function - | [] -> - Lwt.return ys - | x :: xs -> - f i x >>= fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs - in - match l with - | [] -> - Lwt.return [] - | x :: xs -> - lwt_apply2 f 0 x >>= fun y -> aux 1 [y] xs - - let mapi_s f l = rev_mapi_s f l >|= rev - - let rev_mapi_es f l = - let rec aux i ys = function - | [] -> - return ys - | x :: xs -> - f i x >>=? fun y -> (aux [@ocaml.tailcall]) (i + 1) (y :: ys) xs - in - match l with - | [] -> - return [] - | x :: xs -> - lwt_apply2 f 0 x >>=? fun y -> aux 1 [y] xs - - let mapi_es f l = rev_mapi_es f l >|=? rev - - let rev_mapi f l = - let rec aux i ys = function - | [] -> - ys - | x :: xs -> - (aux [@ocaml.tailcall]) (i + 1) (f i x :: ys) xs - in - aux 0 [] l - - let rev_mapi_p f l = all_p @@ rev_mapi f l - - let mapi_p f l = rev_mapi_p f l >|= rev - - let rev_mapi_ep f l = all_ep @@ rev_mapi f l - - let mapi_ep f l = rev_mapi_ep f l >|=? rev - - let rec fold_left_e f acc = function - | [] -> - Ok acc - | x :: xs -> - f acc x >>? fun acc -> (fold_left_e [@ocaml.tailcall]) f acc xs - - let rec fold_left_s f acc = function - | [] -> - Lwt.return acc - | x :: xs -> - f acc x >>= fun acc -> (fold_left_s [@ocaml.tailcall]) f acc xs - - let fold_left_s f acc = function - | [] -> - Lwt.return acc - | x :: xs -> - lwt_apply2 f acc x >>= fun acc -> fold_left_s f acc xs - - let rec fold_left_es f acc = function - | [] -> - return acc - | x :: xs -> - f acc x >>=? fun acc -> (fold_left_es [@ocaml.tailcall]) f acc xs - - let fold_left_es f acc = function - | [] -> - return acc - | x :: xs -> - lwt_apply2 f acc x >>=? fun acc -> fold_left_es f acc xs - - let filter_p f l = - rev_map_p (fun x -> f x >|= fun b -> if b then Some x else None) l - >|= rev_filter_some - - let filter_ep f l = - rev_map_ep (fun x -> f x >|=? fun b -> if b then Some x else None) l - >|=? rev_filter_some - - let rev_filter_map f l = - fold_left - (fun acc x -> match f x with None -> acc | Some y -> y :: acc) - [] - l - - let filter_map f l = rev_filter_map f l |> rev - - let rev_filter_map_e f l = - fold_left_e - (fun acc x -> f x >|? function None -> acc | Some y -> y :: acc) - [] - l - - let filter_map_e f l = rev_filter_map_e f l >|? rev - - let rev_filter_map_s f l = - fold_left_s - (fun acc x -> f x >|= function None -> acc | Some y -> y :: acc) - [] - l - - let filter_map_s f l = rev_filter_map_s f l >|= rev - - let rev_filter_map_es f l = - fold_left_es - (fun acc x -> f x >|=? function None -> acc | Some y -> y :: acc) - [] - l - - let filter_map_es f l = rev_filter_map_es f l >|=? rev - - let filter_map_p f l = rev_map_p f l >|= rev_filter_some - - let filter_map_ep f l = rev_map_ep f l >|=? rev_filter_some - - let rec fold_right_e f l acc = - match l with - | [] -> - Ok acc - | x :: xs -> - fold_right_e f xs acc >>? fun acc -> f x acc - - let rec fold_right_s f l acc = - match l with - | [] -> - Lwt.return acc - | x :: xs -> - fold_right_s f xs acc >>= fun acc -> f x acc - - let rec fold_right_es f l acc = - match l with - | [] -> - return acc - | x :: xs -> - fold_right_es f xs acc >>=? fun acc -> f x acc - - let rev_map2_e ~when_different_lengths f xs ys = - let rec aux zs xs ys = - match (xs, ys) with - | ([], []) -> - Ok zs - | (x :: xs, y :: ys) -> - f x y >>? fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - in - aux [] xs ys - - let rev_map2_s ~when_different_lengths f xs ys = - let rec aux zs xs ys = - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok zs) - | (x :: xs, y :: ys) -> - f x y >>= fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - in - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok []) - | (x :: xs, y :: ys) -> - lwt_apply2 f x y >>= fun z -> aux [z] xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - - let rev_map2_es ~when_different_lengths f xs ys = - let rec aux zs xs ys = - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok zs) - | (x :: xs, y :: ys) -> - f x y >>=? fun z -> (aux [@ocaml.tailcall]) (z :: zs) xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - in - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok []) - | (x :: xs, y :: ys) -> - lwt_apply2 f x y >>=? fun z -> aux [z] xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - - let map2_e ~when_different_lengths f xs ys = - rev_map2_e ~when_different_lengths f xs ys >|? rev - - let map2_s ~when_different_lengths f xs ys = - rev_map2_s ~when_different_lengths f xs ys >|=? rev - - let map2_es ~when_different_lengths f xs ys = - rev_map2_es ~when_different_lengths f xs ys >|=? rev - - let iter2_e ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], []) -> - Monad.ok_unit - | (x :: xs, y :: ys) -> - f x y >>? fun () -> (aux [@ocaml.tailcall]) xs ys - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - in - aux xs ys - - let iter2_s ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok ()) - | (x :: xs, y :: ys) -> - f x y >>= fun () -> (aux [@ocaml.tailcall]) xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - in - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok ()) - | (x :: xs, y :: ys) -> - lwt_apply2 f x y >>= fun () -> aux xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - - let iter2_es ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], []) -> - Monad.return_unit - | (x :: xs, y :: ys) -> - f x y >>=? fun () -> (aux [@ocaml.tailcall]) xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - in - match (xs, ys) with - | ([], []) -> - Monad.return_unit - | (x :: xs, y :: ys) -> - lwt_apply2 f x y >>=? fun () -> aux xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - - let fold_left2_e ~when_different_lengths f init xs ys = - let rec aux acc xs ys = - match (xs, ys) with - | ([], []) -> - Ok acc - | (x :: xs, y :: ys) -> - f acc x y >>? fun acc -> (aux [@ocaml.tailcall]) acc xs ys - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - in - aux init xs ys - - let lwt_apply3 f a x y = try f a x y with exc -> Lwt.fail exc - - let fold_left2_s ~when_different_lengths f init xs ys = - let rec aux acc xs ys = - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok acc) - | (x :: xs, y :: ys) -> - f acc x y >>= fun acc -> (aux [@ocaml.tailcall]) acc xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - in - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok init) - | (x :: xs, y :: ys) -> - lwt_apply3 f init x y >>= fun acc -> aux acc xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - - let fold_left2_es ~when_different_lengths f init xs ys = - let rec aux acc xs ys = - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok acc) - | (x :: xs, y :: ys) -> - f acc x y >>=? fun acc -> (aux [@ocaml.tailcall]) acc xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - in - match (xs, ys) with - | ([], []) -> - Lwt.return (Ok init) - | (x :: xs, y :: ys) -> - lwt_apply3 f init x y >>=? fun acc -> (aux [@ocaml.tailcall]) acc xs ys - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - - let fold_right2_e ~when_different_lengths f xs ys init = - let rec aux xs ys = - match (xs, ys) with - | ([], []) -> - Ok init - | (x :: xs, y :: ys) -> - aux xs ys >>? fun acc -> f x y acc - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - in - aux xs ys - - let fold_right2_s ~when_different_lengths f xs ys init = - let rec aux xs ys = - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Lwt.return (Ok init) - | (x :: xs, y :: ys) -> - (* We could use a specific operator for that. It'd need the following type - ('a, 'err) result Lwt.t -> ('a -> 'b Lwt.t) -> ('b, 'err) result Lwt.t - *) - aux xs ys >>=? fun acc -> f x y acc >|= ok - in - aux xs ys - - let fold_right2_es ~when_different_lengths f xs ys init = - let rec aux xs ys = - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Lwt.return (Ok init) - | (x :: xs, y :: ys) -> - aux xs ys >>=? fun acc -> f x y acc - in - aux xs ys - - let rec for_all_e f = function - | [] -> - Monad.ok_true - | x :: xs -> ( - f x - >>? function - | true -> (for_all_e [@ocaml.tailcall]) f xs | false -> Monad.ok_false - ) - - let rec for_all_s f = function - | [] -> - Lwt.return_true - | x :: xs -> ( - f x - >>= function - | true -> - (for_all_s [@ocaml.tailcall]) f xs - | false -> - Lwt.return_false ) - - let for_all_s f = function - | [] -> - Lwt.return_true - | x :: xs -> ( - Lwt.apply f x - >>= function - | true -> - (for_all_s [@ocaml.tailcall]) f xs - | false -> - Lwt.return_false ) - - let rec for_all_es f = function - | [] -> - Monad.return_true - | x :: xs -> ( - f x - >>=? function - | true -> - (for_all_es [@ocaml.tailcall]) f xs - | false -> - Monad.return_false ) - - let for_all_es f = function - | [] -> - Monad.return_true - | x :: xs -> ( - Lwt.apply f x - >>=? function - | true -> - (for_all_es [@ocaml.tailcall]) f xs - | false -> - Monad.return_false ) - - let for_all_p f l = rev_map_p f l >|= for_all Fun.id - - let for_all_ep f l = rev_map_ep f l >|=? for_all Fun.id - - let rec exists_e f = function - | [] -> - Monad.ok_false - | x :: xs -> ( - f x - >>? function - | false -> (exists_e [@ocaml.tailcall]) f xs | true -> Monad.ok_true ) - - let rec exists_s f = function - | [] -> - Lwt.return_false - | x :: xs -> ( - f x - >>= function - | false -> (exists_s [@ocaml.tailcall]) f xs | true -> Lwt.return_true - ) - - let exists_s f = function - | [] -> - Lwt.return_false - | x :: xs -> ( - Lwt.apply f x - >>= function false -> exists_s f xs | true -> Lwt.return_true ) - - let rec exists_es f = function - | [] -> - Monad.return_false - | x :: xs -> ( - f x - >>=? function - | false -> - (exists_es [@ocaml.tailcall]) f xs - | true -> - Monad.return_true ) - - let exists_es f = function - | [] -> - Monad.return_false - | x :: xs -> ( - Lwt.apply f x - >>=? function false -> exists_es f xs | true -> Monad.return_true ) - - let exists_p f l = rev_map_p f l >|= exists Fun.id - - let exists_ep f l = rev_map_ep f l >|=? exists Fun.id - - let for_all2_e ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - | ([], []) -> - Monad.ok_true - | (x :: xs, y :: ys) -> ( - f x y - >>? function - | true -> (aux [@ocaml.tailcall]) xs ys | false -> Monad.ok_false ) - in - aux xs ys - - let for_all2_s ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Monad.return_true - | (x :: xs, y :: ys) -> ( - f x y - >>= function - | true -> (aux [@ocaml.tailcall]) xs ys | false -> Monad.return_false - ) - in - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Monad.return_true - | (x :: xs, y :: ys) -> ( - lwt_apply2 f x y - >>= function true -> aux xs ys | false -> Monad.return_false ) - - let for_all2_es ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Monad.return_true - | (x :: xs, y :: ys) -> ( - f x y - >>=? function - | true -> (aux [@ocaml.tailcall]) xs ys | false -> Monad.return_false - ) - in - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Monad.return_true - | (x :: xs, y :: ys) -> ( - lwt_apply2 f x y - >>=? function true -> aux xs ys | false -> Monad.return_false ) - - let exists2_e ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Error when_different_lengths - | ([], []) -> - Monad.ok_false - | (x :: xs, y :: ys) -> ( - f x y - >>? function - | false -> (aux [@ocaml.tailcall]) xs ys | true -> Monad.ok_true ) - in - aux xs ys - - let exists2_s ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Monad.return_false - | (x :: xs, y :: ys) -> ( - f x y - >>= function - | false -> (aux [@ocaml.tailcall]) xs ys | true -> Monad.return_true - ) - in - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Monad.return_false - | (x :: xs, y :: ys) -> ( - lwt_apply2 f x y - >>= function false -> aux xs ys | true -> Monad.return_true ) - - let exists2_es ~when_different_lengths f xs ys = - let rec aux xs ys = - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Monad.return_false - | (x :: xs, y :: ys) -> ( - f x y - >>=? function - | false -> (aux [@ocaml.tailcall]) xs ys | true -> Monad.return_true - ) - in - match (xs, ys) with - | ([], _ :: _) | (_ :: _, []) -> - Lwt.return_error when_different_lengths - | ([], []) -> - Monad.return_false - | (x :: xs, y :: ys) -> ( - lwt_apply2 f x y - >>=? function false -> aux xs ys | true -> Monad.return_true ) - - let rev_partition_result xs = - let rec aux oks errors = function - | [] -> - (oks, errors) - | Ok ok :: xs -> - (aux [@ocaml.tailcall]) (ok :: oks) errors xs - | Error error :: xs -> - (aux [@ocaml.tailcall]) oks (error :: errors) xs - in - aux [] [] xs - - let partition_result xs = - let (rev_oks, rev_errors) = rev_partition_result xs in - (rev rev_oks, rev rev_errors) - - let rev_partition_e f l = - let rec aux trues falses = function - | [] -> - Ok (trues, falses) - | x :: xs -> - f x - >>? fun b -> - if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs - else (aux [@ocaml.tailcall]) trues (x :: falses) xs - in - aux [] [] l - - let partition_e f l = - rev_partition_e f l >|? fun (trues, falses) -> (rev trues, rev falses) - - let rev_partition_s f l = - let rec aux trues falses = function - | [] -> - Lwt.return (trues, falses) - | x :: xs -> - f x - >>= fun b -> - if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs - else (aux [@ocaml.tailcall]) trues (x :: falses) xs - in - match l with - | [] -> - Lwt.return ([], []) - | x :: xs -> - Lwt.apply f x >>= fun b -> if b then aux [x] [] xs else aux [] [x] xs - - let partition_s f l = - rev_partition_s f l >|= fun (trues, falses) -> (rev trues, rev falses) - - let rev_partition_es f l = - let rec aux trues falses = function - | [] -> - Lwt.return_ok (trues, falses) - | x :: xs -> - f x - >>=? fun b -> - if b then (aux [@ocaml.tailcall]) (x :: trues) falses xs - else (aux [@ocaml.tailcall]) trues (x :: falses) xs - in - match l with - | [] -> - Lwt.return_ok ([], []) - | x :: xs -> - Lwt.apply f x >>=? fun b -> if b then aux [x] [] xs else aux [] [x] xs - - let partition_es f l = - rev_partition_es f l >|=? fun (trues, falses) -> (rev trues, rev falses) - - let partition_p f l = - rev_map_p (fun x -> f x >|= fun b -> (b, x)) l - >|= fun bxs -> - fold_left - (fun (trues, falses) (b, x) -> - if b then (x :: trues, falses) else (trues, x :: falses)) - ([], []) - bxs - - let partition_ep f l = - rev_map_ep (fun x -> f x >|=? fun b -> (b, x)) l - >|=? fun bxs -> - fold_left - (fun (trues, falses) (b, x) -> - if b then (x :: trues, falses) else (trues, x :: falses)) - ([], []) - bxs - - let combine ~when_different_lengths xs ys = - map2 ~when_different_lengths (fun x y -> (x, y)) xs ys - - let rev_combine ~when_different_lengths xs ys = - rev_map2 ~when_different_lengths (fun x y -> (x, y)) xs ys - - let combine_with_leftovers xs ys = - let rec aux rev_combined xs ys = - match (xs, ys) with - | ([], []) -> - (rev rev_combined, None) - | ((_ :: _ as left), []) -> - (rev rev_combined, Some (`Left left)) - | ([], (_ :: _ as right)) -> - (rev rev_combined, Some (`Right right)) - | (x :: xs, y :: ys) -> - (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys - in - aux [] xs ys - - let combine_drop xs ys = - let rec aux rev_combined xs ys = - match (xs, ys) with - | (x :: xs, y :: ys) -> - (aux [@ocaml.tailcall]) ((x, y) :: rev_combined) xs ys - | ([], []) | (_ :: _, []) | ([], _ :: _) -> - rev rev_combined - in - aux [] xs ys -end diff --git a/src/lib_lwt_result_stdlib/functors/result.ml b/src/lib_lwt_result_stdlib/functors/result.ml deleted file mode 100644 index e7467ddeb3eb50bb1acd133d08d5ad5af9a3cf46..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/functors/result.ml +++ /dev/null @@ -1,128 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 M : Sigs.Result.S = struct - open Lwt.Infix - - type ('a, 'e) t = ('a, 'e) result = Ok of 'a | Error of 'e - - let ok x = Ok x - - let ok_s x = Lwt.return (Ok x) - - let error x = Error x - - let error_s x = Lwt.return (Error x) - - let value r ~default = match r with Ok v -> v | Error _ -> default - - let value_f r ~default = match r with Ok v -> v | Error _ -> default () - - let bind r f = match r with Ok v -> f v | Error _ as error -> error - - let bind_s r f = - match r with Ok v -> f v | Error _ as error -> Lwt.return error - - let bind_error r f = match r with Ok _ as ok -> ok | Error e -> f e - - let bind_error_s r f = - match r with Ok _ as ok -> Lwt.return ok | Error e -> f e - - let join = function - | (Error _ as error) | Ok (Error _ as error) -> - error - | Ok (Ok _ as ok) -> - ok - - let map f = function Ok v -> Ok (f v) | Error _ as error -> error - - let map_e f r = bind r f - - let map_s f = function - | Ok v -> - f v >>= fun v -> Lwt.return (Ok v) - | Error _ as error -> - Lwt.return error - - let map_es f r = bind_s r f - - let map_error f = function Ok _ as ok -> ok | Error e -> Error (f e) - - let map_error_e f r = bind_error r f - - let map_error_s f = function - | Ok v -> - Lwt.return (Ok v) - | Error e -> - f e >>= fun e -> Lwt.return (Error e) - - let map_error_es f r = bind_error_s r f - - let fold ~ok ~error = function Ok v -> ok v | Error e -> error e - - let iter f = function Ok v -> f v | Error _ -> () - - let iter_s f = function Ok v -> f v | Error _ -> Lwt.return_unit - - let iter_error f = function Ok _ -> () | Error e -> f e - - let iter_error_s f = function Ok _ -> Lwt.return_unit | Error e -> f e - - let is_ok = function Ok _ -> true | Error _ -> false - - let is_error = function Ok _ -> false | Error _ -> true - - let equal ~ok ~error x y = - match (x, y) with - | (Ok x, Ok y) -> - ok x y - | (Error x, Error y) -> - error x y - | (Ok _, Error _) | (Error _, Ok _) -> - false - - let compare ~ok ~error x y = - match (x, y) with - | (Ok x, Ok y) -> - ok x y - | (Error x, Error y) -> - error x y - | (Ok _, Error _) -> - -1 - | (Error _, Ok _) -> - 1 - - let to_option = function Ok v -> Some v | Error _ -> None - - let of_option ~error = function Some v -> Ok v | None -> Error error - - let to_list = function Ok v -> [v] | Error _ -> [] - - let to_seq = function - | Ok v -> - Stdlib.Seq.return v - | Error _ -> - Stdlib.Seq.empty -end diff --git a/src/lib_lwt_result_stdlib/functors/seq.ml b/src/lib_lwt_result_stdlib/functors/seq.ml deleted file mode 100644 index 74843ba6657e7a495b9dae9cdd6db7439669a6e3..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/functors/seq.ml +++ /dev/null @@ -1,364 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - - (* Like Lwt.apply but specialised for three parameters *) - let apply3 f x y = try f x y with exn -> Lwt.fail exn - - 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 fold_left_s f acc seq = - match seq () with - | Nil -> - Lwt.return acc - | Cons (item, seq) -> - apply3 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 fold_left_es f acc seq = - match seq () with - | Nil -> - Monad.return acc - | Cons (item, seq) -> - apply3 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 iter_s f seq = - match seq () with - | Nil -> - Lwt.return_unit - | Cons (item, seq) -> - Lwt.apply 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_es f seq = - match seq () with - | Nil -> - return_unit - | Cons (item, seq) -> - Lwt.apply 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 (Lwt.apply 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 (Lwt.apply 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 map_s f seq = - match seq () with - | Nil -> - lwt_empty - | Cons (item, seq) -> - Lwt.apply 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_es f seq = - match seq () with - | Nil -> - return_empty - | Cons (item, seq) -> - Lwt.apply 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 -> Lwt.apply f x :: acc) [] seq) - >|= (* this is equivalent to rev |> to_seq but more direct *) - Stdlib.List.fold_left (fun s x () -> Cons (x, s)) empty - - let map_ep f seq = - all_ep (fold_left (fun acc x -> Lwt.apply f x :: acc) [] seq) - >|=? (* this is equivalent to rev |> to_seq but more direct *) - Stdlib.List.fold_left (fun s x () -> Cons (x, s)) empty - - 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 filter_s f seq = - match seq () with - | Nil -> - lwt_empty - | Cons (item, seq) -> ( - Lwt.apply 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 filter_es f seq = - match seq () with - | Nil -> - return_empty - | Cons (item, seq) -> ( - Lwt.apply 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 filter_map_s f seq = - match seq () with - | Nil -> - lwt_empty - | Cons (item, seq) -> ( - Lwt.apply 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 filter_map_es f seq = - match seq () with - | Nil -> - return_empty - | Cons (item, seq) -> ( - Lwt.apply 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 f seq = - match seq () with - | Nil -> - None - | Cons (item, seq) -> - if f item then Some item else find f seq - - let rec find_e f seq = - match seq () with - | Nil -> - ok_none - | Cons (item, seq) -> ( - f item >>? function true -> ok_some item | false -> find_e f seq ) - - let rec find_s f seq = - match seq () with - | Nil -> - Lwt.return_none - | Cons (item, seq) -> ( - f item - >>= function true -> Lwt.return_some item | false -> find_s f seq ) - - let find_s f seq = - match seq () with - | Nil -> - Lwt.return_none - | Cons (item, seq) -> ( - Lwt.apply f item - >>= function true -> Lwt.return_some item | false -> find_s f seq ) - - let rec find_es f seq = - match seq () with - | Nil -> - return_none - | Cons (item, seq) -> ( - f item - >>=? function true -> return_some item | false -> find_es f seq ) - - let find_es f seq = - match seq () with - | Nil -> - return_none - | Cons (item, seq) -> ( - Lwt.apply f item - >>=? function true -> return_some item | false -> find_es f seq ) -end diff --git a/src/lib_lwt_result_stdlib/lib/dune b/src/lib_lwt_result_stdlib/lib/dune deleted file mode 100644 index 99d21837cd660ff6bf649bc1ad3b143494352eff..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/lib/dune +++ /dev/null @@ -1,13 +0,0 @@ -(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)) - -(rule - (alias runtest_lint) - (deps (glob_files *.ml{,i})) - (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/lib/list.ml b/src/lib_lwt_result_stdlib/lib/list.ml deleted file mode 100644 index a6dac7678449342c9c211fa0f2f26ab4e6ae98b8..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/lib/list.ml +++ /dev/null @@ -1,26 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -include Functors.List.Make (Seq.Monad) diff --git a/src/lib_lwt_result_stdlib/lib/map.ml b/src/lib_lwt_result_stdlib/lib/map.ml deleted file mode 100644 index 634fa4b2dc02df4c963f43ecfc6590cb998ed976..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/lib/map.ml +++ /dev/null @@ -1,26 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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/result.ml b/src/lib_lwt_result_stdlib/lib/result.ml deleted file mode 100644 index 88089399b002f78c094d8e0cd22202aef8a57f81..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/lib/result.ml +++ /dev/null @@ -1,26 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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.Result.M diff --git a/src/lib_lwt_result_stdlib/lib/seq.ml b/src/lib_lwt_result_stdlib/lib/seq.ml deleted file mode 100644 index 6fc48d3833d26c80710e18707a2de7e5a77a1562..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/lib/seq.ml +++ /dev/null @@ -1,29 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - include Tezos_error_monad.TzTrace - include Tezos_error_monad.TzMonad -end) diff --git a/src/lib_lwt_result_stdlib/lib/seq.mli b/src/lib_lwt_result_stdlib/lib/seq.mli deleted file mode 100644 index ef36805351aeac655791676be029f0ca42feda98..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/lib/seq.mli +++ /dev/null @@ -1,29 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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.error = Error_monad.error - and type 'error Monad.trace = 'error Error_monad.trace diff --git a/src/lib_lwt_result_stdlib/lib/set.ml b/src/lib_lwt_result_stdlib/lib/set.ml deleted file mode 100644 index 81203765bec47ca6ee64b57b8b7164a995eb75fe..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/lib/set.ml +++ /dev/null @@ -1,26 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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/withExceptions.mli b/src/lib_lwt_result_stdlib/lib/withExceptions.mli deleted file mode 100644 index f12ce6db3352506c3c0db6e74c86952040ac7c29..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/lib/withExceptions.mli +++ /dev/null @@ -1,26 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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.WithExceptions.S diff --git a/src/lib_lwt_result_stdlib/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml index b0ac6449d6ac038ec32dd60912b075fa2a788428..2059073b8b6df5d98d3549b42cd8c8607b0875d7 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.ml +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -23,11 +23,17 @@ (* *) (*****************************************************************************) -module Seq = Lib.Seq -module Set = Lib.Set -module Map = Lib.Map -module Hashtbl = Lib.Hashtbl -module List = Lib.List -module Option = Lib.Option -module Result = Lib.Result -module WithExceptions = Lib.WithExceptions +module Bare = struct + module Hashtbl = Bare_structs.Hashtbl + module List = Bare_structs.List + module Map = Bare_structs.Map + module Monad = Bare_structs.Monad + module Option = Bare_structs.Option + module Result = Bare_structs.Result + module Seq = Bare_structs.Seq + module Set = Bare_structs.Set + module WithExceptions = Bare_structs.WithExceptions +end + +module Traced (Trace : Traced_sigs.Trace.S) = + Traced_structs.Structs.Make (Trace) diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index c31e66e540e9b8422207704615dffc5f36b4559a..0dd8b1388b571ed40dc10ac27753d1d553216f45 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) +(* Copyright (c) 2020-2021 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -23,39 +23,276 @@ (* *) (*****************************************************************************) -(** [Error_monad]-aware replacements for parts of the Stdlib. +(** {1 Lwtreslib: the Lwt- and result-aware Stdlib complement. - This library aims to provide replacements to some parts of the Stdlib that: + Lwtreslib (or Lwt-result-stdlib) is a library to complement the OCaml's + Stdlib in software projects that make heavy use of Lwt and the result type. - - 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]. + {2 Introduction} - 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). + Lwtreslib aims to + {ul + {li Replace exception-raising functions with exception-safe one. E.g., + functions that may raise {!Not_found} in the Stdlib are + shadowed by functions that return an {!option}.} + {li Provide an extensive set of Lwt-, result- and Lwt-result-traversors + for the common data-types of the Stdlib. E.g., {!List.map} is + available alongside [List.map_s] for Lwt sequential traversal, + [List.map_e] for result traversal, etc.} + {li Provide a uniform semantic, especially regarding error management. + E.g., all sequential traversal functions have the same fail-early + semantic, whereas all concurrent traversal functions have the same + best-effort semantic.} + {li Provide good documentation.} + } - 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) and [Array] will be made available. + {2 Semantic} + The semantic of the functions exported by Lwtreslib is uniform and + predictable. This applies to the Stdlib-like functions, the Lwt-aware + functions, the result-aware functions, and the Lwt-and-result-aware + functions. + + {3 Semantic of vanilla-functions} + + Functions that have the same signature as their Stdlib's counterpart have + the same semantic. + + Functions exported by Lwtreslib do not raise exceptions. (With the exception + of the functions exported by the {!WithExceptions} module.) If a function + raises an exception in the Stdlib, its type is changed in Lwtreslib. In + general the following substitution apply: + + {ul + {li Functions that may raise {!Not_found} (e.g., [List.find]) return an + {!option} instead.} + {li Functions that may fail because of indexing errors (e.g., [List.nth], + [List.hd], etc.) also return an {!option} instead.} + {li Functions that may raise {!Invalid_argument} (e.g., [List.iter2]) + return a {!result} type instead. The take an additional argument + indicating what [Error_] to return instead of the exception.} + } + + {3 Semantic of Lwt-aware functions} + + Lwtreslib exports Lwt-aware functions for all traversal functions of the + Stdlib. + + Functions with the [_s] suffix traverse their underlying collection + sequentially, waiting for the promise associated to one element to resolve + before processing to the next element. + + Functions with the [_p] suffix traverse their underlying collection + concurrently, creating promises for all the elements and then waiting for + all of them to resolve. The "p" in the [_p] suffix is for compatibility with + Lwt and in particular [Lwt_list]. The mnemonic is "parallel" even though + there is not parallelism, only concurrency. + + These [_s]- and [_p]-suffixed functions are semantically identical to their + Lwt counterpart when it is available. Most notably, [Lwtreslib.List] is a + strict superset of [Lwt_list]. + + {3 Semantic of result-aware functions} + + Lwtreslib exports result-aware functions for all the traversal functions of + the Stdlib. These function allow easy manipulation of {!('a, 'e) result} + values. + + Functions with the [_e] suffix traverse their underlying collection whilst + wrapping the accumulator/result in a [result]. These functions have a + fail-early semantic: if one of the step returns an [Error _], then the whole + traversal is interrupted and returns the same [Error _]. + + {3 Semantic of Lwt-result-aware functions} + + Lwtreslib exports Lwt-result-aware functions for all the traversal functions + of the Stdlib. These function allow easy manipulation of + [!('a, 'e) result Lwt.t] -- i.e., promises that may fail. + + Functions with the [_es] suffix traverse their underlying collection + sequentially (like [_s] functions) whilst wrapping the accumulator/result in + a [result] (like [_e] functions). These functions have a fail-early + semantic: if one of the step returns a promise that resolves to an + [Error _], then the whole traversal is interrupted and the returned promise + resolves to the same [Error _]. + + Functions with the [_ep] suffix traverse their underlying collection + concurrently (like [_p] functions) whilst wrapping the accumulator/result in + a [result] (like [_e] functions). These functions have a best-effort + semantic: if one of the step returns a promise that resolves to an + [Error _], the other promises are left to resolve; once all the promises + have resolved, then the returned promise resolves with an [Error _] that + carries all the other errors in a list. It is up to the user to convert this + list to a more manageable type if needed. + + {3 [Traced]} + + The {!Traced} module offers a small wrapper around Lwtreslib. This wrapper + is intended to ease the use of [_ep] functions. It does so by introducing a + trace data-type: a structured collection of errors. + + This trace data-type is used to collapse the types ['e] and ['e list] of + errors. Indeed, without this collapse, chaining [_ep] together or chaining + [_ep] with [_es] functions requires significant boilerplate to flatten + lists, to listify single errors, etc. Need for boilerplate mostly vanishes + when using the [Traced] wrapper. + + {2 Monad helpers} + + Lwtreslib also exports monadic operators (binds, return, etc.) for the + Lwt-monad, the result-monad, and the combined Lwt-result-monad. + + {2 Exceptions} + + If at all possible, avoid exceptions. + + If possible, avoid exceptions. + + If you use exceptions, here are a few things to keep in mind: + + The [_p] functions are semantically equivalent to Lwt's. This means that + some exceptions are dropped. Specifically, when more than one promise raises + an exception in a concurrent traversor, only one is passed on to the user, + the others are silently ignored. + + Use [raise] (rather than [Lwt.fail]) when within an Lwt callback. + + {2 [WithExceptions]} + + The [WithExceptions] module is there for convenience in non-production code + and for the specific cases where it is guaranteed not to raise an exception. + + E.g., it is intended for removing the {!option} boxing in cases where the + invariant is guaranteed by construction: + +{[ +(** Return an interval of integers, from 0 to its argument (if positive) + or from its argument to 0 (otherwise). *) +let steps stop = + if stop = 0 then + [] + else if stop > 0 then + List.init ~when_negative_length:() Fun.id + |> WithExceptions.Option.get ~loc:__LOC__ + else + let stop = Int.neg stop in + List.init ~when_negative_length:() Int.neg + |> WithExceptions.Option.get ~loc:__LOC__ +]} *) + +(** {1 Instance: [Bare]} + + [Bare] provides all the functions as described above. It is intended to be + opened to shadow some modules of [Stdlib]. + + All values within the modules follow the same naming and semantic + conventions described above. The sequential traversors are fail-early: + in the following example the code returns an [Error] and does not print + anything. + +{[ +List.iter_e + (fun x -> + if x = "" then + Error "empty string" + else begin + print_endline x; + Ok ()) + [ + ""; (* This will cause the iteration to stop *) + "this is not printed"; + "neither is this printed"; + ] +]} + + The concurrent (parallel) traversors are best-effort: in the following + example the code prints all the non-empty strings in an unspecified order + before returning an [Error]. + +{[ +List.iter_ep + (fun x -> + if x = "" then + Lwt.return (Error "empty string") + else begin + print_endline x; + Lwt.return (Ok ())) + [ + ""; (* This will cause the iteration to error in the end *) + "this is printed"; + "this is printed as well"; + ] +]} + + The module [WithExceptions] provides some exception-raising helpers to + reduce the boilerplate that the library imposes. +*) +module Bare : sig + module Hashtbl : Bare_sigs.Hashtbl.S + + module List : Bare_sigs.List.S + + module Map : Bare_sigs.Map.S + + module Monad : Bare_sigs.Monad.S + + module Option : Bare_sigs.Option.S + + module Result : Bare_sigs.Result.S + + module Seq : Bare_sigs.Seq.S + + module Set : Bare_sigs.Set.S + + module WithExceptions : Bare_sigs.WithExceptions.S +end + +(** [Traced] is a functor to generate an advanced combined-monad replacements + for parts of the Stdlib. The generated module is similar to [Bare] with the + addition of traces: structured collections of errors. + + For convenience, the monad includes primitives to error directly with a + trace rather than a bare error. + + All the [_ep] traversors return traces of errors rather than lists of + errors. The [_ep] traversors preserve their best-effort semantic. + + Additional functions in the [Monad] allow the construction of sequential + traces: functions to enrich traces with new errors. E.g., + +{[ +let load_config file = + Result.map_error + (fun trace -> + Trace.cons "cannot load configuration file" trace) + @@ begin + open_file >>=? fun file -> + read_lines file >>=? fun lines -> + parse_config lines >>=? fun json -> + make_dictionary json + end +]} + + Example implementations of traces are provided in the [traces/] directory. *) +module Traced (Trace : Traced_sigs.Trace.S) : sig + module Monad : + Traced_sigs.Monad.S with type 'error trace = 'error Trace.trace -module Seq : module type of Lib.Seq + module Hashtbl : + Traced_sigs.Hashtbl.S with type 'error trace := 'error Trace.trace -module Set : module type of Lib.Set + module List : Traced_sigs.List.S with type 'error trace := 'error Trace.trace -module Map : module type of Lib.Map + module Map : Traced_sigs.Map.S with type 'error trace := 'error Trace.trace -module Hashtbl : module type of Lib.Hashtbl + module Option : Traced_sigs.Option.S -module List : module type of Lib.List + module Result : Traced_sigs.Result.S -module Option : module type of Lib.Option + module Seq : Traced_sigs.Seq.S with type 'error trace := 'error Trace.trace -module Result : module type of Lib.Result + module Set : Traced_sigs.Set.S with type 'error trace := 'error Trace.trace -module WithExceptions : module type of Lib.WithExceptions + module WithExceptions : Traced_sigs.WithExceptions.S +end diff --git a/src/lib_lwt_result_stdlib/sigs/monad.ml b/src/lib_lwt_result_stdlib/sigs/monad.ml deleted file mode 100644 index 55b034c3ac2d87f4e5322b5141141a9b6f8d5f4f..0000000000000000000000000000000000000000 --- a/src/lib_lwt_result_stdlib/sigs/monad.ml +++ /dev/null @@ -1,151 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - (** [error] are the errors as injected into the monad. In other words, - [error] is the type of values that are used in primitives that "raise" - an error. *) - type error - - (** [trace] are the errors as received from the monad. In other words, - [trace] is the type of values that are seen when matching on [Error _] - to, say, recover. - - The types [error] and ['error trace] are kept separate (although they can - be equal) to support cases such as the following: - - [trace] are richer than [error], such as by including a - timestamp, a filename, or some other such metadata. - - [trace] is slightly different and [private] and [error] is simply - the type of argument to the functions that construct the private - [trace]. - - [trace] is a collection of [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 'error trace - - val make : 'error -> 'error trace - - val cons : 'error -> 'error trace -> 'error trace - - val conp : 'error trace -> 'error trace -> 'error trace - - (** result monad *) - - val ok : 'a -> ('a, 'trace) result - - val ok_unit : (unit, 'trace) result - - val ok_none : ('a option, 'trace) result - - val ok_some : 'a -> ('a option, 'trace) result - - val ok_nil : ('a list, 'trace) result - - val ok_true : (bool, 'trace) result - - val ok_false : (bool, 'trace) result - - val error : 'error -> ('a, 'error trace) result - - val ( >>? ) : - ('a, 'trace) result -> ('a -> ('b, 'trace) result) -> ('b, 'trace) result - - val ( >|? ) : ('a, 'trace) result -> ('a -> 'b) -> ('b, 'trace) result - - (** lwt-result combined monad *) - - val return : 'a -> ('a, 'trace) result Lwt.t - - val return_unit : (unit, 'trace) result Lwt.t - - val return_none : ('a option, 'trace) result Lwt.t - - val return_some : 'a -> ('a option, 'trace) result Lwt.t - - val return_nil : ('a list, 'trace) result Lwt.t - - val return_true : (bool, 'trace) result Lwt.t - - val return_false : (bool, 'trace) result Lwt.t - - val fail : 'error -> ('a, 'error trace) result Lwt.t - - val ( >>=? ) : - ('a, 'trace) result Lwt.t -> - ('a -> ('b, 'trace) result Lwt.t) -> - ('b, 'trace) result Lwt.t - - val ( >|=? ) : - ('a, 'trace) result Lwt.t -> ('a -> 'b) -> ('b, 'trace) 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, 'trace) result -> - ('a -> ('b, 'trace) result Lwt.t) -> - ('b, 'trace) result Lwt.t - - val ( >|?= ) : - ('a, 'trace) result -> ('a -> 'b Lwt.t) -> ('b, 'trace) result Lwt.t - - (** joins *) - val join_e : (unit, 'error trace) result list -> (unit, 'error trace) result - - val all_e : ('a, 'error trace) result list -> ('a list, 'error trace) result - - val both_e : - ('a, 'error trace) result -> - ('b, 'error trace) result -> - ('a * 'b, 'error trace) 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, 'error trace) result Lwt.t list -> (unit, 'error trace) result Lwt.t - - val all_ep : - ('a, 'error trace) result Lwt.t list -> - ('a list, 'error trace) result Lwt.t - - val both_ep : - ('a, 'error trace) result Lwt.t -> - ('b, 'error trace) result Lwt.t -> - ('a * 'b, 'error trace) result Lwt.t -end diff --git a/src/lib_lwt_result_stdlib/test/dune b/src/lib_lwt_result_stdlib/test/dune index 4201e90450424b3b50cc27e81aa7f1a11486bfe0..05088c897c9f1dde6eda87d96a8c0a2ad2d4a951 100644 --- a/src/lib_lwt_result_stdlib/test/dune +++ b/src/lib_lwt_result_stdlib/test/dune @@ -7,8 +7,9 @@ test_fuzzing_list test_fuzzing_set ) - (libraries tezos-lwt-result-stdlib - tezos-error-monad + (libraries + tezos-lwt-result-stdlib + tezos-lwt-result-stdlib.examples.traces lwt.unix alcotest-lwt crowbar) diff --git a/src/lib_lwt_result_stdlib/functors/seq.mli b/src/lib_lwt_result_stdlib/test/support.ml similarity index 95% rename from src/lib_lwt_result_stdlib/functors/seq.mli rename to src/lib_lwt_result_stdlib/test/support.ml index 4e0911c165e3f7219bd8b66b3f6b4280f77035de..29f17905a3f2e4d2de4b68bc92b7ade88b161f52 100644 --- a/src/lib_lwt_result_stdlib/functors/seq.mli +++ b/src/lib_lwt_result_stdlib/test/support.ml @@ -23,4 +23,5 @@ (* *) (*****************************************************************************) -module Make (Monad : Sigs.Monad.S) : Sigs.Seq.S with module Monad = Monad +module Test_trace = Traces.Full +module Lib = Traced_structs.Structs.Make (Test_trace) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml index 64decbaca7ded4fbc02bca4d2dc31092dd3be0a4..ac6ea788820ef2b3b4a84a8bd8bb3f506b66163d 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml @@ -23,8 +23,7 @@ (* *) (*****************************************************************************) -open Lwt.Infix -open Lwtreslib.Seq.Monad +open Support.Lib.Monad let rec log_pause n = if n <= 0 then Lwt.return_unit @@ -35,29 +34,32 @@ let rec log_pause n = (* Function generators *) module Fn = struct - let pred = + let lambda s l = let open Crowbar in - choose - [ const (fun x _ -> x > 0); - const (fun _ y -> y < 0); - const (fun _ _ -> false); - const (fun _ _ -> true); - const (fun x y -> x < y) ] + with_printer (fun fmt _ -> Format.pp_print_string fmt s) @@ const l + + let pred = + Crowbar.choose + [ lambda "(fun x _ -> x > 0)" (fun x _ -> x > 0); + lambda "(fun _ y -> y < 0)" (fun _ y -> y < 0); + lambda "(fun _ _ -> false)" (fun _ _ -> false); + lambda "(fun _ _ -> true)" (fun _ _ -> true); + lambda "(fun x y -> x < y)" (fun x y -> x < y) ] let arith = - let open Crowbar in - choose - [ const (fun x _ -> x); - const (fun _ y -> y); - const (fun x _ -> 2 * x); - const (fun _ _ -> 0); - map [int] (fun n _ _ -> n); - const (fun x y -> x + y); - const (fun _ y -> 2 * y); - const (fun _ y -> y + 1); - const (fun x y -> min x y); - const (fun x y -> max x y); - const (fun x y -> (5 * x) + (112 * y)) ] + Crowbar.choose + [ lambda "(fun x _ -> x)" (fun x _ -> x); + lambda "(fun _ y -> y)" (fun _ y -> y); + lambda "(fun x _ -> 2 * x)" (fun x _ -> 2 * x); + lambda "(fun _ _ -> 0)" (fun _ _ -> 0); + lambda "(fun x y -> x + y)" (fun x y -> x + y); + lambda "(fun _ y -> 2 * y)" (fun _ y -> 2 * y); + lambda "(fun _ y -> y + 1)" (fun _ y -> y + 1); + lambda "(fun x y -> min x y)" (fun x y -> min x y); + lambda "(fun x y -> max x y)" (fun x y -> max x y); + lambda "(fun x y -> (5 * x) + (112 * y))" (fun x y -> + (5 * x) + (112 * y)); + Crowbar.(map [int] (fun n _ _ -> n)) ] (* combinators *) let e cond ok error x y = if cond x y then Ok (ok x y) else Error (error x y) @@ -260,7 +262,7 @@ end module IterESOf = struct let fn r fn y = r := fn !r y ; - return_unit + unit_es let fn_e r fn y = Lwt.return @@ fn !r y >|=? fun t -> r := t @@ -276,7 +278,7 @@ end module IteriESOf = struct let fn r fn i y = r := fn !r (fn i y) ; - return_unit + unit_es let fn_e r fn i y = Lwt.return @@ fn i y @@ -296,7 +298,7 @@ end module Iter2ESOf = struct let fn r fn x y = r := fn x y ; - return_unit + unit_es let fn_e r fn x y = Lwt.return @@ fn x y >|=? fun t -> r := t @@ -353,6 +355,11 @@ module MapEPOf = struct let fn_es const fn elt = fn const elt >>= function Ok ok -> return ok | Error err -> fail err + + let fn_ep const fn elt = + fn const elt + >>= function + | Ok ok -> return ok | Error err -> fail (Support.Test_trace.make err) end module Map2ESOf = struct @@ -409,6 +416,50 @@ let eq_s ?pp a b = let eq_es ?pp a b = Lwt_main.run (a >>= fun a -> b >|= fun b -> Crowbar.check_eq ?pp a b) +let eq_es_ep ?pp es ep = + Lwt_main.run + ( es + >>= fun es -> + ep + >|= fun ep -> + match (es, ep) with + | (Ok ok_es, Ok ok_ep) -> + eq ?pp ok_es ok_ep + | (Error error_es, Error trace_ep) -> + let trace_ep_has_error_es = + Support.Test_trace.fold + (fun has error -> has || error = error_es) + false + trace_ep + in + if trace_ep_has_error_es then () + else + Crowbar.failf + "%d not in %a" + error_es + (Support.Test_trace.pp Crowbar.pp_int) + trace_ep + | (Ok _, Error _) -> + Crowbar.fail "Ok _ is not Error _" + | (Error _, Ok _) -> + Crowbar.fail "Error _ is not Ok _" ) + +let eq_ep ?pp a b = + Lwt_main.run + ( a + >>= fun a -> + b + >|= fun b -> + match (a, b) with + | (Ok ok_es, Ok ok_ep) -> + eq ?pp ok_es ok_ep + | (Error _, Error _) -> + () (* Not as precise as we could be, but precise enough *) + | (Ok _, Error _) -> + Crowbar.fail "Ok _ is not Error _" + | (Error _, Ok _) -> + Crowbar.fail "Error _ is not Ok _" ) + module PP = struct let int = Format.pp_print_int @@ -419,4 +470,6 @@ module PP = struct let list elt = Format.pp_print_list ~pp_sep:Format.pp_print_space elt let bool = Format.pp_print_bool + + let trace = Support.Test_trace.pp end diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml index 46b6ed5f9f1f79e6221572ce04cd6eefd595b214..9f0c84a8fc83a372d7d3654088f8521dcb574853 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml @@ -28,13 +28,15 @@ open Test_fuzzing_tests module ListWithBase = struct type 'a elt = 'a - include Lwtreslib.List + include Support.Lib.List let of_list = Fun.id let to_list = Fun.id let name = "List" + + let pp = Crowbar.(pp_list pp_int) end (* Internal consistency *) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml index 6c86580ccd461e46eb07ea41d474e266d6c99259..63b3131eac3f9ede9e0eae235bcfdf67338942e3 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml @@ -28,13 +28,15 @@ open Test_fuzzing_tests module SeqWithBase = struct type 'a elt = 'a - include Lwtreslib.Seq + include Support.Lib.Seq let of_list = List.to_seq let to_list = List.of_seq let name = "Seq" + + let pp fmt s = Crowbar.(pp_list pp_int) fmt (to_list s) end (* Internal consistency *) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml index a35f686fddb5b7e03e2fe75c4954db71293fc32c..294b5d68c294daa23021b1a4352b4e3b051bdeb5 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml @@ -25,8 +25,8 @@ open Test_fuzzing_tests -module IntSet : Lwtreslib.Set.S with type elt = int = struct - include Lwtreslib.Set.Make (Int) +module IntSet : Support.Lib.Set.S with type elt = int = struct + include Support.Lib.Set.Make (Int) end module SetWithBase = struct @@ -41,7 +41,8 @@ module SetWithBase = struct type _alias_t = IntSet.t module IntSet : - Lwtreslib.Set.S with type elt := _alias_elt and type t := _alias_t = struct + Support.Lib.Set.S with type elt := _alias_elt and type t := _alias_t = + struct include IntSet end @@ -50,6 +51,8 @@ module SetWithBase = struct let of_list : int list -> _alias_t = of_list let to_list : _alias_t -> int list = elements + + let pp fmt s = Crowbar.(pp_list pp_int) fmt (to_list s) end module Iterp = TestIterMonotoneAgainstStdlibList (SetWithBase) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml index f512c627e7628f9618ce28dbece7dded1a08a47a..a9a266711b54c3d80186bb92ec09039ada332eff 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml @@ -25,8 +25,7 @@ open Traits open Test_fuzzing_helpers -open Lwt.Infix -open Lwtreslib.Seq.Monad +open Support.Lib.Monad (* In the following, in order to reduce the time, output and complexity and testing, we only test for the most general case (i.e., when testing an @@ -44,7 +43,7 @@ open Lwtreslib.Seq.Monad person debugging the code to write additional specialised tests. *) module TestIterFold (M : sig - include BASE with type 'a elt := int + include Traits.BASE with type 'a elt := int include Traits.ITER_SEQUENTIAL with type 'a elt := int and type 'a t := int t @@ -156,8 +155,11 @@ struct [Fn.arith_es; one; many] (fun fn const input -> let input = M.of_list input in - let fn = MapEPOf.fn_es const fn in - eq_es (M.map_ep fn input >|=? M.rev) (M.rev_map_ep fn input)) + let fn_ep = MapEPOf.fn_ep const fn in + eq_ep + ~pp:M.pp + (M.map_ep fn_ep input >|=? M.rev) + (M.rev_map_ep fn_ep input)) end module TestIterAgainstStdlibList (M : sig diff --git a/src/lib_lwt_result_stdlib/test/test_generic.ml b/src/lib_lwt_result_stdlib/test/test_generic.ml index 87054a1508796a9dac8405f5dd58a7e4a7f7164b..3d4cb047076574aed5d651c5f7f3fd64487ece06 100644 --- a/src/lib_lwt_result_stdlib/test/test_generic.ml +++ b/src/lib_lwt_result_stdlib/test/test_generic.ml @@ -34,7 +34,7 @@ module type GEN = sig end module SeqGen = struct - include Lwtreslib.Seq + include Support.Lib.Seq let rec down n : int t = fun () -> if n < 0 then Nil else Cons (n, down (pred n)) @@ -46,7 +46,7 @@ module SeqGen = struct end module ListGen = struct - include Lwtreslib.List + include Support.Lib.List let rec down n : int t = if n < 0 then [] else n :: down (pred n) diff --git a/src/lib_lwt_result_stdlib/test/test_hashtbl.ml b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml index f9d93bf6a6b60c76217ed028133d10b4ab0df3e6..a5c6705a9ae013fc9fe2804134cba3a2386d2c43 100644 --- a/src/lib_lwt_result_stdlib/test/test_hashtbl.ml +++ b/src/lib_lwt_result_stdlib/test/test_hashtbl.ml @@ -23,9 +23,9 @@ (* *) (*****************************************************************************) -open Tezos_error_monad.Error_monad +open Support.Lib.Monad -module IntLwtHashtbl = Lwtreslib.Hashtbl.Make_Lwt (struct +module IntESHashtbl = Support.Lib.Hashtbl.Make_es (struct type t = int let equal x y = x = y @@ -34,8 +34,8 @@ module IntLwtHashtbl = Lwtreslib.Hashtbl.Make_Lwt (struct end) let test_add_remove _ _ = - let t = IntLwtHashtbl.create 2 in - IntLwtHashtbl.find_or_make t 0 (fun () -> return 0) + let t = IntESHashtbl.create 2 in + IntESHashtbl.find_or_make t 0 (fun () -> return 0) >>= function | Error _ -> Assert.fail "Ok 0" "Error _" "find_or_make" @@ -43,7 +43,7 @@ let test_add_remove _ _ = if not (n = 0) then Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make" else - match IntLwtHashtbl.find t 0 with + match IntESHashtbl.find t 0 with | None -> Assert.fail "Some (Ok 0)" "None" "find" | Some p -> ( @@ -58,20 +58,20 @@ let test_add_remove _ _ = (Format.asprintf "Some (Ok %d)" n) "find" else ( - IntLwtHashtbl.remove t 0 ; - match IntLwtHashtbl.find t 0 with + IntESHashtbl.remove t 0 ; + match IntESHashtbl.find t 0 with | Some _ -> Assert.fail "None" "Some _" "remove;find" | None -> Lwt.return_unit ) ) ) let test_add_add _ _ = - let t = IntLwtHashtbl.create 2 in - IntLwtHashtbl.find_or_make t 0 (fun () -> return 0) + let t = IntESHashtbl.create 2 in + IntESHashtbl.find_or_make t 0 (fun () -> return 0) >>= fun _ -> - IntLwtHashtbl.find_or_make t 0 (fun () -> return 1) + IntESHashtbl.find_or_make t 0 (fun () -> return 1) >>= fun _ -> - match IntLwtHashtbl.find t 0 with + match IntESHashtbl.find t 0 with | None -> Assert.fail "Some (Ok 0)" "None" "find" | Some p -> ( @@ -85,50 +85,50 @@ let test_add_add _ _ = else Lwt.return_unit ) let test_length _ _ = - let t = IntLwtHashtbl.create 2 in - IntLwtHashtbl.find_or_make t 0 (fun () -> return 0) + let t = IntESHashtbl.create 2 in + IntESHashtbl.find_or_make t 0 (fun () -> return 0) >>= fun _ -> - IntLwtHashtbl.find_or_make t 1 (fun () -> return 1) + IntESHashtbl.find_or_make t 1 (fun () -> return 1) >>= fun _ -> - IntLwtHashtbl.find_or_make t 2 (fun () -> return 2) + IntESHashtbl.find_or_make t 2 (fun () -> return 2) >>= fun _ -> - IntLwtHashtbl.find_or_make t 3 (fun () -> return 3) + IntESHashtbl.find_or_make t 3 (fun () -> return 3) >>= fun _ -> - let l = IntLwtHashtbl.length t in + let l = IntESHashtbl.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 = IntLwtHashtbl.create 2 in - IntLwtHashtbl.find_or_make t 0 (fun () -> Lwt.return (Ok 0)) + let t = IntESHashtbl.create 2 in + IntESHashtbl.find_or_make t 0 (fun () -> Lwt.return (Ok 0)) >>= fun _ -> - IntLwtHashtbl.find_or_make t 1 (fun () -> Lwt.return (Error [])) + IntESHashtbl.find_or_make t 1 (fun () -> Lwt.return (Error [])) >>= fun _ -> - IntLwtHashtbl.find_or_make t 2 (fun () -> Lwt.return (Error [])) + IntESHashtbl.find_or_make t 2 (fun () -> Lwt.return (Error [])) >>= fun _ -> - IntLwtHashtbl.find_or_make t 3 (fun () -> Lwt.return (Ok 3)) + IntESHashtbl.find_or_make t 3 (fun () -> Lwt.return (Ok 3)) >>= fun _ -> - IntLwtHashtbl.find_or_make t 4 (fun () -> Lwt.return (Ok 4)) + IntESHashtbl.find_or_make t 4 (fun () -> Lwt.return (Ok 4)) >>= fun _ -> - IntLwtHashtbl.find_or_make t 5 (fun () -> Lwt.return (Error [])) + IntESHashtbl.find_or_make t 5 (fun () -> Lwt.return (Error [])) >>= fun _ -> Lwt.catch (fun () -> - IntLwtHashtbl.find_or_make t 6 (fun () -> Lwt.fail Not_found) + IntESHashtbl.find_or_make t 6 (fun () -> Lwt.fail Not_found) >>= fun _ -> Assert.fail_msg "Not_found exception should propagate") (function Not_found -> Lwt.return_unit | exn -> Lwt.fail exn) >>= fun () -> - let l = IntLwtHashtbl.length t in + let l = IntESHashtbl.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 = IntLwtHashtbl.create 2 in + let t = IntESHashtbl.create 2 in let (wter, wker) = Lwt.task () in let world = ref [] in (* PROMISE A *) let p_a = - IntLwtHashtbl.find_or_make t 0 (fun () -> + IntESHashtbl.find_or_make t 0 (fun () -> wter >>= fun r -> world := "a_inner" :: !world ; @@ -141,7 +141,7 @@ let test_order _ _ = >>= fun () -> (* PROMISE B *) let p_b = - IntLwtHashtbl.find_or_make t 0 (fun () -> + IntESHashtbl.find_or_make t 0 (fun () -> world := "b_inner" :: !world ; Lwt.return (Ok 1024)) >>= fun r_b -> diff --git a/src/lib_lwt_result_stdlib/test/test_list_basic.ml b/src/lib_lwt_result_stdlib/test/test_list_basic.ml index a014d7f049b6059fd48c17aaa0d96e900e071aa2..1e18e934c4dc23fbe6a7697fb38e9b04ed0ed4e6 100644 --- a/src/lib_lwt_result_stdlib/test/test_list_basic.ml +++ b/src/lib_lwt_result_stdlib/test/test_list_basic.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -open Lwtreslib.Seq.Monad +open Support.Lib.Monad let assert_eq_s pa pb = let open Lwt.Infix in @@ -47,11 +47,11 @@ let assert_err_p e = let open Lwt.Infix in e >>= fun e -> - assert (e = Error (make ())) ; + assert (e = Error (Support.Test_trace.make ())) ; Lwt.return_unit module ListGen = struct - include Lwtreslib.List + include Support.Lib.List let rec down n : int t = if n < 0 then [] else n :: down (pred n) diff --git a/src/lib_lwt_result_stdlib/test/traits.ml b/src/lib_lwt_result_stdlib/test/traits.ml index 93a1cc883523eb7724367762a3eea89143b121d3..b141b7591a9c5135245adc57b80cf18145f5910b 100644 --- a/src/lib_lwt_result_stdlib/test/traits.ml +++ b/src/lib_lwt_result_stdlib/test/traits.ml @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -open Lwtreslib.Seq.Monad +type 'error trace = 'error Support.Lib.Monad.trace module type BASE = sig val name : string @@ -35,6 +35,8 @@ module type BASE = sig val of_list : int list -> int t val to_list : int t -> int list + + val pp : Format.formatter -> int t -> unit end module type ITER_VANILLA = sig diff --git a/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam b/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam index 859bcfd1685ca758a2a7a4cb95379d70ef226a52..4c0982f88c72893da5b2b661473806b000103bf7 100644 --- a/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam +++ b/src/lib_lwt_result_stdlib/tezos-lwt-result-stdlib.opam @@ -9,7 +9,6 @@ depends: [ "tezos-tooling" { with-test } "dune" { >= "2.0" } "ocaml" { >= "4.07" } - "tezos-error-monad" "lwt" "alcotest-lwt" { with-test & >= "1.1.0" } "crowbar" { with-test } diff --git a/src/lib_lwt_result_stdlib/traced/.ocamlformat b/src/lib_lwt_result_stdlib/traced/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/.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/traced/functor_outputs/.ocamlformat b/src/lib_lwt_result_stdlib/traced/functor_outputs/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/functor_outputs/.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/traced/functor_outputs/dune b/src/lib_lwt_result_stdlib/traced/functor_outputs/dune new file mode 100644 index 0000000000000000000000000000000000000000..28c80919cc4b34bbfecfb543b86e89fce1f69ad1 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/functor_outputs/dune @@ -0,0 +1,9 @@ +(library + (name traced_functor_outputs) + (public_name tezos-lwt-result-stdlib.traced.functor-outputs) + (libraries lwt tezos-lwt-result-stdlib.bare.sigs)) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/traced/functor_outputs/hashtbl.ml b/src/lib_lwt_result_stdlib/traced/functor_outputs/hashtbl.ml new file mode 100644 index 0000000000000000000000000000000000000000..ddd8ffb0bf08412497947e42369874bf9c5cab10 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/functor_outputs/hashtbl.ml @@ -0,0 +1,90 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Hashtables with the signature [S] are exception-safe replacements for + hashtables with the {!Stdlib.Hashtbl.S} signature with Lwt- and result-aware + traversal functions. + + See {!Lwtreslib}'s introductory documentation for explanations regarding + [_e]-, [_s]-, [_es]-, [_p]-, and [_ep]-suffixed functions and exception + safety. See {!Stdlib.Hashtbl.S} for explanations regarding OCaml's + hashtables in general. + + Note that this signature is within the Traced part of the library. As a + result, the [_ep] traversor returns en ['error trace]. *) +module type S = sig + include Bare_functor_outputs.Hashtbl.S + + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + val iter_ep : + (key -> 'a -> (unit, 'error trace) result Lwt.t) -> + 'a t -> + (unit, 'error trace) result Lwt.t +end + +(** Hashtables with the signature [SeededS] are exception-safe replacements for + hashtables with the {!Stdlib.Hashtbl.SeededS} signature with Lwt- and + result-aware traversal functions. + + See {!Lwtreslib}'s introductory documentation for explanations regarding + [_e]-, [_s]-, [_es]-, [_p]-, and [_ep]-suffixed functions and exception + safety. See {!Stdlib.Hashtbl.SeededS} for explanations regarding OCaml's + seeded hashtables in general. + + Note that this signature is within the Traced part of the library. As a + result, the [_ep] traversor returns en ['error trace]. *) +module type SeededS = sig + include Bare_functor_outputs.Hashtbl.SeededS + + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + val iter_ep : + (key -> 'a -> (unit, 'error trace) result Lwt.t) -> + 'a t -> + (unit, 'error trace) result Lwt.t +end + +(** Hashtables with the signature [S_ES] are Hashtbl-like data structures. See + {!Bare_functor_outputs.Hashtbl.S_ES} for full information. + + Note that this signature is within the Traced part of the library. As a + result, the [_ep] traversor returns en ['error trace]. *) +module type S_ES = sig + include Bare_functor_outputs.Hashtbl.S_ES + + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + val iter_with_waiting_ep : + (key -> 'a -> (unit, 'error trace) result Lwt.t) -> + ('a, 'error trace) t -> + (unit, 'error trace) result Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/traced/functor_outputs/map.ml b/src/lib_lwt_result_stdlib/traced/functor_outputs/map.ml new file mode 100644 index 0000000000000000000000000000000000000000..738c1431ac4a66ff62a2e01131fc9f6d11ce2c98 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/functor_outputs/map.ml @@ -0,0 +1,47 @@ +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Maps with the signature [S] are exception-safe replacements for + maps with the {!Stdlib.Map.S} signature with Lwt- and result-aware + traversal functions. + + See {!Lwtreslib}'s introductory documentation for explanations regarding + [_e]-, [_s]-, [_es]-, [_p]-, and [_ep]-suffixed functions and exception + safety. See {!Stdlib.Map.S} for explanations regarding OCaml's + maps in general. + + Note that this signature is within the Traced part of the library. As a + result, the [_ep] traversor returns en ['error trace]. *) +module type S = sig + include Bare_functor_outputs.Map.S + + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + val iter_ep : + (key -> 'a -> (unit, 'error trace) result Lwt.t) -> + 'a t -> + (unit, 'error trace) result Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/traced/functor_outputs/set.ml b/src/lib_lwt_result_stdlib/traced/functor_outputs/set.ml new file mode 100644 index 0000000000000000000000000000000000000000..4540f4255d8adae0b7a7a8ce10b70db8892a22e5 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/functor_outputs/set.ml @@ -0,0 +1,48 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Sets with the signature [S] are exception-safe replacements for + sets with the {!Stdlib.Set.S} signature with Lwt- and result-aware + traversal functions. + + See {!Lwtreslib}'s introductory documentation for explanations regarding + [_e]-, [_s]-, [_es]-, [_p]-, and [_ep]-suffixed functions and exception + safety. See {!Stdlib.Set.S} for explanations regarding OCaml's + sets in general. + + Note that this signature is within the Traced part of the library. As a + result, the [_ep] traversor returns en ['error trace]. *) +module type S = sig + include Bare_functor_outputs.Set.S + + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + val iter_ep : + (elt -> (unit, 'error trace) result Lwt.t) -> + t -> + (unit, 'error trace) result Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/traced/sigs/.ocamlformat b/src/lib_lwt_result_stdlib/traced/sigs/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/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/traced/sigs/dune b/src/lib_lwt_result_stdlib/traced/sigs/dune new file mode 100644 index 0000000000000000000000000000000000000000..6948983e2b1f137d03708f26fcb5af11ce84f8fe --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/dune @@ -0,0 +1,9 @@ +(library + (name traced_sigs) + (public_name tezos-lwt-result-stdlib.traced.sigs) + (libraries lwt tezos-lwt-result-stdlib.bare.sigs tezos-lwt-result-stdlib.traced.functor-outputs)) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/traced/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/traced/sigs/hashtbl.ml new file mode 100644 index 0000000000000000000000000000000000000000..b1d1e9e28ca7f2da5467105b98933d457053144d --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/hashtbl.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. *) +(* *) +(*****************************************************************************) + +(** In Lwtreslib, like in the Stdlib, the Hashtbl module exports mainly functors + to instantiate hashtables with known-type keys. As a result, the bulk of the + documentation for hashtables is located within the module types returned by + the functors: in {!Traced_functor_outputs.Hashtbl}. + + Note the presence of [Make_es] which deviates from the Stdlib to provide + specialised convenience for tables of elements the initialisation of which + may take time and may fail. *) +module type S = sig + type 'error trace + + val hash : 'a -> int + + val seeded_hash : int -> 'a -> int + + val hash_param : meaningful:int -> total:int -> 'a -> int + + val seeded_hash_param : meaningful:int -> total:int -> int -> 'a -> int + + module type S = + Traced_functor_outputs.Hashtbl.S with type 'error trace := 'error trace + + module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t + + module type SeededS = + Traced_functor_outputs.Hashtbl.SeededS + with type 'error trace := 'error trace + + module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : + SeededS with type key = H.t + + module type S_ES = + Traced_functor_outputs.Hashtbl.S_ES with type 'error trace := 'error trace + + module Make_es (H : Stdlib.Hashtbl.HashedType) : S_ES with type key = H.t +end diff --git a/src/lib_lwt_result_stdlib/traced/sigs/list.ml b/src/lib_lwt_result_stdlib/traced/sigs/list.ml new file mode 100644 index 0000000000000000000000000000000000000000..95d4adaec416525f0557f1fdf0263f57d25a8fa1 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/list.ml @@ -0,0 +1,103 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** [S] is the signature for an exception-safe replacements for {!Stdlib.List} + with Lwt- and result-aware traversal functions. + + See {!Lwtreslib}'s introductory documentation for explanations regarding + [_e]-, [_s]-, [_es]-, [_p]-, and [_ep]-suffixed functions and exception + safety. See {!Stdlib.Hashtbl.S} for explanations regarding OCaml's + hashtables in general. + + Note that this signature is within the Traced part of the library. As a + result, the [_ep] traversor returns en ['error trace]. *) +module type S = sig + include Bare_sigs.List.S + + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + val init_ep : + when_negative_length:'error -> + int -> + (int -> ('a, 'error trace) result Lwt.t) -> + ('a list, 'error trace) result Lwt.t + + val filter_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + ('a list, 'error trace) result Lwt.t + + val partition_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + ('a list * 'a list, 'error trace) result Lwt.t + + val iter_ep : + ('a -> (unit, 'error trace) result Lwt.t) -> + 'a list -> + (unit, 'error trace) result Lwt.t + + val iteri_ep : + (int -> 'a -> (unit, 'error trace) result Lwt.t) -> + 'a list -> + (unit, 'error trace) result Lwt.t + + val map_ep : + ('a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val mapi_ep : + (int -> 'a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val rev_map_ep : + ('a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val rev_mapi_ep : + (int -> 'a -> ('b, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val filter_map_ep : + ('a -> ('b option, 'error trace) result Lwt.t) -> + 'a list -> + ('b list, 'error trace) result Lwt.t + + val for_all_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + (bool, 'error trace) result Lwt.t + + val exists_ep : + ('a -> (bool, 'error trace) result Lwt.t) -> + 'a list -> + (bool, 'error trace) result Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/traced/sigs/map.ml b/src/lib_lwt_result_stdlib/traced/sigs/map.ml new file mode 100644 index 0000000000000000000000000000000000000000..af1deec75fe7a4608a4017f1b65eecdfc2111944 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/map.ml @@ -0,0 +1,39 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** In Lwtreslib, like in the Stdlib, the Map module exports a functor + to instantiate maps with known-type keys. As a result, the bulk of the + documentation for maps is located within the module types returned by + the functors: in {!Traced_functor_outputs.Map}. *) +module type S = sig + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + module type S = + Traced_functor_outputs.Map.S with type 'error trace := 'error trace + + module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t +end diff --git a/src/lib_lwt_result_stdlib/traced/sigs/monad.ml b/src/lib_lwt_result_stdlib/traced/sigs/monad.ml new file mode 100644 index 0000000000000000000000000000000000000000..0e5cdee822747dfc5ed23d97bb513699228cc4d5 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/monad.ml @@ -0,0 +1,74 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** [S] is the signature for a Lwt, result and Lwt-result combined monad. It is + similar to {!Bare_sigs.Monad} with the addition of traces. Specifically: + + - The type ['error trace] is meant to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]). + - The functions [error_trace] and [fail_trace] allow failing immediately + with a trace-wrapped error. + - [{join,all,both}_{e,ep}] return ['error trace] rather than ['error list]. + *) +module type S = sig + include Bare_sigs.Monad.S + + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + (** [error_trace e] is [Error (Trace.make e)] where [Trace] is the + {!Traced_sigs.Trace} module that provides the trace type and functions. + *) + val error_trace : 'error -> ('a, 'error trace) result + + (** [fail_trace e] is [Lwt.return (Error (Trace.make e))] where [Trace] is the + {!Traced_sigs.Trace} module that provides the trace type and functions. + *) + val fail_trace : 'error -> ('a, 'error trace) result Lwt.t + + (** [join], [all], and [both] all return traces rather than lists of errors. + This applies to both result-only and Lwt-result monads. *) + val join_e : (unit, 'error trace) result list -> (unit, 'error trace) result + + val all_e : ('a, 'error trace) result list -> ('a list, 'error trace) result + + val both_e : + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result + + val join_ep : + (unit, 'error trace) result Lwt.t list -> (unit, 'error trace) result Lwt.t + + val all_ep : + ('a, 'error trace) result Lwt.t list -> + ('a list, 'error trace) result Lwt.t + + val both_ep : + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/functors/set.mli b/src/lib_lwt_result_stdlib/traced/sigs/option.ml similarity index 86% rename from src/lib_lwt_result_stdlib/functors/set.mli rename to src/lib_lwt_result_stdlib/traced/sigs/option.ml index b55a257f44d2604216e2781da339f214643ac4d5..9245037800aa7459ba9fea0afaec01cc6d3d397a 100644 --- a/src/lib_lwt_result_stdlib/functors/set.mli +++ b/src/lib_lwt_result_stdlib/traced/sigs/option.ml @@ -23,8 +23,10 @@ (* *) (*****************************************************************************) -module Make (Seq : Sigs.Seq.S) : sig - module type S = Sigs.Set.S with type 'error trace := 'error Seq.Monad.trace +(** A replacement for {!Stdlib.Option} which + - is exception-safe, + - includes Lwt-, result-, and Lwt-result-aware traversors. - module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t -end + See {!Lwtreslib} and {!Seq} for general description of traversors and the + meaning of [_s], [_e], and [_es] suffixes. *) +module type S = Bare_sigs.Option.S diff --git a/src/lib_lwt_result_stdlib/traced/sigs/result.ml b/src/lib_lwt_result_stdlib/traced/sigs/result.ml new file mode 100644 index 0000000000000000000000000000000000000000..29293a63af82be2ee8e5663f645341c1ac3296fe --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/result.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. *) +(* *) +(*****************************************************************************) + +(** A replacement for {!Stdlib.Result} which + - is exception-safe, + - includes Lwt-, result-, and Lwt-result-aware traversors. + + See {!Lwtreslib} and {!Seq} for general description of traversors and the + meaning of [_s], [_e], and [_es] suffixes. *) +module type S = Bare_sigs.Result.S diff --git a/src/lib_lwt_result_stdlib/traced/sigs/seq.ml b/src/lib_lwt_result_stdlib/traced/sigs/seq.ml new file mode 100644 index 0000000000000000000000000000000000000000..1f15ff6d6398a7f599c6bafd63a313db464c9687 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/seq.ml @@ -0,0 +1,67 @@ +(*****************************************************************************) +(* *) +(* 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 replacement for {!Stdlib.Seq} which + - is exception-safe, + - includes Lwt-, result- and Lwt-result-aware traversal functions. + + See {!Lwtreslib} for a general description of traversors and the meaning for + the name suffixes. A full description is also below. *) +module type S = sig + include Bare_sigs.Seq.S + + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + (** 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, 'error trace) result Lwt.t) -> + 'a t -> + (unit, 'error trace) result Lwt.t + + (** Similar to {!map} but wraps the transformation in [result Lwt]. All the + transformations are done concurrently. The promise [map_ep 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_ep] is not tail-recursive. + *) + val map_ep : + ('a -> ('b, 'error trace) result Lwt.t) -> + 'a t -> + ('b t, 'error trace) result Lwt.t +end diff --git a/src/lib_lwt_result_stdlib/traced/sigs/set.ml b/src/lib_lwt_result_stdlib/traced/sigs/set.ml new file mode 100644 index 0000000000000000000000000000000000000000..5fef36da2525c814f9268dac565bf1b5894e1f65 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/set.ml @@ -0,0 +1,39 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** In Lwtreslib, like in the Stdlib, the Set module exports mainly functors + to instantiate sets with known-type keys. As a result, the bulk of the + documentation for sets is located within the module types returned by + the functors: in {!Traced_functor_outputs.Set}. *) +module type S = sig + (** ['error trace] is intended to be substituted by a type provided by a + [Trace] module ([with type 'error trace := 'error Trace.trace]) *) + type 'error trace + + module type S = + Traced_functor_outputs.Set.S with type 'error trace := 'error trace + + module Make (Ord : Stdlib.Set.OrderedType) : S with type elt = Ord.t +end diff --git a/src/lib_lwt_result_stdlib/traced/sigs/trace.ml b/src/lib_lwt_result_stdlib/traced/sigs/trace.ml new file mode 100644 index 0000000000000000000000000000000000000000..d2fc33dc3fe78f0584febcd838006fad06a7d7e8 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/sigs/trace.ml @@ -0,0 +1,122 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 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. *) +(* *) +(*****************************************************************************) + +(** Traces are used when errors need to be composed. This is useful directly to + the user: building traces of errors to keep track of successive failures. It + is also useful to the parallel traversors of this library ([_ep]) to + combine errors that were constructed concurrently. *) + +module type S = sig + (** [trace] are the errors as received from the monad. In other words, + [trace] is the type of values that are seen when matching on [Error _] + to, say, recover. + + The types ['error] and ['error trace] are kept separate (although they can + be equal) to support cases such as the following: + - [trace] are richer than [error], such as by including a + timestamp, a filename, or some other such metadata. + - [trace] is a [private] type or an [abstract] type and [error] is the + type of argument to the functions that construct the private/abstract + [trace]. + - [trace] is a collection of [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. + + There is {e some} leeway about what traces are, what information they + carry, etc. Beyond this leeway, Lwtreslib is opinionated about traces. + Specifically, Lwtreslib has a notion of {e sequential} and {e parallel} + composition. A trace can be either of the following. + - A {e single-error trace}, i.e., the simplest possible trace that + corresponds to a simple failure/issue/unexpected behaviour in the + program. See [make]. + - A {e sequential trace}, i.e., a trace of errors where one precedes + another. This is used to contextualise failures. E.g., in a high-level + network handshaking function, a low-level I/O error may be built into a + trace that shows how the low-level error caused a high-level issue). See + [cons]. + - A {e parallel trace}, i.e., a trace of errors that happened in concurrent + (or non-causally related) parts of the program. See [conp]. *) + type 'error trace + + (** [make e] is a trace made of one single error. *) + val make : 'error -> 'error trace + + (** [cons e t] is a trace made of the error [e] composed sequentially with the + trace [t]. + + Typically, this is used to give context to a low-level error. + +{[ +let query key = + connect_to_server () >>=? fun c -> + send_query_over_connection c key >>=? fun r -> + check_response r >>=? fun () -> + return r + +let query key = + query_key >|= function + | Ok r -> Ok r + | Error trace -> Error (cons `Query_failure trace) +]} *) + val cons : 'error -> 'error trace -> 'error trace + + (** [cons_list error errors] is the sequential composition of all the errors + passed as parameters. It is equivalent to folding [cons] over + [List.rev (error :: errors)] but more efficient. + + Note that [error] and [errors] are separated as parameters to enforce that + empty traces cannot be constructed. The recommended use is: +{[ + match a_bunch_of_errors with + | [] -> Ok () (* or something else depending on the context *) + | error :: errors -> Error (cons_list error errors) +]} + *) + val cons_list : 'error -> 'error list -> 'error trace + + (** [conp t1 t2] is a trace made of the traces [t1] and [t2] composed + concurrently. *) + val conp : 'error trace -> 'error trace -> 'error trace + + (** [conp_list trace traces] is the parallel composition of all the traces + passed as parameters. It is equivalent to + [List.fold_left conp trace traces] but more efficient. + + Note that [trace] and [traces] are separated as parameters to enforce that + empty traces cannot be constructed. The recommended use is: +{[ + match a_bunch_of_traces with + | [] -> Ok () (* or something else depending on the context *) + | trace :: traces -> Error (conp_list trace traces) +]} + *) + val conp_list : 'err trace -> 'err trace list -> 'err trace + + (** Note that the Lwtreslib's library does not require it, but it is + recommended that you also make, for your own use, a pretty-printing + function as well as some introspection functions. + + One possible extension can be found in [examples/traces/traces.ml]. *) +end diff --git a/src/lib_lwt_result_stdlib/lib/withExceptions.ml b/src/lib_lwt_result_stdlib/traced/sigs/withExceptions.ml similarity index 97% rename from src/lib_lwt_result_stdlib/lib/withExceptions.ml rename to src/lib_lwt_result_stdlib/traced/sigs/withExceptions.ml index 7767b748556c0b0b669aa4bf5d88bd71ab330576..ae3b38454b2b9fbf5146ea88e245fb9ccf389efe 100644 --- a/src/lib_lwt_result_stdlib/lib/withExceptions.ml +++ b/src/lib_lwt_result_stdlib/traced/sigs/withExceptions.ml @@ -23,4 +23,4 @@ (* *) (*****************************************************************************) -include Functors.WithExceptions.M +module type S = Bare_sigs.WithExceptions.S diff --git a/src/lib_lwt_result_stdlib/traced/structs/.ocamlformat b/src/lib_lwt_result_stdlib/traced/structs/.ocamlformat new file mode 100644 index 0000000000000000000000000000000000000000..8278a132e3d6f6c868be4c6e0a012089319d0bbc --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/.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/traced/structs/dune b/src/lib_lwt_result_stdlib/traced/structs/dune new file mode 100644 index 0000000000000000000000000000000000000000..ffeaf10e3457a1430c647b667abe7da95e9f2b6a --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/dune @@ -0,0 +1,13 @@ +(library + (name traced_structs) + (public_name tezos-lwt-result-stdlib.traced.structs) + (libraries + lwt + tezos-lwt-result-stdlib.traced.sigs + tezos-lwt-result-stdlib.bare.structs + )) + +(rule + (alias runtest_lint) + (deps (glob_files *.ml{,i})) + (action (run %{lib:tezos-tooling:lint.sh} %{deps}))) diff --git a/src/lib_lwt_result_stdlib/functors/withExceptions.ml b/src/lib_lwt_result_stdlib/traced/structs/hashtbl.ml similarity index 54% rename from src/lib_lwt_result_stdlib/functors/withExceptions.ml rename to src/lib_lwt_result_stdlib/traced/structs/hashtbl.ml index 5113bad2c2faab3ce76d79c97fecf9a2915c1493..c68f651c4e0d1e06b29679f7c2e44a03be30e1e4 100644 --- a/src/lib_lwt_result_stdlib/functors/withExceptions.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/hashtbl.ml @@ -23,63 +23,61 @@ (* *) (*****************************************************************************) -module M = struct - let invalid name loc = - Invalid_argument (Printf.sprintf "%s called from %s" name loc) +module Make + (Monad : Traced_sigs.Monad.S) + (Seq : Traced_sigs.Seq.S with type 'error trace := 'error Monad.trace) = +struct + let hash = Stdlib.Hashtbl.hash - module Option = struct - let get ~loc = function - | Some v -> - v - | None -> - raise (invalid "Lwtreslib.WithExceptions.Option.get" loc) + let seeded_hash = Stdlib.Hashtbl.seeded_hash - let to_exn ~none = function Some v -> v | None -> raise none + let hash_param ~meaningful ~total v = + Stdlib.Hashtbl.hash_param meaningful total v - let to_exn_f ~none = function Some v -> v | None -> raise (none ()) - end + let seeded_hash_param ~meaningful ~total seed v = + Stdlib.Hashtbl.seeded_hash_param meaningful total seed v + + module type S = + Traced_functor_outputs.Hashtbl.S + with type 'error trace := 'error Monad.trace - module Result = struct - let get_ok ~loc = function - | Ok v -> - v - | Error _ -> - raise (invalid "Lwtreslib.WithExceptions.Result.get_ok" loc) + module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t = struct + include Bare_structs.Hashtbl.Make (H) - let get_error ~loc = function - | Error e -> - e - | Ok _ -> - raise (invalid "Lwtreslib.WithExceptions.Result.get_error" loc) + let iter_ep f t = Seq.iter_ep (fun (k, v) -> f k v) (to_seq t) + end - let to_exn = function Ok v -> v | Error exc -> raise exc + module type SeededS = + Traced_functor_outputs.Hashtbl.SeededS + with type 'error trace := 'error Monad.trace - let to_exn_f ~error = function Ok v -> v | Error b -> raise (error b) + module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : + SeededS with type key = H.t = struct + include Bare_structs.Hashtbl.MakeSeeded (H) + + let iter_ep f t = Seq.iter_ep (fun (k, v) -> f k v) (to_seq t) end - module List = struct - let rev_combine ~loc xs ys = - let rec aux acc xs ys = - match (xs, ys) with - | ([], []) -> - acc - | (x :: xs, y :: ys) -> - aux ((x, y) :: acc) xs ys - | ([], _ :: _) | (_ :: _, []) -> - raise (invalid "Lwtreslib.WithExceptions.List.rev_combine" loc) - in - aux [] xs ys + module type S_ES = + Traced_functor_outputs.Hashtbl.S_ES + with type 'error trace := 'error Monad.trace + + module Make_es (H : Stdlib.Hashtbl.HashedType) : S_ES with type key = H.t = + struct + include Bare_structs.Hashtbl.Make_es (H) - let combine ~loc xs ys = - let rec aux acc xs ys = - match (xs, ys) with - | ([], []) -> - acc - | (x :: xs, y :: ys) -> - aux ((x, y) :: acc) xs ys - | ([], _ :: _) | (_ :: _, []) -> - raise (invalid "Lwtreslib.WithExceptions.List.combine" loc) - in - Stdlib.List.rev (aux [] xs ys) + let iter_with_waiting_ep f t = + Monad.join_ep + @@ fold_promises + (fun k p acc -> + let promise = + Lwt.try_bind + (fun () -> p) + (function Error _ -> Monad.unit_es | Ok v -> f k v) + (fun _ -> Monad.unit_es) + in + promise :: acc) + t + [] end end diff --git a/src/lib_lwt_result_stdlib/functors/map.mli b/src/lib_lwt_result_stdlib/traced/structs/hashtbl.mli similarity index 90% rename from src/lib_lwt_result_stdlib/functors/map.mli rename to src/lib_lwt_result_stdlib/traced/structs/hashtbl.mli index 22381f1494160201e2c0281241611bc5f6981d2c..30cdea8538ea6ba1a1dbfd67fb7a931a21660f4a 100644 --- a/src/lib_lwt_result_stdlib/functors/map.mli +++ b/src/lib_lwt_result_stdlib/traced/structs/hashtbl.mli @@ -23,8 +23,7 @@ (* *) (*****************************************************************************) -module Make (Seq : Sigs.Seq.S) : sig - module type S = Sigs.Map.S with type 'error trace := 'error Seq.Monad.trace - - module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t -end +module Make + (Monad : Traced_sigs.Monad.S) + (Seq : Traced_sigs.Seq.S with type 'error trace := 'error Monad.trace) : + Traced_sigs.Hashtbl.S with type 'error trace := 'error Monad.trace diff --git a/src/lib_lwt_result_stdlib/traced/structs/list.ml b/src/lib_lwt_result_stdlib/traced/structs/list.ml new file mode 100644 index 0000000000000000000000000000000000000000..9c3e3e71e625135d237af2d11e69d159c5df9e36 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/list.ml @@ -0,0 +1,72 @@ +(*****************************************************************************) +(* *) +(* 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 : Traced_sigs.Monad.S) : + Traced_sigs.List.S with type 'error trace := 'error Monad.trace = struct + open Monad + include Bare_structs.List + + let init_ep ~when_negative_length l f = + let rec aux acc i = + if i >= l then all_ep (rev acc) + else (aux [@ocaml.tailcall]) (Lwt.apply f i :: acc) (i + 1) + in + if l < 0 then Monad.fail_trace when_negative_length + else if l = 0 then nil_es + else aux [] 0 + + let iter_ep f l = join_ep (rev_map (Lwt.apply f) l) + + let lwt_apply2 f x y = try f x y with exc -> Lwt.fail exc + + let iteri_ep f l = join_ep (mapi (lwt_apply2 f) l) + + let rev_map_ep f l = all_ep @@ rev_map (Lwt.apply f) l + + let map_ep f l = rev_map_ep f l >|=? rev + + let rev_mapi_ep f l = all_ep @@ rev_mapi f l + + let mapi_ep f l = rev_mapi_ep f l >|=? rev + + let filter_ep f l = + rev_map_ep (fun x -> f x >|=? fun b -> if b then Some x else None) l + >|=? rev_filter_some + + let filter_map_ep f l = rev_map_ep f l >|=? rev_filter_some + + let for_all_ep f l = rev_map_ep f l >|=? for_all Fun.id + + let exists_ep f l = rev_map_ep f l >|=? exists Fun.id + + let partition_ep f l = + rev_map_ep (fun x -> f x >|=? fun b -> (b, x)) l + >|=? fun bxs -> + fold_left + (fun (trues, falses) (b, x) -> + if b then (x :: trues, falses) else (trues, x :: falses)) + ([], []) + bxs +end diff --git a/src/lib_lwt_result_stdlib/lib/list.mli b/src/lib_lwt_result_stdlib/traced/structs/list.mli similarity index 94% rename from src/lib_lwt_result_stdlib/lib/list.mli rename to src/lib_lwt_result_stdlib/traced/structs/list.mli index e686712c35bd21d57dbd431a917c26a2f1fcfc7c..561d784f2b7522f070f2d468020588e66a22057e 100644 --- a/src/lib_lwt_result_stdlib/lib/list.mli +++ b/src/lib_lwt_result_stdlib/traced/structs/list.mli @@ -23,4 +23,5 @@ (* *) (*****************************************************************************) -include Sigs.List.S with type 'error trace := 'error Error_monad.trace +module Make (Monad : Traced_sigs.Monad.S) : + Traced_sigs.List.S with type 'error trace := 'error Monad.trace diff --git a/src/lib_lwt_result_stdlib/traced/structs/map.ml b/src/lib_lwt_result_stdlib/traced/structs/map.ml new file mode 100644 index 0000000000000000000000000000000000000000..56d03cd7b8c184fffd286d329e6fc5af7ef0a641 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/map.ml @@ -0,0 +1,38 @@ +(*****************************************************************************) +(* *) +(* 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 : Traced_sigs.Monad.S) + (Seq : Traced_sigs.Seq.S with type 'error trace := 'error Monad.trace) : + Traced_sigs.Map.S with type 'error trace := 'error Monad.trace = struct + module type S = + Traced_functor_outputs.Map.S with type 'error trace := 'error Monad.trace + + module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t = struct + include Bare_structs.Map.Make (Ord) + + let iter_ep f t = Seq.iter_ep (fun (k, v) -> f k v) (to_seq t) + end +end diff --git a/src/lib_lwt_result_stdlib/lib/map.mli b/src/lib_lwt_result_stdlib/traced/structs/map.mli similarity index 91% rename from src/lib_lwt_result_stdlib/lib/map.mli rename to src/lib_lwt_result_stdlib/traced/structs/map.mli index ec82c946a7760f68e6d628d466d7ce71326199c5..ef7aca3dd3db6224c2f9f073fb75be38e24aa896 100644 --- a/src/lib_lwt_result_stdlib/lib/map.mli +++ b/src/lib_lwt_result_stdlib/traced/structs/map.mli @@ -23,6 +23,7 @@ (* *) (*****************************************************************************) -module type S = Sigs.Map.S with type 'error trace := 'error Seq.Monad.trace - -module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t +module Make + (Monad : Traced_sigs.Monad.S) + (Seq : Traced_sigs.Seq.S with type 'error trace := 'error Monad.trace) : + Traced_sigs.Map.S with type 'error trace := 'error Monad.trace diff --git a/src/lib_lwt_result_stdlib/functors/map.ml b/src/lib_lwt_result_stdlib/traced/structs/monad.ml similarity index 61% rename from src/lib_lwt_result_stdlib/functors/map.ml rename to src/lib_lwt_result_stdlib/traced/structs/monad.ml index da1f332021ec932879b25050f7bc7573e613afe5..087f5e69e119591c178c66152e1a16b0df7aa5dc 100644 --- a/src/lib_lwt_result_stdlib/functors/map.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/monad.ml @@ -23,43 +23,55 @@ (* *) (*****************************************************************************) -module Make (Seq : Sigs.Seq.S) = struct - module type S = Sigs.Map.S with type 'error trace := 'error Seq.Monad.trace - - module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t = struct - open Seq - module Legacy = Stdlib.Map.Make (Ord) - include Legacy - - 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 +module Make (Trace : Traced_sigs.Trace.S) : + Traced_sigs.Monad.S with type 'error trace = 'error Trace.trace = struct + include Bare_structs.Monad + + type 'error trace = 'error Trace.trace + + let error_trace e = error (Trace.make e) + + let fail_trace e = fail (Trace.make e) + + let rec join_e_errors trace_acc = function + | Ok _ :: ts -> + join_e_errors trace_acc ts + | Error trace :: ts -> + join_e_errors (Trace.conp trace_acc trace) ts + | [] -> + Error trace_acc + + let rec join_e = function + | [] -> + unit_e + | Ok () :: ts -> + join_e ts + | Error trace :: ts -> + join_e_errors trace ts + + let all_e ts = + let rec aux acc = function + | [] -> + Ok (Stdlib.List.rev acc) + | Ok v :: ts -> + aux (v :: acc) ts + | Error trace :: ts -> + join_e_errors trace 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) -> + Error (Trace.conp erra errb) + + 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 end diff --git a/src/lib_lwt_result_stdlib/traced/structs/monad.mli b/src/lib_lwt_result_stdlib/traced/structs/monad.mli new file mode 100644 index 0000000000000000000000000000000000000000..07a8caf2c1b290cd9134cd06026c10a9754380d3 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/monad.mli @@ -0,0 +1,27 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Make (Trace : Traced_sigs.Trace.S) : + Traced_sigs.Monad.S with type 'error trace = 'error Trace.trace diff --git a/src/lib_lwt_result_stdlib/traced/structs/seq.ml b/src/lib_lwt_result_stdlib/traced/structs/seq.ml new file mode 100644 index 0000000000000000000000000000000000000000..f60fba120a96b14c25f4baad403485f17401af88 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/seq.ml @@ -0,0 +1,45 @@ +(*****************************************************************************) +(* *) +(* 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 : Traced_sigs.Monad.S) : + Traced_sigs.Seq.S with type 'error trace := 'error Monad.trace = struct + include Bare_structs.Seq + + let iter_ep f seq = + let rec iter_ep f seq acc = + match seq () with + | Nil -> + Monad.join_ep acc + | Cons (item, seq) -> + iter_ep f seq (Lwt.apply f item :: acc) + in + iter_ep f seq [] + + let map_ep f seq = + let open Monad in + all_ep (fold_left (fun acc x -> Lwt.apply f x :: acc) [] seq) + >|=? (* this is equivalent to rev |> to_seq but more direct *) + Stdlib.List.fold_left (fun s x () -> Cons (x, s)) empty +end diff --git a/src/lib_lwt_result_stdlib/functors/list.mli b/src/lib_lwt_result_stdlib/traced/structs/seq.mli similarity index 94% rename from src/lib_lwt_result_stdlib/functors/list.mli rename to src/lib_lwt_result_stdlib/traced/structs/seq.mli index d1230ce4576c64913a60a9b2f1fc164b9471f227..3ecdd356a43665608481202ad139313560d89fa7 100644 --- a/src/lib_lwt_result_stdlib/functors/list.mli +++ b/src/lib_lwt_result_stdlib/traced/structs/seq.mli @@ -23,5 +23,5 @@ (* *) (*****************************************************************************) -module Make (Monad : Sigs.Monad.S) : - Sigs.List.S with type 'error trace := 'error Monad.trace +module Make (Monad : Traced_sigs.Monad.S) : + Traced_sigs.Seq.S with type 'error trace := 'error Monad.trace diff --git a/src/lib_lwt_result_stdlib/traced/structs/set.ml b/src/lib_lwt_result_stdlib/traced/structs/set.ml new file mode 100644 index 0000000000000000000000000000000000000000..3e1231ea788003d141449bbfa0452fcb1c5dbbc0 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/set.ml @@ -0,0 +1,38 @@ +(*****************************************************************************) +(* *) +(* 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 : Traced_sigs.Monad.S) + (Seq : Traced_sigs.Seq.S with type 'error trace := 'error Monad.trace) : + Traced_sigs.Set.S with type 'error trace := 'error Monad.trace = struct + module type S = + Traced_functor_outputs.Set.S with type 'error trace := 'error Monad.trace + + module Make (Ord : Stdlib.Set.OrderedType) : S with type elt = Ord.t = struct + include Bare_structs.Set.Make (Ord) + + let iter_ep f t = Seq.iter_ep f (to_seq t) + end +end diff --git a/src/lib_lwt_result_stdlib/lib/set.mli b/src/lib_lwt_result_stdlib/traced/structs/set.mli similarity index 91% rename from src/lib_lwt_result_stdlib/lib/set.mli rename to src/lib_lwt_result_stdlib/traced/structs/set.mli index 47bf1cacc95dca95c9ea193d9928881465af8363..f1302bddae349ca140060b0ceee6d9b2695b773c 100644 --- a/src/lib_lwt_result_stdlib/lib/set.mli +++ b/src/lib_lwt_result_stdlib/traced/structs/set.mli @@ -23,6 +23,7 @@ (* *) (*****************************************************************************) -module type S = Sigs.Set.S with type 'error trace := 'error Seq.Monad.trace - -module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t +module Make + (Monad : Traced_sigs.Monad.S) + (Seq : Traced_sigs.Seq.S with type 'error trace := 'error Monad.trace) : + Traced_sigs.Set.S with type 'error trace := 'error Monad.trace diff --git a/src/lib_lwt_result_stdlib/traced/structs/structs.ml b/src/lib_lwt_result_stdlib/traced/structs/structs.ml new file mode 100644 index 0000000000000000000000000000000000000000..688d887fef4cd56a0b889bfb533236b74379f120 --- /dev/null +++ b/src/lib_lwt_result_stdlib/traced/structs/structs.ml @@ -0,0 +1,38 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 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. *) +(* *) +(*****************************************************************************) + +(** [Make] is a functor that takes a [Trace] as argument and instantiates all + the Traced modules based on it. *) +module Make (Trace : Traced_sigs.Trace.S) = struct + module Monad = Monad.Make (Trace) + module Seq = Seq.Make (Monad) + module Hashtbl = Hashtbl.Make (Monad) (Seq) + module List = List.Make (Monad) + module Map = Map.Make (Monad) (Seq) + module Option = Bare_structs.Option + module Result = Bare_structs.Result + module Set = Set.Make (Monad) (Seq) + module WithExceptions = Bare_structs.WithExceptions +end diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index c4c5d6aab99411c9cd2ec554d3bde434b2984edf..927c87a95510ed1c1e6e151da2e1602f51753aac 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -138,7 +138,7 @@ struct module Int64 = Int64 module Buffer = Buffer module Format = Format - module Option = Tezos_lwt_result_stdlib.Lwtreslib.Option + module Option = Tezos_error_monad.TzLwtreslib.Option module Raw_hashes = struct let sha256 = Hacl.Hash.SHA256.digest diff --git a/src/lib_sapling/dune b/src/lib_sapling/dune index 0560a191f5d989c49aede146e6cb0e09a7b1e244..0bd07a614e88b10cd3a0f6b5209e87234ecf884f 100644 --- a/src/lib_sapling/dune +++ b/src/lib_sapling/dune @@ -15,7 +15,7 @@ (flags (:standard -open Tezos_stdlib -open Tezos_crypto -open Tezos_error_monad - -open Tezos_lwt_result_stdlib.Lwtreslib))) + -open Tezos_error_monad.TzLwtreslib))) (rule (alias runtest_lint) diff --git a/src/lib_sapling/test/example.ml b/src/lib_sapling/test/example.ml index ded70fb5fb614ffe34148c71c51a9fdf3ee64c2f..98922395476626fa34b31123dc337f4cf0ebbab6 100644 --- a/src/lib_sapling/test/example.ml +++ b/src/lib_sapling/test/example.ml @@ -21,7 +21,7 @@ * SOFTWARE. *) open Tezos_error_monad.Error_monad -open Tezos_lwt_result_stdlib.Lwtreslib +open Tezos_error_monad.TzLwtreslib module Client = struct module Core = Core.Client diff --git a/src/lib_signer_backends/test/dune b/src/lib_signer_backends/test/dune index bd7dddd4345f0a1017988460f8a1325536a0724c..fbea8fd2ec4326e4a0258e0fe43c65bad587eefe 100644 --- a/src/lib_signer_backends/test/dune +++ b/src/lib_signer_backends/test/dune @@ -4,7 +4,7 @@ alcotest-lwt) (flags (:standard -open Tezos_error_monad -open Tezos_stdlib - -open Tezos_lwt_result_stdlib.Lwtreslib + -open Tezos_error_monad.TzLwtreslib -open Tezos_crypto -open Tezos_client_base -open Tezos_signer_backends))) diff --git a/src/lib_stdlib_unix/dune b/src/lib_stdlib_unix/dune index 5dd825cc01d675cc30f0a30296e91fdb799c66f4..e1af20c5a0237e35cefe8913386321e37f1a9df1 100644 --- a/src/lib_stdlib_unix/dune +++ b/src/lib_stdlib_unix/dune @@ -2,7 +2,7 @@ (name tezos_stdlib_unix) (public_name tezos-stdlib-unix) (flags (:standard -open Tezos_error_monad - -open Tezos_lwt_result_stdlib.Lwtreslib + -open Tezos_error_monad.TzLwtreslib -open Tezos_event_logging -open Tezos_stdlib -open Data_encoding))