From 02a9639d0203dcf86c37a413ae33cce8293a3f92 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Mon, 25 Jan 2016 21:18:33 +0100
Subject: [PATCH] add `CCResult`, with dependency on `result` for retrocompat

---
 .merlin               |   1 +
 _oasis                |   4 +-
 doc/intro.txt         |   1 +
 opam                  |   1 +
 src/core/CCResult.ml  | 248 ++++++++++++++++++++++++++++++++++++++++++
 src/core/CCResult.mli | 182 +++++++++++++++++++++++++++++++
 6 files changed, 435 insertions(+), 2 deletions(-)
 create mode 100644 src/core/CCResult.ml
 create mode 100644 src/core/CCResult.mli

diff --git a/.merlin b/.merlin
index d0a5cac0..dcf99f7b 100644
--- a/.merlin
+++ b/.merlin
@@ -28,6 +28,7 @@ B _build/examples
 B _build/tests
 PKG oUnit
 PKG benchmark
+PKG result
 PKG threads
 PKG threads.posix
 PKG lwt
diff --git a/_oasis b/_oasis
index f0fb6fbc..26cffeba 100644
--- a/_oasis
+++ b/_oasis
@@ -46,8 +46,8 @@ Library "containers"
   Modules:          CCVector, CCPrint, CCError, CCHeap, CCList, CCOpt, CCPair,
                     CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, CCRef, CCSet,
                     CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO,
-                    CCInt64, CCChar, Containers
-  BuildDepends:     bytes
+                    CCInt64, CCChar, CCResult, Containers
+  BuildDepends:     bytes, result
   # BuildDepends:     bytes, bisect_ppx
 
 Library "containers_io"
diff --git a/doc/intro.txt b/doc/intro.txt
index 338a2596..6855b114 100644
--- a/doc/intro.txt
+++ b/doc/intro.txt
@@ -44,6 +44,7 @@ CCPair
 CCPrint
 CCRandom
 CCRef
+CCResult
 CCSet
 CCString
 CCVector
diff --git a/opam b/opam
index a3b0dfe8..51a80a86 100644
--- a/opam
+++ b/opam
@@ -27,6 +27,7 @@ remove: [
 depends: [
     "ocamlfind" {build}
     "base-bytes"
+    "result"
     "cppo" {build}
     "oasis" {build}
     "ocamlbuild" {build}
diff --git a/src/core/CCResult.ml b/src/core/CCResult.ml
new file mode 100644
index 00000000..ed05df1d
--- /dev/null
+++ b/src/core/CCResult.ml
@@ -0,0 +1,248 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Error Monad} *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a equal = 'a -> 'a -> bool
+type 'a ord = 'a -> 'a -> int
+type 'a printer = Buffer.t -> 'a -> unit
+type 'a formatter = Format.formatter -> 'a -> unit
+
+(** {2 Basics} *)
+
+type (+'good, +'bad) t = ('good, 'bad) Result.result =
+  | Ok of 'good
+  | Error of 'bad
+
+let return x = Ok x
+
+let fail s = Error s
+
+let fail_printf format =
+  let buf = Buffer.create 64 in
+  Printf.kbprintf
+    (fun buf -> fail (Buffer.contents buf))
+    buf format
+
+let fail_fprintf format =
+  let buf = Buffer.create 64 in
+  let out = Format.formatter_of_buffer buf in
+  Format.kfprintf
+    (fun out -> Format.pp_print_flush out (); fail (Buffer.contents buf))
+    out format
+
+let of_exn e =
+  let msg = Printexc.to_string e in
+  Error msg
+
+let of_exn_trace e =
+  let res = Printf.sprintf "%s\n%s"
+    (Printexc.to_string e) (Printexc.get_backtrace ())
+  in
+  Error res
+
+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)
+
+let iter f e = match e with
+  | Ok x -> f x
+  | Error _ -> ()
+
+exception GetOnError
+
+let get_exn = function
+  | Ok x -> x
+  | Error _ -> raise GetOnError
+
+let catch e ~ok ~err = match e with
+  | Ok x -> ok x
+  | Error y -> err y
+
+let flat_map f e = match e with
+  | Ok x -> f x
+  | Error s -> Error s
+
+let (>|=) e f = map f e
+
+let (>>=) e f = flat_map f e
+
+let equal ?(err=Pervasives.(=)) eq a b = match a, b with
+  | Ok x, Ok y -> eq x y
+  | Error s, Error s' -> err s s'
+  | _ -> false
+
+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' -> err s s'
+
+let fold ~ok ~error x = match x with
+  | Ok x -> ok x
+  | Error s -> error s
+
+(** {2 Wrappers} *)
+
+let guard f =
+  try Ok (f ())
+  with e -> Error e
+
+let guard_str f =
+  try Ok (f())
+  with e -> of_exn e
+
+let guard_str_trace f =
+  try Ok (f())
+  with e -> of_exn_trace e
+
+let wrap1 f x =
+  try return (f x)
+  with e -> Error e
+
+let wrap2 f x y =
+  try return (f x y)
+  with e -> Error e
+
+let wrap3 f x y z =
+  try return (f x y z)
+  with e -> Error e
+
+(** {2 Applicative} *)
+
+let pure = return
+
+let (<*>) f x = match f with
+  | Error s -> fail s
+  | Ok f -> map f x
+
+let join t = match t with
+  | Ok (Ok o) -> Ok o
+  | Ok (Error e) -> Error e
+  | (Error _) as e -> e
+
+let both x y = match x,y with
+   | Ok o, Ok o' -> Ok (o, o')
+   | Ok _, Error e -> Error e
+   | Error e, _  -> Error e
+
+(** {2 Collections} *)
+
+let map_l f l =
+  let rec map acc l = match l with
+  | [] -> Ok (List.rev acc)
+  | x::l' ->
+      match f x with
+      | Error s -> Error s
+      | Ok y -> map (y::acc) l'
+  in map [] l
+
+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 -> err := Some s; raise LocalExit
+        | Ok y -> acc := y);
+    Ok !acc
+  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)
+
+(** {2 Misc} *)
+
+let choose l =
+  let rec find_ = function
+    | [] -> raise Not_found
+    | ((Ok _) as res) :: _ -> res
+    | (Error _) :: l' -> find_ l'
+  in
+  try find_ l
+  with Not_found ->
+    let l' = List.map (function Error s -> s | Ok _ -> assert false) l in
+    Error l'
+
+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 e -> retry (n-1) (e::acc)
+  in retry n []
+
+(** {2 Infix} *)
+
+module Infix = struct
+  let (>>=) = (>>=)
+  let (>|=) = (>|=)
+  let (<*>) = (<*>)
+end
+
+(** {2 Monadic Operations} *)
+
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) = struct
+  let (>>=) = M.(>>=)
+
+  let map_m f e = match e with
+    | Error s -> M.return (Error s)
+    | Ok x -> f x >>= fun y -> M.return (Ok y)
+
+  let sequence_m m = map_m (fun x->x) m
+
+  let fold_m f acc e = match e with
+    | Error _ -> M.return acc
+    | Ok x -> f acc x >>= fun y -> M.return y
+
+  let retry_m n f =
+    let rec retry n acc = match n with
+    | 0 -> M.return (fail (List.rev acc))
+    | _ ->
+        f () >>= function
+        | Ok x -> M.return (Ok x)
+        | Error e -> retry (n-1) (e::acc)
+    in retry n []
+end
+
+(** {2 Conversions} *)
+
+let to_opt = function
+  | Ok x -> Some x
+  | Error _ -> None
+
+let of_opt = function
+  | None -> Error "of_opt"
+  | Some x -> Ok x
+
+let to_seq e k = match e with
+  | Ok x -> k x
+  | Error _ -> ()
+
+(** {2 IO} *)
+
+let pp pp_x buf e = match e with
+  | Ok x -> Printf.bprintf buf "ok(%a)" pp_x x
+  | Error s -> Printf.bprintf buf "error(%s)" s
+
+let print pp_x fmt e = match e with
+  | Ok x -> Format.fprintf fmt "@[ok(@,%a)@]" pp_x x
+  | Error s -> Format.fprintf fmt "@[error(@,%s)@]" s
diff --git a/src/core/CCResult.mli b/src/core/CCResult.mli
new file mode 100644
index 00000000..565591b8
--- /dev/null
+++ b/src/core/CCResult.mli
@@ -0,0 +1,182 @@
+
+(* This file is free software, part of containers. See file "license" for more details. *)
+
+(** {1 Error Monad}
+
+    Uses the new "result" type from OCaml 4.03.
+
+    @since NEXT_RELEASE *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a equal = 'a -> 'a -> bool
+type 'a ord = 'a -> 'a -> int
+type 'a printer = Buffer.t -> 'a -> unit
+type 'a formatter = Format.formatter -> 'a -> unit
+
+(** {2 Basics} *)
+
+type (+'good, +'bad) t = ('good, 'bad) Result.result =
+  | Ok of 'good
+  | Error of 'bad
+
+val return : 'a -> ('a, 'err) t
+(** Successfully return a value *)
+
+val fail : 'err -> ('a, 'err) t
+(** Fail with an error *)
+
+val of_exn : exn -> ('a, string) t
+(** [of_exn e] uses {!Printexc} to print the exception as a string *)
+
+val of_exn_trace : exn -> ('a, string) t
+(** [of_exn_trace e] is similar to [of_exn e], but it adds the stacktrace
+    to the error message.
+
+    Remember to call [Printexc.record_backtrace true] and compile with the
+    debug flag for this to work. *)
+
+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] *)
+
+val fail_fprintf : ('a, Format.formatter, unit, ('a, string) t) format4 -> 'a
+(** [fail_printf format] uses [format] to obtain an error message
+    and then returns [Error msg] *)
+
+val map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t
+(** Map on success *)
+
+val map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t
+(** Map on the error variant *)
+
+val map2 : ('a -> 'b) -> ('err1 -> 'err2) -> ('a, 'err1) t -> ('b, 'err2) 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
+(** Apply the function only in case of Ok *)
+
+exception GetOnError
+
+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 GetOnError if the value is an error. *)
+
+val catch : ('a, 'err) t -> ok:('a -> 'b) -> err:('err -> 'b) -> 'b
+(** [catch e ~ok ~err] calls either [ok] or [err] depending on
+    the value of [e]. *)
+
+val flat_map : ('a -> ('b, 'err) t) -> ('a, 'err) t -> ('b, 'err) t
+
+val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t
+
+val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t
+
+val equal : ?err:'err equal -> 'a equal -> ('a, 'err) t equal
+
+val compare : ?err:'err ord -> 'a ord -> ('a, 'err) t ord
+
+val fold : ok:('a -> 'b) -> error:('err -> 'b) -> ('a, 'err) t -> 'b
+(** [fold ~ok ~error e] opens [e] and, if [e = Ok x], returns
+    [ok x], otherwise [e = Error s] and it returns [error s]. *)
+
+(** {2 Wrappers} *)
+
+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 e] *)
+
+val guard_str : (unit -> 'a) -> ('a, string) t
+(** Same as {!guard} but uses {!of_exn} to print the exception. *)
+
+val guard_str_trace : (unit -> 'a) -> ('a, string) t
+(** Same as {!guard_str} but uses {!of_exn_trace} instead of {!of_exn} so
+    that the stack trace is printed. *)
+
+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, exn) t
+(** Same as {!guard} but gives the function two arguments. *)
+
+val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> ('d, exn) t
+(** Same as {!guard} but gives the function three arguments. *)
+
+(** {2 Applicative} *)
+
+val pure : 'a -> ('a, 'err) t
+(** Synonym of {!return} *)
+
+val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t
+(** [a <*> b] evaluates [a] and [b], and, in case of success, returns
+    [Ok (a b)]. Otherwise, it fails, and the error of [a] is chosen
+    over the error of [b] if both fail. *)
+
+val join : (('a, 'err) t, 'err) t -> ('a, 'err) t
+(** [join t], in case of success, returns [Ok o] from [Ok (Ok o)]. Otherwise,
+    it fails with [Error e] where [e] is the unwrapped error of [t]. *)
+
+val both : ('a, 'err) t  -> ('b, 'err) t -> (('a * 'b), 'err) t
+(** [both a b], in case of success, returns [Ok (o, o')] with the ok values
+    of [a] and [b]. Otherwise, it fails, and the error of [a] is chosen over the
+    error of [b] if both fail. *)
+
+(** {2 Infix} *)
+
+module Infix : sig
+  val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t
+  val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t
+  val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t
+end
+
+(** {2 Collections} *)
+
+val map_l : ('a -> ('b, 'err) t) -> 'a list -> ('b list, 'err) t
+
+val fold_l : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a list -> ('b, 'err) t
+
+val fold_seq : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a sequence -> ('b, 'err) t
+
+(** {2 Misc} *)
+
+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 l] otherwise, where [l] is the list of errors. *)
+
+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
+    with the list of successive errors. *)
+
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) : sig
+  val sequence_m : ('a M.t, 'err) t -> ('a, 'err) t 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, 'err) t -> ('b, 'err) 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 of_opt : 'a option -> ('a, string) t
+
+val to_seq : ('a, _) t -> 'a sequence
+
+(** {2 IO} *)
+
+val pp : 'a printer -> ('a, string) t printer
+
+val print : 'a formatter -> ('a, string) t formatter