From c69dc8b0095a08bb47754a3cfc5114f88aa6cefe Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Nov 2014 15:51:55 +0100 Subject: [PATCH] CCError: now polymorphic on the error type; some retro-incompatibilies (wrap,guard) --- core/CCError.ml | 75 ++++++++++++++++----------------- core/CCError.mli | 106 +++++++++++++++++++++++++++-------------------- 2 files changed, 99 insertions(+), 82 deletions(-) diff --git a/core/CCError.ml b/core/CCError.ml index 79c555e1..053de05d 100644 --- a/core/CCError.ml +++ b/core/CCError.ml @@ -34,9 +34,9 @@ type 'a formatter = Format.formatter -> 'a -> unit (** {2 Basics} *) -type +'a t = - [ `Ok of 'a - | `Error of string +type (+'good, +'bad) t = + [ `Ok of 'good + | `Error of 'bad ] let return x = `Ok x @@ -68,6 +68,10 @@ let map f e = match e with | `Ok x -> `Ok (f x) | `Error s -> `Error s +let map_err f e = match e with + | `Ok _ as res -> res + | `Error y -> `Error (f y) + let map2 f g e = match e with | `Ok x -> `Ok (f x) | `Error s -> `Error (g s) @@ -88,16 +92,16 @@ let (>|=) e f = map f e let (>>=) e f = flat_map f e -let equal eq a b = match a, b with +let equal ?(err=Pervasives.(=)) eq a b = match a, b with | `Ok x, `Ok y -> eq x y - | `Error s, `Error s' -> s = s' + | `Error s, `Error s' -> err s s' | _ -> false -let compare cmp a b = match a, b with +let compare ?(err=Pervasives.compare) cmp a b = match a, b with | `Ok x, `Ok y -> cmp x y | `Ok _, _ -> 1 | _, `Ok _ -> -1 - | `Error s, `Error s' -> String.compare s s' + | `Error s, `Error s' -> err s s' let fold ~success ~failure x = match x with | `Ok x -> success x @@ -106,21 +110,24 @@ let fold ~success ~failure x = match x with (** {2 Wrappers} *) let guard f = - try - return (f ()) + try `Ok (f ()) + with e -> `Error e + +let guard_str f = + try `Ok (f()) with e -> of_exn e let wrap1 f x = try return (f x) - with e -> of_exn e + with e -> `Error e let wrap2 f x y = try return (f x y) - with e -> of_exn e + with e -> `Error e let wrap3 f x y z = try return (f x y z) - with e -> of_exn e + with e -> `Error e (** {2 Applicative} *) @@ -141,18 +148,20 @@ let map_l f l = | `Ok y -> map (y::acc) l' in map [] l -exception LocalExit of string +exception LocalExit let fold_seq f acc seq = + let err = ref None in try let acc = ref acc in seq (fun x -> match f !acc x with - | `Error s -> raise (LocalExit s) + | `Error s -> err := Some s; raise LocalExit | `Ok y -> acc := y ); `Ok !acc - with LocalExit s -> `Error s + with LocalExit -> + match !err with None -> assert false | Some s -> `Error s let fold_l f acc l = fold_seq f acc (fun k -> List.iter k l) @@ -166,26 +175,17 @@ let choose l = in try _find l with Not_found -> - let buf = Buffer.create 32 in - (* print errors on the buffer *) - let rec print buf l = match l with - | `Ok _ :: _ -> assert false - | (`Error x)::((_::_) as l) -> - Buffer.add_string buf x; - Buffer.add_string buf ", "; - print buf l - | `Error x::[] -> Buffer.add_string buf x - | [] -> () - in - Printf.bprintf buf "CCError.choice failed: [%a]" print l; - fail (Buffer.contents buf) + let l' = List.map (function `Error s -> s | `Ok _ -> assert false) l in + `Error l' -let rec retry n f = match n with - | 0 -> fail "retry failed" +let retry n f = + let rec retry n acc = match n with + | 0 -> fail (List.rev acc) | _ -> match f () with | `Ok _ as res -> res - | `Error _ -> retry (n-1) f + | `Error e -> retry (n-1) (e::acc) + in retry n [] (** {2 Monadic Operations} *) @@ -208,13 +208,14 @@ module Traverse(M : MONAD) = struct | `Error _ -> M.return acc | `Ok x -> f acc x >>= fun y -> M.return y - let rec retry_m n f = match n with - | 0 -> M.return (fail "retry failed") + let retry_m n f = + let rec retry n acc = match n with + | 0 -> M.return (fail (List.rev acc)) | _ -> - let x = f () in - x >>= function - | `Ok _ -> x - | `Error _ -> retry_m (n-1) f + f () >>= function + | `Ok x -> M.return (`Ok x) + | `Error e -> retry (n-1) (e::acc) + in retry n [] end (** {2 Conversions} *) diff --git a/core/CCError.mli b/core/CCError.mli index ee2368dd..17297bb6 100644 --- a/core/CCError.mli +++ b/core/CCError.mli @@ -24,7 +24,9 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 Error Monad} *) +(** {1 Error Monad} + +The variant is polymorphic in the error type since NEXT_RELEASE *) type 'a sequence = ('a -> unit) -> unit type 'a equal = 'a -> 'a -> bool @@ -34,90 +36,104 @@ type 'a formatter = Format.formatter -> 'a -> unit (** {2 Basics} *) -type +'a t = - [ `Ok of 'a - | `Error of string +type (+'good, +'bad) t = + [ `Ok of 'good + | `Error of 'bad ] -val return : 'a -> 'a t +val return : 'a -> ('a,'err) t +(** Successfully return a value *) -val fail : string -> 'a t +val fail : 'err -> ('a,'err) t +(** Fail with an error *) -val of_exn : exn -> 'a t +val of_exn : exn -> ('a, string) t +(** [of_exn e] uses {!Printexc} to print the exception as a string *) -val fail_printf : ('a, Buffer.t, unit, 'a t) format4 -> 'a +val fail_printf : ('a, Buffer.t, unit, ('a,string) t) format4 -> 'a (** [fail_printf format] uses [format] to obtain an error message and then returns [`Error msg] @since 0.3.3 *) -val map : ('a -> 'b) -> 'a t -> 'b t +val map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t +(** Map on success *) -val map2 : ('a -> 'b) -> (string -> string) -> 'a t -> 'b t +val map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t +(** Map on error. + @since NEXT_RELEASE *) + +val map2 : ('a -> 'b) -> ('err -> 'err) -> ('a, 'err) t -> ('b, 'err) t (** Same as {!map}, but also with a function that can transform the error message in case of failure *) -val iter : ('a -> unit) -> 'a t -> unit +val iter : ('a -> unit) -> ('a, _) t -> unit (** Apply the function only in case of `Ok *) -val get_exn : 'a t -> 'a +val get_exn : ('a, _) t -> 'a (** Extract the value [x] from [`Ok x], fails otherwise. You should be careful with this function, and favor other combinators whenever possible. @raise Invalid_argument if the value is an error. *) -val flat_map : ('a -> 'b t) -> 'a t -> 'b t +val flat_map : ('a -> ('b, 'err) t) -> ('a, 'err) t -> ('b, 'err) t -val (>|=) : 'a t -> ('a -> 'b) -> 'b t +val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t -val equal : 'a equal -> 'a t equal +val equal : ?err:'err equal -> 'a equal -> ('a, 'err) t equal -val compare : 'a ord -> 'a t ord +val compare : ?err:'err ord -> 'a ord -> ('a, 'err) t ord -val fold : success:('a -> 'b) -> failure:(string -> 'b) -> 'a t -> 'b +val fold : success:('a -> 'b) -> failure:('err -> 'b) -> ('a, 'err) t -> 'b (** [fold ~success ~failure e] opens [e] and, if [e = `Ok x], returns [success x], otherwise [e = `Error s] and it returns [failure s]. *) -(** {2 Wrappers} *) +(** {2 Wrappers} -val guard : (unit -> 'a) -> 'a t +The functions {!guard}, {!wrap1}, {!wrap2} and {!wrap3} now return +exceptions in case of failure, @since NEXT_RELEASE *) + +val guard : (unit -> 'a) -> ('a, exn) t (** [guard f] runs [f ()] and returns its result wrapped in [`Ok]. If - [f ()] raises some exception [e], then it fails with [`Error msg] - where [msg] is some printing of [e] (see {!register_printer}). *) + [f ()] raises some exception [e], then it fails with [`Error e] *) -val wrap1 : ('a -> 'b) -> 'a -> 'b t +val guard_str : (unit -> 'a) -> ('a, string) t +(** Same as {!guard} but uses {!of_exn} to print the exception. + See {!register_printer} *) + +val wrap1 : ('a -> 'b) -> 'a -> ('b, exn) t (** Same as {!guard} but gives the function one argument. *) -val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t +val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> ('c, exn) t (** Same as {!guard} but gives the function two arguments. *) -val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t +val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> ('d, exn) t (** {2 Applicative} *) -val pure : 'a -> 'a t +val pure : 'a -> ('a, 'err) t -val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t (** {2 Collections} *) -val map_l : ('a -> 'b t) -> 'a list -> 'b list t +val map_l : ('a -> ('b, 'err) t) -> 'a list -> ('b list, 'err) t -val fold_l : ('b -> 'a -> 'b t) -> 'b -> 'a list -> 'b t +val fold_l : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a list -> ('b, 'err) t -val fold_seq : ('b -> 'a -> 'b t) -> 'b -> 'a sequence -> 'b t +val fold_seq : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a sequence -> ('b, 'err) t (** {2 Misc} *) -val choose : 'a t list -> 'a t +val choose : ('a, 'err) t list -> ('a, 'err list) t (** [choose l] selects a member of [l] that is a [`Ok _] value, - or returns [`Error msg] otherwise, where [msg] is obtained by - combining the error messages of all elements of [l] *) + or returns [`Error l] otherwise, where [l] is the list of errors. *) -val retry : int -> (unit -> 'a t) -> 'a t +val retry : int -> (unit -> ('a, 'err) t) -> ('a, 'err list) t (** [retry n f] calls [f] at most [n] times, returning the first result - of [f ()] that doesn't fail. If [f] fails [n] times, [retry n f] fails. *) + of [f ()] that doesn't fail. If [f] fails [n] times, [retry n f] fails + with the list of successive errors. *) (** {2 Monadic Operations} *) module type MONAD = sig @@ -127,28 +143,28 @@ module type MONAD = sig end module Traverse(M : MONAD) : sig - val sequence_m : 'a M.t t -> 'a t M.t + val sequence_m : ('a M.t, 'err) t -> ('a, 'err) t M.t - val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t + val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> ('a, 'err) t -> 'b M.t - val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t + val map_m : ('a -> 'b M.t) -> ('a, 'err) t -> ('b, 'err) t M.t - val retry_m : int -> (unit -> 'a t M.t) -> 'a t M.t + val retry_m : int -> (unit -> ('a, 'err) t M.t) -> ('a, 'err list) t M.t end (** {2 Conversions} *) -val to_opt : 'a t -> 'a option +val to_opt : ('a, _) t -> 'a option -val of_opt : 'a option -> 'a t +val of_opt : 'a option -> ('a, string) t -val to_seq : 'a t -> 'a sequence +val to_seq : ('a, _) t -> 'a sequence (** {2 IO} *) -val pp : 'a printer -> 'a t printer +val pp : 'a printer -> ('a, string) t printer -val print : 'a formatter -> 'a t formatter +val print : 'a formatter -> ('a, string) t formatter (** {2 Global Exception Printers} @@ -156,7 +172,7 @@ One can register exception printers here, so they will be used by {!guard}, {!wrap1}, etc. The printers should succeed (print) on exceptions they can deal with, and re-raise the exception otherwise. For instance if I register a printer for [Not_found], it could look like: - + {[CCError.register_printer (fun buf exn -> match exn with | Not_found -> Buffer.add_string buf "Not_found"