From 5c00f771ccce3538ff7ce55502b92deb1d89b952 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 10 Aug 2021 15:51:31 +0100 Subject: [PATCH 1/5] Error-monad,Lwtreslib: move monad part from former to latter --- src/lib_error_monad/TzMonad.ml | 2 +- src/lib_error_monad/TzMonad.mli | 2 +- src/lib_error_monad/error_monad.mli | 2 +- src/lib_error_monad/monad_ext_maker.ml | 51 +++- src/lib_error_monad/monad_ext_maker.mli | 3 +- src/lib_error_monad/monad_maker.ml | 155 ----------- src/lib_error_monad/monad_maker.mli | 27 -- src/lib_error_monad/sig.ml | 243 ++---------------- src/lib_lwt_result_stdlib/bare/sigs/monad.ml | 20 ++ src/lib_lwt_result_stdlib/lwtreslib.ml | 6 +- src/lib_lwt_result_stdlib/lwtreslib.mli | 11 +- .../environment_V0.ml | 9 +- .../environment_V1.ml | 5 +- .../environment_V2.ml | 5 +- .../environment_V3.ml | 5 +- 15 files changed, 119 insertions(+), 427 deletions(-) delete mode 100644 src/lib_error_monad/monad_maker.ml delete mode 100644 src/lib_error_monad/monad_maker.mli diff --git a/src/lib_error_monad/TzMonad.ml b/src/lib_error_monad/TzMonad.ml index f4fac0da176f..43d85db97326 100644 --- a/src/lib_error_monad/TzMonad.ml +++ b/src/lib_error_monad/TzMonad.ml @@ -26,6 +26,6 @@ type error = TzCore.error = .. -module Monad = Monad_maker.Make (TzTrace) +module Monad = TzLwtreslib.Monad include Monad include Monad_ext_maker.Make (TzCore) (TzTrace) (Monad) diff --git a/src/lib_error_monad/TzMonad.mli b/src/lib_error_monad/TzMonad.mli index 27e12eb34cdb..372605801363 100644 --- a/src/lib_error_monad/TzMonad.mli +++ b/src/lib_error_monad/TzMonad.mli @@ -26,7 +26,7 @@ type error = TzCore.error = .. -include Sig.MONAD with type 'error trace := 'error TzTrace.trace +include module type of TzLwtreslib.Monad include Sig.MONAD_EXT diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index e647d6f6c06e..2159e4d972e0 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -44,7 +44,7 @@ module TzTrace : Sig.TRACE with type 'error trace = 'error list type 'error trace = 'error TzTrace.trace -include Sig.MONAD with type 'error trace := 'error TzTrace.trace +include module type of TzLwtreslib.Monad with type 'error trace := 'error trace include Sig.MONAD_EXT diff --git a/src/lib_error_monad/monad_ext_maker.ml b/src/lib_error_monad/monad_ext_maker.ml index 0c1d81fef170..dd0294b94a40 100644 --- a/src/lib_error_monad/monad_ext_maker.ml +++ b/src/lib_error_monad/monad_ext_maker.ml @@ -31,10 +31,17 @@ module Make (Error : sig include Sig.EXT with type error := error end) (Trace : Sig.TRACE) -(Monad : Sig.MONAD with type 'error trace := 'error Trace.trace) : +(Monad : Tezos_lwt_result_stdlib.Lwtreslib.TRACED_MONAD + with type 'error trace := 'error Trace.trace) : Sig.MONAD_EXT with type error := Error.error and type 'error trace := 'error Trace.trace = struct + open Monad + + let fail e = Lwt.return_error (Trace.make e) + + let error e = Error (Trace.make e) + type tztrace = Error.error Trace.trace type 'a tzresult = ('a, tztrace) result @@ -71,4 +78,46 @@ end) (fun c e -> Sig.combine_category c (Error.classify_error e)) `Temporary trace + + let record_trace err result = + match result with + | Ok _ as res -> res + | Error trace -> Error (Trace.cons err trace) + + let trace err f = + f >>= function + | Error trace -> Lwt.return_error (Trace.cons err trace) + | ok -> Lwt.return ok + + let record_trace_eval mk_err = function + | Error trace -> mk_err () >>? fun err -> Error (Trace.cons err trace) + | ok -> ok + + let trace_eval mk_err f = + f >>= function + | Error trace -> + mk_err () >>=? fun err -> Lwt.return_error (Trace.cons err trace) + | ok -> Lwt.return ok + + let error_unless cond exn = if cond then ok_unit else error exn + + let error_when cond exn = if cond then error exn else ok_unit + + let fail_unless cond exn = if cond then return_unit else fail exn + + let fail_when cond exn = if cond then fail exn else return_unit + + let unless cond f = if cond then return_unit else f () + + let when_ cond f = if cond then f () else return_unit + + let dont_wait f err_handler exc_handler = + Lwt.dont_wait + (fun () -> + f () >>= function + | Ok () -> Lwt.return_unit + | Error trace -> + err_handler trace ; + Lwt.return_unit) + exc_handler end diff --git a/src/lib_error_monad/monad_ext_maker.mli b/src/lib_error_monad/monad_ext_maker.mli index a50448478c28..4f367c8321ad 100644 --- a/src/lib_error_monad/monad_ext_maker.mli +++ b/src/lib_error_monad/monad_ext_maker.mli @@ -31,7 +31,8 @@ module Make (Error : sig include Sig.EXT with type error := error end) (Trace : Sig.TRACE) -(Monad : Sig.MONAD with type 'error trace := 'error Trace.trace) : +(Monad : Tezos_lwt_result_stdlib.Lwtreslib.TRACED_MONAD + with type 'error trace := 'error Trace.trace) : Sig.MONAD_EXT with type error := Error.error and type 'error trace := 'error Trace.trace diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml deleted file mode 100644 index 8719a3231379..000000000000 --- a/src/lib_error_monad/monad_maker.ml +++ /dev/null @@ -1,155 +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 (Trace : Sig.TRACE) : - Sig.MONAD with type 'err trace := 'err Trace.trace = struct - let ( >>= ) = Lwt.( >>= ) - - let[@inline] ok v = Ok v - - let ok_unit = Ok () - - let ok_none = Ok None - - let[@inline] ok_some x = Ok (Some x) - - let ok_nil = Ok [] - - let ok_true = Ok true - - let ok_false = Ok false - - let[@inline] error s = Error (Trace.make s) - - let[@inline] return v = Lwt.return_ok v - - let return_unit = Lwt.return ok_unit - - let return_none = Lwt.return ok_none - - let[@inline] return_some x = Lwt.return (Ok (Some x)) - - let return_nil = Lwt.return ok_nil - - let return_true = Lwt.return ok_true - - let return_false = Lwt.return ok_false - - let[@inline] fail s = Lwt.return_error @@ Trace.make s - - let ( >>? ) v f = match v with Error _ as err -> err | Ok v -> f v - - let ( >>=? ) v f = - v >>= function Error _ as err -> Lwt.return err | Ok v -> f v - - let ( >>?= ) 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 >>= Lwt.return_ok - - let ( >|=? ) v f = v >>=? fun v -> Lwt.return_ok (f v) - - let ( >|= ) = Lwt.( >|= ) - - let ( >|? ) v f = v >>? fun v -> Ok (f v) - - let join_p = Lwt.join - - let all_p = Lwt.all - - let both_p = Lwt.both - - 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 - | [] -> ok_unit - | Ok () :: ts -> join_e ts - | Error trace :: ts -> join_e_errors trace ts - - let all_e ts = - let rec aux acc = function - | [] -> Ok (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 - - let record_trace err result = - match result with - | Ok _ as res -> res - | Error trace -> Error (Trace.cons err trace) - - let trace err f = - f >>= function - | Error trace -> Lwt.return_error (Trace.cons err trace) - | ok -> Lwt.return ok - - let record_trace_eval mk_err = function - | Error trace -> mk_err () >>? fun err -> Error (Trace.cons err trace) - | ok -> ok - - let trace_eval mk_err f = - f >>= function - | Error trace -> - mk_err () >>=? fun err -> Lwt.return_error (Trace.cons err trace) - | ok -> Lwt.return ok - - let error_unless cond exn = if cond then ok_unit else error exn - - let error_when cond exn = if cond then error exn else ok_unit - - let fail_unless cond exn = if cond then return_unit else fail exn - - let fail_when cond exn = if cond then fail exn else return_unit - - let unless cond f = if cond then return_unit else f () - - let when_ cond f = if cond then f () else return_unit - - let dont_wait f err_handler exc_handler = - Lwt.dont_wait - (fun () -> - f () >>= function - | Ok () -> Lwt.return_unit - | Error trace -> - err_handler trace ; - Lwt.return_unit) - exc_handler -end diff --git a/src/lib_error_monad/monad_maker.mli b/src/lib_error_monad/monad_maker.mli deleted file mode 100644 index 541d04a429df..000000000000 --- a/src/lib_error_monad/monad_maker.mli +++ /dev/null @@ -1,27 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2019 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 : Sig.TRACE) : - Sig.MONAD with type 'err trace := 'err Trace.trace diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index 95a3f453d48b..af2c0403d9c8 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -192,88 +192,8 @@ module type TRACE = sig Eventually, we can make the trace abstract in the instantiated error monad, we can have different notions of traces for the protocol and the shell, etc. *) - type 'err trace - - (** [make e] makes a singleton trace, the simplest of traces that carries a - single error. *) - val make : 'error -> 'error trace - - (** [cons e t] (construct sequential) constructs a sequential trace. This is - for tracing events/failures/things that happen one after the other, - generally one as a consequence of the other. E.g., - - [let file_handle = - match attempt_open name with - | Ok handle -> Ok handle - | Error error -> - let trace = make error in - match attempt_create name with - | 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., - - [let fetch_density () = - let area = fetch_area () in - let population = fetch_population () in - match area, population with - | Ok area, Ok population -> Ok (population / area) - | 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 + + include Tezos_lwt_result_stdlib.Lwtreslib.TRACE (** [pp_print] pretty-prints a trace of errors *) val pp_print : @@ -292,101 +212,36 @@ module type TRACE = sig val fold : ('a -> 'error -> 'a) -> 'a -> 'error trace -> 'a end -module type MONAD = sig - (** To be substituted/constrained *) - type 'err trace - - (** Successful result *) - 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 - - (** Successful return *) - val return : 'a -> ('a, 'trace) result Lwt.t - - (** Successful return of [()] *) - val return_unit : (unit, 'trace) result Lwt.t - - (** Successful return of [None] *) - val return_none : ('a option, 'trace) result Lwt.t - - (** [return_some x] is a successful return of [Some x] *) - val return_some : 'a -> ('a option, 'trace) result Lwt.t - - (** Successful return of [[]] *) - val return_nil : ('a list, 'trace) result Lwt.t - - (** Successful return of [true] *) - val return_true : (bool, 'trace) result Lwt.t - - (** Successful return of [false] *) - val return_false : (bool, 'trace) result Lwt.t - - (** Erroneous result *) - val error : 'err -> ('a, 'err trace) result +module type MONAD_EXT = sig + (** for substitution *) + type error - (** Erroneous return *) - val fail : 'err -> ('a, 'err trace) result Lwt.t + (** for substitution *) + type 'error trace - (** Infix operators for monadic binds/maps. 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. - *) + type tztrace = error trace - (** Lwt's bind reexported. Following Lwt's convention, in this operator and - the ones below, [=] indicate we operate within Lwt. *) - val ( >>= ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t + type 'a tzresult = ('a, tztrace) result - (** Lwt's map reexported. The [|] indicates a map rather than a bind. *) - val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t + val classify_errors : tztrace -> error_category - (** Non-Lwt bind operator. In this operator and the ones below, [?] indicates - that we operate within the error monad. *) - val ( >>? ) : - ('a, 'trace) result -> ('a -> ('b, 'trace) result) -> ('b, 'trace) result + val fail : 'error -> ('a, 'error trace) result Lwt.t - (** Non-Lwt map operator. *) - val ( >|? ) : ('a, 'trace) result -> ('a -> 'b) -> ('b, 'trace) result + val error : 'error -> ('a, 'error trace) result - (** Combined bind operator. The [=?] indicates that the operator acts within - the combined error-lwt monad. *) - val ( >>=? ) : - ('a, 'trace) result Lwt.t -> - ('a -> ('b, 'trace) result Lwt.t) -> - ('b, 'trace) result Lwt.t + (* This is for legacy, for backwards compatibility, there are old names *) - (** Combined map operator. *) - val ( >|=? ) : - ('a, 'trace) result Lwt.t -> ('a -> 'b) -> ('b, 'trace) result Lwt.t + (* NOTE: Right now we leave this [pp_print_error] named as is. Later on we + might rename it to [pp_print_trace]. *) + val pp_print_error : Format.formatter -> error trace -> unit - (** Injecting bind operator. This is for transitioning from the simple Error - monad to the combined Error-Lwt monad. + (** Pretty prints a trace as the message of its first error *) + val pp_print_error_first : Format.formatter -> error trace -> unit - Note the order of the character: it starts with the error monad marker [?] - and has the Lwt monad marker later. This hints at the role of the operator - to transition into Lwt. *) - val ( >>?= ) : - ('a, 'trace) result -> - ('a -> ('b, 'trace) result Lwt.t) -> - ('b, 'trace) result Lwt.t + val trace_encoding : error trace Data_encoding.t - (** Injecting map operator. *) - val ( >|?= ) : - ('a, 'trace) result -> ('a -> 'b Lwt.t) -> ('b, 'trace) result Lwt.t + (** A serializer for result of a given type *) + val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.t (** Enrich an error report (or do nothing on a successful result) manually *) val record_trace : 'err -> ('a, 'err trace) result -> ('a, 'err trace) result @@ -429,60 +284,4 @@ module type MONAD = sig ('trace -> unit) -> (exn -> unit) -> unit - - (** A few aliases for Lwt functions *) - val join_p : unit Lwt.t list -> unit Lwt.t - - val all_p : 'a Lwt.t list -> 'a list Lwt.t - - val both_p : 'a Lwt.t -> 'b Lwt.t -> ('a * 'b) Lwt.t - - (** Similar functions in the error monad *) - val join_e : (unit, 'err trace) result list -> (unit, 'err trace) result - - val all_e : ('a, 'err trace) result list -> ('a list, 'err trace) result - - val both_e : - ('a, 'err trace) result -> - ('b, 'err trace) result -> - ('a * 'b, 'err trace) result - - (** Similar functions in the combined monad *) - val join_ep : - (unit, 'err trace) result Lwt.t list -> (unit, 'err trace) result Lwt.t - - val all_ep : - ('a, 'err trace) result Lwt.t list -> ('a list, 'err trace) result Lwt.t - - val both_ep : - ('a, 'err trace) result Lwt.t -> - ('b, 'err trace) result Lwt.t -> - ('a * 'b, 'err trace) result Lwt.t -end - -module type MONAD_EXT = sig - (** for substitution *) - type error - - type 'error trace - - type tztrace = error trace - - type 'a tzresult = ('a, tztrace) result - - val classify_errors : tztrace -> error_category - - (* This is for legacy, for backwards compatibility, there are old names *) - - (* NOTE: Right now we leave this [pp_print_error] named as is. Later on we - might rename it to [pp_print_trace]. *) - val pp_print_error : Format.formatter -> error trace -> unit - - (** Pretty prints a trace as the message of its first error *) - val pp_print_error_first : Format.formatter -> error trace -> unit - - val trace_encoding : error trace Data_encoding.t - - (** A serializer for result of a given type *) - val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.t end diff --git a/src/lib_lwt_result_stdlib/bare/sigs/monad.ml b/src/lib_lwt_result_stdlib/bare/sigs/monad.ml index 81df6077f1eb..41d573bc19cf 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/monad.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/monad.ml @@ -200,6 +200,26 @@ module type S = sig val return_unit : (unit, 'error) result Lwt.t + val ok_none : ('a option, 'trace) result + + val return_none : ('a option, 'trace) result Lwt.t + + val ok_some : 'a -> ('a option, 'trace) result + + val return_some : 'a -> ('a option, 'trace) result Lwt.t + + val ok_nil : ('a list, 'trace) result + + val return_nil : ('a list, 'trace) result Lwt.t + + val ok_true : (bool, 'trace) result + + val return_true : (bool, 'trace) result Lwt.t + + val ok_false : (bool, 'trace) result + + val return_false : (bool, 'trace) result Lwt.t + (** joins *) val join_p : unit Lwt.t list -> unit Lwt.t diff --git a/src/lib_lwt_result_stdlib/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml index a9731bb7ad05..3602148dece6 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.ml +++ b/src/lib_lwt_result_stdlib/lwtreslib.ml @@ -39,4 +39,8 @@ module Bare = struct module WithExceptions = Bare_structs.WithExceptions end -module Traced (Trace : Traced_sigs.Trace.S) = Traced_structs.Structs.Make (Trace) +module type TRACE = Traced_sigs.Trace.S + +module type TRACED_MONAD = Traced_sigs.Monad.S + +module Traced (Trace : TRACE) = Traced_structs.Structs.Make (Trace) diff --git a/src/lib_lwt_result_stdlib/lwtreslib.mli b/src/lib_lwt_result_stdlib/lwtreslib.mli index b246ef64df3a..426114cd20fe 100644 --- a/src/lib_lwt_result_stdlib/lwtreslib.mli +++ b/src/lib_lwt_result_stdlib/lwtreslib.mli @@ -288,7 +288,7 @@ module Bare : sig module WithExceptions : Bare_sigs.WithExceptions.S end -(** [Traced] is a functor to generate an advanced combined-monad replacements +(** [Traced] is a functor to generate 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. @@ -316,8 +316,13 @@ let load_config file = 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 type TRACE = Traced_sigs.Trace.S +(* exporting for availablility *) + +module type TRACED_MONAD = Traced_sigs.Monad.S (* exporting for availablility *) + +module Traced (Trace : TRACE) : sig + module Monad : TRACED_MONAD with type 'error trace = 'error Trace.trace module Hashtbl : Traced_sigs.Hashtbl.S with type 'error trace := 'error Trace.trace diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 32127861f873..60bed4423d67 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -370,16 +370,15 @@ struct type error_category = [`Branch | `Temporary | `Permanent] include Error_core - module Local_monad = Tezos_error_monad.Monad_maker.Make (TzTrace) - include Local_monad + include Tezos_error_monad.TzLwtreslib.Monad include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) - (Local_monad) + (Tezos_error_monad.TzLwtreslib.Monad) - (* Backwards compatibility additions (traversors, infix op) *) + (* below is for backward compatibility *) include Error_monad_traversors - let ( >>|? ) = ( >|=? ) (* for backward compatibility *) + let ( >>|? ) = ( >|=? ) end let () = diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index a31324212154..3f72e68f4316 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -557,11 +557,10 @@ struct type error_category = [`Branch | `Temporary | `Permanent] include Error_core - module Local_monad = Tezos_error_monad.Monad_maker.Make (TzTrace) - include Local_monad + include Tezos_error_monad.TzLwtreslib.Monad include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) - (Local_monad) + (Tezos_error_monad.TzLwtreslib.Monad) (* Backwards compatibility additions (traversors, dont_wait, trace) *) include Error_monad_traversors diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index 4c4b85176306..04cb5b905c4f 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -565,11 +565,10 @@ struct type error_category = [`Branch | `Temporary | `Permanent] include Error_core - module Local_monad = Tezos_error_monad.Monad_maker.Make (TzTrace) - include Local_monad + include Tezos_error_monad.TzLwtreslib.Monad include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) - (Local_monad) + (Tezos_error_monad.TzLwtreslib.Monad) (* Backwards compatibility additions (traversors, dont_wait, trace helpers) *) include Error_monad_traversors diff --git a/src/lib_protocol_environment/environment_V3.ml b/src/lib_protocol_environment/environment_V3.ml index 6f550ec5c0a2..2c9f9f91e58c 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -629,11 +629,10 @@ struct type error_category = [`Branch | `Temporary | `Permanent] include Error_core - module Local_monad = Tezos_error_monad.Monad_maker.Make (TzTrace) - include Local_monad + include Tezos_error_monad.TzLwtreslib.Monad include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) - (Local_monad) + (Tezos_error_monad.TzLwtreslib.Monad) (* Backwards compatibility additions (dont_wait, trace helpers) *) let dont_wait ex er f = dont_wait f er ex -- GitLab From 1ca498e5bddedf691deee473504a761d8f3414ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 11 Aug 2021 08:59:49 +0100 Subject: [PATCH 2/5] Lwtreslib: add Result and LwtResult to Monad Lwt.return_unit Result.return_unit (previously (Error_monad.)ok_unit) LwtResult.return_unit (previously (Error_monad.)return_unit) Traced versions are also included. --- src/lib_error_monad/monad_ext_maker.ml | 26 ++- src/lib_error_monad/sig.ml | 15 ++ src/lib_lwt_result_stdlib/bare/sigs/monad.ml | 184 +++++++++--------- src/lib_lwt_result_stdlib/bare/sigs/result.ml | 50 +++-- .../bare/structs/hashtbl.ml | 8 +- .../bare/structs/list.ml | 130 +++++++------ .../bare/structs/monad.ml | 83 ++++---- .../bare/structs/result.ml | 18 ++ src/lib_lwt_result_stdlib/bare/structs/seq.ml | 10 +- .../bare/structs/seq_e.ml | 14 +- .../bare/structs/seq_es.ml | 8 +- .../bare/structs/seq_s.ml | 8 +- .../bare/structs/unit.ml | 6 +- .../test/test_fuzzing_helpers.ml | 8 +- .../test/test_fuzzing_seq_tiered.ml | 8 +- .../traced/sigs/monad.ml | 93 ++++++++- .../traced/structs/hashtbl.ml | 6 +- .../traced/structs/monad.ml | 14 +- 18 files changed, 430 insertions(+), 259 deletions(-) diff --git a/src/lib_error_monad/monad_ext_maker.ml b/src/lib_error_monad/monad_ext_maker.ml index dd0294b94a40..f40eea611974 100644 --- a/src/lib_error_monad/monad_ext_maker.ml +++ b/src/lib_error_monad/monad_ext_maker.ml @@ -38,10 +38,18 @@ end) and type 'error trace := 'error Trace.trace = struct open Monad - let fail e = Lwt.return_error (Trace.make e) + (* we default to combined monad everywhere. Note that we include [LwtResult] + rather than [LwtTracedResult] because [return] and [return_*] functions are + more generic. The [fail] function is re-shadowed below for more specific + [fail] default. *) + include LwtResult - let error e = Error (Trace.make e) + (* we default to failing within the traced monad *) + let fail = fail_trace + let error = error_trace + + (* default (traced-everywhere) helper types *) type tztrace = Error.error Trace.trace type 'a tzresult = ('a, tztrace) result @@ -99,17 +107,19 @@ end) mk_err () >>=? fun err -> Lwt.return_error (Trace.cons err trace) | ok -> Lwt.return ok - let error_unless cond exn = if cond then ok_unit else error exn + let error_unless cond exn = if cond then Result.return_unit else error exn - let error_when cond exn = if cond then error exn else ok_unit + let error_when cond exn = if cond then error exn else Result.return_unit - let fail_unless cond exn = if cond then return_unit else fail exn + let fail_unless cond exn = + if cond then LwtTracedResult.return_unit else fail exn - let fail_when cond exn = if cond then fail exn else return_unit + let fail_when cond exn = + if cond then fail exn else LwtTracedResult.return_unit - let unless cond f = if cond then return_unit else f () + let unless cond f = if cond then LwtResult.return_unit else f () - let when_ cond f = if cond then f () else return_unit + let when_ cond f = if cond then f () else LwtResult.return_unit let dont_wait f err_handler exc_handler = Lwt.dont_wait diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index af2c0403d9c8..da9e10e32e00 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -225,6 +225,21 @@ module type MONAD_EXT = sig val classify_errors : tztrace -> error_category + val return : 'a -> ('a, 'e) result Lwt.t + + val return_unit : (unit, 'e) result Lwt.t + + val return_none : ('a option, 'e) result Lwt.t + + val return_some : 'a -> ('a option, 'e) result Lwt.t + + val return_nil : ('a list, 'e) result Lwt.t + + val return_true : (bool, 'e) result Lwt.t + + val return_false : (bool, 'e) result Lwt.t + + (** more defaulting to trace *) val fail : 'error -> ('a, 'error trace) result Lwt.t val error : 'error -> ('a, 'error trace) result diff --git a/src/lib_lwt_result_stdlib/bare/sigs/monad.ml b/src/lib_lwt_result_stdlib/bare/sigs/monad.ml index 41d573bc19cf..99a91d005cc0 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/monad.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/monad.ml @@ -102,147 +102,151 @@ *) module type S = sig - (** lwt monad *) + (** {1 The tower of monads} - 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 + Each monad is given: + - a module that groups returns and binds, + - a set of infix operators. *) - val ( >|=? ) : - ('a, 'trace) result Lwt.t -> ('a -> 'b) -> ('b, 'trace) result Lwt.t + (** {2 The Lwt monad: for concurrency} *) - (** Mixing operators *) + module Lwt : module type of struct + include Lwt + end - (** 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. *) + (** [(>>=)] is the monad-global infix alias for [Lwt.bind]. *) + val ( >>= ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t - val ( >>?= ) : - ('a, 'trace) result -> - ('a -> ('b, 'trace) result Lwt.t) -> - ('b, 'trace) result Lwt.t + (** [(>|=)] is the monad-global infix alias for [Lwt.map]. *) + val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t - val ( >|?= ) : - ('a, 'trace) result -> ('a -> 'b Lwt.t) -> ('b, 'trace) result Lwt.t + (** Note that there is no monad-global alias for [Lwt.return]. *) - (** preallocated in-monad values *) + (** {2 The (generic) Result monad: for success/failure} *) - val unit_s : unit Lwt.t + module Result : Result.S - val unit_e : (unit, 'trace) result + (** [ok] is the monad-global alias for [Result.return]. *) + val ok : 'a -> ('a, 'e) result - val unit_es : (unit, 'trace) result Lwt.t + (** [error] is the monad-global alias for [Result.fail]. *) + val error : 'e -> ('a, 'e) result - val none_s : 'a option Lwt.t + (** [(>>?)] is the monad-global infix alias for [Result.bind]. *) + val ( >>? ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result - val none_e : ('a option, 'trace) result + (** [(>|?)] is the monad-global infix alias for [Result.map]. *) + val ( >|? ) : ('a, 'e) result -> ('a -> 'b) -> ('b, 'e) result - val none_es : ('a option, 'trace) result Lwt.t + (** {2 The combined Lwt+Result monad: for concurrent successes/failures} *) - val some_s : 'a -> 'a option Lwt.t + module LwtResult : sig + val return : 'a -> ('a, 'e) result Lwt.t - val some_e : 'a -> ('a option, 'trace) result + val fail : 'e -> ('a, 'e) result Lwt.t - val some_es : 'a -> ('a option, 'trace) result Lwt.t + val return_unit : (unit, 'e) result Lwt.t - val nil_s : 'a list Lwt.t + val return_none : ('a option, 'e) result Lwt.t - val nil_e : ('a list, 'trace) result + val return_some : 'a -> ('a option, 'e) result Lwt.t - val nil_es : ('a list, 'trace) result Lwt.t + val return_nil : ('a list, 'e) result Lwt.t - val true_s : bool Lwt.t + val return_true : (bool, 'e) result Lwt.t - val true_e : (bool, 'trace) result + val return_false : (bool, 'e) result Lwt.t - val true_es : (bool, 'trace) result Lwt.t + (* Unlike [Lwt], we do not provide [return_ok] and [return_error]. They + would be as follow and it is not clear they would be useful. - val false_s : bool Lwt.t + {[ + val return_ok : 'a -> (('a, 'e) result, 'f) result Lwt.t + val return_error : 'e -> (('a, 'e) result, 'f) result Lwt.t + ]} - val false_e : (bool, 'trace) result + Note the availability of [return] and [fail]. *) - val false_es : (bool, 'trace) result Lwt.t + val bind : + ('a, 'e) result Lwt.t -> + ('a -> ('b, 'e) result Lwt.t) -> + ('b, 'e) result Lwt.t - (** additional preallocated in-monad values + val bind_error : + ('a, 'e) result Lwt.t -> + ('e -> ('a, 'f) result Lwt.t) -> + ('a, 'f) result Lwt.t - this is for backwards compatibility and for similarity with Lwt *) + val map : ('a -> 'b) -> ('a, 'e) result Lwt.t -> ('b, 'e) result Lwt.t - val ok_unit : (unit, 'error) result + val map_error : ('e -> 'f) -> ('a, 'e) result Lwt.t -> ('a, 'f) result Lwt.t + end - val return_unit : (unit, 'error) result Lwt.t + (** [return] is the monad-global alias for [LwtResult.return]. *) + val return : 'a -> ('a, 'e) result Lwt.t - val ok_none : ('a option, 'trace) result + (** [fail] is the monad-global alias for [LwtResult.fail]. *) + val fail : 'e -> ('a, 'e) result Lwt.t - val return_none : ('a option, 'trace) result Lwt.t + (** [(>>=?)] is the monad-global infix alias for [LwtResult.bind]. *) + val ( >>=? ) : + ('a, 'e) result Lwt.t -> + ('a -> ('b, 'e) result Lwt.t) -> + ('b, 'e) result Lwt.t - val ok_some : 'a -> ('a option, 'trace) result + (** [(>|=?)] is the monad-global infix alias for [LwtResult.map]. *) + val ( >|=? ) : ('a, 'e) result Lwt.t -> ('a -> 'b) -> ('b, 'e) result Lwt.t - val return_some : 'a -> ('a option, 'trace) result Lwt.t + (** {1 Mixing operators} - val ok_nil : ('a list, 'trace) result + These are helpers to "go from one monad into another". *) - val return_nil : ('a list, 'trace) result Lwt.t + (** All mixing 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 ok_true : (bool, 'trace) result + val ( >>?= ) : + ('a, 'e) result -> ('a -> ('b, 'e) result Lwt.t) -> ('b, 'e) result Lwt.t - val return_true : (bool, 'trace) result Lwt.t + val ( >|?= ) : ('a, 'e) result -> ('a -> 'b Lwt.t) -> ('b, 'e) result Lwt.t - val ok_false : (bool, 'trace) result + (** Note that more micing operators are possible. However, their use is + discouraged because they tend to degrade readability. *) - val return_false : (bool, 'trace) result Lwt.t + (** {1 Joins} - (** joins *) + These functions handle lists (or tuples) of in-monad value. *) + (** [join_p] is the joining of concurrent unit values (it is [Lwt.join]). *) val join_p : unit Lwt.t list -> unit Lwt.t + (** [all_p] is the joining of concurrent non-unit values (it is [Lwt.all]). *) val all_p : 'a Lwt.t list -> 'a list Lwt.t + (** [both_p] is the joining of two concurrent non-unit values (it is [Lwt.both]). *) val both_p : 'a Lwt.t -> 'b Lwt.t -> ('a * 'b) Lwt.t - val join_e : (unit, 'trace) result list -> (unit, 'trace list) result + (** [join_e] is the joining of success/failure unit values. *) + val join_e : (unit, 'e) result list -> (unit, 'e list) result - val all_e : ('a, 'trace) result list -> ('a list, 'trace list) result + (** [all_e] is the joining of success/failure non-unit values. *) + val all_e : ('a, 'e) result list -> ('a list, 'e list) result - val both_e : - ('a, 'trace) result -> ('b, 'trace) result -> ('a * 'b, 'trace list) result + (** [both_e] is the joining of two success/failure non-unit values. *) + val both_e : ('a, 'e) result -> ('b, 'e) result -> ('a * 'b, 'e list) result - val join_ep : - (unit, 'trace) result Lwt.t list -> (unit, 'trace list) result Lwt.t + (** [join_ep] is the joining of concurrent success/failure unit values. *) + val join_ep : (unit, 'e) result Lwt.t list -> (unit, 'e list) result Lwt.t - val all_ep : - ('a, 'trace) result Lwt.t list -> ('a list, 'trace list) result Lwt.t + (** [all_ep] is the joining of concurrent success/failure non-unit values. *) + val all_ep : ('a, 'e) result Lwt.t list -> ('a list, 'e list) result Lwt.t + (** [both_ep] is the joining of two concurrent success/failure non-unit values. *) val both_ep : - ('a, 'trace) result Lwt.t -> - ('b, 'trace) result Lwt.t -> - ('a * 'b, 'trace list) result Lwt.t + ('a, 'e) result Lwt.t -> + ('b, 'e) result Lwt.t -> + ('a * 'b, 'e list) result Lwt.t end diff --git a/src/lib_lwt_result_stdlib/bare/sigs/result.ml b/src/lib_lwt_result_stdlib/bare/sigs/result.ml index ff7ca007348e..7a63dec31ec1 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/result.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/result.ml @@ -29,9 +29,44 @@ See {!Lwtreslib} and {!Seq} for general description of traversors and the meaning of [_s], [_e], and [_es] suffixes. *) -module type S = sig + +module type MONAD_S = sig type ('a, 'e) t = ('a, 'e) result = Ok of 'a | Error of 'e (***) + val return : 'a -> ('a, 'e) result + + val return_unit : (unit, 'e) result + + val return_none : ('a option, 'e) result + + val return_some : 'a -> ('a option, 'e) result + + val return_nil : ('a list, 'e) result + + val return_true : (bool, 'e) result + + val return_false : (bool, 'e) result + + val fail : 'e -> ('a, 'e) result + + val bind : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result + + val bind_error : ('a, 'e) result -> ('e -> ('a, 'f) result) -> ('a, 'f) result + + val map : ('a -> 'b) -> ('a, 'e) result -> ('b, 'e) result + + val map_error : ('e -> 'f) -> ('a, 'e) result -> ('a, 'f) result +end + +module type S = sig + include MONAD_S + + (* We do not provide all of the [_e] and [_es] functions that you might expect + based on other modules such as [Option]. This is because the returned + values are results within results ([(('a, 'e) result, 'ee) result]) which + are often impractical. It is possible to achieve manually in the rare + occasions where it might be appropriate. *) + val ok : 'a -> ('a, 'e) result val ok_s : 'a -> ('a, 'e) result Lwt.t @@ -44,20 +79,14 @@ module type S = sig val value_f : ('a, 'e) result -> default:(unit -> 'a) -> 'a - val bind : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result - val bind_s : ('a, 'e) result -> ('a -> ('b, 'e) result Lwt.t) -> ('b, 'e) result Lwt.t - val bind_error : ('a, 'e) result -> ('e -> ('a, 'f) result) -> ('a, 'f) result - val bind_error_s : ('a, 'e) result -> ('e -> ('a, 'f) result Lwt.t) -> ('a, 'f) result Lwt.t val join : (('a, 'e) result, 'e) result -> ('a, 'e) result - val map : ('a -> 'b) -> ('a, 'e) result -> ('b, 'e) result - (* NOTE: [map_e] is [bind] *) val map_e : ('a -> ('b, 'e) result) -> ('a, 'e) result -> ('b, 'e) result @@ -67,8 +96,6 @@ module type S = sig val map_es : ('a -> ('b, 'e) result Lwt.t) -> ('a, 'e) result -> ('b, 'e) result Lwt.t - val map_error : ('e -> 'f) -> ('a, 'e) result -> ('a, 'f) result - (* NOTE: [map_error_e] is [bind_error] *) val map_error_e : ('e -> ('a, 'f) result) -> ('a, 'e) result -> ('a, 'f) result @@ -137,10 +164,7 @@ module type S = sig [catch_only] has the same use as with [catch]. The same restriction on catching non-deterministic runtime exceptions applies. *) val catch_f : - ?catch_only:(exn -> bool) -> - (unit -> 'a) -> - (exn -> 'error) -> - ('a, 'error) result + ?catch_only:(exn -> bool) -> (unit -> 'a) -> (exn -> 'e) -> ('a, 'e) result (** [catch_ef f handler] is equivalent to [join @@ map_error (catch f) handler]. In other words, it catches exceptions in [f ()] and either returns the diff --git a/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml b/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml index ca3d41fa6839..a18350dbbdf2 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/hashtbl.ml @@ -166,8 +166,8 @@ struct (fun (k, p) -> Lwt.try_bind (fun () -> p) - (function Error _ -> unit_es | Ok v -> f k v) - (fun _ -> unit_es)) + (function Error _ -> LwtResult.return_unit | Ok v -> f k v) + (fun _ -> LwtResult.return_unit)) (T.to_seq t) let fold_with_waiting_es f t init = @@ -200,8 +200,8 @@ struct let promise = Lwt.try_bind (fun () -> p) - (function Error _ -> Monad.unit_es | Ok v -> f k v) - (fun _ -> Monad.unit_es) + (function Error _ -> LwtResult.return_unit | Ok v -> f k v) + (fun _ -> LwtResult.return_unit) in promise :: acc) t diff --git a/src/lib_lwt_result_stdlib/bare/structs/list.ml b/src/lib_lwt_result_stdlib/bare/structs/list.ml index bcfe03b11939..cf57a0d29896 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/list.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/list.ml @@ -69,7 +69,7 @@ let rec iter2 ~when_different_lengths f xs ys = The same remark applies to the other 2-list iterators. *) match (xs, ys) with - | ([], []) -> Monad.unit_e + | ([], []) -> Result.return_unit | ([], _ :: _) | (_ :: _, []) -> Error when_different_lengths | (x :: xs, y :: ys) -> f x y ; @@ -249,35 +249,35 @@ let init_p ~when_negative_length l f = else aux [] 0 let rec find_e f = function - | [] -> none_e + | [] -> Result.return_none | x :: xs -> ( f x >>? function | true -> Ok (Some x) | false -> (find_e [@ocaml.tailcall]) f xs) let rec find_s f = function - | [] -> none_s + | [] -> 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 - | [] -> none_s + | [] -> 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 - | [] -> none_es + | [] -> LwtResult.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 - | [] -> none_es + | [] -> LwtResult.return_none | x :: xs -> ( Lwt.apply f x >>=? function | true -> Lwt.return (Ok (Some x)) @@ -361,23 +361,23 @@ let rev_filter_es f xs = let filter_es f xs = rev_filter_es f xs >|=? rev let rec iter_e f = function - | [] -> unit_e + | [] -> Result.return_unit | h :: t -> f h >>? fun () -> (iter_e [@ocaml.tailcall]) f t let rec iter_s f = function - | [] -> unit_s + | [] -> Lwt.return_unit | h :: t -> f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t let iter_s f = function - | [] -> unit_s + | [] -> Lwt.return_unit | h :: t -> Lwt.apply f h >>= fun () -> (iter_s [@ocaml.tailcall]) f t let rec iter_es f = function - | [] -> unit_es + | [] -> LwtResult.return_unit | h :: t -> f h >>=? fun () -> (iter_es [@ocaml.tailcall]) f t let iter_es f = function - | [] -> unit_es + | [] -> LwtResult.return_unit | 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) @@ -386,27 +386,27 @@ 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 + | [] -> Result.return_unit | x :: xs -> f i x >>? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs in aux 0 l let iteri_s f l = let rec aux i = function - | [] -> unit_s + | [] -> Lwt.return_unit | x :: xs -> f i x >>= fun () -> (aux [@ocaml.tailcall]) (i + 1) xs in match l with - | [] -> unit_s + | [] -> Lwt.return_unit | x :: xs -> lwt_apply2 f 0 x >>= fun () -> aux 1 xs let iteri_es f l = let rec aux i = function - | [] -> unit_es + | [] -> LwtResult.return_unit | x :: xs -> f i x >>=? fun () -> (aux [@ocaml.tailcall]) (i + 1) xs in match l with - | [] -> unit_es + | [] -> LwtResult.return_unit | x :: xs -> lwt_apply2 f 0 x >>=? fun () -> aux 1 xs let iteri_ep f l = join_ep (mapi (lwt_apply2 f) l) @@ -656,7 +656,7 @@ let map2_es ~when_different_lengths f xs ys = let iter2_e ~when_different_lengths f xs ys = let rec aux xs ys = match (xs, ys) with - | ([], []) -> unit_e + | ([], []) -> Result.return_unit | (x :: xs, y :: ys) -> f x y >>? fun () -> (aux [@ocaml.tailcall]) xs ys | ([], _ :: _) | (_ :: _, []) -> Error when_different_lengths in @@ -677,12 +677,12 @@ let iter2_s ~when_different_lengths f xs ys = let iter2_es ~when_different_lengths f xs ys = let rec aux xs ys = match (xs, ys) with - | ([], []) -> Monad.unit_es + | ([], []) -> LwtResult.return_unit | (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 + | ([], []) -> LwtResult.return_unit | (x :: xs, y :: ys) -> lwt_apply2 f x y >>=? fun () -> aux xs ys | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths @@ -755,74 +755,78 @@ let fold_right2_es ~when_different_lengths f xs ys init = aux xs ys let rec for_all_e f = function - | [] -> true_e + | [] -> Result.return_true | x :: xs -> ( f x >>? function | true -> (for_all_e [@ocaml.tailcall]) f xs - | false -> false_e) + | false -> Result.return_false) let rec for_all_s f = function - | [] -> true_s + | [] -> Lwt.return_true | x :: xs -> ( f x >>= function | true -> (for_all_s [@ocaml.tailcall]) f xs - | false -> false_s) + | false -> Lwt.return_false) let for_all_s f = function - | [] -> true_s + | [] -> Lwt.return_true | x :: xs -> ( Lwt.apply f x >>= function | true -> (for_all_s [@ocaml.tailcall]) f xs - | false -> false_s) + | false -> Lwt.return_false) let rec for_all_es f = function - | [] -> true_es + | [] -> LwtResult.return_true | x :: xs -> ( f x >>=? function | true -> (for_all_es [@ocaml.tailcall]) f xs - | false -> false_es) + | false -> LwtResult.return_false) let for_all_es f = function - | [] -> true_es + | [] -> LwtResult.return_true | x :: xs -> ( Lwt.apply f x >>=? function | true -> (for_all_es [@ocaml.tailcall]) f xs - | false -> false_es) + | false -> LwtResult.return_false) 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 + | [] -> Result.return_false | x :: xs -> ( f x >>? function | false -> (exists_e [@ocaml.tailcall]) f xs - | true -> true_e) + | true -> Result.return_true) let rec exists_s f = function - | [] -> false_s + | [] -> Lwt.return_false | x :: xs -> ( f x >>= function | false -> (exists_s [@ocaml.tailcall]) f xs - | true -> true_s) + | true -> Lwt.return_true) let exists_s f = function - | [] -> false_s + | [] -> Lwt.return_false | x :: xs -> ( - Lwt.apply f x >>= function false -> exists_s f xs | true -> true_s) + Lwt.apply f x >>= function + | false -> exists_s f xs + | true -> Lwt.return_true) let rec exists_es f = function - | [] -> false_es + | [] -> LwtResult.return_false | x :: xs -> ( f x >>=? function | false -> (exists_es [@ocaml.tailcall]) f xs - | true -> true_es) + | true -> LwtResult.return_true) let exists_es f = function - | [] -> false_es + | [] -> LwtResult.return_false | x :: xs -> ( - Lwt.apply f x >>=? function false -> exists_es f xs | true -> true_es) + Lwt.apply f x >>=? function + | false -> exists_es f xs + | true -> LwtResult.return_true) let exists_ep f l = rev_map_ep f l >|=? exists Fun.id @@ -832,11 +836,11 @@ 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 + | ([], []) -> Result.return_true | (x :: xs, y :: ys) -> ( f x y >>? function | true -> (aux [@ocaml.tailcall]) xs ys - | false -> false_e) + | false -> Result.return_false) in aux xs ys @@ -844,43 +848,47 @@ 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 + | ([], []) -> LwtResult.return_true | (x :: xs, y :: ys) -> ( f x y >>= function | true -> (aux [@ocaml.tailcall]) xs ys - | false -> false_es) + | false -> LwtResult.return_false) in match (xs, ys) with | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> true_es + | ([], []) -> LwtResult.return_true | (x :: xs, y :: ys) -> ( - lwt_apply2 f x y >>= function true -> aux xs ys | false -> false_es) + lwt_apply2 f x y >>= function + | true -> aux xs ys + | false -> LwtResult.return_false) 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 + | ([], []) -> LwtResult.return_true | (x :: xs, y :: ys) -> ( f x y >>=? function | true -> (aux [@ocaml.tailcall]) xs ys - | false -> false_es) + | false -> LwtResult.return_false) in match (xs, ys) with | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> true_es + | ([], []) -> LwtResult.return_true | (x :: xs, y :: ys) -> ( - lwt_apply2 f x y >>=? function true -> aux xs ys | false -> false_es) + lwt_apply2 f x y >>=? function + | true -> aux xs ys + | false -> LwtResult.return_false) let exists2_e ~when_different_lengths f xs ys = let rec aux xs ys = match (xs, ys) with | ([], _ :: _) | (_ :: _, []) -> Error when_different_lengths - | ([], []) -> false_e + | ([], []) -> Result.return_false | (x :: xs, y :: ys) -> ( f x y >>? function | false -> (aux [@ocaml.tailcall]) xs ys - | true -> true_e) + | true -> Result.return_true) in aux xs ys @@ -888,33 +896,37 @@ let exists2_s ~when_different_lengths f xs ys = let rec aux xs ys = match (xs, ys) with | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> false_es + | ([], []) -> LwtResult.return_false | (x :: xs, y :: ys) -> ( f x y >>= function | false -> (aux [@ocaml.tailcall]) xs ys - | true -> true_es) + | true -> LwtResult.return_true) in match (xs, ys) with | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> false_es + | ([], []) -> LwtResult.return_false | (x :: xs, y :: ys) -> ( - lwt_apply2 f x y >>= function false -> aux xs ys | true -> true_es) + lwt_apply2 f x y >>= function + | false -> aux xs ys + | true -> LwtResult.return_true) let exists2_es ~when_different_lengths f xs ys = let rec aux xs ys = match (xs, ys) with | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> false_es + | ([], []) -> LwtResult.return_false | (x :: xs, y :: ys) -> ( f x y >>=? function | false -> (aux [@ocaml.tailcall]) xs ys - | true -> true_es) + | true -> LwtResult.return_true) in match (xs, ys) with | ([], _ :: _) | (_ :: _, []) -> fail when_different_lengths - | ([], []) -> false_es + | ([], []) -> LwtResult.return_false | (x :: xs, y :: ys) -> ( - lwt_apply2 f x y >>=? function false -> aux xs ys | true -> true_es) + lwt_apply2 f x y >>=? function + | false -> aux xs ys + | true -> LwtResult.return_true) let rev_partition f xs = let rec aux trues falses = function diff --git a/src/lib_lwt_result_stdlib/bare/structs/monad.ml b/src/lib_lwt_result_stdlib/bare/structs/monad.ml index d8671994748f..989eaa74cf89 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/monad.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/monad.ml @@ -25,12 +25,16 @@ (** Lwt monad *) +module Lwt = Lwt + let ( >>= ) = Lwt.( >>= ) let ( >|= ) = Lwt.( >|= ) (** result monad *) +module Result = Result + let ok x = Ok x let error e = Error e @@ -41,13 +45,42 @@ 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) +module LwtResult = struct + let return x = Lwt.return (Ok x) + + let fail x = Lwt.return (Error x) + + let return_unit = Lwt.return (Ok ()) + + let return_none = Lwt.return (Ok None) + + let return_some x = Lwt.return (Ok (Some x)) + + let return_true = Lwt.return (Ok true) + + let return_false = Lwt.return (Ok false) -let return = ok_s + let return_nil = Lwt.return (Ok []) -let error_s v = Lwt.return (Error v) + let bind v f = v >>= function Error _ as err -> Lwt.return err | Ok v -> f v -let fail = error_s + let bind_error v f = + v >>= function Error e -> f e | Ok _ as ok -> Lwt.return ok + + let map f v = + v >>= function + | Error _ as err -> Lwt.return err + | Ok v -> Lwt.return (Ok (f v)) + + let map_error f v = + v >>= function + | Error e -> Lwt.return (Error (f e)) + | Ok _ as ok -> Lwt.return ok +end + +let return v = Lwt.return (Ok v) + +let fail v = Lwt.return (Error v) let ( >>=? ) v f = v >>= function Error _ as err -> Lwt.return err | Ok v -> f v @@ -70,46 +103,6 @@ let ( >|?= ) v f = | 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 @@ -124,7 +117,7 @@ let rec join_e_errors errors = function | [] -> Error errors let rec join_e = function - | [] -> unit_e + | [] -> Result.return_unit | Ok () :: ts -> join_e ts | Error error :: ts -> join_e_errors [error] ts diff --git a/src/lib_lwt_result_stdlib/bare/structs/result.ml b/src/lib_lwt_result_stdlib/bare/structs/result.ml index ea6cb48d6bb4..d98012e4db65 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/result.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/result.ml @@ -27,6 +27,24 @@ open Lwt.Infix type ('a, 'e) t = ('a, 'e) result = Ok of 'a | Error of 'e +(* Monad returns (positive, negative, and pre-allocated) *) +let return x = Ok x + +let fail x = Error x + +let return_unit = Ok () + +let return_none = Ok None + +let return_some x = Ok (Some x) + +let return_nil = Ok [] + +let return_true = Ok true + +let return_false = Ok false + +(* constructors as functions, including _s variants *) let ok x = Ok x let ok_s x = Lwt.return (Ok x) diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq.ml b/src/lib_lwt_result_stdlib/bare/structs/seq.ml index dfe86fd237b8..143bfea16bc9 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq.ml @@ -62,27 +62,27 @@ let fold_left_es f acc seq = let rec iter_e f seq = match seq () with - | Nil -> unit_e + | Nil -> Result.return_unit | Cons (item, seq) -> f item >>? fun () -> iter_e f seq let rec iter_s f seq = match seq () with - | Nil -> unit_s + | Nil -> Lwt.return_unit | Cons (item, seq) -> f item >>= fun () -> iter_s f seq let iter_s f seq = match seq () with - | Nil -> unit_s + | 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 -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> f item >>=? fun () -> iter_es f seq let iter_es f seq = match seq () with - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> Lwt.apply f item >>=? fun () -> iter_es f seq let iter_ep f seq = diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml index ba08cd3b10bf..bd3ee8b6adec 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_e.ml @@ -90,41 +90,41 @@ let fold_left_es f acc seq = let rec iter f seq = seq () >>? function - | Nil -> unit_e + | Nil -> Result.return_unit | Cons (item, seq) -> f item ; iter f seq let rec iter_e f seq = seq () >>? function - | Nil -> unit_e + | Nil -> Result.return_unit | Cons (item, seq) -> f item >>? fun () -> iter_e f seq let rec iter_s f seq = seq () >>?= function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> f item >>= fun () -> iter_s f seq let iter_s f seq = seq () >>?= function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> Lwt.apply f item >>= fun () -> iter_s f seq let rec iter_es f seq = seq () >>?= function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> f item >>=? fun () -> iter_es f seq let iter_es f seq = seq () >>?= function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> Lwt.apply f item >>=? fun () -> iter_es f seq let iter_p f seq = let rec iter_p acc f seq = match seq () with | Error _ as e -> join_p acc >>= fun () -> Lwt.return e - | Ok Nil -> join_p acc >>= fun () -> Monad.unit_es + | Ok Nil -> join_p acc >>= fun () -> LwtResult.return_unit | Ok (Cons (item, seq)) -> iter_p (Lwt.apply f item :: acc) f seq in iter_p [] f seq diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml b/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml index 02021c34369e..c1160b9bc89a 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_es.ml @@ -103,7 +103,7 @@ let fold_left_es f acc seq = fold_left_es f acc @@ protect seq let rec iter f seq = seq () >>=? function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> f item ; iter f seq @@ -112,21 +112,21 @@ let iter f seq = iter f @@ protect seq let rec iter_e f seq = seq () >>=? function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> f item >>?= fun () -> iter_e f seq let iter_e f seq = iter_e f @@ protect seq let rec iter_s f seq = seq () >>=? function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> f item >>= fun () -> iter_s f seq let iter_s f seq = iter_s f @@ protect seq let rec iter_es f seq = seq () >>=? function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> f item >>=? fun () -> iter_es f seq let iter_es f seq = iter_es f @@ protect seq diff --git a/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml b/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml index a4e6f3b6734f..2f432d73adc6 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/seq_s.ml @@ -81,7 +81,7 @@ let fold_left_es f acc seq = fold_left_es f acc @@ protect seq let rec iter f seq = seq () >>= function - | Nil -> unit_s + | Nil -> Lwt.return_unit | Cons (item, seq) -> f item ; iter f seq @@ -90,21 +90,21 @@ let iter f seq = iter f @@ protect seq let rec iter_e f seq = seq () >>= function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> f item >>?= fun () -> iter_e f seq let iter_e f seq = iter_e f @@ protect seq let rec iter_s f seq = seq () >>= function - | Nil -> unit_s + | Nil -> Lwt.return_unit | Cons (item, seq) -> f item >>= fun () -> iter_s f seq let iter_s f seq = iter_s f @@ protect seq let rec iter_es f seq = seq () >>= function - | Nil -> unit_es + | Nil -> LwtResult.return_unit | Cons (item, seq) -> f item >>=? fun () -> iter_es f seq let iter_es f seq = iter_es f @@ protect seq diff --git a/src/lib_lwt_result_stdlib/bare/structs/unit.ml b/src/lib_lwt_result_stdlib/bare/structs/unit.ml index 2a2e502965e4..b05d36d43b1e 100644 --- a/src/lib_lwt_result_stdlib/bare/structs/unit.ml +++ b/src/lib_lwt_result_stdlib/bare/structs/unit.ml @@ -27,11 +27,11 @@ include Stdlib.Unit let unit = () -let unit_s = Monad.unit_s +let unit_s = Monad.Lwt.return_unit -let unit_e = Monad.unit_e +let unit_e = Monad.Result.return_unit -let unit_es = Monad.unit_es +let unit_es = Monad.LwtResult.return_unit let catch ?(catch_only = fun _ -> true) f = match f () with 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 0cde750f245e..16fc66ef187f 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml @@ -270,11 +270,11 @@ end module IterESOf = struct let fn r fn y = r := fn !r y ; - unit_es + LwtResult.return_unit let monotonous r fn const y = r := !r + fn const y ; - unit_es + LwtResult.return_unit let fn_e r fn y = Lwt.return @@ fn !r y >|=? fun t -> r := t @@ -289,7 +289,7 @@ end module IteriESOf = struct let fn r fn i y = r := fn !r (fn i y) ; - unit_es + LwtResult.return_unit let fn_e r fn i y = Lwt.return @@ fn i y >>=? fun z -> @@ -309,7 +309,7 @@ end module Iter2ESOf = struct let fn r fn x y = r := fn x y ; - unit_es + LwtResult.return_unit let fn_e r fn x y = Lwt.return @@ fn x y >|=? fun t -> r := t diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml index fe5409c0c794..270532296a67 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml @@ -56,9 +56,9 @@ module TieredSeq : TIER with type t = int Seq.t = struct let iter f s = iter f s ; - unit_es + LwtResult.return_unit - let iter_s f s = iter_s f s >>= fun () -> unit_es + let iter_s f s = iter_s f s >>= fun () -> LwtResult.return_unit let iter_e f s = Lwt.return @@ iter_e f s @@ -134,9 +134,9 @@ module TieredSeq_s : TIER with type t = int Seq_s.t = struct open Monad - let iter f s = iter f s >>= fun () -> unit_es + let iter f s = iter f s >>= fun () -> LwtResult.return_unit - let iter_s f s = iter_s f s >>= fun () -> unit_es + let iter_s f s = iter_s f s >>= fun () -> LwtResult.return_unit end module TestedSeq_s = TestIter (TieredSeq_s) diff --git a/src/lib_lwt_result_stdlib/traced/sigs/monad.ml b/src/lib_lwt_result_stdlib/traced/sigs/monad.ml index 9c26902c2253..70987cce1666 100644 --- a/src/lib_lwt_result_stdlib/traced/sigs/monad.ml +++ b/src/lib_lwt_result_stdlib/traced/sigs/monad.ml @@ -33,24 +33,105 @@ - [{join,all,both}_{e,ep}] return ['error trace] rather than ['error list]. *) module type S = sig + (** Most of it is defined in the non-traced monad. The rest is trace-specific, + occasionally shadowing. *) 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. - *) + (** {2 The traced Result monad: for success and traced failure} + + The [TracedResult] module is similar to the [Result] module with the + following differences: + - only the monadic-core is exposed (no [iter], no [is_ok], etc.; you + need to manipulate the values explicitly to achieve that), and + - all the returned [result] carry ['e trace] in their [Error] constructor + (including [fail] which wraps the provided error into a singleton + trace). + *) + module TracedResult : sig + val return : 'a -> ('a, 'error trace) result + + val return_unit : (unit, 'error trace) result + + val return_none : ('a option, 'error trace) result + + val return_some : 'a -> ('a option, 'error trace) result + + val return_nil : ('a list, 'error trace) result + + val return_true : (bool, 'error trace) result + + val return_false : (bool, 'error trace) result + + (** [fail e] is [Error (Trace.make e)] where [Trace] is the + {!Traced_sigs.Trace} module that provides the trace type and functions. *) + val fail : 'error -> ('a, 'error trace) result + + val bind : + ('a, 'error trace) result -> + ('a -> ('b, 'error trace) result) -> + ('b, 'error trace) result + + val map : + ('a -> 'b) -> ('a, 'error trace) result -> ('b, 'error trace) result + + val iter : ('a -> unit) -> ('a, 'error trace) result -> unit + end + + (** [error_trace e] is the monad-global alias for [TracedResult.fail e]. *) val error_trace : 'error -> ('a, 'error trace) result - (** [fail_trace e] is [Lwt.return (Error (Trace.make e))] where [Trace] is the + (** {2 The Lwt traced Result monad: for concurrent successes and traced failures} + + The [LwtTracedResult] module is similar to the [LwtResult] module with the + following difference: + - all the returned [result] carry ['e trace] in their [Error] constructor + (including [fail] which wraps the provided error into a singleton + trace). + *) + module LwtTracedResult : sig + val return : 'a -> ('a, 'error trace) result Lwt.t + + val return_unit : (unit, 'error trace) result Lwt.t + + val return_none : ('a option, 'error trace) result Lwt.t + + val return_some : 'a -> ('a option, 'error trace) result Lwt.t + + val return_nil : ('a list, 'error trace) result Lwt.t + + val return_true : (bool, 'error trace) result Lwt.t + + val return_false : (bool, 'error trace) result Lwt.t + + (** [fail 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 : 'error -> ('a, 'error trace) result Lwt.t + + val bind : + ('a, 'error trace) result Lwt.t -> + ('a -> ('b, 'error trace) result Lwt.t) -> + ('b, 'error trace) result Lwt.t + + val map : + ('a -> 'b) -> + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t + end + + (** [fail_trace e] is the monad-global alias for [LwtTracedResult.fail e]. *) 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. *) + (** {1 Joins} + + Joins are similar to the non-traced monad's functions of the same names. + The difference is that failures that are joined together are grouped in a + traced (using [Trace.conp]/[Trace.conp_list]) rather than returned as a + list. *) 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 diff --git a/src/lib_lwt_result_stdlib/traced/structs/hashtbl.ml b/src/lib_lwt_result_stdlib/traced/structs/hashtbl.ml index c68f651c4e0d..4117776fc2c1 100644 --- a/src/lib_lwt_result_stdlib/traced/structs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/hashtbl.ml @@ -73,8 +73,10 @@ struct let promise = Lwt.try_bind (fun () -> p) - (function Error _ -> Monad.unit_es | Ok v -> f k v) - (fun _ -> Monad.unit_es) + (function + | Error _ -> Monad.LwtTracedResult.return_unit + | Ok v -> f k v) + (fun _ -> Monad.LwtTracedResult.return_unit) in promise :: acc) t diff --git a/src/lib_lwt_result_stdlib/traced/structs/monad.ml b/src/lib_lwt_result_stdlib/traced/structs/monad.ml index 7b9b5a76607e..a397cb6b43e2 100644 --- a/src/lib_lwt_result_stdlib/traced/structs/monad.ml +++ b/src/lib_lwt_result_stdlib/traced/structs/monad.ml @@ -33,13 +33,25 @@ module Make (Trace : Traced_sigs.Trace.S) : let fail_trace e = fail (Trace.make e) + module TracedResult = struct + include Result + + let fail x = error_trace x + end + + module LwtTracedResult = struct + include LwtResult + + let fail x = fail_trace x + end + 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 + | [] -> Result.return_unit | Ok () :: ts -> join_e ts | Error trace :: ts -> join_e_errors trace ts -- GitLab From a641bed75a209dab330b1e36d5f6072a362f1963 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 17 Aug 2021 15:29:57 +0100 Subject: [PATCH 3/5] Proto-env: compatibility layer for legacy preallocated monad values --- .../environment_V1.ml | 1 + .../environment_V2.ml | 1 + .../environment_V3.ml | 3 ++ .../environment_V4.ml | 8 ++-- src/lib_protocol_environment/structs/dune | 3 +- .../structs/v1.dune.inc | 1 + .../v1/error_monad_preallocated_values.ml | 44 +++++++++++++++++++ .../structs/v2.dune.inc | 1 + .../structs/v3.dune.inc | 1 + .../structs/v4.dune.inc | 9 ++++ 10 files changed, 68 insertions(+), 4 deletions(-) create mode 100644 src/lib_protocol_environment/structs/v1/error_monad_preallocated_values.ml create mode 100644 src/lib_protocol_environment/structs/v4.dune.inc diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index 3f72e68f4316..9c45cbdb77db 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -564,6 +564,7 @@ struct (* Backwards compatibility additions (traversors, dont_wait, trace) *) include Error_monad_traversors + include Error_monad_preallocated_values let dont_wait ex er f = dont_wait f er ex diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index 04cb5b905c4f..d473832ad67b 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -572,6 +572,7 @@ struct (* Backwards compatibility additions (traversors, dont_wait, trace helpers) *) include Error_monad_traversors + include Error_monad_preallocated_values let dont_wait ex er f = dont_wait f er ex diff --git a/src/lib_protocol_environment/environment_V3.ml b/src/lib_protocol_environment/environment_V3.ml index 2c9f9f91e58c..79cae9ad656d 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -635,6 +635,9 @@ struct (Tezos_error_monad.TzLwtreslib.Monad) (* Backwards compatibility additions (dont_wait, trace helpers) *) + include + Tezos_protocol_environment_structs.V3.M.Error_monad_preallocated_values + let dont_wait ex er f = dont_wait f er ex let trace_of_error e = TzTrace.make e diff --git a/src/lib_protocol_environment/environment_V4.ml b/src/lib_protocol_environment/environment_V4.ml index 5b75cd7b5252..20ec2075ea00 100644 --- a/src/lib_protocol_environment/environment_V4.ml +++ b/src/lib_protocol_environment/environment_V4.ml @@ -620,13 +620,15 @@ struct type error_category = [`Branch | `Temporary | `Permanent] include Error_core - module Local_monad = Tezos_error_monad.Monad_maker.Make (TzTrace) - include Local_monad + include Tezos_error_monad.TzLwtreslib.Monad include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) - (Local_monad) + (Tezos_error_monad.TzLwtreslib.Monad) (* Backwards compatibility additions (dont_wait, trace helpers) *) + include + Tezos_protocol_environment_structs.V4.M.Error_monad_preallocated_values + let dont_wait ex er f = dont_wait f er ex let trace_of_error e = TzTrace.make e diff --git a/src/lib_protocol_environment/structs/dune b/src/lib_protocol_environment/structs/dune index 989d8bb1d682..3e9bbf805ded 100644 --- a/src/lib_protocol_environment/structs/dune +++ b/src/lib_protocol_environment/structs/dune @@ -2,6 +2,7 @@ (include v1.dune.inc) (include v2.dune.inc) (include v3.dune.inc) +(include v4.dune.inc) (library (name tezos_protocol_environment_structs) @@ -12,4 +13,4 @@ tezos-lwt-result-stdlib data-encoding bls12-381-legacy) - (modules "V0" "V1" "V2" "V3")) + (modules "V0" "V1" "V2" "V3" "V4")) diff --git a/src/lib_protocol_environment/structs/v1.dune.inc b/src/lib_protocol_environment/structs/v1.dune.inc index 1ab1b7deb191..71b6fae81ee3 100644 --- a/src/lib_protocol_environment/structs/v1.dune.inc +++ b/src/lib_protocol_environment/structs/v1.dune.inc @@ -18,6 +18,7 @@ v0/data_encoding.ml v1/option.ml v1/bls12_381.ml + v1/error_monad_preallocated_values.ml ) (action (with-stdout-to %{targets} (chdir %{workspace_root}} diff --git a/src/lib_protocol_environment/structs/v1/error_monad_preallocated_values.ml b/src/lib_protocol_environment/structs/v1/error_monad_preallocated_values.ml new file mode 100644 index 000000000000..f10885fe83a3 --- /dev/null +++ b/src/lib_protocol_environment/structs/v1/error_monad_preallocated_values.ml @@ -0,0 +1,44 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(* In the MR https://gitlab.com/tezos/tezos/-/merge_requests/3346, some of the + pre-allocated values for the error monad are removed. The intent is to avoid + giving two names to the same value where a single one gives more focus and + clarity to the code. + + This module exports the old names (available in some legacy protocol + environments) for backwards compatibility purpose. *) + +let ok_unit = Tezos_lwt_result_stdlib.Lwtreslib.Bare.Monad.Result.return_unit + +let ok_none = Tezos_lwt_result_stdlib.Lwtreslib.Bare.Monad.Result.return_none + +let ok_some = Tezos_lwt_result_stdlib.Lwtreslib.Bare.Monad.Result.return_some + +let ok_nil = Tezos_lwt_result_stdlib.Lwtreslib.Bare.Monad.Result.return_nil + +let ok_true = Tezos_lwt_result_stdlib.Lwtreslib.Bare.Monad.Result.return_true + +let ok_false = Tezos_lwt_result_stdlib.Lwtreslib.Bare.Monad.Result.return_false diff --git a/src/lib_protocol_environment/structs/v2.dune.inc b/src/lib_protocol_environment/structs/v2.dune.inc index 760de7037ea0..92b42fe8749b 100644 --- a/src/lib_protocol_environment/structs/v2.dune.inc +++ b/src/lib_protocol_environment/structs/v2.dune.inc @@ -17,6 +17,7 @@ v0/error_monad_traversors.ml v0/data_encoding.ml v1/bls12_381.ml + v1/error_monad_preallocated_values.ml ) (action (with-stdout-to %{targets} (chdir %{workspace_root}} diff --git a/src/lib_protocol_environment/structs/v3.dune.inc b/src/lib_protocol_environment/structs/v3.dune.inc index 569910b3c0f6..090e4c43aeb9 100644 --- a/src/lib_protocol_environment/structs/v3.dune.inc +++ b/src/lib_protocol_environment/structs/v3.dune.inc @@ -2,6 +2,7 @@ (targets v3.ml) (deps v1/bls12_381.ml + v1/error_monad_preallocated_values.ml ) (action (with-stdout-to %{targets} (chdir %{workspace_root}} diff --git a/src/lib_protocol_environment/structs/v4.dune.inc b/src/lib_protocol_environment/structs/v4.dune.inc new file mode 100644 index 000000000000..4c91550a5de2 --- /dev/null +++ b/src/lib_protocol_environment/structs/v4.dune.inc @@ -0,0 +1,9 @@ +(rule + (targets v4.ml) + (deps + v1/error_monad_preallocated_values.ml + ) + +(action (with-stdout-to %{targets} (chdir %{workspace_root}} + (run %{libexec:tezos-protocol-environment-packer:s_packer} "structs" %{deps}))))) + -- GitLab From 1f7d9f787f25fcaaf16c3eb06e14acf92459e418 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 17 Aug 2021 15:30:28 +0100 Subject: [PATCH 4/5] Everywhere: adapt to new, more consistent preallocated monad values --- src/bin_validation/validator.ml | 2 +- src/lib_shell/prevalidator.ml | 4 +++- src/lib_validation/block_validation.ml | 2 +- src/proto_008_PtEdo2Zk/lib_protocol/test/gas_properties.ml | 6 +++--- src/proto_008_PtEdo2Zk/lib_protocol/test/script_gas.ml | 2 +- src/proto_008_PtEdo2Zk/lib_protocol/test/test_sapling.ml | 2 +- src/proto_009_PsFLoren/lib_client/limit.ml | 6 +++--- .../lib_protocol/test/test_gas_properties.ml | 6 +++--- src/proto_009_PsFLoren/lib_protocol/test/test_sapling.ml | 2 +- src/proto_009_PsFLoren/lib_protocol/test/test_script_gas.ml | 2 +- src/proto_010_PtGRANAD/lib_benchmark/test/test_helpers.ml | 2 +- src/proto_010_PtGRANAD/lib_client/limit.ml | 6 +++--- src/proto_010_PtGRANAD/lib_delegate/client_baking_forge.ml | 2 +- src/proto_010_PtGRANAD/lib_protocol/test/test_sapling.ml | 2 +- .../lib_protocol/test/test_typechecking.ml | 4 ++-- src/proto_alpha/lib_benchmark/test/test_helpers.ml | 2 +- src/proto_alpha/lib_client/limit.ml | 6 +++--- src/proto_alpha/lib_delegate/client_baking_forge.ml | 2 +- src/proto_alpha/lib_protocol/test/test_sapling.ml | 2 +- 19 files changed, 32 insertions(+), 30 deletions(-) diff --git a/src/bin_validation/validator.ml b/src/bin_validation/validator.ml index 55e573733e7e..59a888ed9c0e 100644 --- a/src/bin_validation/validator.ml +++ b/src/bin_validation/validator.ml @@ -113,7 +113,7 @@ let load_protocol proto protocol_root = Events.(emit dynload_protocol proto) >|= fun () -> try Dynlink.loadfile_private cmxs_file ; - ok_unit + Result.return_unit with Dynlink.Error err -> Format.ksprintf (fun msg -> diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index ea27916ce6a6..0334c1a7684b 100644 --- a/src/lib_shell/prevalidator.ml +++ b/src/lib_shell/prevalidator.ml @@ -1192,7 +1192,9 @@ module Make let on_error _w r st errs = Event.(emit request_failed) (r, st, errs) >|= fun () -> - match r with Request.(View (Inject _)) -> ok_unit | _ -> Error errs + match r with + | Request.(View (Inject _)) -> Result.return_unit + | _ -> Error errs let on_completion _w r _ st = match Request.view r with diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index 7577bdf269f5..9cef7c202ae9 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -56,7 +56,7 @@ type result = { } let check_proto_environment_version_increasing block_hash before after = - if Protocol.compare_version before after <= 0 then ok_unit + if Protocol.compare_version before after <= 0 then Result.return_unit else error (invalid_block diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_properties.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_properties.ml index db6851b2b7b7..72a78e550cb3 100644 --- a/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_properties.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/gas_properties.ml @@ -71,7 +71,7 @@ let free_neutral since = Gas.Arith.( Gas.consumed ~since:ctxt ~until:branch1 = Gas.consumed ~since:ctxt ~until:branch2) - then ok_none + then Result.return_none else Ok (Some (cost, Gas.free)) let consume_commutes since = @@ -86,12 +86,12 @@ let consume_commutes since = Gas.Arith.( Gas.consumed ~since:ctxt ~until:branch1 = Gas.consumed ~since:ctxt ~until:branch2) - then ok_none + then Result.return_none else Ok (Some (cost1, cost2)) let rec loop_check check n ctxt = let open Environment.Error_monad in - if n = 0 then ok_none + if n = 0 then Result.return_none else check ctxt >>? function | None -> loop_check check (n - 1) ctxt diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/test/script_gas.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/script_gas.ml index 7cff86178303..19dc398cf6b4 100644 --- a/src/proto_008_PtEdo2Zk/lib_protocol/test/script_gas.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/script_gas.ml @@ -103,7 +103,7 @@ module Tested_terms () = struct (TzTrace.make (Exn (Failure "min costs and full costs have different lengths"))) (fun min full -> - if Z.leq min full then ok_unit + if Z.leq min full then Result.return_unit else generic_error "Script_repr: inconsistent costs %a vs %a@." diff --git a/src/proto_008_PtEdo2Zk/lib_protocol/test/test_sapling.ml b/src/proto_008_PtEdo2Zk/lib_protocol/test/test_sapling.ml index 687e16491bc2..719092386338 100644 --- a/src/proto_008_PtEdo2Zk/lib_protocol/test/test_sapling.ml +++ b/src/proto_008_PtEdo2Zk/lib_protocol/test/test_sapling.ml @@ -758,7 +758,7 @@ module Interpreter_tests = struct true | _ -> false) errs) ; - ok_unit + Result.return_unit (* In this test we do two transactions in one block and same two in two block. We check that the sate is the same expect for roots. diff --git a/src/proto_009_PsFLoren/lib_client/limit.ml b/src/proto_009_PsFLoren/lib_client/limit.ml index ea2709ecbb94..ea1f4e0db243 100644 --- a/src/proto_009_PsFLoren/lib_client/limit.ml +++ b/src/proto_009_PsFLoren/lib_client/limit.ml @@ -35,10 +35,10 @@ let is_unknown = Option.is_none let join (type a) ~where eq (l1 : a t) (l2 : a t) = match (l1, l2) with - | (None, None) -> ok_none - | (Some x, None) | (None, Some x) -> ok (Some x) + | (None, None) -> Result.return_none + | (Some x, None) | (None, Some x) -> Result.return_some x | (Some x, Some y) -> - if eq x y then ok (Some x) + if eq x y then Result.return_some x else generic_error "Limit.join: error (%s)" where let%test "join" = diff --git a/src/proto_009_PsFLoren/lib_protocol/test/test_gas_properties.ml b/src/proto_009_PsFLoren/lib_protocol/test/test_gas_properties.ml index ac250a427400..8fa77cac3e31 100644 --- a/src/proto_009_PsFLoren/lib_protocol/test/test_gas_properties.ml +++ b/src/proto_009_PsFLoren/lib_protocol/test/test_gas_properties.ml @@ -80,7 +80,7 @@ let test_free_neutral since = Gas.Arith.( Gas.consumed ~since:ctxt ~until:branch1 = Gas.consumed ~since:ctxt ~until:branch2) - then ok_none + then Result.return_none else Ok (Some (cost, Gas.free)) (** Consuming [cost1] then [cost2] is equivalent to consuming @@ -97,12 +97,12 @@ let test_consume_commutes since = Gas.Arith.( Gas.consumed ~since:ctxt ~until:branch1 = Gas.consumed ~since:ctxt ~until:branch2) - then ok_none + then Result.return_none else Ok (Some (cost1, cost2)) let rec loop_check check n ctxt = let open Environment.Error_monad in - if n = 0 then ok_none + if n = 0 then Result.return_none else check ctxt >>? function | None -> loop_check check (n - 1) ctxt diff --git a/src/proto_009_PsFLoren/lib_protocol/test/test_sapling.ml b/src/proto_009_PsFLoren/lib_protocol/test/test_sapling.ml index 47aadb74cdb0..e24b255c7a2d 100644 --- a/src/proto_009_PsFLoren/lib_protocol/test/test_sapling.ml +++ b/src/proto_009_PsFLoren/lib_protocol/test/test_sapling.ml @@ -801,7 +801,7 @@ module Interpreter_tests = struct true | _ -> false) errs) ; - ok_unit + Result.return_unit (* In this test we do two transactions in one block and same two in two block. We check that the sate is the same expect for roots. diff --git a/src/proto_009_PsFLoren/lib_protocol/test/test_script_gas.ml b/src/proto_009_PsFLoren/lib_protocol/test/test_script_gas.ml index de62253a56fc..abf88d88af45 100644 --- a/src/proto_009_PsFLoren/lib_protocol/test/test_script_gas.ml +++ b/src/proto_009_PsFLoren/lib_protocol/test/test_script_gas.ml @@ -108,7 +108,7 @@ module Tested_terms () = struct ~when_different_lengths: (TzTrace.make @@ Exn (Failure "differently sized cost lists")) (fun smin full -> - if S.(smin <= full) then ok_unit + if S.(smin <= full) then Result.return_unit else generic_error "Script_repr: inconsistent costs %a vs %a@." diff --git a/src/proto_010_PtGRANAD/lib_benchmark/test/test_helpers.ml b/src/proto_010_PtGRANAD/lib_benchmark/test/test_helpers.ml index b601e4418e2e..5aa1428c2bea 100644 --- a/src/proto_010_PtGRANAD/lib_benchmark/test/test_helpers.ml +++ b/src/proto_010_PtGRANAD/lib_benchmark/test/test_helpers.ml @@ -109,7 +109,7 @@ let typecheck_by_tezos = Tezos_crypto.Operation_hash.zero in fun bef node -> - Result.get_ok + Stdlib.Result.get_ok (Lwt_main.run ( context_init_memory ~rng_state >>=? fun ctxt -> let stack = stack_type_to_michelson_type_list bef in diff --git a/src/proto_010_PtGRANAD/lib_client/limit.ml b/src/proto_010_PtGRANAD/lib_client/limit.ml index ea2709ecbb94..ea1f4e0db243 100644 --- a/src/proto_010_PtGRANAD/lib_client/limit.ml +++ b/src/proto_010_PtGRANAD/lib_client/limit.ml @@ -35,10 +35,10 @@ let is_unknown = Option.is_none let join (type a) ~where eq (l1 : a t) (l2 : a t) = match (l1, l2) with - | (None, None) -> ok_none - | (Some x, None) | (None, Some x) -> ok (Some x) + | (None, None) -> Result.return_none + | (Some x, None) | (None, Some x) -> Result.return_some x | (Some x, Some y) -> - if eq x y then ok (Some x) + if eq x y then Result.return_some x else generic_error "Limit.join: error (%s)" where let%test "join" = diff --git a/src/proto_010_PtGRANAD/lib_delegate/client_baking_forge.ml b/src/proto_010_PtGRANAD/lib_delegate/client_baking_forge.ml index 3ab6e26749ea..a9d26c057f37 100644 --- a/src/proto_010_PtGRANAD/lib_delegate/client_baking_forge.ml +++ b/src/proto_010_PtGRANAD/lib_delegate/client_baking_forge.ml @@ -1367,7 +1367,7 @@ let traced_option_to_result ~error = Option.fold ~some:ok ~none:(Error_monad.error error) let check_file_exists file = - if Sys.file_exists file then ok_unit + if Sys.file_exists file then Result.return_unit else error (Block_vote_file_not_found file) let read_liquidity_baking_escape_vote ~per_block_vote_file = diff --git a/src/proto_010_PtGRANAD/lib_protocol/test/test_sapling.ml b/src/proto_010_PtGRANAD/lib_protocol/test/test_sapling.ml index 642251349050..9800f1db8bf6 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/test/test_sapling.ml +++ b/src/proto_010_PtGRANAD/lib_protocol/test/test_sapling.ml @@ -801,7 +801,7 @@ module Interpreter_tests = struct true | _ -> false) errs) ; - ok_unit + Result.return_unit (* In this test we do two transactions in one block and same two in two block. We check that the sate is the same expect for roots. diff --git a/src/proto_010_PtGRANAD/lib_protocol/test/test_typechecking.ml b/src/proto_010_PtGRANAD/lib_protocol/test/test_typechecking.ml index 9c779dcbc250..445423b7dbed 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/test/test_typechecking.ml +++ b/src/proto_010_PtGRANAD/lib_protocol/test/test_typechecking.ml @@ -474,7 +474,7 @@ let test_parse_data ?(equal = Stdlib.( = )) loc ctxt ty node expected = wrap_error_lwt ( Script_ir_translator.parse_data ctxt ~legacy ~allow_forged ty node >>=? fun (actual, ctxt) -> - if equal actual expected then return ctxt + if equal actual expected then Environment.Error_monad.return ctxt else Alcotest.failf "Unexpected error: %s" loc ) let test_parse_data_fails loc ctxt ty node = @@ -495,7 +495,7 @@ let test_parse_data_fails loc ctxt ty node = if Astring.String.is_infix ~affix:expect_id trace_string && Astring.String.is_infix ~affix:expect_descrfiption trace_string - then return_unit + then Environment.Error_monad.return_unit else Alcotest.failf "Unexpected error (%s) at %s" diff --git a/src/proto_alpha/lib_benchmark/test/test_helpers.ml b/src/proto_alpha/lib_benchmark/test/test_helpers.ml index c45f148f095b..61e7d1b0c4c6 100644 --- a/src/proto_alpha/lib_benchmark/test/test_helpers.ml +++ b/src/proto_alpha/lib_benchmark/test/test_helpers.ml @@ -106,7 +106,7 @@ let typecheck_by_tezos = Tezos_crypto.Operation_hash.zero in fun bef node -> - Result.get_ok + Stdlib.Result.get_ok (Lwt_main.run ( context_init_memory ~rng_state >>=? fun ctxt -> let stack = stack_type_to_michelson_type_list bef in diff --git a/src/proto_alpha/lib_client/limit.ml b/src/proto_alpha/lib_client/limit.ml index ea2709ecbb94..ea1f4e0db243 100644 --- a/src/proto_alpha/lib_client/limit.ml +++ b/src/proto_alpha/lib_client/limit.ml @@ -35,10 +35,10 @@ let is_unknown = Option.is_none let join (type a) ~where eq (l1 : a t) (l2 : a t) = match (l1, l2) with - | (None, None) -> ok_none - | (Some x, None) | (None, Some x) -> ok (Some x) + | (None, None) -> Result.return_none + | (Some x, None) | (None, Some x) -> Result.return_some x | (Some x, Some y) -> - if eq x y then ok (Some x) + if eq x y then Result.return_some x else generic_error "Limit.join: error (%s)" where let%test "join" = diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index 547e22222e12..4d5a9d1f808d 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -1363,7 +1363,7 @@ let traced_option_to_result ~error = Option.fold ~some:ok ~none:(Error_monad.error error) let check_file_exists file = - if Sys.file_exists file then ok_unit + if Sys.file_exists file then Result.return_unit else error (Block_vote_file_not_found file) let read_liquidity_baking_escape_vote ~per_block_vote_file = diff --git a/src/proto_alpha/lib_protocol/test/test_sapling.ml b/src/proto_alpha/lib_protocol/test/test_sapling.ml index c71ee6990299..24e7cebe00fa 100644 --- a/src/proto_alpha/lib_protocol/test/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/test_sapling.ml @@ -804,7 +804,7 @@ module Interpreter_tests = struct true | _ -> false) errs) ; - ok_unit + Result.return_unit (* In this test we do two transactions in one block and same two in two block. We check that the sate is the same expect for roots. -- GitLab From 8bc9e8bbad45a947ab3d74bb370da5972ed06540 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 17 Aug 2021 17:43:44 +0100 Subject: [PATCH 5/5] Error-monad: more and better documentation --- src/lib_error_monad/TzMonad.ml | 5 +-- src/lib_error_monad/TzMonad.mli | 4 +- src/lib_error_monad/error_monad.mli | 60 ++++++++++++++++++++++++++--- src/lib_error_monad/sig.ml | 17 +++++--- 4 files changed, 72 insertions(+), 14 deletions(-) diff --git a/src/lib_error_monad/TzMonad.ml b/src/lib_error_monad/TzMonad.ml index 43d85db97326..4241f5c07f5e 100644 --- a/src/lib_error_monad/TzMonad.ml +++ b/src/lib_error_monad/TzMonad.ml @@ -26,6 +26,5 @@ type error = TzCore.error = .. -module Monad = TzLwtreslib.Monad -include Monad -include Monad_ext_maker.Make (TzCore) (TzTrace) (Monad) +include TzLwtreslib.Monad +include Monad_ext_maker.Make (TzCore) (TzTrace) (TzLwtreslib.Monad) diff --git a/src/lib_error_monad/TzMonad.mli b/src/lib_error_monad/TzMonad.mli index 372605801363..c49b426d7d14 100644 --- a/src/lib_error_monad/TzMonad.mli +++ b/src/lib_error_monad/TzMonad.mli @@ -26,7 +26,9 @@ type error = TzCore.error = .. -include module type of TzLwtreslib.Monad +include + Tezos_lwt_result_stdlib.Lwtreslib.TRACED_MONAD + with type 'error trace := 'error TzTrace.trace include Sig.MONAD_EXT diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index 2159e4d972e0..faeedecb6733 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -26,12 +26,18 @@ (** Tezos Protocol Implementation - Error Monad *) -(** Categories of error *) +(** {1 Categories of error} + + Note: this is only meaningful within the protocol. It may be removed from + the error monad and pushed to the protocol environment in the future. + See https://gitlab.com/tezos/tezos/-/issues/1576 *) type error_category = [ `Branch (** Errors that may not happen in another context *) | `Temporary (** Errors that may not happen in a later context *) | `Permanent (** Errors that will happen no matter the context *) ] +(** {1 Assembling the different components of the error monad.} *) + type error = TzCore.error = .. include Sig.CORE with type error := error @@ -44,19 +50,48 @@ module TzTrace : Sig.TRACE with type 'error trace = 'error list type 'error trace = 'error TzTrace.trace -include module type of TzLwtreslib.Monad with type 'error trace := 'error trace +include + Tezos_lwt_result_stdlib.Lwtreslib.TRACED_MONAD + with type 'error trace := 'error TzTrace.trace include Sig.MONAD_EXT with type error := error and type 'error trace := 'error TzTrace.trace -(** Erroneous result (shortcut for generic errors) *) +(** {1 Exception-Error bridge} *) + +(** [generic_error] is for generic failure within the [Result] monad. You + should use this function rarely: only when there isn't a more specific + error. + + The traced error carried in the returned value is unspecified. It is not + meant to be recovered from. The error message includes the one passed as + argument. Tracking the origin of these errors is generally more difficult + than tracking a more specialised error. + + Note: this is somewhat equivalent to [Stdlib.failwith] in that it is a + generic failure mechanism with a simple error message that should be + replaced by a specific exception in most cases. *) val generic_error : ('a, Format.formatter, unit, 'b tzresult) format4 -> 'a -(** Erroneous return (shortcut for generic errors) *) +(** [failwith] is like {!generic_error} but for the LwtResult-monad. The same + usage notes apply. *) val failwith : ('a, Format.formatter, unit, 'b tzresult Lwt.t) format4 -> 'a +(** [error_exn exc] wraps the exception [exc] within an (unspecified) error + within a trace within a result. It is meant as a way to switch from + exception-based error management to tzresult-based error management, e.g., + when calling external libraries that use exceptions. + +{[ + try Ok (parse_input s) with Lex_error | Parse_error as exc -> error_exn exc +]} + + [error_exn] is named after {!error} which is the function that fails within + the TracedResult monad. If you need a lower-level function that constructs + the error trace but doesn't wrap it in a [result], you can use + {!error_of_exn}. *) val error_exn : exn -> 'a tzresult (** [error_of_exn e] is a trace that carries the exception [e]. This function is @@ -69,7 +104,11 @@ try with | (Not_found | Failure _) as e -> Error (error_of_exn e) -]} *) +]} + + [error_of_exn] converts (by wrapping) an exception into a traced error. If + you intend to place this value in an [Error] construct, you can use + {!error_exn} instead. *) val error_of_exn : exn -> error trace (** [tzresult_of_exn_result r] wraps the payload construction of the [Error] @@ -82,10 +121,19 @@ Lwt_result.catch p >|= tzresult_of_exn_result ]} *) val tzresult_of_exn_result : ('a, exn) result -> 'a tzresult +(** {2 Exception traces} + + The following functions allow you to enrich existing traces with wrapped + exceptions. *) + +(** [record_trace_exn exc r] is [record_trace (error_of_exn exc) r] *) val record_trace_exn : exn -> 'a tzresult -> 'a tzresult +(** [trace_exn exc r] is [trace (error_of_exn exc) r] *) val trace_exn : exn -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t +(** [generic_trace … r] is [r] where the trace (if any) is enriched with + [generic_error …]. *) val generic_trace : ( 'a, Format.formatter, @@ -96,6 +144,8 @@ val generic_trace : val pp_exn : Format.formatter -> exn -> unit +(** [failure …] is like [generic_error …] but the error isn't wrapped in a trace + in a result. *) val failure : ('a, Format.formatter, unit, error) format4 -> 'a (** Wrapped OCaml/Lwt exception *) diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index da9e10e32e00..da61e352a4e7 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -57,6 +57,9 @@ module type CORE = sig val pp : Format.formatter -> error -> unit end +(** [EXT] is the extensions on top of a [CORE]. The separation is largely + artificial and will most likely disappear with the next round of + refactoring. See https://gitlab.com/tezos/tezos/-/issues/1579 *) module type EXT = sig type error = .. @@ -185,14 +188,15 @@ module type WITH_WRAPPED = sig end module type TRACE = sig - (** [trace] is abstract in this interface but it is made concrete in the - instantiated error monad (see [error_monad.mli]). + (** The [trace] type (included as part of the + [Tezos_lwt_result_stdlib.Lwtreslib.TRACE] module is abstract in this + interface but it is made concrete in the instantiated error monad (see + [error_monad.mli]). The idea of abstracting the trace is so that it can evolve more easily. Eventually, we can make the trace abstract in the instantiated error monad, we can have different notions of traces for the protocol and the shell, etc. *) - include Tezos_lwt_result_stdlib.Lwtreslib.TRACE (** [pp_print] pretty-prints a trace of errors *) @@ -212,6 +216,11 @@ module type TRACE = sig val fold : ('a -> 'error -> 'a) -> 'a -> 'error trace -> 'a end +(** [MONAD_EXT] is the Tezos-specific extension to the generic monad provided by + Lwtreslib. It sets some defaults (e.g., it defaults traced failures), it + brings some qualified identifiers into the main unqualified part (e.g., + [return_unit]), it provides some tracing helpers and some in-monad assertion + checks. *) module type MONAD_EXT = sig (** for substitution *) type error @@ -244,8 +253,6 @@ module type MONAD_EXT = sig val error : 'error -> ('a, 'error trace) result - (* This is for legacy, for backwards compatibility, there are old names *) - (* NOTE: Right now we leave this [pp_print_error] named as is. Later on we might rename it to [pp_print_trace]. *) val pp_print_error : Format.formatter -> error trace -> unit -- GitLab