From 9df989dd0abdad70e229c68c021fd41f5b576222 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Mon, 8 Aug 2022 16:52:09 +0200 Subject: [PATCH 1/2] Env-v7: Update monad syntaxes and lwt --- src/lib_protocol_environment/sigs/v7.ml | 92 +++++++++++++++++++ .../sigs/v7/error_monad.mli | 52 +++++++++++ src/lib_protocol_environment/sigs/v7/lwt.mli | 40 ++++++++ 3 files changed, 184 insertions(+) diff --git a/src/lib_protocol_environment/sigs/v7.ml b/src/lib_protocol_environment/sigs/v7.ml index bb9f3e77f19f..55c7f5a5be1e 100644 --- a/src/lib_protocol_environment/sigs/v7.ml +++ b/src/lib_protocol_environment/sigs/v7.ml @@ -2868,6 +2868,10 @@ type +'a t There is one exception to this: most promises can be {e canceled} by calling {!Lwt.cancel}, without going through a resolver. *) +(** We omit [u], [wait], [wakeup*] and so on because these are only useful to + define new synchronization primitives which the protocol doesn't need: it + gets its synchronization primitives from the environment. *) + val return : 'a -> 'a t (** [Lwt.return v] creates a new {{: #TYPEt} promise} that is {e already fulfilled} with value [v]. @@ -2891,6 +2895,9 @@ let%lwt line = Lwt_io.(read_line stdin) in Lwt.return (line ^ ".") ]} *) +(** We omit [fail] as well as [catch] and such because we discourage the use of + exceptions in the environment. The Error Monad provides sufficient + primitives. *) (** {3 Callbacks} *) @@ -3000,6 +3007,15 @@ let () = +(** We omit [dont_wait] and other such functions because we it is only useful in + mutation-heavy loosely-synchronised code which the protocol shouldn't be. *) + +(** We omit many synchronisation primitives such as [choose] because it + introduce non-determinism. *) + +(** We omit cancelation-related primitives because we discourage Cancelation in + the protocol. *) + (** {2 Convenience} *) (** {3 Callback helpers} *) @@ -3067,6 +3083,11 @@ let read_int : unit -> int Lwt.t = fun () -> - If [f v] returns another value [v'], [p_3] is fulfilled with [v']. - If [f v] raises exception [exn], [p_3] is rejected with [exn]. *) +(** We omit explicit callback registration ([on_termination] and such) because + it is only useful for mutation-heavy code *) + +(** We omit syntax helpers because they are available through the dedicated + syntax modules of the Error Monad. *) (** {3 Pre-allocated promises} *) @@ -3101,6 +3122,25 @@ val return_true : bool t val return_false : bool t (** [Lwt.return_false] is like {!Lwt.return_unit}, but for {!Lwt.return}[ false]. *) + +(** We omit state introspection because it is discouraged when not defining new + synchronisation primitives which the protocol doesn't do. *) + +val return_some : 'a -> ('a option) t +(** Counterpart to {!Lwt.return_none}. However, unlike {!Lwt.return_none}, this + function performs no {{: #VALreturn_unit} optimization}. This is because it + takes an argument, so it cannot be evaluated at initialization time, at + which time the argument is not yet available. *) + +val return_ok : 'a -> (('a, _) result) t +(** Like {!Lwt.return_some}, this function performs no optimization. + + @since Lwt 2.6.0 *) + +val return_error : 'e -> ((_, 'e) result) t +(** Like {!Lwt.return_some}, this function performs no optimization. + + @since Lwt 2.6.0 *) end # 30 "v7.in.ml" @@ -5498,6 +5538,30 @@ module Lwt_syntax : sig val both : 'a Lwt.t -> 'b Lwt.t -> ('a * 'b) Lwt.t end +module Option_syntax : sig + val return : 'a -> 'a option + + val fail : 'a option + + val return_unit : unit option + + val return_nil : 'a list option + + val return_true : bool option + + val return_false : bool option + + val ( let* ) : 'a option -> ('a -> 'b option) -> 'b option + + val ( and* ) : 'a option -> 'b option -> ('a * 'b) option + + val ( let+ ) : 'a option -> ('a -> 'b) -> 'b option + + val ( and+ ) : 'a option -> 'b option -> ('a * 'b) option + + val both : 'a option -> 'b option -> ('a * 'b) option +end + module Result_syntax : sig val return : 'a -> ('a, 'e) result @@ -5568,6 +5632,34 @@ module Lwt_result_syntax : sig ('a * 'b, 'e list) result Lwt.t end +module Lwt_option_syntax : sig + val return : 'a -> 'a option Lwt.t + + val return_unit : unit option Lwt.t + + val return_nil : 'a list option Lwt.t + + val return_true : bool option Lwt.t + + val return_false : bool option Lwt.t + + val fail : 'a option Lwt.t + + val ( let* ) : 'a option Lwt.t -> ('a -> 'b option Lwt.t) -> 'b option Lwt.t + + val ( and* ) : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t + + val ( let+ ) : 'a option Lwt.t -> ('a -> 'b) -> 'b option Lwt.t + + val ( and+ ) : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t + + val ( let*! ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t + + val ( let*? ) : 'a option -> ('a -> 'b option Lwt.t) -> 'b option Lwt.t + + val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t +end + module Tzresult_syntax : sig val return : 'a -> ('a, 'error) result diff --git a/src/lib_protocol_environment/sigs/v7/error_monad.mli b/src/lib_protocol_environment/sigs/v7/error_monad.mli index 97a044ee1370..4e6be497c44d 100644 --- a/src/lib_protocol_environment/sigs/v7/error_monad.mli +++ b/src/lib_protocol_environment/sigs/v7/error_monad.mli @@ -265,6 +265,30 @@ module Lwt_syntax : sig val both : 'a Lwt.t -> 'b Lwt.t -> ('a * 'b) Lwt.t end +module Option_syntax : sig + val return : 'a -> 'a option + + val fail : 'a option + + val return_unit : unit option + + val return_nil : 'a list option + + val return_true : bool option + + val return_false : bool option + + val ( let* ) : 'a option -> ('a -> 'b option) -> 'b option + + val ( and* ) : 'a option -> 'b option -> ('a * 'b) option + + val ( let+ ) : 'a option -> ('a -> 'b) -> 'b option + + val ( and+ ) : 'a option -> 'b option -> ('a * 'b) option + + val both : 'a option -> 'b option -> ('a * 'b) option +end + module Result_syntax : sig val return : 'a -> ('a, 'e) result @@ -335,6 +359,34 @@ module Lwt_result_syntax : sig ('a * 'b, 'e list) result Lwt.t end +module Lwt_option_syntax : sig + val return : 'a -> 'a option Lwt.t + + val return_unit : unit option Lwt.t + + val return_nil : 'a list option Lwt.t + + val return_true : bool option Lwt.t + + val return_false : bool option Lwt.t + + val fail : 'a option Lwt.t + + val ( let* ) : 'a option Lwt.t -> ('a -> 'b option Lwt.t) -> 'b option Lwt.t + + val ( and* ) : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t + + val ( let+ ) : 'a option Lwt.t -> ('a -> 'b) -> 'b option Lwt.t + + val ( and+ ) : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t + + val ( let*! ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t + + val ( let*? ) : 'a option -> ('a -> 'b option Lwt.t) -> 'b option Lwt.t + + val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t +end + module Tzresult_syntax : sig val return : 'a -> ('a, 'error) result diff --git a/src/lib_protocol_environment/sigs/v7/lwt.mli b/src/lib_protocol_environment/sigs/v7/lwt.mli index 5361fc293adc..017303a42d9c 100644 --- a/src/lib_protocol_environment/sigs/v7/lwt.mli +++ b/src/lib_protocol_environment/sigs/v7/lwt.mli @@ -30,6 +30,10 @@ type +'a t There is one exception to this: most promises can be {e canceled} by calling {!Lwt.cancel}, without going through a resolver. *) +(** We omit [u], [wait], [wakeup*] and so on because these are only useful to + define new synchronization primitives which the protocol doesn't need: it + gets its synchronization primitives from the environment. *) + val return : 'a -> 'a t (** [Lwt.return v] creates a new {{: #TYPEt} promise} that is {e already fulfilled} with value [v]. @@ -53,6 +57,9 @@ let%lwt line = Lwt_io.(read_line stdin) in Lwt.return (line ^ ".") ]} *) +(** We omit [fail] as well as [catch] and such because we discourage the use of + exceptions in the environment. The Error Monad provides sufficient + primitives. *) (** {3 Callbacks} *) @@ -162,6 +169,15 @@ let () = +(** We omit [dont_wait] and other such functions because we it is only useful in + mutation-heavy loosely-synchronised code which the protocol shouldn't be. *) + +(** We omit many synchronisation primitives such as [choose] because it + introduce non-determinism. *) + +(** We omit cancelation-related primitives because we discourage Cancelation in + the protocol. *) + (** {2 Convenience} *) (** {3 Callback helpers} *) @@ -229,6 +245,11 @@ let read_int : unit -> int Lwt.t = fun () -> - If [f v] returns another value [v'], [p_3] is fulfilled with [v']. - If [f v] raises exception [exn], [p_3] is rejected with [exn]. *) +(** We omit explicit callback registration ([on_termination] and such) because + it is only useful for mutation-heavy code *) + +(** We omit syntax helpers because they are available through the dedicated + syntax modules of the Error Monad. *) (** {3 Pre-allocated promises} *) @@ -263,3 +284,22 @@ val return_true : bool t val return_false : bool t (** [Lwt.return_false] is like {!Lwt.return_unit}, but for {!Lwt.return}[ false]. *) + +(** We omit state introspection because it is discouraged when not defining new + synchronisation primitives which the protocol doesn't do. *) + +val return_some : 'a -> ('a option) t +(** Counterpart to {!Lwt.return_none}. However, unlike {!Lwt.return_none}, this + function performs no {{: #VALreturn_unit} optimization}. This is because it + takes an argument, so it cannot be evaluated at initialization time, at + which time the argument is not yet available. *) + +val return_ok : 'a -> (('a, _) result) t +(** Like {!Lwt.return_some}, this function performs no optimization. + + @since Lwt 2.6.0 *) + +val return_error : 'e -> ((_, 'e) result) t +(** Like {!Lwt.return_some}, this function performs no optimization. + + @since Lwt 2.6.0 *) -- GitLab From 1f8baf516232dc7484f72f81f012f9f16cbb4da7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Tue, 9 Aug 2022 08:21:33 +0200 Subject: [PATCH 2/2] Error-monad: fix Lwt_option_syntax pointer --- src/lib_error_monad/TzMonad.ml | 2 +- src/lib_error_monad/TzMonad.mli | 2 +- src/lib_error_monad/error_monad.mli | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lib_error_monad/TzMonad.ml b/src/lib_error_monad/TzMonad.ml index 9feb1a8b323e..a016b624cf67 100644 --- a/src/lib_error_monad/TzMonad.ml +++ b/src/lib_error_monad/TzMonad.ml @@ -25,5 +25,5 @@ (*****************************************************************************) module Option_syntax = TzLwtreslib.Monad.Option_syntax -module Lwt_option_syntax = TzLwtreslib.Monad.Option_syntax +module Lwt_option_syntax = TzLwtreslib.Monad.Lwt_option_syntax include Monad_maker.Make (TzCore) (TzTrace) (TzLwtreslib.Monad) diff --git a/src/lib_error_monad/TzMonad.mli b/src/lib_error_monad/TzMonad.mli index 44e39a736a11..88c047178e14 100644 --- a/src/lib_error_monad/TzMonad.mli +++ b/src/lib_error_monad/TzMonad.mli @@ -25,7 +25,7 @@ (*****************************************************************************) module Option_syntax = TzLwtreslib.Monad.Option_syntax -module Lwt_option_syntax = TzLwtreslib.Monad.Option_syntax +module Lwt_option_syntax = TzLwtreslib.Monad.Lwt_option_syntax include Monad_maker.S diff --git a/src/lib_error_monad/error_monad.mli b/src/lib_error_monad/error_monad.mli index 632f335f2e03..7ab9a0c88484 100644 --- a/src/lib_error_monad/error_monad.mli +++ b/src/lib_error_monad/error_monad.mli @@ -81,7 +81,7 @@ include (* Other syntax module *) module Option_syntax = TzLwtreslib.Monad.Option_syntax -module Lwt_option_syntax = TzLwtreslib.Monad.Option_syntax +module Lwt_option_syntax = TzLwtreslib.Monad.Lwt_option_syntax (** {1 Exception-Error bridge} -- GitLab