CCError: now polymorphic on the error type; some retro-incompatibilies (wrap,guard)

core/CCError.ml

@@ -34,9 +34,9 @@ type 'a formatter = Format.formatter -> 'a -> unit
 
 (** {2 Basics} *)
 
-type +'a t =
+type (+'good, +'bad) t =
-  [ `Ok of 'a
+  [ `Ok of 'good
-  | `Error of string
+  | `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
+  try `Ok (f ())
-    return (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
+    let l' = List.map (function `Error s -> s | `Ok _ -> assert false) l in
-    (* print errors on the buffer *)
+    `Error l'
-    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 rec retry n f = match n with
+let retry n f =
-  | 0 -> fail "retry failed"
+  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
+  let retry_m n f =
-    | 0 -> M.return (fail "retry failed")
+    let rec retry n acc = match n with
+    | 0 -> M.return (fail (List.rev acc))
     | _ ->
-        let x = f () in
+        f () >>= function
-        x >>= function
+        | `Ok x -> M.return (`Ok x)
-        | `Ok _ -> x
+        | `Error e -> retry (n-1) (e::acc)
-        | `Error _ -> retry_m (n-1) f
+    in retry n []
 end
 
 (** {2 Conversions} *)

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 =
+type (+'good, +'bad) t =
-  [ `Ok of 'a
+  [ `Ok of 'good
-  | `Error of string
+  | `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]
+    [f ()] raises some exception [e], then it fails with [`Error e] *)
-    where [msg] is some printing of [e] (see {!register_printer}). *)
 
-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
+    or returns [`Error l] otherwise, where [l] is the list of errors. *)
-    combining the error messages of all elements of [l] *)
 
-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}