diff --git a/src/bin_validation/validator.ml b/src/bin_validation/validator.ml index 55e573733e7e278d32edfb63df8ac4318eb596f1..59a888ed9c0e279cdeb987a6e5b8c5d5fe0f8ea4 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_error_monad/TzMonad.ml b/src/lib_error_monad/TzMonad.ml index f4fac0da176fbca1fd1e8da21f6c8c8efbf32e39..4241f5c07f5edba9b6d51e641424759878253096 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 = Monad_maker.Make (TzTrace) -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 27e12eb34cdb2ce110a9b7b54d944a7843d475a7..c49b426d7d1492c92b6919f08ff11ae9ef6508c7 100644 --- a/src/lib_error_monad/TzMonad.mli +++ b/src/lib_error_monad/TzMonad.mli @@ -26,7 +26,9 @@ type error = TzCore.error = .. -include Sig.MONAD with type 'error trace := 'error TzTrace.trace +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 e647d6f6c06e833e1e496743f8a50fbd74152470..faeedecb67332c00088317f15f407dec1b7f0362 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 Sig.MONAD with type 'error trace := 'error TzTrace.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/monad_ext_maker.ml b/src/lib_error_monad/monad_ext_maker.ml index 0c1d81fef1703f617e4b9854ba4c98cabfd37fc7..f40eea611974e74d3d3c910d95878b8411daaa86 100644 --- a/src/lib_error_monad/monad_ext_maker.ml +++ b/src/lib_error_monad/monad_ext_maker.ml @@ -31,10 +31,25 @@ 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 + + (* 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 + + (* 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 @@ -71,4 +86,48 @@ 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 Result.return_unit else error exn + + let error_when cond exn = if cond then error exn else Result.return_unit + + 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 LwtTracedResult.return_unit + + let unless cond f = if cond then LwtResult.return_unit else f () + + let when_ cond f = if cond then f () else LwtResult.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 a50448478c282880a361f52814ec15103ebad440..4f367c8321ad58641d3023c2a3c046dd5d2fe38a 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 8719a323137949cd9855d264cb9675906a7c2ec4..0000000000000000000000000000000000000000 --- 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/sig.ml b/src/lib_error_monad/sig.ml index 95a3f453d48b111d9edabeca610a9743ffcb0a2f..da61e352a4e73c6719aa6c2e275a29a1b77d3677 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,95 +188,16 @@ 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. *) - 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 +216,54 @@ 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 +(** [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 - (** Successful return of [None] *) - val return_none : ('a option, 'trace) result Lwt.t + (** for substitution *) + type 'error trace - (** [return_some x] is a successful return of [Some x] *) - val return_some : 'a -> ('a option, 'trace) result Lwt.t + type tztrace = error trace - (** Successful return of [[]] *) - val return_nil : ('a list, 'trace) result Lwt.t + type 'a tzresult = ('a, tztrace) result - (** Successful return of [true] *) - val return_true : (bool, 'trace) result Lwt.t + val classify_errors : tztrace -> error_category - (** Successful return of [false] *) - val return_false : (bool, 'trace) result Lwt.t + val return : 'a -> ('a, 'e) result Lwt.t - (** Erroneous result *) - val error : 'err -> ('a, 'err trace) result + val return_unit : (unit, 'e) result Lwt.t - (** Erroneous return *) - val fail : 'err -> ('a, 'err trace) result Lwt.t + val return_none : ('a option, 'e) result Lwt.t - (** 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. - *) + val return_some : 'a -> ('a option, 'e) result Lwt.t - (** 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 + val return_nil : ('a list, 'e) result Lwt.t - (** Lwt's map reexported. The [|] indicates a map rather than a bind. *) - val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t + val return_true : (bool, 'e) result Lwt.t - (** 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 return_false : (bool, 'e) result Lwt.t - (** Non-Lwt map operator. *) - val ( >|? ) : ('a, 'trace) result -> ('a -> 'b) -> ('b, 'trace) result + (** more defaulting to trace *) + val fail : 'error -> ('a, 'error trace) result Lwt.t - (** 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 + val error : 'error -> ('a, 'error trace) result - (** 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 +306,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 81df6077f1ebf169b9a3268c7350fe04a402be90..99a91d005cc057c9976a7a8358fcb5a24f17bfa1 100644 --- a/src/lib_lwt_result_stdlib/bare/sigs/monad.ml +++ b/src/lib_lwt_result_stdlib/bare/sigs/monad.ml @@ -102,127 +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 + Each monad is given: + - a module that groups returns and binds, + - a set of infix operators. *) - (** result monad *) + (** {2 The Lwt monad: for concurrency} *) - val ok : 'a -> ('a, 'trace) result + module Lwt : module type of struct + include Lwt + end - val error : 'error -> ('a, 'error) result - - val ( >>? ) : - ('a, 'trace) result -> ('a -> ('b, 'trace) result) -> ('b, 'trace) result + (** [(>>=)] 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) -> ('b, 'trace) result + (** [(>|=)] is the monad-global infix alias for [Lwt.map]. *) + val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t - (** lwt-result combined monad *) + (** Note that there is no monad-global alias for [Lwt.return]. *) - val ok_s : 'a -> ('a, 'trace) result Lwt.t + (** {2 The (generic) Result monad: for success/failure} *) - val return : 'a -> ('a, 'trace) result Lwt.t + module Result : Result.S - val error_s : 'error -> ('a, 'error) result Lwt.t + (** [ok] is the monad-global alias for [Result.return]. *) + val ok : 'a -> ('a, 'e) result - val fail : 'error -> ('a, 'error) result Lwt.t + (** [error] is the monad-global alias for [Result.fail]. *) + val error : 'e -> ('a, 'e) result - val ( >>=? ) : - ('a, 'trace) result Lwt.t -> - ('a -> ('b, 'trace) result Lwt.t) -> - ('b, 'trace) result Lwt.t + (** [(>>?)] is the monad-global infix alias for [Result.bind]. *) + val ( >>? ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result - val ( >|=? ) : - ('a, 'trace) result Lwt.t -> ('a -> 'b) -> ('b, 'trace) result Lwt.t + (** [(>|?)] is the monad-global infix alias for [Result.map]. *) + val ( >|? ) : ('a, 'e) result -> ('a -> 'b) -> ('b, 'e) result - (** Mixing operators *) + (** {2 The combined Lwt+Result monad: for concurrent successes/failures} *) - (** 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. *) + module LwtResult : sig + val return : 'a -> ('a, 'e) result Lwt.t - val ( >>?= ) : - ('a, 'trace) result -> - ('a -> ('b, 'trace) result Lwt.t) -> - ('b, 'trace) result Lwt.t + val fail : 'e -> ('a, 'e) result Lwt.t - val ( >|?= ) : - ('a, 'trace) result -> ('a -> 'b Lwt.t) -> ('b, 'trace) result Lwt.t + val return_unit : (unit, 'e) result Lwt.t - (** preallocated in-monad values *) + val return_none : ('a option, 'e) result Lwt.t - val unit_s : unit Lwt.t + val return_some : 'a -> ('a option, 'e) result Lwt.t - val unit_e : (unit, 'trace) result + val return_nil : ('a list, 'e) result Lwt.t - val unit_es : (unit, 'trace) result Lwt.t + val return_true : (bool, 'e) result Lwt.t - val none_s : 'a option Lwt.t + val return_false : (bool, 'e) result Lwt.t - val none_e : ('a option, 'trace) result + (* 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 none_es : ('a option, 'trace) result 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 some_s : 'a -> 'a option Lwt.t + Note the availability of [return] and [fail]. *) - val some_e : 'a -> ('a option, 'trace) result + val bind : + ('a, 'e) result Lwt.t -> + ('a -> ('b, 'e) result Lwt.t) -> + ('b, 'e) result Lwt.t - val some_es : 'a -> ('a option, 'trace) result Lwt.t + val bind_error : + ('a, 'e) result Lwt.t -> + ('e -> ('a, 'f) result Lwt.t) -> + ('a, 'f) result Lwt.t - val nil_s : 'a list Lwt.t + val map : ('a -> 'b) -> ('a, 'e) result Lwt.t -> ('b, 'e) result Lwt.t - val nil_e : ('a list, 'trace) result + val map_error : ('e -> 'f) -> ('a, 'e) result Lwt.t -> ('a, 'f) result Lwt.t + end - val nil_es : ('a list, 'trace) result Lwt.t + (** [return] is the monad-global alias for [LwtResult.return]. *) + val return : 'a -> ('a, 'e) result Lwt.t - val true_s : bool Lwt.t + (** [fail] is the monad-global alias for [LwtResult.fail]. *) + val fail : 'e -> ('a, 'e) result Lwt.t - val true_e : (bool, 'trace) result + (** [(>>=?)] 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 true_es : (bool, 'trace) result Lwt.t + (** [(>|=?)] is the monad-global infix alias for [LwtResult.map]. *) + val ( >|=? ) : ('a, 'e) result Lwt.t -> ('a -> 'b) -> ('b, 'e) result Lwt.t - val false_s : bool Lwt.t + (** {1 Mixing operators} - val false_e : (bool, 'trace) result + These are helpers to "go from one monad into another". *) - val false_es : (bool, '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. *) - (** additional preallocated in-monad values + val ( >>?= ) : + ('a, 'e) result -> ('a -> ('b, 'e) result Lwt.t) -> ('b, 'e) result Lwt.t - this is for backwards compatibility and for similarity with Lwt *) + val ( >|?= ) : ('a, 'e) result -> ('a -> 'b Lwt.t) -> ('b, 'e) result Lwt.t - val ok_unit : (unit, 'error) result + (** Note that more micing operators are possible. However, their use is + discouraged because they tend to degrade readability. *) - val return_unit : (unit, 'error) 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 ff7ca007348e64a9c807bdecc04de9e9fc8adf7b..7a63dec31ec1d28e3e18f016fb3bd3a34a7406d9 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 ca3d41fa683997291d0d3d28421cf9b1dbdeb82f..a18350dbbdf20b429c5b8f290b8adb57b92d12af 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 bcfe03b1193957a1769ff62ef7e982928477e213..cf57a0d29896faf592db866680ea42f272ef6e5b 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 d8671994748fd2d44e1c7b4deebd2dba3e575886..989eaa74cf89ea69f87bdf2dd75651cbba8868ce 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 ea6cb48d6bb47a028c37cf2307b3140a864ed774..d98012e4db656392333109cf639159264736b307 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 dfe86fd237b8bc7e9be894b1be6b7b4b48d4065c..143bfea16bc96819321ebbd3e9ccb4b80f8eeb7d 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 ba08cd3b10bf2dc8ba09dc67c7905ef825c322cd..bd3ee8b6adecfcd880ef9b61ed0aaba4b8cb21dc 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 02021c34369ee4beaab0fd5da91a9e8e46361bac..c1160b9bc89a9dc4f9adb9a5d6d959970c7a777e 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 a4e6f3b6734fa4f2e7135e21922a78fa21571348..2f432d73adc69a98cf004d70c7537a61879dde04 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 2a2e502965e498767391ec9ae4d2f5a1b958d492..b05d36d43b1ef0b5a0d90bc3fe6644bf43a75b0c 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/lwtreslib.ml b/src/lib_lwt_result_stdlib/lwtreslib.ml index a9731bb7ad050a2bd3398bd052e846ef89f177a4..3602148dece6085fe10f7038901b3258cc89d80c 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 b246ef64df3af983df80abbec0ce86579f34edbb..426114cd20fee2a626194115a44f48a9d62e3c52 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_lwt_result_stdlib/test/test_fuzzing_helpers.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml index 0cde750f245eb4243ba5ea398bb10cbafaada3f9..16fc66ef187fcb1f2e4b9fa78aef49d082385cd8 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 fe5409c0c794b58bd172314d39777cbf99c15c86..270532296a67bf5e2fbd09ec5384aec7d09b6926 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 9c26902c2253557d7f74b63fd85fb2b88d7f113e..70987cce16665b0667d697895f79646d7e273605 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 c68f651c4e0d1e06b29679f7c2e44a03be30e1e4..4117776fc2c1c3c18b95105a6d4f27858164cb22 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 7b9b5a76607e097480b85521868d53e5e6a0a299..a397cb6b43e2cafc233cd80d19d192727f463592 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 diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 32127861f873c37aeec1e3aee86852013ee0d1f0..60bed4423d6793915a0667e180c841a383a91a6f 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 a3132421215427a70e3203435603996023048eff..9c45cbdb77db5396419494004effd99d2408a424 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -557,14 +557,14 @@ 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 + 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 4c4b85176306849510d9c648c848393781cfebce..d473832ad67be868c19bcc0698f7fe7d04145f10 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -565,14 +565,14 @@ 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 + 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 6f550ec5c0a20d790bca887ae14827a9d84e9229..79cae9ad656de277b19511ede07a0686eff7afd3 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -629,13 +629,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.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 5b75cd7b5252266a0c12d338a2f83b2c864b9bf2..20ec2075ea0059d8fda52a753d4874def20d06e3 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 989d8bb1d6825728fb227d4f43529dfeaef5cd44..3e9bbf805dedd195c7e1cd5aa8b2fc8e1dac4cce 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 1ab1b7deb1919ac2546f95f5125cf45c548644f6..71b6fae81ee30f079ebdd69173fa9bd36229d03c 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_error_monad/monad_maker.mli b/src/lib_protocol_environment/structs/v1/error_monad_preallocated_values.ml similarity index 66% rename from src/lib_error_monad/monad_maker.mli rename to src/lib_protocol_environment/structs/v1/error_monad_preallocated_values.ml index 541d04a429dfca128e9355195219e237a4a97f85..f10885fe83a3a8dcdf022650bb7aaf2c23962b8f 100644 --- a/src/lib_error_monad/monad_maker.mli +++ b/src/lib_protocol_environment/structs/v1/error_monad_preallocated_values.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2019 Nomadic Labs *) +(* Copyright (c) 2021 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -23,5 +23,22 @@ (* *) (*****************************************************************************) -module Make (Trace : Sig.TRACE) : - Sig.MONAD with type 'err trace := 'err Trace.trace +(* 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 760de7037ea0b982bcffefe84013542783639bb2..92b42fe8749b0a0c5e77fa07c32ee994878bbdbb 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 569910b3c0f6fee12714940063ae37425cb851f7..090e4c43aeb93ae98258cff8b75a2605e0fc21c3 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 0000000000000000000000000000000000000000..4c91550a5de27baa7f310f5a94cb4efa1e65b5f4 --- /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}))))) + diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index ea27916ce6a6af9034a05d7173439699864efd69..0334c1a7684beb36b8760cc8ad6037cff9aabcca 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 7577bdf269f5df4772cff212c8d59caff34d7496..9cef7c202ae9366d02bd65402950f96228d3372b 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 db6851b2b7b7b6ddced30d081df92c814fdbb940..72a78e550cb35476d0e0a8b844e6da982965f348 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 7cff86178303c136af718626d0508171fab4a1bb..19dc398cf6b45d3900b61f2b16d9138435205592 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 687e16491bc260dccf9216d91ab9ab09f562d314..719092386338c54799f70c3d769e32a46d894f89 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 ea2709ecbb94b057baa8e921d311b69dbe5a7e72..ea1f4e0db24338e85e74ff7ef0e421b773b970f0 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 ac250a427400d956a49e1320b9f4664af5da1c81..8fa77cac3e317eee65431f1db03356fde0c21800 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 47aadb74cdb0aba35421f4361d00be47ef6a6296..e24b255c7a2d0cb37a71875d34ecf6d0e409afbd 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 de62253a56fcf259d6c4a9dee583d86c534d5e3b..abf88d88af45035ce0459c2b823206cee73c6d62 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 b601e4418e2e1b24b0017eb6228a80fe72bf69dd..5aa1428c2bea47f37f315497a5fefda3ea672a43 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 ea2709ecbb94b057baa8e921d311b69dbe5a7e72..ea1f4e0db24338e85e74ff7ef0e421b773b970f0 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 3ab6e26749ea21917f99f0f4f32ee37fdaef6b70..a9d26c057f37a175a2a082aee65e1d43e442d45e 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 6422513490503b5cfc73577865756e6681090848..9800f1db8bf6f5fa22a36dc23e53be85c22e775e 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 9c779dcbc250d263af2c42a9c5b29021938b9d66..445423b7dbed1778de631248866e4caee13993c2 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 c45f148f095b45b2444b146ee8c4cc2cc9fca245..61e7d1b0c4c68715ee5216b7bc74044db98bbd75 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 ea2709ecbb94b057baa8e921d311b69dbe5a7e72..ea1f4e0db24338e85e74ff7ef0e421b773b970f0 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 547e22222e12445942478a3a81f02158eb1421f1..4d5a9d1f808d3e0d05ab2bebaa3db292ab40c1ef 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 c71ee6990299da73df79db4f9b11d8df3d7b21ba..24e7cebe00fa696aba4c0ca935cbaf6600f26b3b 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.