Merge pull request #33 from mbarbin/initialize-rresult

Vcs.Rresult (Vcs_base refactor)

.vscode/settings.json

@@ -8,9 +8,10 @@
         "opam",
         "pathspec",
         "rmtree",
+        "rresult",
         "Stdenv",
         "subdir",
         "worktree",
         "worktrees"
     ]
-}
+}

CHANGES.md

@@ -2,12 +2,13 @@
 
 ### Added
 
-- Add new `vcs-base` package meant to extend `vcs` with base-style functionality.
+- Add new `vcs-base` package meant to extend `vcs` with base-style functionality (#31, @mbarbin).
 - Add `Vcs.find_enclosing_repo_root` helper (#28, @mbarbin).
 - Add `Vcs.read_dir` helper (#28, @mbarbin).
 
 ### Changed
 
+- Rename what was `Vcs.Result` to `Vcs.Rresult` and introduce `Vcs.Result` whose type is simpler (#32, @mbarbin).
 - Moved `ocaml-vcs more-tests` commands at top-level (#28, @mbarbin).
 
 ### Deprecated

README.md

@@ -39,7 +39,7 @@ We extend our gratitude to the following individuals and teams, whose contributi
 
 - Vincent Simonet and contributors for [headache](https://github.com/Frama-C/headache), which we use to manage the copyright headers at the beginning of our files.
 
-- The [Rresult](https://erratique.ch/software/rresult/doc/Rresult/index.html#usage) developers: Their usage design guidelines have been a reference in the design of `Vcs`'s error handling, the `Vcs.Result` module in particular.
+- The [Rresult](https://erratique.ch/software/rresult/doc/Rresult/index.html#usage) developers: Their usage design guidelines have been a reference in the design of `Vcs`'s error handling, the `Vcs.Rresult` module in particular.
 
 We look forward to continuing to learn from and collaborate with the broader open source community.
 

TODO.md

@@ -31,7 +31,7 @@ Only keep sexp related ppx that have no runtime dependency on `base`, such as `s
 
 ### Stage 3 - Refactor non-raising APIs
 
-- [ ] Pending
+- [x] Completed: Oct. 2024
 
 - Rename `Result` => `Rresult`, introduce a new `Result` one.
 
@@ -52,6 +52,7 @@ Use `vcs/src/import` to make a local mini-stdlib with utils required to remove `
 Do this for the other libraries:
 
 - [ ] vcs
+- [ ] vcs_command
+- [ ] vcs_git_blocking
 - [ ] vcs_git_eio
 - [ ] vcs_git_provider
-- [ ] vcs_git_blocking

example/hello_blocking.ml

@@ -68,7 +68,7 @@ let%expect_test "hello commit" =
         ~f:Result.return
     with
     | Ok _ -> assert false
-    | Error (`Vcs err) -> print_s (Vcs.Err.sexp_of_t err)
+    | Error err -> print_s (Vcs.Err.sexp_of_t err)
   in
   [%expect
     {|
@@ -88,10 +88,10 @@ let%expect_test "hello commit" =
       Vcs.Result.git vcs ~repo_root ~args:[ "rev-parse"; "INVALID-REF" ] ~f:(fun output ->
         if output.exit_code = 0
         then assert false [@coverage off]
-        else Error (`Vcs (Vcs.Err.create_s [%sexp "Hello invalid exit code"])))
+        else Error (Vcs.Err.create_s [%sexp "Hello invalid exit code"]))
     with
     | Ok _ -> assert false
-    | Error (`Vcs err) ->
+    | Error err ->
       print_s
         (Vcs_test_helpers.redact_sexp
            (Vcs.Err.sexp_of_t err)

example/hello_error.ml

@@ -71,7 +71,7 @@ let%expect_test "hello error" =
   let () =
     match Vcs.Result.init vcs ~path:invalid_path with
     | Ok _ -> assert false
-    | Error (`Vcs err) -> print_s (redact_sexp [%sexp (err : Vcs.Err.t)])
+    | Error err -> print_s (redact_sexp [%sexp (err : Vcs.Err.t)])
   in
   [%expect
     {|
@@ -85,5 +85,23 @@ let%expect_test "hello error" =
        (stderr      "")
        (error       <REDACTED>))))
     |}];
+  let () =
+    match Vcs.Rresult.init vcs ~path:invalid_path with
+    | Ok _ -> assert false
+    | Error err -> print_s (redact_sexp [%sexp (err : Vcs.Rresult.err)])
+  in
+  [%expect
+    {|
+    (Vcs (
+      (steps ((Vcs.init ((path /invalid/path)))))
+      (error (
+        (prog git)
+        (args (init .))
+        (exit_status Unknown)
+        (cwd         /invalid/path)
+        (stdout      "")
+        (stderr      "")
+        (error       <REDACTED>)))))
+    |}];
   ()
 ;;

example/hello_git_cli.ml

@@ -150,7 +150,37 @@ let%expect_test "hello cli" =
       Vcs.Result.git vcs ~repo_root ~args:[ "rev-parse"; "INVALID-REF" ] ~f:(fun output ->
         if output.exit_code = 0
         then assert false [@coverage off]
-        else Error (`Vcs (Vcs.Err.create_s [%sexp "Hello invalid exit code"])))
+        else Error (Vcs.Err.create_s [%sexp "Hello invalid exit code"]))
+    with
+    | Ok _ -> assert false
+    | Error err ->
+      print_s
+        (Vcs_test_helpers.redact_sexp
+           [%sexp (err : Vcs.Err.t)]
+           ~fields:[ "cwd"; "repo_root"; "stderr" ])
+  in
+  [%expect
+    {|
+    ((steps ((Vcs.git ((repo_root <REDACTED>) (args (rev-parse INVALID-REF))))))
+     (error (
+       (prog git)
+       (args        (rev-parse INVALID-REF))
+       (exit_status (Exited    128))
+       (cwd    <REDACTED>)
+       (stdout INVALID-REF)
+       (stderr <REDACTED>)
+       (error  "Hello invalid exit code"))))
+    |}];
+  let () =
+    match
+      Vcs.Rresult.git
+        vcs
+        ~repo_root
+        ~args:[ "rev-parse"; "INVALID-REF" ]
+        ~f:(fun output ->
+          if output.exit_code = 0
+          then assert false [@coverage off]
+          else Error (`Vcs (Vcs.Err.create_s [%sexp "Hello invalid exit code"])))
     with
     | Ok _ -> assert false
     | Error (`Vcs err) ->

lib/vcs/src/err.ml

@@ -22,24 +22,45 @@
 open! Import
 
 type t =
-  { steps : Info.t list
-  ; error : Error.t
+  { steps : Sexp.t list
+  ; error : Sexp.t
   }
 [@@deriving sexp_of]
 
-let sexp_of_t ({ steps; error } as t) =
-  if List.is_empty steps then Error.sexp_of_t error else sexp_of_t t
-;;
-
+let sexp_of_t ({ steps; error } as t) = if List.is_empty steps then error else sexp_of_t t
 let to_string_hum t = t |> sexp_of_t |> Sexp.to_string_hum
-let create_s sexp = { steps = []; error = Error.create_s sexp }
+let create_s sexp = { steps = []; error = sexp }
+let error_string str = create_s (Sexp.Atom str)
+let of_exn exn = create_s (sexp_of_exn exn)
+let add_context t ~step = { steps = step :: t.steps; error = t.error }
+let init error ~step = { steps = [ step ]; error }
+
+module Private = struct
+  module Non_raising_M = struct
+    type nonrec t = t
+
+    let sexp_of_t = sexp_of_t
+    let to_err t = t
+    let of_err t = t
+  end
+
+  module View = struct
+    type nonrec t = t =
+      { steps : Sexp.t list
+      ; error : Sexp.t
+      }
+  end
+
+  let view t = t
 
-let to_error t =
-  match t.steps with
-  | [] -> t.error
-  | _ :: _ -> Error.create_s (sexp_of_t t)
-;;
+  module Vcs_base = struct
+    let to_error t =
+      Error.create_s
+        (match view t with
+         | { steps = []; error } -> error
+         | { steps = _ :: _; error = _ } -> sexp_of_t t)
+    ;;
 
-let of_error error = { steps = []; error }
-let add_context t ~step = { steps = Info.create_s step :: t.steps; error = t.error }
-let init error ~step = { steps = [ Info.create_s step ]; error }
+    let of_error error = create_s (Error.sexp_of_t error)
+  end
+end

lib/vcs/src/err.mli

@@ -36,18 +36,40 @@ val sexp_of_t : t -> Sexp.t
 (** [to_string_hum t] is a convenience wrapper around [t |> sexp_of_t |> Sexp.to_string_hum]. *)
 val to_string_hum : t -> string
 
+val error_string : string -> t
 val create_s : Sexp.t -> t
-
-(** Inject [t] into [Base.Error.t]. This is useful if you'd like to use [Vcs]
-    inside the [Or_error] monad. *)
-val to_error : t -> Error.t
-
-(** Create an error with no initial step. *)
-val of_error : Error.t -> t
+val of_exn : exn -> t
 
 (** Add a step of context into the stack trace contained by the error. *)
 val add_context : t -> step:Sexp.t -> t
 
-(** This is useful if you are starting from an [Error.t] initially with an
+(** This is useful if you are starting from an [Sexp.t] initially with an
     initial step. *)
-val init : Error.t -> step:Sexp.t -> t
+val init : Sexp.t -> step:Sexp.t -> t
+
+module Private : sig
+  module Non_raising_M : sig
+    type nonrec t = t [@@deriving sexp_of]
+
+    val to_err : t -> t
+    val of_err : t -> t
+  end
+
+  module View : sig
+    type t =
+      { steps : Sexp.t list
+      ; error : Sexp.t
+      }
+  end
+
+  val view : t -> View.t
+
+  module Vcs_base : sig
+    (** Inject [t] into [Base.Error.t]. This is useful if you'd like to use [Vcs]
+        inside the [Or_error] monad. *)
+    val to_error : t -> Error.t
+
+    (** Create an error with no initial step. *)
+    val of_error : Error.t -> t
+  end
+end

lib/vcs/src/git.ml

@@ -58,10 +58,10 @@ end
 module Non_raising = struct
   module type M = Vcs_interface.Error_S
 
-  module Make (M : M) : S with type 'a result := ('a, M.err) Result.t = struct
+  module Make (M : M) : S with type 'a result := ('a, M.t) Result.t = struct
     let map_result = function
       | Ok x -> Ok x
-      | Error error -> Error (M.map_error (Err.of_error error))
+      | Error error -> Error (M.of_err (Err.Private.Vcs_base.of_error error))
     ;;
 
     let exit0 output = Or_error.exit0 output |> map_result
@@ -72,11 +72,12 @@ end
 
 let err_exn = function
   | Ok x -> x
-  | Error err -> raise (Exn0.E (Err.of_error err))
+  | Error err -> raise (Exn0.E (Err.Private.Vcs_base.of_error err))
 ;;
 
 let exit0 output = Or_error.exit0 output |> err_exn
 let exit0_and_stdout output = Or_error.exit0_and_stdout output |> err_exn
 let exit_code output ~accept = Or_error.exit_code output ~accept |> err_exn
 
-module Result = Non_raising.Make (Vcs_result0)
+module Rresult = Non_raising.Make (Vcs_rresult0)
+module Result = Non_raising.Make (Err.Private.Non_raising_M)

lib/vcs/src/git.mli

@@ -33,8 +33,8 @@ end
 
 (** This is the interface commonly used by raising and non-raising helper
     modules, such as {!module:Vcs.Git}, {!module:Vcs.Git.Or_error},
-    {!module:Vcs.Git.Result}, and custom ones built with
-    {!module:Vcs.Git.Non_raising.Make}. [S] is parametrized by the result
+    {!module:Vcs.Git.Result}, {!module:Vcs.Git.Rresult}, and custom ones built
+    with {!module:Vcs.Git.Non_raising.Make}. [S] is parametrized by the result
     type returned by the helpers. *)
 module type S = Vcs_interface.Process_S
 
@@ -48,16 +48,17 @@ module type S = Vcs_interface.Process_S
 include S with type 'a result := 'a
 
 module Non_raising : sig
-  (** A functor to build non raising helpers based on a custom result type.
+  (** A functor to build non raising helpers based on a custom error type.
 
-      In addition to {!module:Vcs.Git.Or_error} and {!module:Vcs.Git.Result}, we
-      provide this functor to create a [Git.S] interface based on a custom
-      result type of your choice. *)
+      In addition to {!module:Vcs.Git.Or_error}, {!module:Vcs.Git.Result} and
+      {!module:Vcs.Git.Rresult} we provide this functor to create a [Git.S]
+      interface based on a custom error type of your choice. *)
 
   module type M = Vcs_interface.Error_S
 
-  module Make (M : M) : S with type 'a result := ('a, M.err) Result.t
+  module Make (M : M) : S with type 'a result := ('a, M.t) Result.t
 end
 
-module Or_error : S with type 'a result := ('a, Vcs_or_error0.err) Result.t
-module Result : S with type 'a result := ('a, Vcs_result0.err) Result.t
+module Or_error : S with type 'a result := ('a, Vcs_or_error0.t) Result.t
+module Rresult : S with type 'a result := ('a, Vcs_rresult0.t) Result.t
+module Result : S with type 'a result := ('a, Err.t) Result.t

lib/vcs/src/non_raising.ml

@@ -25,11 +25,11 @@ module type M = Vcs_interface.Error_S
 module type S = Vcs_interface.S
 
 module Make (M : M) :
-  S with type 'a t := 'a Vcs0.t and type 'a result := ('a, M.err) Result.t = struct
+  S with type 'a t := 'a Vcs0.t and type 'a result := ('a, M.t) Result.t = struct
   let try_with f =
     match f () with
     | r -> Ok r
-    | exception Exn0.E err -> Error (M.map_error err)
+    | exception Exn0.E err -> Error (M.of_err err)
   ;;
 
   let init vcs ~path = try_with (fun () -> Vcs0.init vcs ~path)
@@ -99,14 +99,16 @@ module Make (M : M) :
   let git ?env ?run_in_subdir vcs ~repo_root ~args ~f =
     match
       Vcs0.Private.git ?env ?run_in_subdir vcs ~repo_root ~args ~f:(fun output ->
-        f output |> Result.map_error ~f:M.to_error)
+        f output
+        |> Result.map_error ~f:(fun err_m ->
+          Err.Private.Vcs_base.to_error (M.to_err err_m)))
     with
     | Ok t -> Ok t
     | Error error ->
       Error
-        (M.map_error
+        (M.of_err
            (Err.init
-              error
+              (Error.sexp_of_t error)
               ~step:
                 (Vcs0.Private.make_git_err_step ?env ?run_in_subdir ~repo_root ~args ())))
   ;;

lib/vcs/src/non_raising.mli

@@ -30,4 +30,4 @@ module type M = Vcs_interface.Error_S
 module type S = Vcs_interface.S
 
 module Make (M : M) :
-  S with type 'a t := 'a Vcs0.t and type 'a result := ('a, M.err) Result.t
+  S with type 'a t := 'a Vcs0.t and type 'a result := ('a, M.t) Result.t

lib/vcs/src/vcs.ml

@@ -45,6 +45,7 @@ module Remote_name = Remote_name
 module Repo_name = Repo_name
 module Repo_root = Repo_root
 module Result = Vcs_result
+module Rresult = Vcs_rresult
 module Rev = Rev
 module Tag_name = Tag_name
 module Trait = Trait

lib/vcs/src/vcs.mli

@@ -324,6 +324,7 @@ module For_test = For_test
 
 module Or_error = Vcs_or_error
 module Result = Vcs_result
+module Rresult = Vcs_rresult
 module Non_raising = Non_raising
 
 module Private : sig

lib/vcs/src/vcs0.ml

@@ -28,7 +28,7 @@ let ( let* ) = Stdlib.Result.bind
 
 let of_result ~step = function
   | Ok r -> r
-  | Error error -> raise (Exn0.E (Err.init error ~step:(force step)))
+  | Error error -> raise (Exn0.E (Err.init (Error.sexp_of_t error) ~step:(force step)))
 ;;
 
 let load_file (Provider.T { t; handler }) ~path =