From 5cfa37ea9e782fe1a72b58ae7a91beef7da46634 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 5 Aug 2020 15:17:27 +0200 Subject: [PATCH 1/6] Error_monad: separate generic/specific parts Specifically, the functors (especially Make_monad) become more generic and the instantiated modules get a name-change (with a Tz prefix) to mark them as special. --- src/lib_error_monad/{core.ml => TzCore.ml} | 0 src/lib_error_monad/{core.mli => TzCore.mli} | 4 +- src/lib_error_monad/{monad.ml => TzMonad.ml} | 6 +- .../{monad.mli => TzMonad.mli} | 12 +- src/lib_error_monad/TzTrace.ml | 59 ++++++ src/lib_error_monad/TzTrace.mli | 33 ++++ src/lib_error_monad/core_maker.ml | 4 +- src/lib_error_monad/core_maker.mli | 4 +- src/lib_error_monad/error_monad.ml | 17 +- src/lib_error_monad/error_monad.mli | 24 ++- src/lib_error_monad/monad_ext_maker.ml | 68 +++++++ src/lib_error_monad/monad_ext_maker.mli | 39 ++++ src/lib_error_monad/monad_maker.ml | 175 +++++++----------- src/lib_error_monad/monad_maker.mli | 5 +- src/lib_error_monad/sig.ml | 96 +++++++--- .../test/test_recursive_registration.ml | 6 +- src/lib_lwt_result_stdlib/lib/seq.ml | 4 +- .../environment_V0.ml | 6 +- src/lib_test_services/test_services.ml | 2 +- .../lib_protocol/test/helpers/testable.ml | 2 +- 20 files changed, 408 insertions(+), 158 deletions(-) rename src/lib_error_monad/{core.ml => TzCore.ml} (100%) rename src/lib_error_monad/{core.mli => TzCore.mli} (97%) rename src/lib_error_monad/{monad.ml => TzMonad.ml} (92%) rename src/lib_error_monad/{monad.mli => TzMonad.mli} (89%) create mode 100644 src/lib_error_monad/TzTrace.ml create mode 100644 src/lib_error_monad/TzTrace.mli create mode 100644 src/lib_error_monad/monad_ext_maker.ml create mode 100644 src/lib_error_monad/monad_ext_maker.mli diff --git a/src/lib_error_monad/core.ml b/src/lib_error_monad/TzCore.ml similarity index 100% rename from src/lib_error_monad/core.ml rename to src/lib_error_monad/TzCore.ml diff --git a/src/lib_error_monad/core.mli b/src/lib_error_monad/TzCore.mli similarity index 97% rename from src/lib_error_monad/core.mli rename to src/lib_error_monad/TzCore.mli index b0c0072d5812..7a3fa57b00aa 100644 --- a/src/lib_error_monad/core.mli +++ b/src/lib_error_monad/TzCore.mli @@ -24,7 +24,9 @@ (* *) (*****************************************************************************) -include Sig.CORE +type error = .. + +include Sig.CORE with type error := error include Sig.EXT with type error := error diff --git a/src/lib_error_monad/monad.ml b/src/lib_error_monad/TzMonad.ml similarity index 92% rename from src/lib_error_monad/monad.ml rename to src/lib_error_monad/TzMonad.ml index cab4df91a6d9..4a47da1e151b 100644 --- a/src/lib_error_monad/monad.ml +++ b/src/lib_error_monad/TzMonad.ml @@ -24,6 +24,8 @@ (* *) (*****************************************************************************) -type error = Core.error = .. +type error = TzCore.error = .. -include Monad_maker.Make (Core) +module Monad = Monad_maker.Make (TzCore) (TzTrace) +include Monad +include Monad_ext_maker.Make (TzCore) (TzTrace) (Monad) diff --git a/src/lib_error_monad/monad.mli b/src/lib_error_monad/TzMonad.mli similarity index 89% rename from src/lib_error_monad/monad.mli rename to src/lib_error_monad/TzMonad.mli index fb5a160a980a..6e1bc9bb4f5a 100644 --- a/src/lib_error_monad/monad.mli +++ b/src/lib_error_monad/TzMonad.mli @@ -24,6 +24,14 @@ (* *) (*****************************************************************************) -type error = Core.error = .. +type error = TzCore.error = .. -include Sig.MONAD with type error := Core.error +include + Sig.MONAD + with type error := error + and type 'error trace := 'error TzTrace.trace + +include + Sig.MONAD_EXT + with type 'a tzresult := 'a tzresult + and type trace := error TzTrace.trace diff --git a/src/lib_error_monad/TzTrace.ml b/src/lib_error_monad/TzTrace.ml new file mode 100644 index 000000000000..92d4d91772eb --- /dev/null +++ b/src/lib_error_monad/TzTrace.ml @@ -0,0 +1,59 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* INVARIANT: traces are never empty, they must contain at least one error *) +type 'err trace = 'err list + +let make err = [err] + +let cons err trace = err :: trace + +(* This is temporary. Eventually, the traces might have a more structured + semantic. *) +let conp trace _trace = trace + +let pp_print pp_error ppf = function + | [] -> + assert false + | [error] -> + Format.fprintf ppf "@[Error:@ %a@]@." pp_error error + | error :: _ as errors -> + Format.fprintf + ppf + "@[Error:@ %a,@ trace:@ %a@]@." + pp_error + error + (Format.pp_print_list pp_error) + (List.rev errors) + +let pp_print_top pp_error fmt = function + | [] -> + assert false + | error :: _ -> + pp_error fmt error + +let encoding error_encoding = Data_encoding.list error_encoding + +let fold = List.fold_left diff --git a/src/lib_error_monad/TzTrace.mli b/src/lib_error_monad/TzTrace.mli new file mode 100644 index 000000000000..438c7103bc8f --- /dev/null +++ b/src/lib_error_monad/TzTrace.mli @@ -0,0 +1,33 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** A [trace] is a stack of [error]s. It is implemented as an [error list] + but such a list MUST NEVER be empty. + + It is implemented as a concrete [error list] for backwards compatibility + but future improvements might modify the type or render the type + abstract. *) +include + Sig.TRACE with type 'err trace = 'err list diff --git a/src/lib_error_monad/core_maker.ml b/src/lib_error_monad/core_maker.ml index 9afadafb9fad..d13ad34ade2c 100644 --- a/src/lib_error_monad/core_maker.ml +++ b/src/lib_error_monad/core_maker.ml @@ -35,7 +35,9 @@ let json_pp id description encoding ppf data = let set_error_encoding_cache_dirty = ref (fun () -> ()) module Make (Prefix : Sig.PREFIX) : sig - include Sig.CORE + type error = .. + + include Sig.CORE with type error := error include Sig.EXT with type error := error diff --git a/src/lib_error_monad/core_maker.mli b/src/lib_error_monad/core_maker.mli index 3036891d389f..168362e41d4e 100644 --- a/src/lib_error_monad/core_maker.mli +++ b/src/lib_error_monad/core_maker.mli @@ -24,7 +24,9 @@ (*****************************************************************************) module Make (Prefix : Sig.PREFIX) : sig - include Sig.CORE + type error = .. + + include Sig.CORE with type error := error include Sig.EXT with type error := error diff --git a/src/lib_error_monad/error_monad.ml b/src/lib_error_monad/error_monad.ml index cb51423ef86c..3d123b43c0ba 100644 --- a/src/lib_error_monad/error_monad.ml +++ b/src/lib_error_monad/error_monad.ml @@ -30,8 +30,11 @@ type error_category = [`Branch | `Temporary | `Permanent] -include Core -include Monad +include TzCore +include TzMonad +module TzTrace = TzTrace + +type 'error trace = 'error TzTrace.trace type error += Exn of exn @@ -56,7 +59,7 @@ let generic_error fmt = Format.kasprintf (fun s -> error (Exn (Failure s))) fmt let failwith fmt = Format.kasprintf (fun s -> fail (Exn (Failure s))) fmt -let error_exn s = Error [Exn s] +let error_exn s = Error (TzTrace.make @@ Exn s) let trace_exn exn f = trace (Exn exn) f @@ -106,16 +109,16 @@ let protect ?on_error ?canceler t = >>= function | Ok _ -> res - | Error err -> ( + | Error trace -> ( let canceled = Option.fold canceler ~none:false ~some:Lwt_canceler.canceled in - let err = if canceled then [Canceled] else err in + let trace = if canceled then TzTrace.make Canceled else trace in match on_error with | None -> - Lwt.return_error err + Lwt.return_error trace | Some on_error -> - Lwt.catch (fun () -> on_error err) (fun exn -> fail (Exn exn)) ) + Lwt.catch (fun () -> on_error trace) (fun exn -> fail (Exn exn)) ) type error += Timeout diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index 54515d4cfc47..72a9f539c29e 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -32,13 +32,27 @@ type error_category = | `Temporary (** Errors that may not happen in a later context *) | `Permanent (** Errors that will happen no matter the context *) ] -include Sig.CORE with type error = Core.error +type error = TzCore.error = .. + +include Sig.CORE with type error := error include Sig.EXT with type error := error include Sig.WITH_WRAPPED with type error := error -include Sig.MONAD with type error := error +module TzTrace : Sig.TRACE with type 'error trace = 'error list + +type 'error trace = 'error TzTrace.trace + +include + Sig.MONAD + with type error := error + and type 'error trace := 'error TzTrace.trace + +include + Sig.MONAD_EXT + with type 'a tzresult := 'a tzresult + and type trace := error TzTrace.trace (** Erroneous result (shortcut for generic errors) *) val generic_error : ('a, Format.formatter, unit, 'b tzresult) format4 -> 'a @@ -56,7 +70,7 @@ val generic_trace : ( 'a, Format.formatter, unit, - ('b, trace) result Lwt.t -> ('b, trace) result Lwt.t ) + ('b, error trace) result Lwt.t -> ('b, error trace) result Lwt.t ) format4 -> 'a @@ -82,7 +96,7 @@ type error += Canceled is returned. An Lwt failure triggered by [~on_error] is wrapped into an [Exn] *) val protect : - ?on_error:(trace -> 'a tzresult Lwt.t) -> + ?on_error:(error trace -> 'a tzresult Lwt.t) -> ?canceler:Lwt_canceler.t -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t @@ -97,4 +111,4 @@ val with_timeout : (**/**) -val errs_tag : trace Tag.def +val errs_tag : error trace Tag.def diff --git a/src/lib_error_monad/monad_ext_maker.ml b/src/lib_error_monad/monad_ext_maker.ml new file mode 100644 index 000000000000..1c3c4a4ce5f3 --- /dev/null +++ b/src/lib_error_monad/monad_ext_maker.ml @@ -0,0 +1,68 @@ +(*****************************************************************************) +(* *) +(* 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 (Error : sig + type error = .. + + include Sig.CORE with type error := error + + include Sig.EXT with type error := error +end) +(Trace : Sig.TRACE) +(Monad : Sig.MONAD + with type error := Error.error + and type 'error trace := 'error Trace.trace) : + Sig.MONAD_EXT + with type 'a tzresult := 'a Monad.tzresult + and type trace := Error.error Trace.trace = struct + let classify_errors trace = + Trace.fold + (fun c e -> Sig.combine_category c (Error.classify_error e)) + `Temporary + trace + + type Error.error += Assert_error of string * string + + let () = + Error.register_error_kind + `Permanent + ~id:"assertion" + ~title:"Assertion failure" + ~description:"A fatal assertion failed" + ~pp:(fun ppf (loc, msg) -> + Format.fprintf + ppf + "Assert failure (%s)%s" + loc + (if msg = "" then "." else ": " ^ msg)) + Data_encoding.(obj2 (req "loc" string) (req "msg" string)) + (function Assert_error (loc, msg) -> Some (loc, msg) | _ -> None) + (fun (loc, msg) -> Assert_error (loc, msg)) + + let _assert b loc fmt = + if b then + Format.ikfprintf (fun _ -> Monad.return_unit) Format.str_formatter fmt + else Format.kasprintf (fun msg -> Monad.fail (Assert_error (loc, msg))) fmt +end diff --git a/src/lib_error_monad/monad_ext_maker.mli b/src/lib_error_monad/monad_ext_maker.mli new file mode 100644 index 000000000000..c352ae440adb --- /dev/null +++ b/src/lib_error_monad/monad_ext_maker.mli @@ -0,0 +1,39 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Make (Error : sig + type error = .. + + include Sig.CORE with type error := error + + include Sig.EXT with type error := error +end) +(Trace : Sig.TRACE) +(Monad : Sig.MONAD + with type error := Error.error + and type 'error trace := 'error Trace.trace) : + Sig.MONAD_EXT + with type 'a tzresult := 'a Monad.tzresult + and type trace := Error.error Trace.trace diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index 13390731c436..f75b844b6d67 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -23,49 +23,23 @@ (* *) (*****************************************************************************) -module Make (Error : Sig.CORE) : Sig.MONAD with type error := Error.error = -struct - (* INVARIANT: traces are never empty, they must contain at least one error *) +module Make (Error : Sig.CORE) (Trace : Sig.TRACE) : + Sig.MONAD + with type error := Error.error + and type 'err trace := 'err Trace.trace = struct + type tztrace = Error.error Trace.trace - type trace = Error.error list + let trace_encoding = Trace.encoding Error.error_encoding - let trace_encoding = Data_encoding.list Error.error_encoding + let pp_print_error = Trace.pp_print Error.pp - let pp_print_error ppf = function - | [] -> - assert false - | [error] -> - Format.fprintf ppf "@[Error:@ %a@]@." Error.pp error - | error :: _ as errors -> - Format.fprintf - ppf - "@[Error:@ %a,@ trace:@ %a@]@." - Error.pp - error - (Format.pp_print_list Error.pp) - (List.rev errors) - - let pp_print_error_first fmt trace = - Format.fprintf fmt "%a" Error.pp @@ List.hd trace - - let classify_errors trace = - List.fold_left - (fun r e -> - match (r, Error.classify_error e) with - | (`Permanent, _) | (_, `Permanent) -> - `Permanent - | (`Branch, _) | (_, `Branch) -> - `Branch - | (`Temporary, `Temporary) -> - `Temporary) - `Temporary - trace - - type 'a tzresult = ('a, trace) result + let pp_print_error_first = Trace.pp_print_top Error.pp + + type 'a tzresult = ('a, tztrace) result let result_encoding a_encoding = let open Data_encoding in - let errors_encoding = obj1 (req "error" trace_encoding) in + let trace_encoding = obj1 (req "error" trace_encoding) in let a_encoding = obj1 (req "result" a_encoding) in union ~tag_size:`Uint8 @@ -77,10 +51,10 @@ struct (function res -> Ok res); case (Tag 1) - errors_encoding + trace_encoding ~title:"Error" (function Error x -> Some x | _ -> None) - (function [] -> assert false | _ :: _ as errs -> Error errs) ] + (function x -> Error x) ] let ( >>= ) = Lwt.( >>= ) @@ -98,7 +72,7 @@ struct let ok_false = Ok false - let[@inline] error s = Error [s] + let[@inline] error s = Error (Trace.make s) let[@inline] return v = Lwt.return_ok v @@ -114,7 +88,7 @@ struct let return_false = Lwt.return ok_false - let[@inline] fail s = Lwt.return_error [s] + let[@inline] fail s = Lwt.return_error @@ Trace.make s let ( >>? ) v f = match v with Error _ as err -> err | Ok v -> f v @@ -188,10 +162,10 @@ struct match (x, l) with | (Ok x, Ok l) -> Lwt.return_ok (x :: l) - | (Error exn1, Error exn2) -> - Lwt.return_error (exn1 @ exn2) - | (Ok _, Error exn) | (Error exn, Ok _) -> - Lwt.return_error exn ) + | (Error trace1, Error trace2) -> + Lwt.return_error (Trace.conp trace1 trace2) + | (Ok _, Error trace) | (Error trace, Ok _) -> + Lwt.return_error trace ) let mapi_p f l = let rec mapi_p f i l = @@ -207,10 +181,10 @@ struct match (x, l) with | (Ok x, Ok l) -> Lwt.return_ok (x :: l) - | (Error exn1, Error exn2) -> - Lwt.return_error (exn1 @ exn2) - | (Ok _, Error exn) | (Error exn, Ok _) -> - Lwt.return_error exn ) + | (Error trace1, Error trace2) -> + Lwt.return_error (Trace.conp trace1 trace2) + | (Ok _, Error trace) | (Error trace, Ok _) -> + Lwt.return_error trace ) in mapi_p f 0 l @@ -329,10 +303,10 @@ struct match (tx_res, tl_res) with | (Ok (), Ok ()) -> Lwt.return_ok () - | (Error exn1, Error exn2) -> - Lwt.return_error (exn1 @ exn2) - | (Ok (), Error exn) | (Error exn, Ok ()) -> - Lwt.return_error exn ) + | (Error trace1, Error trace2) -> + Lwt.return_error (Trace.conp trace1 trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) let iteri_p f l = let rec iteri_p i f l = @@ -348,10 +322,10 @@ struct match (tx_res, tl_res) with | (Ok (), Ok ()) -> Lwt.return ok_unit - | (Error exn1, Error exn2) -> - Lwt.return (Error (exn1 @ exn2)) - | (Ok (), Error exn) | (Error exn, Ok ()) -> - Lwt.return (Error exn) ) + | (Error trace1, Error trace2) -> + Lwt.return_error (Trace.conp trace1 trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) in iteri_p 0 f l @@ -370,10 +344,10 @@ struct match (tx_res, tl_res) with | (Ok (), Ok ()) -> Lwt.return_ok () - | (Error exn1, Error exn2) -> - Lwt.return_error (exn1 @ exn2) - | (Ok (), Error exn) | (Error exn, Ok ()) -> - Lwt.return_error exn ) + | (Error trace1, Error trace2) -> + Lwt.return_error (Trace.conp trace1 trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) let iteri2_p f l1 l2 = let rec iteri2_p i f l1 l2 = @@ -391,10 +365,10 @@ struct match (tx_res, tl_res) with | (Ok (), Ok ()) -> Lwt.return_ok () - | (Error exn1, Error exn2) -> - Lwt.return_error (exn1 @ exn2) - | (Ok (), Error exn) | (Error exn, Ok ()) -> - Lwt.return_error exn ) + | (Error trace1, Error trace2) -> + Lwt.return_error (Trace.conp trace1 trace2) + | (Ok (), Error trace) | (Error trace, Ok ()) -> + Lwt.return_error trace ) in iteri2_p 0 f l1 l2 @@ -418,18 +392,30 @@ struct 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 - | t :: ts -> - t >>? fun () -> join_e ts + | 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) - | t :: ts -> - t >>? fun v -> aux (v :: acc) ts + | Ok v :: ts -> + aux (v :: acc) ts + | Error trace :: ts -> + join_e_errors trace ts in aux [] ts @@ -440,8 +426,7 @@ struct | (Error err, Ok _) | (Ok _, Error err) -> Error err | (Error erra, Error errb) -> - (* Improve this once we improved the support for parallel traces *) - ignore errb ; Error erra + Error (Trace.conp erra errb) let join_ep ts = all_p ts >|= join_e @@ -450,25 +435,31 @@ struct let both_ep a b = both_p a b >|= fun (a, b) -> both_e a b let record_trace err result = - match result with Ok _ as res -> res | Error errs -> Error (err :: errs) + match result with + | Ok _ as res -> + res + | Error trace -> + Error (Trace.cons err trace) let trace err f = f >>= function - | Error errs -> Lwt.return_error (err :: errs) | ok -> Lwt.return ok + | Error trace -> + Lwt.return_error (Trace.cons err trace) + | ok -> + Lwt.return ok - let record_trace_eval mk_err result = - match result with - | Ok _ as res -> - res - | Error errs -> - mk_err () >>? fun err -> Error (err :: errs) + 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 errs -> - mk_err () >>=? fun err -> Lwt.return_error (err :: errs) + | Error trace -> + mk_err () >>=? fun err -> Lwt.return_error (Trace.cons err trace) | ok -> Lwt.return ok @@ -484,28 +475,6 @@ struct let _when cond f = if cond then f () else return_unit - type Error.error += Assert_error of string * string - - let () = - Error.register_error_kind - `Permanent - ~id:"assertion" - ~title:"Assertion failure" - ~description:"A fatal assertion failed" - ~pp:(fun ppf (loc, msg) -> - Format.fprintf - ppf - "Assert failure (%s)%s" - loc - (if msg = "" then "." else ": " ^ msg)) - Data_encoding.(obj2 (req "loc" string) (req "msg" string)) - (function Assert_error (loc, msg) -> Some (loc, msg) | _ -> None) - (fun (loc, msg) -> Assert_error (loc, msg)) - - let _assert b loc fmt = - if b then Format.ikfprintf (fun _ -> return_unit) Format.str_formatter fmt - else Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt - let dont_wait exc_handler err_handler f = Lwt_utils.dont_wait exc_handler (fun () -> f () diff --git a/src/lib_error_monad/monad_maker.mli b/src/lib_error_monad/monad_maker.mli index 98270f369289..41e5d434102d 100644 --- a/src/lib_error_monad/monad_maker.mli +++ b/src/lib_error_monad/monad_maker.mli @@ -23,4 +23,7 @@ (* *) (*****************************************************************************) -module Make (Error : Sig.CORE) : Sig.MONAD with type error := Error.error +module Make (Error : Sig.CORE) (Trace : Sig.TRACE) : + Sig.MONAD + with type error := Error.error + and type 'err trace := 'err Trace.trace diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index f9995078fcc0..57a75b001843 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -38,6 +38,15 @@ let string_of_category = function | `Branch -> "branch" +let combine_category c1 c2 = + match (c1, c2) with + | (`Permanent, _) | (_, `Permanent) -> + `Permanent + | (`Branch, _) | (_, `Branch) -> + `Branch + | (`Temporary, `Temporary) -> + `Temporary + module type PREFIX = sig (** The identifier for parts of the code that need their own error monad. It is expected (but not enforced) that the identifier: @@ -47,11 +56,15 @@ module type PREFIX = sig end module type CORE = sig - type error = .. + type error val error_encoding : error Data_encoding.t val pp : Format.formatter -> error -> unit +end + +module type EXT = sig + type error = .. (** The error data type is extensible. Each module can register specialized error serializers @@ -91,10 +104,6 @@ module type CORE = sig (** Classify an error using the registered kinds *) val classify_error : error -> error_category -end - -module type EXT = sig - type error = .. (** Catch all error when 'serializing' an error. *) type error += @@ -149,6 +158,34 @@ module type WITH_WRAPPED = sig unit 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]). *) + type 'err trace + + val make : 'error -> 'error trace + + val cons : 'error -> 'error trace -> 'error trace + + val conp : 'error trace -> 'error trace -> 'error trace + + val pp_print : + (Format.formatter -> 'err -> unit) -> + Format.formatter -> + 'err trace -> + unit + + val pp_print_top : + (Format.formatter -> 'err -> unit) -> + Format.formatter -> + 'err trace -> + unit + + val encoding : 'error Data_encoding.t -> 'error trace Data_encoding.t + + val fold : ('a -> 'error -> 'a) -> 'a -> 'error trace -> 'a +end + module type MONAD = sig (** This type is meant to be substituted/constrained. The intended use is along the following lines: @@ -164,33 +201,26 @@ module type MONAD = sig *) type error - (** A [trace] is a stack of [error]s. It is implemented as an [error list] - but such a list MUST NEVER be empty. + (** To be subsituted/constrained *) + type 'err trace - It is implemented as a concrete [error list] for backwards compatibility - but future improvements might modify the type or render the type - abstract. *) - type trace = error list + type tztrace = error trace (* 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 -> trace -> unit + 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 -> trace -> unit + val pp_print_error_first : Format.formatter -> error trace -> unit - val trace_encoding : trace Data_encoding.t - - (* NOTE: Right now we leave this [classify_errors] named as is. Later on we - might rename it to [classify_trace]. *) - val classify_errors : trace -> error_category + val trace_encoding : error trace Data_encoding.t (** The error monad wrapper type, the error case holds a stack of error, initialized by the first call to {!fail} and completed by each call to {!trace} as the stack is rewound. The most general error is thus at the top of the error stack, going down to the specific error that actually caused the failure. *) - type 'a tzresult = ('a, trace) result + type 'a tzresult = ('a, tztrace) result (** A serializer for result of a given type *) val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.t @@ -307,16 +337,12 @@ module type MONAD = sig val _when : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t - (* Usage: [_assert cond __LOC__ "" ...] *) - val _assert : - bool -> - string -> - ('a, Format.formatter, unit, unit tzresult Lwt.t) format4 -> - 'a - (** Wrapper around [Lwt_utils.dont_wait] *) val dont_wait : - (exn -> unit) -> (trace -> unit) -> (unit -> unit tzresult Lwt.t) -> unit + (exn -> unit) -> + (error trace -> unit) -> + (unit -> unit tzresult Lwt.t) -> + unit (** {2 In-monad list iterators} *) @@ -432,3 +458,19 @@ module type MONAD = sig val both_ep : 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t end + +module type MONAD_EXT = sig + (** for substitution *) + type 'a tzresult + + type trace + + val classify_errors : trace -> error_category + + (* Usage: [_assert cond __LOC__ "" ...] *) + val _assert : + bool -> + string -> + ('a, Format.formatter, unit, unit tzresult Lwt.t) format4 -> + 'a +end diff --git a/src/lib_error_monad/test/test_recursive_registration.ml b/src/lib_error_monad/test/test_recursive_registration.ml index d83d7d9914a2..fc5bcfabc19a 100644 --- a/src/lib_error_monad/test/test_recursive_registration.ml +++ b/src/lib_error_monad/test/test_recursive_registration.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module Make () = struct - open Core + open TzCore (* Shallow parallel errors *) type error += ParSha of error list @@ -103,7 +103,7 @@ module Make () = struct let (_ : string) = Format.asprintf "%a" pp parsha_aa (* Deep recursive errors *) - type error += ParD of Monad.trace list + type error += ParD of TzMonad.tztrace list let () = register_recursive_error_kind @@ -118,7 +118,7 @@ module Make () = struct (List.length traces) (Format.pp_print_list ~pp_sep:Format.pp_print_space - Monad.pp_print_error) + TzMonad.pp_print_error) traces) (fun err_enc -> let open Data_encoding in diff --git a/src/lib_lwt_result_stdlib/lib/seq.ml b/src/lib_lwt_result_stdlib/lib/seq.ml index a0cabf0b48c2..af36f89cc676 100644 --- a/src/lib_lwt_result_stdlib/lib/seq.ml +++ b/src/lib_lwt_result_stdlib/lib/seq.ml @@ -26,7 +26,7 @@ include Functors.Seq.Make (struct type in_error = Error_monad.error - type out_error = Error_monad.error list + type out_error = Error_monad.error TzTrace.trace - include Tezos_error_monad.Monad + include Tezos_error_monad.TzMonad end) diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 34122c435442..414cab6517c3 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -530,7 +530,11 @@ struct type error_category = [`Branch | `Temporary | `Permanent] include Error_core - include Tezos_error_monad.Monad_maker.Make (Error_core) + module Local_monad = + Tezos_error_monad.Monad_maker.Make (Error_core) (TzTrace) + include Local_monad + include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) + (Local_monad) let ( >>|? ) = ( >|=? ) (* for backward compatibility *) end diff --git a/src/lib_test_services/test_services.ml b/src/lib_test_services/test_services.ml index b45f0ac9751d..fe1efd2f93ba 100644 --- a/src/lib_test_services/test_services.ml +++ b/src/lib_test_services/test_services.ml @@ -29,7 +29,7 @@ include Alcotest include Test_services_base -let trace : trace testable = testable pp_print_error ( = ) +let trace : error trace testable = testable pp_print_error ( = ) let tzresults (type a) (t : a testable) : a tzresult testable = result t trace diff --git a/src/proto_alpha/lib_protocol/test/helpers/testable.ml b/src/proto_alpha/lib_protocol/test/helpers/testable.ml index 0f73eaab4a4a..79cc1d89ff8a 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/testable.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/testable.ml @@ -31,7 +31,7 @@ let contract : Protocol.Alpha_context.Contract.t Alcotest.testable = let script_expr : Protocol.Alpha_context.Script.expr Alcotest.testable = Alcotest.testable Michelson_v1_printer.print_expr ( = ) -let trace : trace Alcotest.testable = Alcotest.testable pp_print_error ( = ) +let trace : tztrace Alcotest.testable = Alcotest.testable pp_print_error ( = ) let protocol_error : Environment.Error_monad.error Alcotest.testable = let open Environment.Error_monad in -- GitLab From 06d7ff602690b591508313562649ccba2a5079ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 5 Aug 2020 15:58:29 +0200 Subject: [PATCH 2/6] Error_monad: further separate generic and specialise code --- src/lib_error_monad/TzMonad.mli | 6 ++-- src/lib_error_monad/error_monad.mli | 6 ++-- src/lib_error_monad/monad_ext_maker.ml | 31 +++++++++++++++++-- src/lib_error_monad/monad_ext_maker.mli | 6 ++-- src/lib_error_monad/monad_maker.ml | 25 --------------- src/lib_error_monad/sig.ml | 41 +++++++++++++------------ 6 files changed, 62 insertions(+), 53 deletions(-) diff --git a/src/lib_error_monad/TzMonad.mli b/src/lib_error_monad/TzMonad.mli index 6e1bc9bb4f5a..7eeee9d08bc1 100644 --- a/src/lib_error_monad/TzMonad.mli +++ b/src/lib_error_monad/TzMonad.mli @@ -33,5 +33,7 @@ include include Sig.MONAD_EXT - with type 'a tzresult := 'a tzresult - and type trace := error TzTrace.trace + with type error := error + and type 'error trace := 'error TzTrace.trace + and type tztrace := tztrace + and type 'a tzresult := 'a tzresult diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index 72a9f539c29e..ae0496a53fcb 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -51,8 +51,10 @@ include include Sig.MONAD_EXT - with type 'a tzresult := 'a tzresult - and type trace := error TzTrace.trace + with type error := error + and type 'error trace := 'error TzTrace.trace + and type tztrace := tztrace + and type 'a tzresult := 'a tzresult (** Erroneous result (shortcut for generic errors) *) val generic_error : ('a, Format.formatter, unit, 'b tzresult) format4 -> 'a diff --git a/src/lib_error_monad/monad_ext_maker.ml b/src/lib_error_monad/monad_ext_maker.ml index 1c3c4a4ce5f3..f81f564fd16c 100644 --- a/src/lib_error_monad/monad_ext_maker.ml +++ b/src/lib_error_monad/monad_ext_maker.ml @@ -35,8 +35,35 @@ end) with type error := Error.error and type 'error trace := 'error Trace.trace) : Sig.MONAD_EXT - with type 'a tzresult := 'a Monad.tzresult - and type trace := Error.error Trace.trace = struct + with type error := Error.error + and type 'error trace := 'error Trace.trace + and type tztrace := Monad.tztrace + and type 'a tzresult := 'a Monad.tzresult = struct + let trace_encoding = Trace.encoding Error.error_encoding + + let result_encoding a_encoding = + let open Data_encoding in + let trace_encoding = obj1 (req "error" trace_encoding) in + let a_encoding = obj1 (req "result" a_encoding) in + union + ~tag_size:`Uint8 + [ case + (Tag 0) + a_encoding + ~title:"Ok" + (function Ok x -> Some x | _ -> None) + (function res -> Ok res); + case + (Tag 1) + trace_encoding + ~title:"Error" + (function Error x -> Some x | _ -> None) + (function x -> Error x) ] + + let pp_print_error = Trace.pp_print Error.pp + + let pp_print_error_first = Trace.pp_print_top Error.pp + let classify_errors trace = Trace.fold (fun c e -> Sig.combine_category c (Error.classify_error e)) diff --git a/src/lib_error_monad/monad_ext_maker.mli b/src/lib_error_monad/monad_ext_maker.mli index c352ae440adb..c9aa9cbfd890 100644 --- a/src/lib_error_monad/monad_ext_maker.mli +++ b/src/lib_error_monad/monad_ext_maker.mli @@ -35,5 +35,7 @@ end) with type error := Error.error and type 'error trace := 'error Trace.trace) : Sig.MONAD_EXT - with type 'a tzresult := 'a Monad.tzresult - and type trace := Error.error Trace.trace + with type error := Error.error + and type 'error trace := 'error Trace.trace + and type tztrace := Monad.tztrace + and type 'a tzresult := 'a Monad.tzresult diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index f75b844b6d67..6760446d4c3b 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -29,33 +29,8 @@ module Make (Error : Sig.CORE) (Trace : Sig.TRACE) : and type 'err trace := 'err Trace.trace = struct type tztrace = Error.error Trace.trace - let trace_encoding = Trace.encoding Error.error_encoding - - let pp_print_error = Trace.pp_print Error.pp - - let pp_print_error_first = Trace.pp_print_top Error.pp - type 'a tzresult = ('a, tztrace) result - let result_encoding a_encoding = - let open Data_encoding in - let trace_encoding = obj1 (req "error" trace_encoding) in - let a_encoding = obj1 (req "result" a_encoding) in - union - ~tag_size:`Uint8 - [ case - (Tag 0) - a_encoding - ~title:"Ok" - (function Ok x -> Some x | _ -> None) - (function res -> Ok res); - case - (Tag 1) - trace_encoding - ~title:"Error" - (function Error x -> Some x | _ -> None) - (function x -> Error x) ] - let ( >>= ) = Lwt.( >>= ) let[@inline] ok v = Ok v diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index 57a75b001843..fed89df8eb3b 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -206,25 +206,8 @@ module type MONAD = sig type tztrace = error trace - (* 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 - - (** The error monad wrapper type, the error case holds a stack of - error, initialized by the first call to {!fail} and completed by - each call to {!trace} as the stack is rewound. The most general - error is thus at the top of the error stack, going down to the - specific error that actually caused the failure. *) type 'a tzresult = ('a, tztrace) result - (** A serializer for result of a given type *) - val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.t - (** Successful result *) val ok : 'a -> 'a tzresult @@ -461,11 +444,15 @@ end module type MONAD_EXT = sig (** for substitution *) - type 'a tzresult + type error + + type 'error trace + + type tztrace = error trace - type trace + type 'a tzresult = ('a, tztrace) result - val classify_errors : trace -> error_category + val classify_errors : tztrace -> error_category (* Usage: [_assert cond __LOC__ "" ...] *) val _assert : @@ -473,4 +460,18 @@ module type MONAD_EXT = sig string -> ('a, Format.formatter, unit, unit tzresult Lwt.t) format4 -> 'a + + (* 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 -- GitLab From 17a178eecb9fee3b7c56d2d93514edb7099b2814 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 5 Aug 2020 16:15:10 +0200 Subject: [PATCH 3/6] Error_monad: generalise result combinators in Monad MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit NOTE: this commit is PARTIAL, it only does the modification to the `lib_error_monad` directory. The two next commits propagate the changes further. Co-authored-by: Mehdi Bouaziz Co-authored-by: Raphaël Proust --- src/lib_error_monad/TzMonad.mli | 2 - src/lib_error_monad/error_monad.mli | 2 - src/lib_error_monad/monad_ext_maker.ml | 6 +- src/lib_error_monad/monad_ext_maker.mli | 2 - src/lib_error_monad/monad_maker.ml | 4 - src/lib_error_monad/sig.ml | 250 +++++++++++++++++------- 6 files changed, 180 insertions(+), 86 deletions(-) diff --git a/src/lib_error_monad/TzMonad.mli b/src/lib_error_monad/TzMonad.mli index 7eeee9d08bc1..64f926665a3a 100644 --- a/src/lib_error_monad/TzMonad.mli +++ b/src/lib_error_monad/TzMonad.mli @@ -35,5 +35,3 @@ include Sig.MONAD_EXT with type error := error and type 'error trace := 'error TzTrace.trace - and type tztrace := tztrace - and type 'a tzresult := 'a tzresult diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index ae0496a53fcb..3e3405dc9d66 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -53,8 +53,6 @@ include Sig.MONAD_EXT with type error := error and type 'error trace := 'error TzTrace.trace - and type tztrace := tztrace - and type 'a tzresult := 'a tzresult (** Erroneous result (shortcut for generic errors) *) val generic_error : ('a, Format.formatter, unit, 'b tzresult) format4 -> 'a diff --git a/src/lib_error_monad/monad_ext_maker.ml b/src/lib_error_monad/monad_ext_maker.ml index f81f564fd16c..43faa2b1fc51 100644 --- a/src/lib_error_monad/monad_ext_maker.ml +++ b/src/lib_error_monad/monad_ext_maker.ml @@ -36,9 +36,9 @@ end) and type 'error trace := 'error Trace.trace) : Sig.MONAD_EXT with type error := Error.error - and type 'error trace := 'error Trace.trace - and type tztrace := Monad.tztrace - and type 'a tzresult := 'a Monad.tzresult = struct + and type 'error trace := 'error Trace.trace = struct + type tztrace = Error.error Trace.trace + type 'a tzresult = ('a, tztrace) result let trace_encoding = Trace.encoding Error.error_encoding let result_encoding a_encoding = diff --git a/src/lib_error_monad/monad_ext_maker.mli b/src/lib_error_monad/monad_ext_maker.mli index c9aa9cbfd890..b318a4a8080f 100644 --- a/src/lib_error_monad/monad_ext_maker.mli +++ b/src/lib_error_monad/monad_ext_maker.mli @@ -37,5 +37,3 @@ end) Sig.MONAD_EXT with type error := Error.error and type 'error trace := 'error Trace.trace - and type tztrace := Monad.tztrace - and type 'a tzresult := 'a Monad.tzresult diff --git a/src/lib_error_monad/monad_maker.ml b/src/lib_error_monad/monad_maker.ml index 6760446d4c3b..22f6ef5c1929 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -27,10 +27,6 @@ module Make (Error : Sig.CORE) (Trace : Sig.TRACE) : Sig.MONAD with type error := Error.error and type 'err trace := 'err Trace.trace = struct - type tztrace = Error.error Trace.trace - - type 'a tzresult = ('a, tztrace) result - let ( >>= ) = Lwt.( >>= ) let[@inline] ok v = Ok v diff --git a/src/lib_error_monad/sig.ml b/src/lib_error_monad/sig.ml index fed89df8eb3b..b18127432735 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -160,21 +160,57 @@ 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]). *) + 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) + ] + *) val cons : 'error -> 'error trace -> '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) + ] + *) val conp : 'error trace -> 'error trace -> 'error trace + (** [pp_print] pretty-prints a trace of errors *) val pp_print : (Format.formatter -> 'err -> unit) -> Format.formatter -> 'err trace -> unit + (** [pp_print_top] pretty-prints the top errors of the trace *) val pp_print_top : (Format.formatter -> 'err -> unit) -> Format.formatter -> @@ -183,6 +219,10 @@ module type TRACE = sig val encoding : 'error Data_encoding.t -> 'error trace Data_encoding.t + (** [fold f init trace] traverses the trace (in an unspecified manner) so that + [init] is folded over each of the error within [trace] by [f]. Typical use + is to find the worst error, to check for the presence of a given error, + etc. *) val fold : ('a -> 'error -> 'a) -> 'a -> 'error trace -> 'a end @@ -204,51 +244,47 @@ module type MONAD = sig (** To be subsituted/constrained *) type 'err trace - type tztrace = error trace - - type 'a tzresult = ('a, tztrace) result - (** Successful result *) - val ok : 'a -> 'a tzresult + val ok : 'a -> ('a, 'trace) result - val ok_unit : unit tzresult + val ok_unit : (unit, 'trace) result - val ok_none : 'a option tzresult + val ok_none : ('a option, 'trace) result - val ok_some : 'a -> 'a option tzresult + val ok_some : 'a -> ('a option, 'trace) result - val ok_nil : 'a list tzresult + val ok_nil : ('a list, 'trace) result - val ok_true : bool tzresult + val ok_true : (bool, 'trace) result - val ok_false : bool tzresult + val ok_false : (bool, 'trace) result (** Successful return *) - val return : 'a -> 'a tzresult Lwt.t + val return : 'a -> ('a, 'trace) result Lwt.t (** Successful return of [()] *) - val return_unit : unit tzresult Lwt.t + val return_unit : (unit, 'trace) result Lwt.t (** Successful return of [None] *) - val return_none : 'a option tzresult Lwt.t + 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 tzresult Lwt.t + val return_some : 'a -> ('a option, 'trace) result Lwt.t (** Successful return of [[]] *) - val return_nil : 'a list tzresult Lwt.t + val return_nil : ('a list, 'trace) result Lwt.t (** Successful return of [true] *) - val return_true : bool tzresult Lwt.t + val return_true : (bool, 'trace) result Lwt.t (** Successful return of [false] *) - val return_false : bool tzresult Lwt.t + val return_false : (bool, 'trace) result Lwt.t (** Erroneous result *) - val error : error -> 'a tzresult + val error : 'err -> ('a, 'err trace) result (** Erroneous return *) - val fail : error -> 'a tzresult Lwt.t + val fail : 'err -> ('a, 'err trace) result Lwt.t (** Infix operators for monadic binds/maps. All operators follow this naming convention: @@ -268,18 +304,22 @@ module type MONAD = sig (** Non-Lwt bind operator. In this operator and the ones below, [?] indicates that we operate within the error monad. *) - val ( >>? ) : 'a tzresult -> ('a -> 'b tzresult) -> 'b tzresult + val ( >>? ) : + ('a, 'trace) result -> ('a -> ('b, 'trace) result) -> ('b, 'trace) result (** Non-Lwt map operator. *) - val ( >|? ) : 'a tzresult -> ('a -> 'b) -> 'b tzresult + val ( >|? ) : ('a, 'trace) result -> ('a -> 'b) -> ('b, 'trace) result (** Combined bind operator. The [=?] indicates that the operator acts within the combined error-lwt monad. *) val ( >>=? ) : - 'a tzresult Lwt.t -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t + ('a, 'trace) result Lwt.t -> + ('a -> ('b, 'trace) result Lwt.t) -> + ('b, 'trace) result Lwt.t (** Combined map operator. *) - val ( >|=? ) : 'a tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t + val ( >|=? ) : + ('a, 'trace) result Lwt.t -> ('a -> 'b) -> ('b, 'trace) result Lwt.t (** Injecting bind operator. This is for transitioning from the simple Error monad to the combined Error-Lwt monad. @@ -287,137 +327,194 @@ module type MONAD = sig 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 tzresult -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t + val ( >>?= ) : + ('a, 'trace) result -> + ('a -> ('b, 'trace) result Lwt.t) -> + ('b, 'trace) result Lwt.t (** Injecting map operator. *) - val ( >|?= ) : 'a tzresult -> ('a -> 'b Lwt.t) -> 'b tzresult Lwt.t + val ( >|?= ) : + ('a, 'trace) result -> ('a -> 'b Lwt.t) -> ('b, 'trace) result Lwt.t (** Enrich an error report (or do nothing on a successful result) manually *) - val record_trace : error -> 'a tzresult -> 'a tzresult + val record_trace : 'err -> ('a, 'err trace) result -> ('a, 'err trace) result (** Automatically enrich error reporting on stack rewind *) - val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t + val trace : + 'err -> ('b, 'err trace) result Lwt.t -> ('b, 'err trace) result Lwt.t (** Same as record_trace, for unevaluated error *) val record_trace_eval : - (unit -> error tzresult) -> 'a tzresult -> 'a tzresult + (unit -> ('err, 'err trace) result) -> + ('a, 'err trace) result -> + ('a, 'err trace) result (** Same as trace, for unevaluated Lwt error *) val trace_eval : - (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t + (unit -> ('err, 'err trace) result Lwt.t) -> + ('b, 'err trace) result Lwt.t -> + ('b, 'err trace) result Lwt.t (** Error on failed assertion *) - val error_unless : bool -> error -> unit tzresult + val error_unless : bool -> 'err -> (unit, 'err trace) result - val error_when : bool -> error -> unit tzresult + val error_when : bool -> 'err -> (unit, 'err trace) result (** Erroneous return on failed assertion *) - val fail_unless : bool -> error -> unit tzresult Lwt.t + val fail_unless : bool -> 'err -> (unit, 'err trace) result Lwt.t - val fail_when : bool -> error -> unit tzresult Lwt.t + val fail_when : bool -> 'err -> (unit, 'err trace) result Lwt.t - val unless : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t + val unless : + bool -> + (unit -> (unit, 'trace) result Lwt.t) -> + (unit, 'trace) result Lwt.t - val _when : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t + val _when : + bool -> + (unit -> (unit, 'trace) result Lwt.t) -> + (unit, 'trace) result Lwt.t (** Wrapper around [Lwt_utils.dont_wait] *) val dont_wait : (exn -> unit) -> - (error trace -> unit) -> - (unit -> unit tzresult Lwt.t) -> + ('trace -> unit) -> + (unit -> (unit, 'trace) result Lwt.t) -> unit (** {2 In-monad list iterators} *) (** A {!List.iter} in the monad *) - val iter : ('a -> unit tzresult) -> 'a list -> unit tzresult + val iter : ('a -> (unit, 'trace) result) -> 'a list -> (unit, 'trace) result - val iter_s : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t + val iter_s : + ('a -> (unit, 'trace) result Lwt.t) -> + 'a list -> + (unit, 'trace) result Lwt.t - val iter_p : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t + val iter_p : + ('a -> (unit, 'err trace) result Lwt.t) -> + 'a list -> + (unit, 'err trace) result Lwt.t val iteri_p : - (int -> 'a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t + (int -> 'a -> (unit, 'err trace) result Lwt.t) -> + 'a list -> + (unit, 'err trace) result Lwt.t (** @raise [Invalid_argument] if provided two lists of different lengths. *) val iter2_p : - ('a -> 'b -> unit tzresult Lwt.t) -> + ('a -> 'b -> (unit, 'err trace) result Lwt.t) -> 'a list -> 'b list -> - unit tzresult Lwt.t + (unit, 'err trace) result Lwt.t (** @raise [Invalid_argument] if provided two lists of different lengths. *) val iteri2_p : - (int -> 'a -> 'b -> unit tzresult Lwt.t) -> + (int -> 'a -> 'b -> (unit, 'err trace) result Lwt.t) -> 'a list -> 'b list -> - unit tzresult Lwt.t + (unit, 'err trace) result Lwt.t (** A {!List.map} in the monad *) - val map : ('a -> 'b tzresult) -> 'a list -> 'b list tzresult + val map : ('a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result - val mapi : (int -> 'a -> 'b tzresult) -> 'a list -> 'b list tzresult + val mapi : + (int -> 'a -> ('b, 'trace) result) -> 'a list -> ('b list, 'trace) result - val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + val map_s : + ('a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t val rev_map_s : - ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + ('a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t - val map_p : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + val map_p : + ('a -> ('b, 'err trace) result Lwt.t) -> + 'a list -> + ('b list, 'err trace) result Lwt.t val mapi_s : - (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + (int -> 'a -> ('b, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t val mapi_p : - (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + (int -> 'a -> ('b, 'err trace) result Lwt.t) -> + 'a list -> + ('b list, 'err trace) result Lwt.t (** A {!List.map2} in the monad. @raise [Invalid_argument] if provided two lists of different lengths. *) val map2 : - ('a -> 'b -> 'c tzresult) -> 'a list -> 'b list -> 'c list tzresult + ('a -> 'b -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + ('c list, 'trace) result (** @raise [Invalid_argument] if provided two lists of different lengths. *) val mapi2 : - (int -> 'a -> 'b -> 'c tzresult) -> 'a list -> 'b list -> 'c list tzresult + (int -> 'a -> 'b -> ('c, 'trace) result) -> + 'a list -> + 'b list -> + ('c list, 'trace) result (** @raise [Invalid_argument] if provided two lists of different lengths. *) val map2_s : - ('a -> 'b -> 'c tzresult Lwt.t) -> + ('a -> 'b -> ('c, 'trace) result Lwt.t) -> 'a list -> 'b list -> - 'c list tzresult Lwt.t + ('c list, 'trace) result Lwt.t (** @raise [Invalid_argument] if provided two lists of different lengths. *) val mapi2_s : - (int -> 'a -> 'b -> 'c tzresult Lwt.t) -> + (int -> 'a -> 'b -> ('c, 'trace) result Lwt.t) -> 'a list -> 'b list -> - 'c list tzresult Lwt.t + ('c list, 'trace) result Lwt.t (** A {!List.filter_map} in the monad *) val filter_map_s : - ('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + ('a -> ('b option, 'trace) result Lwt.t) -> + 'a list -> + ('b list, 'trace) result Lwt.t val filter_map_p : - ('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t + ('a -> ('b option, 'err trace) result Lwt.t) -> + 'a list -> + ('b list, 'err trace) result Lwt.t (** A {!List.filter} in the monad *) - val filter : ('a -> bool tzresult) -> 'a list -> 'a list tzresult + val filter : + ('a -> (bool, 'trace) result) -> 'a list -> ('a list, 'trace) result val filter_s : - ('a -> bool tzresult Lwt.t) -> 'a list -> 'a list tzresult Lwt.t + ('a -> (bool, 'trace) result Lwt.t) -> + 'a list -> + ('a list, 'trace) result Lwt.t val filter_p : - ('a -> bool tzresult Lwt.t) -> 'a list -> 'a list tzresult Lwt.t + ('a -> (bool, 'err trace) result Lwt.t) -> + 'a list -> + ('a list, 'err trace) result Lwt.t (** A {!List.fold_left} in the monad *) val fold_left_s : - ('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b list -> 'a tzresult Lwt.t + ('a -> 'b -> ('a, 'trace) result Lwt.t) -> + 'a -> + 'b list -> + ('a, 'trace) result Lwt.t (** A {!List.fold_right} in the monad *) val fold_right_s : - ('a -> 'b -> 'b tzresult Lwt.t) -> 'a list -> 'b -> 'b tzresult Lwt.t + ('a -> 'b -> ('b, 'trace) result Lwt.t) -> + 'a list -> + 'b -> + ('b, 'trace) result Lwt.t (** A few aliases for Lwt functions *) val join_p : unit Lwt.t list -> unit Lwt.t @@ -427,19 +524,26 @@ module type MONAD = sig val both_p : 'a Lwt.t -> 'b Lwt.t -> ('a * 'b) Lwt.t (** Similar functions in the error monad *) - val join_e : unit tzresult list -> unit tzresult + val join_e : (unit, 'err trace) result list -> (unit, 'err trace) result - val all_e : 'a tzresult list -> 'a list tzresult + val all_e : ('a, 'err trace) result list -> ('a list, 'err trace) result - val both_e : 'a tzresult -> 'b tzresult -> ('a * 'b) tzresult + 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 tzresult Lwt.t list -> unit tzresult Lwt.t + val join_ep : + (unit, 'err trace) result Lwt.t list -> (unit, 'err trace) result Lwt.t - val all_ep : 'a tzresult Lwt.t list -> 'a list tzresult Lwt.t + val all_ep : + ('a, 'err trace) result Lwt.t list -> ('a list, 'err trace) result Lwt.t val both_ep : - 'a tzresult Lwt.t -> 'b tzresult Lwt.t -> ('a * 'b) tzresult Lwt.t + ('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 -- GitLab From 684a35cecbfab9b0baa28f3546af2a365d31296b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 5 Aug 2020 16:51:41 +0200 Subject: [PATCH 4/6] Error_monad: remove now dead-code from generalised monad --- src/lib_error_monad/TzMonad.ml | 2 +- src/lib_error_monad/TzMonad.mli | 5 +---- src/lib_error_monad/error_monad.mli | 5 +---- src/lib_error_monad/monad_ext_maker.ml | 10 +++++----- src/lib_error_monad/monad_ext_maker.mli | 4 +--- src/lib_error_monad/monad_maker.ml | 6 ++---- src/lib_error_monad/monad_maker.mli | 6 ++---- src/lib_error_monad/sig.ml | 14 -------------- src/lib_protocol_environment/environment_V0.ml | 3 +-- 9 files changed, 14 insertions(+), 41 deletions(-) diff --git a/src/lib_error_monad/TzMonad.ml b/src/lib_error_monad/TzMonad.ml index 4a47da1e151b..f4fac0da176f 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 (TzCore) (TzTrace) +module Monad = Monad_maker.Make (TzTrace) 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 64f926665a3a..27e12eb34cdb 100644 --- a/src/lib_error_monad/TzMonad.mli +++ b/src/lib_error_monad/TzMonad.mli @@ -26,10 +26,7 @@ type error = TzCore.error = .. -include - Sig.MONAD - with type error := error - and type 'error trace := 'error TzTrace.trace +include Sig.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 3e3405dc9d66..b7b6c2ad72e1 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -44,10 +44,7 @@ module TzTrace : Sig.TRACE with type 'error trace = 'error list type 'error trace = 'error TzTrace.trace -include - Sig.MONAD - with type error := error - and type 'error trace := 'error TzTrace.trace +include Sig.MONAD with type 'error trace := 'error TzTrace.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 43faa2b1fc51..4be2d0cedae1 100644 --- a/src/lib_error_monad/monad_ext_maker.ml +++ b/src/lib_error_monad/monad_ext_maker.ml @@ -31,14 +31,14 @@ module Make (Error : sig include Sig.EXT with type error := error end) (Trace : Sig.TRACE) -(Monad : Sig.MONAD - with type error := Error.error - and type 'error trace := 'error Trace.trace) : +(Monad : Sig.MONAD with type 'error trace := 'error Trace.trace) : Sig.MONAD_EXT with type error := Error.error and type 'error trace := 'error Trace.trace = struct - type tztrace = Error.error Trace.trace - type 'a tzresult = ('a, tztrace) result + type tztrace = Error.error Trace.trace + + type 'a tzresult = ('a, tztrace) result + let trace_encoding = Trace.encoding Error.error_encoding let result_encoding a_encoding = diff --git a/src/lib_error_monad/monad_ext_maker.mli b/src/lib_error_monad/monad_ext_maker.mli index b318a4a8080f..a50448478c28 100644 --- a/src/lib_error_monad/monad_ext_maker.mli +++ b/src/lib_error_monad/monad_ext_maker.mli @@ -31,9 +31,7 @@ module Make (Error : sig include Sig.EXT with type error := error end) (Trace : Sig.TRACE) -(Monad : Sig.MONAD - with type error := Error.error - and type 'error trace := 'error Trace.trace) : +(Monad : Sig.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 index 22f6ef5c1929..051242fe8153 100644 --- a/src/lib_error_monad/monad_maker.ml +++ b/src/lib_error_monad/monad_maker.ml @@ -23,10 +23,8 @@ (* *) (*****************************************************************************) -module Make (Error : Sig.CORE) (Trace : Sig.TRACE) : - Sig.MONAD - with type error := Error.error - and type 'err trace := 'err Trace.trace = struct +module Make (Trace : Sig.TRACE) : + Sig.MONAD with type 'err trace := 'err Trace.trace = struct let ( >>= ) = Lwt.( >>= ) let[@inline] ok v = Ok v diff --git a/src/lib_error_monad/monad_maker.mli b/src/lib_error_monad/monad_maker.mli index 41e5d434102d..541d04a429df 100644 --- a/src/lib_error_monad/monad_maker.mli +++ b/src/lib_error_monad/monad_maker.mli @@ -23,7 +23,5 @@ (* *) (*****************************************************************************) -module Make (Error : Sig.CORE) (Trace : Sig.TRACE) : - Sig.MONAD - with type error := Error.error - and type 'err trace := 'err Trace.trace +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 b18127432735..45d90891aaab 100644 --- a/src/lib_error_monad/sig.ml +++ b/src/lib_error_monad/sig.ml @@ -227,20 +227,6 @@ module type TRACE = sig end module type MONAD = sig - (** This type is meant to be substituted/constrained. The intended use is - along the following lines: - - [module Foo : sig - include CORE - include MONAD with type error := error - end = struct - ... - end] - - See core.mli and monad.mli as examples. - *) - type error - (** To be subsituted/constrained *) type 'err trace diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 414cab6517c3..95d26c44cfa8 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -530,8 +530,7 @@ struct type error_category = [`Branch | `Temporary | `Permanent] include Error_core - module Local_monad = - Tezos_error_monad.Monad_maker.Make (Error_core) (TzTrace) + module Local_monad = Tezos_error_monad.Monad_maker.Make (TzTrace) include Local_monad include Tezos_error_monad.Monad_ext_maker.Make (Error_core) (TzTrace) (Local_monad) -- GitLab From 6e449b79b4e60fd5a95e59080b27474eaa7e3ea6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 5 Aug 2020 16:17:31 +0200 Subject: [PATCH 5/6] Lwtreslib: generalise traversors. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Mehdi Bouaziz Co-authored-by: Raphaël Proust --- src/lib_lwt_result_stdlib/functors/hashtbl.ml | 14 ++- .../functors/hashtbl.mli | 12 +- src/lib_lwt_result_stdlib/functors/map.ml | 2 +- src/lib_lwt_result_stdlib/functors/map.mli | 2 +- src/lib_lwt_result_stdlib/functors/set.ml | 2 +- src/lib_lwt_result_stdlib/functors/set.mli | 2 +- src/lib_lwt_result_stdlib/lib/hashtbl.mli | 11 +- src/lib_lwt_result_stdlib/lib/map.mli | 2 +- src/lib_lwt_result_stdlib/lib/seq.ml | 5 +- src/lib_lwt_result_stdlib/lib/seq.mli | 4 +- src/lib_lwt_result_stdlib/lib/set.mli | 2 +- src/lib_lwt_result_stdlib/sigs/hashtbl.ml | 99 +++++++++-------- src/lib_lwt_result_stdlib/sigs/map.ml | 21 ++-- src/lib_lwt_result_stdlib/sigs/monad.ml | 103 +++++++++--------- src/lib_lwt_result_stdlib/sigs/seq.ml | 60 ++++------ src/lib_lwt_result_stdlib/sigs/set.ml | 16 +-- 16 files changed, 183 insertions(+), 174 deletions(-) diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.ml b/src/lib_lwt_result_stdlib/functors/hashtbl.ml index bcddc5a5621f..e773ab31c54a 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.ml @@ -34,10 +34,8 @@ module Make (Seq : Sigs.Seq.S) = struct let seeded_hash_param ~meaningful ~total seed v = Stdlib.Hashtbl.seeded_hash_param meaningful total seed v - module type S = Sigs.Hashtbl.S with type error := Seq.Monad.out_error - - module type SeededS = - Sigs.Hashtbl.SeededS with type error := Seq.Monad.out_error + module type S = + Sigs.Hashtbl.S with type 'error trace := 'error Seq.Monad.trace module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t = struct open Seq @@ -70,6 +68,9 @@ module Make (Seq : Sigs.Seq.S) = struct t end + module type SeededS = + Sigs.Hashtbl.SeededS with type 'error trace := 'error Seq.Monad.trace + module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : SeededS with type key = H.t = struct open Seq @@ -102,7 +103,8 @@ module Make (Seq : Sigs.Seq.S) = struct t end - module type S_LWT = Sigs.Hashtbl.S_LWT with type error := Seq.Monad.out_error + module type S_LWT = + Sigs.Hashtbl.S_LWT with type 'error trace := 'error Seq.Monad.trace module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t = struct @@ -112,7 +114,7 @@ module Make (Seq : Sigs.Seq.S) = struct type key = H.t - type 'a t = ('a, Seq.Monad.out_error) result Lwt.t T.t + type ('a, 'trace) t = ('a, 'trace) result Lwt.t T.t let create n = T.create n diff --git a/src/lib_lwt_result_stdlib/functors/hashtbl.mli b/src/lib_lwt_result_stdlib/functors/hashtbl.mli index 043f019007e1..a170341e4919 100644 --- a/src/lib_lwt_result_stdlib/functors/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/functors/hashtbl.mli @@ -35,17 +35,19 @@ module Make (Seq : Sigs.Seq.S) : sig val seeded_hash_param : meaningful:int -> total:int -> int -> 'a -> int - module type S = Sigs.Hashtbl.S with type error := Seq.Monad.out_error - - module type SeededS = - Sigs.Hashtbl.SeededS with type error := Seq.Monad.out_error + module type S = + Sigs.Hashtbl.S with type 'error trace := 'error Seq.Monad.trace module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t + module type SeededS = + Sigs.Hashtbl.SeededS with type 'error trace := 'error Seq.Monad.trace + module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : SeededS with type key = H.t - module type S_LWT = Sigs.Hashtbl.S_LWT with type error := Seq.Monad.out_error + module type S_LWT = + Sigs.Hashtbl.S_LWT with type 'error trace := 'error Seq.Monad.trace module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t end diff --git a/src/lib_lwt_result_stdlib/functors/map.ml b/src/lib_lwt_result_stdlib/functors/map.ml index d5e43e1d51c5..a2d16cac4196 100644 --- a/src/lib_lwt_result_stdlib/functors/map.ml +++ b/src/lib_lwt_result_stdlib/functors/map.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) = struct - module type S = Sigs.Map.S with type error := Seq.Monad.out_error + module type S = Sigs.Map.S with type 'error trace := 'error Seq.Monad.trace module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t = struct open Seq diff --git a/src/lib_lwt_result_stdlib/functors/map.mli b/src/lib_lwt_result_stdlib/functors/map.mli index 423803dae6f1..22381f149416 100644 --- a/src/lib_lwt_result_stdlib/functors/map.mli +++ b/src/lib_lwt_result_stdlib/functors/map.mli @@ -24,7 +24,7 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) : sig - module type S = Sigs.Map.S with type error := Seq.Monad.out_error + module type S = Sigs.Map.S with type 'error trace := 'error Seq.Monad.trace module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t end diff --git a/src/lib_lwt_result_stdlib/functors/set.ml b/src/lib_lwt_result_stdlib/functors/set.ml index 5a10e59eb9ba..a4e0dc46f150 100644 --- a/src/lib_lwt_result_stdlib/functors/set.ml +++ b/src/lib_lwt_result_stdlib/functors/set.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) = struct - module type S = Sigs.Set.S with type error := Seq.Monad.out_error + module type S = Sigs.Set.S with type 'error trace := 'error Seq.Monad.trace module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t = struct open Seq diff --git a/src/lib_lwt_result_stdlib/functors/set.mli b/src/lib_lwt_result_stdlib/functors/set.mli index 27f62475a57c..b55a257f44d2 100644 --- a/src/lib_lwt_result_stdlib/functors/set.mli +++ b/src/lib_lwt_result_stdlib/functors/set.mli @@ -24,7 +24,7 @@ (*****************************************************************************) module Make (Seq : Sigs.Seq.S) : sig - module type S = Sigs.Set.S with type error := Seq.Monad.out_error + module type S = Sigs.Set.S with type 'error trace := 'error Seq.Monad.trace module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t end diff --git a/src/lib_lwt_result_stdlib/lib/hashtbl.mli b/src/lib_lwt_result_stdlib/lib/hashtbl.mli index 4cf52134175a..7c6a9ee16098 100644 --- a/src/lib_lwt_result_stdlib/lib/hashtbl.mli +++ b/src/lib_lwt_result_stdlib/lib/hashtbl.mli @@ -31,17 +31,18 @@ val hash_param : meaningful:int -> total:int -> 'a -> int val seeded_hash_param : meaningful:int -> total:int -> int -> 'a -> int -module type S = Sigs.Hashtbl.S with type error := Error_monad.error list - -module type SeededS = - Sigs.Hashtbl.SeededS with type error := Error_monad.error list +module type S = + Sigs.Hashtbl.S with type 'error trace := 'error Error_monad.trace module Make (H : Stdlib.Hashtbl.HashedType) : S with type key = H.t +module type SeededS = + Sigs.Hashtbl.SeededS with type 'error trace := 'error Error_monad.trace + module MakeSeeded (H : Stdlib.Hashtbl.SeededHashedType) : SeededS with type key = H.t module type S_LWT = - Sigs.Hashtbl.S_LWT with type error := Error_monad.error list + Sigs.Hashtbl.S_LWT with type 'error trace := 'error Seq.Monad.trace module Make_Lwt (H : Stdlib.Hashtbl.HashedType) : S_LWT with type key = H.t diff --git a/src/lib_lwt_result_stdlib/lib/map.mli b/src/lib_lwt_result_stdlib/lib/map.mli index a6a303cfd664..ec82c946a776 100644 --- a/src/lib_lwt_result_stdlib/lib/map.mli +++ b/src/lib_lwt_result_stdlib/lib/map.mli @@ -23,6 +23,6 @@ (* *) (*****************************************************************************) -module type S = Sigs.Map.S with type error := Error_monad.error list +module type S = Sigs.Map.S with type 'error trace := 'error Seq.Monad.trace module Make (Ord : Stdlib.Map.OrderedType) : S with type key = Ord.t diff --git a/src/lib_lwt_result_stdlib/lib/seq.ml b/src/lib_lwt_result_stdlib/lib/seq.ml index af36f89cc676..6fc48d3833d2 100644 --- a/src/lib_lwt_result_stdlib/lib/seq.ml +++ b/src/lib_lwt_result_stdlib/lib/seq.ml @@ -24,9 +24,6 @@ (*****************************************************************************) include Functors.Seq.Make (struct - type in_error = Error_monad.error - - type out_error = Error_monad.error TzTrace.trace - + include Tezos_error_monad.TzTrace include Tezos_error_monad.TzMonad end) diff --git a/src/lib_lwt_result_stdlib/lib/seq.mli b/src/lib_lwt_result_stdlib/lib/seq.mli index 0376a707e72f..ef36805351ae 100644 --- a/src/lib_lwt_result_stdlib/lib/seq.mli +++ b/src/lib_lwt_result_stdlib/lib/seq.mli @@ -25,5 +25,5 @@ include Sigs.Seq.S - with type Monad.in_error = Error_monad.error - and type Monad.out_error = Error_monad.error list + with type Monad.error = Error_monad.error + and type 'error Monad.trace = 'error Error_monad.trace diff --git a/src/lib_lwt_result_stdlib/lib/set.mli b/src/lib_lwt_result_stdlib/lib/set.mli index a9fae50ff217..47bf1cacc95d 100644 --- a/src/lib_lwt_result_stdlib/lib/set.mli +++ b/src/lib_lwt_result_stdlib/lib/set.mli @@ -23,6 +23,6 @@ (* *) (*****************************************************************************) -module type S = Sigs.Set.S with type error := Error_monad.error list +module type S = Sigs.Set.S with type 'error trace := 'error Seq.Monad.trace module Make (Ord : Stdlib.Map.OrderedType) : S with type elt = Ord.t diff --git a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml index 5463affc28e1..1b28b69ad890 100644 --- a/src/lib_lwt_result_stdlib/sigs/hashtbl.ml +++ b/src/lib_lwt_result_stdlib/sigs/hashtbl.ml @@ -27,7 +27,7 @@ than raising [Not_found]) extensions of [Hashtbl.S] with some Lwt- and Error-aware traversal functions. *) module type S = sig - type error + type 'error trace type key @@ -58,34 +58,37 @@ module type S = sig val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t val iter_e : - (key -> 'a -> (unit, error) result) -> 'a t -> (unit, error) result + (key -> 'a -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result val iter_es : - (key -> 'a -> (unit, error) result Lwt.t) -> + (key -> 'a -> (unit, 'trace) result Lwt.t) -> 'a t -> - (unit, error) result Lwt.t + (unit, 'trace) result Lwt.t val iter_ep : - (key -> 'a -> (unit, error) result Lwt.t) -> + (key -> 'a -> (unit, 'error trace) result Lwt.t) -> 'a t -> - (unit, error) result Lwt.t + (unit, 'error trace) result Lwt.t val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit - val try_map_inplace : (key -> 'a -> ('a, error) result) -> 'a t -> unit + val try_map_inplace : (key -> 'a -> ('a, 'trace) result) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_s : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t val fold_e : - (key -> 'a -> 'b -> ('b, error) result) -> 'a t -> 'b -> ('b, error) result + (key -> 'a -> 'b -> ('b, 'trace) result) -> + 'a t -> + 'b -> + ('b, 'trace) result val fold_es : - (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> + (key -> 'a -> 'b -> ('b, 'trace) result Lwt.t) -> 'a t -> 'b -> - ('b, error) result Lwt.t + ('b, 'trace) result Lwt.t val length : 'a t -> int @@ -105,7 +108,7 @@ module type S = sig end module type SeededS = sig - type error + type 'error trace type key @@ -136,34 +139,37 @@ module type SeededS = sig val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t val iter_e : - (key -> 'a -> (unit, error) result) -> 'a t -> (unit, error) result + (key -> 'a -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result val iter_es : - (key -> 'a -> (unit, error) result Lwt.t) -> + (key -> 'a -> (unit, 'trace) result Lwt.t) -> 'a t -> - (unit, error) result Lwt.t + (unit, 'trace) result Lwt.t val iter_ep : - (key -> 'a -> (unit, error) result Lwt.t) -> + (key -> 'a -> (unit, 'error trace) result Lwt.t) -> 'a t -> - (unit, error) result Lwt.t + (unit, 'error trace) result Lwt.t val filter_map_inplace : (key -> 'a -> 'a option) -> 'a t -> unit - val try_map_inplace : (key -> 'a -> ('a, error) result) -> 'a t -> unit + val try_map_inplace : (key -> 'a -> ('a, 'trace) result) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_s : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t val fold_e : - (key -> 'a -> 'b -> ('b, error) result) -> 'a t -> 'b -> ('b, error) result + (key -> 'a -> 'b -> ('b, 'trace) result) -> + 'a t -> + 'b -> + ('b, 'trace) result val fold_es : - (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> + (key -> 'a -> 'b -> ('b, 'trace) result Lwt.t) -> 'a t -> 'b -> - ('b, error) result Lwt.t + ('b, 'trace) result Lwt.t val length : 'a t -> int @@ -236,20 +242,20 @@ end [reset], or just [remove]), the promise is canceled. *) module type S_LWT = sig - type error + type 'error trace type key - type 'a t + type ('a, 'trace) t - val create : int -> 'a t + val create : int -> ('a, 'trace) t (** [clear tbl] cancels and removes all the promises in [tbl]. *) - val clear : 'a t -> unit + val clear : ('a, 'trace) t -> unit (** [reset tbl] cancels and removes all the promises in [tbl], and resizes [tbl] to its initial size. *) - val reset : 'a t -> unit + val reset : ('a, 'trace) t -> unit (** [find_or_make tbl k make] behaves differently depending on [k] being bound in [tbl]: @@ -265,18 +271,18 @@ module type S_LWT = sig resolved, it may be removed automatically from [tbl] as described above. *) val find_or_make : - 'a t -> + ('a, 'trace) t -> key -> - (unit -> ('a, error) result Lwt.t) -> - ('a, error) result Lwt.t + (unit -> ('a, 'trace) result Lwt.t) -> + ('a, 'trace) result Lwt.t (** [remove tbl k] cancels the promise bound to [k] in [tbl] and removes it. If [k] is not bound in [tbl] it does nothing. *) - val remove : 'a t -> key -> unit + val remove : ('a, 'trace) t -> key -> unit - val find : 'a t -> key -> ('a, error) result Lwt.t option + val find : ('a, 'trace) t -> key -> ('a, 'trace) result Lwt.t option - val mem : 'a t -> key -> bool + val mem : ('a, 'trace) t -> key -> bool (** [iter_with_waiting_es f tbl] iterates [f] over the bindings in [tbl]. @@ -290,9 +296,9 @@ module type S_LWT = sig promise to resolve and then the call promise to resolve before continuing to the next binding. *) val iter_with_waiting_es : - (key -> 'a -> (unit, error) result Lwt.t) -> - 'a t -> - (unit, error) result Lwt.t + (key -> 'a -> (unit, 'trace) result Lwt.t) -> + ('a, 'trace) t -> + (unit, 'trace) result Lwt.t (** [iter_with_waiting_ep f tbl] iterates [f] over the bindings in [tbl]. @@ -307,9 +313,9 @@ module type S_LWT = sig It processes all bindings concurrently: it concurrently waits for all the bound promises to resolve and calls [f] as they resolve. *) val iter_with_waiting_ep : - (key -> 'a -> (unit, error) result Lwt.t) -> - 'a t -> - (unit, error) result Lwt.t + (key -> 'a -> (unit, 'error trace) result Lwt.t) -> + ('a, 'error trace) t -> + (unit, 'error trace) result Lwt.t (** [fold_with_waiting_es f tbl init] folds [init] with [f] over the bindings in [tbl]. @@ -321,12 +327,12 @@ module type S_LWT = sig It processes bindings one after the other. *) val fold_with_waiting_es : - (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> - 'a t -> + (key -> 'a -> 'b -> ('b, 'trace) result Lwt.t) -> + ('a, 'trace) t -> 'b -> - ('b, error) result Lwt.t + ('b, 'trace) result Lwt.t - val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b + val fold_keys : (key -> 'b -> 'b) -> ('a, 'trace) t -> 'b -> 'b (** [fold_promises f tbl init] folds over the table, passing the raw promises to [f]. This means that [f] can observe [Error]/rejections. @@ -334,14 +340,17 @@ module type S_LWT = sig This can be used to, e.g., count the number of resolved/unresolved promises. *) val fold_promises : - (key -> ('a, error) result Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b + (key -> ('a, 'trace) result Lwt.t -> 'b -> 'b) -> + ('a, 'trace) t -> + 'b -> + 'b (** [fold_resolved f tbl init] folds over the already resolved promises of [tbl]. More specifically, it folds over the [v] for all the promises fulfilled with [Ok v] that are bound in [tbl]. *) - val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val fold_resolved : (key -> 'a -> 'b -> 'b) -> ('a, 'trace) t -> 'b -> 'b - val length : 'a t -> int + val length : ('a, 'trace) t -> int - val stats : 'a t -> Stdlib.Hashtbl.statistics + val stats : ('a, 'trace) t -> Stdlib.Hashtbl.statistics end diff --git a/src/lib_lwt_result_stdlib/sigs/map.ml b/src/lib_lwt_result_stdlib/sigs/map.ml index 3e73e3292374..093477535155 100644 --- a/src/lib_lwt_result_stdlib/sigs/map.ml +++ b/src/lib_lwt_result_stdlib/sigs/map.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module type S = sig - type error (* for substitution/constraint *) + type 'error trace type key @@ -61,7 +61,7 @@ module type S = sig [Error e] then the iteration stops and the result of the iteration is [Error e]. *) val iter_e : - (key -> 'a -> (unit, error) result) -> 'a t -> (unit, error) result + (key -> 'a -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t @@ -73,18 +73,18 @@ module type S = sig the applications results in [Error e] then the iteration stops and the result of the iteration is [Error e]. *) val iter_es : - (key -> 'a -> (unit, error) result Lwt.t) -> + (key -> 'a -> (unit, 'trace) result Lwt.t) -> 'a t -> - (unit, error) result Lwt.t + (unit, 'trace) result Lwt.t (** [iter_ep f m] applies [f] to the bindings of [m]. All the applications are done concurrently. If all the applications result in [Ok ()], then the result of the iteration is [Ok ()]. If any of the applications results in [Error e] then the result of the iteration is [Error e]. *) val iter_ep : - (key -> 'a -> (unit, error) result Lwt.t) -> + (key -> 'a -> (unit, 'error trace) result Lwt.t) -> 'a t -> - (unit, error) result Lwt.t + (unit, 'error trace) result Lwt.t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b @@ -92,7 +92,10 @@ module type S = sig [f k1 d1 init >>? fun acc -> f k2 d2 acc >>? fun acc -> …] where [kN] is the key bound to [dN] in [m]. *) val fold_e : - (key -> 'a -> 'b -> ('b, error) result) -> 'a t -> 'b -> ('b, error) result + (key -> 'a -> 'b -> ('b, 'trace) result) -> + 'a t -> + 'b -> + ('b, 'trace) result val fold_s : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t @@ -100,10 +103,10 @@ module type S = sig [f k1 d1 init >>=? fun acc -> f k2 d2 acc >>=? fun acc -> …] where [kN] is the key bound to [dN] in [m]. *) val fold_es : - (key -> 'a -> 'b -> ('b, error) result Lwt.t) -> + (key -> 'a -> 'b -> ('b, 'trace) result Lwt.t) -> 'a t -> 'b -> - ('b, error) result Lwt.t + ('b, 'trace) result Lwt.t val for_all : (key -> 'a -> bool) -> 'a t -> bool diff --git a/src/lib_lwt_result_stdlib/sigs/monad.ml b/src/lib_lwt_result_stdlib/sigs/monad.ml index 6920de28e070..55b034c3ac2d 100644 --- a/src/lib_lwt_result_stdlib/sigs/monad.ml +++ b/src/lib_lwt_result_stdlib/sigs/monad.ml @@ -27,78 +27,82 @@ this library. [S] describes a generic Lwt-Result combined monad, the rest of this library builds upon. *) module type S = sig - (** [in_error] are the errors as injected into the monad. In other words, - [in_error] is the type of values that are used in primitives that "raise" + (** [error] are the errors as injected into the monad. In other words, + [error] is the type of values that are used in primitives that "raise" an error. *) - type in_error + type error - (** [out_error] are the errors as received from the monad. In other words, - [out_error] is the type of values that are seen when matching on [Error _] + (** [trace] are the errors as received from the monad. In other words, + [trace] is the type of values that are seen when matching on [Error _] to, say, recover. - The types [in_error] and [out_error] are kept separate (although they can + The types [error] and ['error trace] are kept separate (although they can be equal) to support cases such as the following: - - [out_error] are richer than [in_error], such as by including a + - [trace] are richer than [error], such as by including a timestamp, a filename, or some other such metadata. - - [out_error] is slightly different and [private] and [in_error] is simply + - [trace] is slightly different and [private] and [error] is simply the type of argument to the functions that construct the private - [out_error]. - - [out_error] is a collection of [in_error] and additional functions (not + [trace]. + - [trace] is a collection of [error] and additional functions (not required by this library) allow additional manipulation. E.g., in the case of Tezos: errors are built into traces that can be grown. *) - type out_error + type 'error trace + + val make : 'error -> 'error trace + + val cons : 'error -> 'error trace -> 'error trace + + val conp : 'error trace -> 'error trace -> 'error trace (** result monad *) - val ok : 'a -> ('a, out_error) result + val ok : 'a -> ('a, 'trace) result - val ok_unit : (unit, out_error) result + val ok_unit : (unit, 'trace) result - val ok_none : ('a option, out_error) result + val ok_none : ('a option, 'trace) result - val ok_some : 'a -> ('a option, out_error) result + val ok_some : 'a -> ('a option, 'trace) result - val ok_nil : ('a list, out_error) result + val ok_nil : ('a list, 'trace) result - val ok_true : (bool, out_error) result + val ok_true : (bool, 'trace) result - val ok_false : (bool, out_error) result + val ok_false : (bool, 'trace) result - val error : in_error -> ('a, out_error) result + val error : 'error -> ('a, 'error trace) result val ( >>? ) : - ('a, out_error) result -> - ('a -> ('b, out_error) result) -> - ('b, out_error) result + ('a, 'trace) result -> ('a -> ('b, 'trace) result) -> ('b, 'trace) result - val ( >|? ) : ('a, out_error) result -> ('a -> 'b) -> ('b, out_error) result + val ( >|? ) : ('a, 'trace) result -> ('a -> 'b) -> ('b, 'trace) result (** lwt-result combined monad *) - val return : 'a -> ('a, out_error) result Lwt.t + val return : 'a -> ('a, 'trace) result Lwt.t - val return_unit : (unit, out_error) result Lwt.t + val return_unit : (unit, 'trace) result Lwt.t - val return_none : ('a option, out_error) result Lwt.t + val return_none : ('a option, 'trace) result Lwt.t - val return_some : 'a -> ('a option, out_error) result Lwt.t + val return_some : 'a -> ('a option, 'trace) result Lwt.t - val return_nil : ('a list, out_error) result Lwt.t + val return_nil : ('a list, 'trace) result Lwt.t - val return_true : (bool, out_error) result Lwt.t + val return_true : (bool, 'trace) result Lwt.t - val return_false : (bool, out_error) result Lwt.t + val return_false : (bool, 'trace) result Lwt.t - val fail : in_error -> ('a, out_error) result Lwt.t + val fail : 'error -> ('a, 'error trace) result Lwt.t val ( >>=? ) : - ('a, out_error) result Lwt.t -> - ('a -> ('b, out_error) result Lwt.t) -> - ('b, out_error) result Lwt.t + ('a, 'trace) result Lwt.t -> + ('a -> ('b, 'trace) result Lwt.t) -> + ('b, 'trace) result Lwt.t val ( >|=? ) : - ('a, out_error) result Lwt.t -> ('a -> 'b) -> ('b, out_error) result Lwt.t + ('a, 'trace) result Lwt.t -> ('a -> 'b) -> ('b, 'trace) result Lwt.t (** Mixing operators *) @@ -110,22 +114,22 @@ module type S = sig only used for operator that are within both monads. *) val ( >>?= ) : - ('a, out_error) result -> - ('a -> ('b, out_error) result Lwt.t) -> - ('b, out_error) result Lwt.t + ('a, 'trace) result -> + ('a -> ('b, 'trace) result Lwt.t) -> + ('b, 'trace) result Lwt.t val ( >|?= ) : - ('a, out_error) result -> ('a -> 'b Lwt.t) -> ('b, out_error) result Lwt.t + ('a, 'trace) result -> ('a -> 'b Lwt.t) -> ('b, 'trace) result Lwt.t (** joins *) - val join_e : (unit, out_error) result list -> (unit, out_error) result + val join_e : (unit, 'error trace) result list -> (unit, 'error trace) result - val all_e : ('a, out_error) result list -> ('a list, out_error) result + val all_e : ('a, 'error trace) result list -> ('a list, 'error trace) result val both_e : - ('a, out_error) result -> - ('b, out_error) result -> - ('a * 'b, out_error) result + ('a, 'error trace) result -> + ('b, 'error trace) result -> + ('a * 'b, 'error trace) result val join_p : unit Lwt.t list -> unit Lwt.t @@ -134,13 +138,14 @@ module type S = sig val both_p : 'a Lwt.t -> 'b Lwt.t -> ('a * 'b) Lwt.t val join_ep : - (unit, out_error) result Lwt.t list -> (unit, out_error) result Lwt.t + (unit, 'error trace) result Lwt.t list -> (unit, 'error trace) result Lwt.t val all_ep : - ('a, out_error) result Lwt.t list -> ('a list, out_error) result Lwt.t + ('a, 'error trace) result Lwt.t list -> + ('a list, 'error trace) result Lwt.t val both_ep : - ('a, out_error) result Lwt.t -> - ('b, out_error) result Lwt.t -> - ('a * 'b, out_error) result Lwt.t + ('a, 'error trace) result Lwt.t -> + ('b, 'error trace) result Lwt.t -> + ('a * 'b, 'error trace) result Lwt.t end diff --git a/src/lib_lwt_result_stdlib/sigs/seq.ml b/src/lib_lwt_result_stdlib/sigs/seq.ml index fc3e842f7caf..3cd7384eefd3 100644 --- a/src/lib_lwt_result_stdlib/sigs/seq.ml +++ b/src/lib_lwt_result_stdlib/sigs/seq.ml @@ -60,7 +60,7 @@ module type S = sig module Monad : Monad.S - open Monad (* for [error] *) + open Monad (* for [error]/[trace] *) (** including the OCaml's {!Stdlib.Seq} module to share the {!Seq.t} type (including concrete definition) and to bring the existing functions. *) @@ -71,21 +71,18 @@ module type S = sig (** in-monad, preallocated empty/nil *) - val ok_empty : ('a t, out_error) result + val ok_empty : ('a t, 'trace) result - val return_empty : ('a t, out_error) result Lwt.t + val return_empty : ('a t, 'trace) result Lwt.t - val ok_nil : ('a node, out_error) result + val ok_nil : ('a node, 'trace) result - val return_nil : ('a node, out_error) result Lwt.t + val return_nil : ('a node, 'trace) result Lwt.t (** Similar to {!fold_left} but wraps the traversal in {!result}. The traversal is interrupted if one of the step returns an [Error _]. *) val fold_left_e : - ('a -> 'b -> ('a, out_error) result) -> - 'a -> - 'b t -> - ('a, out_error) result + ('a -> 'b -> ('a, 'trace) result) -> 'a -> 'b t -> ('a, 'trace) result (** Similar to {!fold_left} but wraps the traversing in {!Lwt}. Each step of the traversal is started after the previous one has resolved. The @@ -97,15 +94,14 @@ module type S = sig traversal is interrupted if one of the step is rejected or is fulfilled with [Error _]. *) val fold_left_es : - ('a -> 'b -> ('a, out_error) result Lwt.t) -> + ('a -> 'b -> ('a, 'trace) result Lwt.t) -> 'a -> 'b t -> - ('a, out_error) result Lwt.t + ('a, 'trace) result Lwt.t (** Similar to {!iter} but wraps the iteration in {!result}. The iteration is interrupted if one of the step returns an [Error _]. *) - val iter_e : - ('a -> (unit, out_error) result) -> 'a t -> (unit, out_error) result + val iter_e : ('a -> (unit, 'trace) result) -> 'a t -> (unit, 'trace) result (** Similar to {!iter} but wraps the iteration in {!Lwt}. Each step of the iteration is started after the previous one resolved. The iteration @@ -117,9 +113,7 @@ module type S = sig is interrupted if one of the promise is rejected of fulfilled with an [Error _]. *) val iter_es : - ('a -> (unit, out_error) result Lwt.t) -> - 'a t -> - (unit, out_error) result Lwt.t + ('a -> (unit, 'trace) result Lwt.t) -> 'a t -> (unit, 'trace) result Lwt.t (** Similar to {!iter} but wraps the iteration in {!Lwt}. All the steps of the iteration are started concurrently. The promise [iter_p f s] @@ -137,9 +131,9 @@ module type S = sig otherwise - is fulfilled with [Ok ()] if all the promises are. *) val iter_ep : - ('a -> (unit, out_error) result Lwt.t) -> + ('a -> (unit, 'error trace) result Lwt.t) -> 'a t -> - (unit, out_error) result Lwt.t + (unit, 'error trace) result Lwt.t (** Similar to {!map} but wraps the transformation in {!result}. The traversal is interrupted if any of the application returns an [Error _]. @@ -149,8 +143,7 @@ module type S = sig is interrupted by an [Error _]) and does not terminate on infinite sequences (again, unless interrupted). Moreover [map_e] is not tail-recursive. *) - val map_e : - ('a -> ('b, out_error) result) -> 'a t -> ('b t, out_error) result + val map_e : ('a -> ('b, 'trace) result) -> 'a t -> ('b t, 'trace) result (** Similar to {!map} but wraps the transformation in {!Lwt}. Each transformation is done sequentially, only starting once the previous @@ -174,9 +167,7 @@ module type S = sig infinite sequences (again, unless interrupted). Moreover [map_es] is not tail-recursive. *) val map_es : - ('a -> ('b, out_error) result Lwt.t) -> - 'a t -> - ('b t, out_error) result Lwt.t + ('a -> ('b, 'trace) result Lwt.t) -> 'a t -> ('b t, 'trace) result Lwt.t (** Similar to {!map} but wraps the transformation in {!Lwt}. All the transformations are done concurrently. The promise [map_p f s] resolves @@ -201,16 +192,15 @@ module type S = sig terminate on infinite sequences. Moreover [map_p] is not tail-recursive. *) val map_ep : - ('a -> ('b, out_error) result Lwt.t) -> + ('a -> ('b, 'error trace) result Lwt.t) -> 'a t -> - ('b t, out_error) result Lwt.t + ('b t, 'error trace) result Lwt.t (** Similar to {!filter} but wraps the transformation in [result]. Note that, unlike {!filter}, [filter_e] is not lazy: it applies the transformation immediately and does not terminate on infinite sequences. Moreover [filter_e] is not tail-recursive. *) - val filter_e : - ('a -> (bool, out_error) result) -> 'a t -> ('a t, out_error) result + val filter_e : ('a -> (bool, 'trace) result) -> 'a t -> ('a t, 'trace) result (** Similar to {!filter} but wraps the transformation in {!Lwt.t}. Each test of the predicate is done sequentially, only starting once the @@ -225,14 +215,12 @@ module type S = sig lazy: it applies the transformation immediately and does not terminate on infinite sequences. Moreover [filter_es] is not tail-recursive. *) val filter_es : - ('a -> (bool, out_error) result Lwt.t) -> - 'a t -> - ('a t, out_error) result Lwt.t + ('a -> (bool, 'trace) result Lwt.t) -> 'a t -> ('a t, 'trace) result Lwt.t (** Similar to {!filter_map} but within [result]. Not lazy and not tail-recursive. *) val filter_map_e : - ('a -> ('b option, out_error) result) -> 'a t -> ('b t, out_error) result + ('a -> ('b option, 'trace) result) -> 'a t -> ('b t, 'trace) result (** Similar to {!filter_map} but within [Lwt.t]. Not lazy and not tail-recursive. *) @@ -241,9 +229,9 @@ module type S = sig (** Similar to {!filter_map} but within [result Lwt.t]. Not lazy and not tail-recursive. *) val filter_map_es : - ('a -> ('b option, out_error) result Lwt.t) -> + ('a -> ('b option, 'trace) result Lwt.t) -> 'a t -> - ('b t, out_error) result Lwt.t + ('b t, 'trace) result Lwt.t (** [find_first f t] is [Some x] where [x] is the first item in [t] such that [f x]. It is [None] if there are no such element. It does not terminate if @@ -259,7 +247,7 @@ module type S = sig - [Ok None] otherwise and [t] is finite, - an expression that never returns otherwise. *) val find_first_e : - ('a -> (bool, out_error) result) -> 'a t -> ('a option, out_error) result + ('a -> (bool, 'trace) result) -> 'a t -> ('a option, 'trace) result (** [find_first_s f t] is similar to {!find_first} but wrapped within [Lwt.t]. The search is identical to [find_first_e] but each @@ -270,7 +258,7 @@ module type S = sig [result Lwt.t]. The search is identical to [find_first_e] but each predicate is applied when the previous one has resolved. *) val find_first_es : - ('a -> (bool, out_error) result Lwt.t) -> + ('a -> (bool, 'trace) result Lwt.t) -> 'a t -> - ('a option, out_error) result Lwt.t + ('a option, 'trace) result Lwt.t end diff --git a/src/lib_lwt_result_stdlib/sigs/set.ml b/src/lib_lwt_result_stdlib/sigs/set.ml index 8646f5b2609e..5aa796a0ed08 100644 --- a/src/lib_lwt_result_stdlib/sigs/set.ml +++ b/src/lib_lwt_result_stdlib/sigs/set.ml @@ -24,7 +24,7 @@ (*****************************************************************************) module type S = sig - type error (* for substitution/constraint *) + type 'error trace type elt @@ -58,32 +58,34 @@ module type S = sig val iter : (elt -> unit) -> t -> unit - val iter_e : (elt -> (unit, error) result) -> t -> (unit, error) result + val iter_e : (elt -> (unit, 'trace) result) -> t -> (unit, 'trace) result val iter_s : (elt -> unit Lwt.t) -> t -> unit Lwt.t val iter_p : (elt -> unit Lwt.t) -> t -> unit Lwt.t val iter_es : - (elt -> (unit, error) result Lwt.t) -> t -> (unit, error) result Lwt.t + (elt -> (unit, 'trace) result Lwt.t) -> t -> (unit, 'trace) result Lwt.t val iter_ep : - (elt -> (unit, error) result Lwt.t) -> t -> (unit, error) result Lwt.t + (elt -> (unit, 'error trace) result Lwt.t) -> + t -> + (unit, 'error trace) result Lwt.t val map : (elt -> elt) -> t -> t val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val fold_e : - (elt -> 'a -> ('a, error) result) -> t -> 'a -> ('a, error) result + (elt -> 'a -> ('a, 'trace) result) -> t -> 'a -> ('a, 'trace) result val fold_s : (elt -> 'a -> 'a Lwt.t) -> t -> 'a -> 'a Lwt.t val fold_es : - (elt -> 'a -> ('a, error) result Lwt.t) -> + (elt -> 'a -> ('a, 'trace) result Lwt.t) -> t -> 'a -> - ('a, error) result Lwt.t + ('a, 'trace) result Lwt.t val for_all : (elt -> bool) -> t -> bool -- GitLab From 72b6b79d257f1e31269032e446a4340c9a05b2a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Wed, 5 Aug 2020 16:17:53 +0200 Subject: [PATCH 6/6] Shell: adapt to generalised lwtreslib traversors MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Mehdi Bouaziz Co-authored-by: Raphaël Proust --- src/lib_shell/chain_validator.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/lib_shell/chain_validator.ml b/src/lib_shell/chain_validator.ml index de829398d092..ca7b8ecb3343 100644 --- a/src/lib_shell/chain_validator.ml +++ b/src/lib_shell/chain_validator.ml @@ -83,7 +83,8 @@ module Types = struct new_head_input : State.Block.t Lwt_watcher.input; mutable child : (state * (unit -> unit Lwt.t (* shutdown *))) option; mutable prevalidator : Prevalidator.t option; - active_peers : Peer_validator.t P2p_peer.Error_table.t; + active_peers : + (Peer_validator.t, Error_monad.tztrace) P2p_peer.Error_table.t; } let view (state : state) _ : view = -- GitLab