Raise [Vcs.E] more systematically

CHANGES.md

@@ -9,16 +9,18 @@
 ### Changed
 
 - Provider interfaces now uses `Vcs.Result` type instead of `Or_error` (#34, @mbarbin).
-- Moved `Vcs.raise_s` to `Vcs.Exn.raise_s` to group exn related helpers (#34, @mbarbin).
 - Rename what was `Vcs.Result` to `Vcs.Rresult` and introduce `Vcs.Result` whose type is simpler (#33, @mbarbin).
 - Moved `ocaml-vcs more-tests` commands at top-level (#28, @mbarbin).
 
 ### Deprecated
 
 ### Fixed
 
+- Changed some exceptions raised by the `vcs` related libraries to the `Vcs.E` exception (#34, @mbarbin).
+
 ### Removed
 
+- Removed `Vcs.Exn.raise_s` since it is causing `bisect_ppx` unvisitable points (#34, @mbarbin).
 - Removed package `vcs-arg` and inline what's needed directly in `vcs-command` (#28, @mbarbin).
 
 ## 0.0.8 (2024-09-30)

lib/vcs/src/graph.ml

@@ -229,7 +229,7 @@ let refs t =
 
 let set_ref t ~rev ~ref_kind =
   match Hashtbl.find t.revs rev with
-  | None -> raise_s [%sexp "Rev not found", (rev : Rev.t)]
+  | None -> raise (Exn0.E (Err.create_s [%sexp "Rev not found", (rev : Rev.t)]))
   | Some index ->
     Hashtbl.set t.refs ~key:ref_kind ~data:index;
     Hashtbl.add_multi t.reverse_refs ~key:index ~data:ref_kind
@@ -497,7 +497,11 @@ let rec summary t =
 let check_index_exn t ~index =
   let node_count = node_count t in
   if index < 0 || index >= node_count
-  then raise_s [%sexp "Node index out of bounds", { index : int; node_count : int }]
+  then
+    raise
+      (Exn0.E
+         (Err.create_s
+            [%sexp "Node index out of bounds", { index : int; node_count : int }]))
 ;;
 
 let get_node_exn t ~index =

lib/vcs/src/vcs_exn.ml

@@ -23,10 +23,6 @@ let reraise_with_context err bt ~step =
   Stdlib.Printexc.raise_with_backtrace (Exn0.E (Err.add_context err ~step)) bt
 ;;
 
-let raise_s msg sexp =
-  raise (Exn0.E (Err.create_s [%sexp (msg : string), (sexp : Sexp.t)]))
-;;
-
 module Private = struct
   let try_with f =
     match f () with

lib/vcs/src/vcs_exn.mli

@@ -45,10 +45,6 @@
     ]} *)
 val reraise_with_context : Err.t -> Stdlib.Printexc.raw_backtrace -> step:Sexp.t -> _
 
-(** Build an err payload from the supplied message and data and raise it as a
-    {!exception:Vcs.E} exception. *)
-val raise_s : string -> Sexp.t -> _
-
 module Private : sig
   (** [try_with f] runs [f] and wraps any exception it raises into an
       {!type:Err.t} error. Because this catches all exceptions, including

lib/vcs/test/test__graph.ml

@@ -443,7 +443,7 @@ let%expect_test "set invalid rev" =
       ~ref_kind:(Local_branch { branch_name = Vcs.Branch_name.v "main" })
   in
   require_does_raise [%here] (fun () -> set_ref_r1 ());
-  [%expect {| ("Rev not found" 5cd237e9598b11065c344d1eb33bc8c15cd237e9) |}];
+  [%expect {| (Vcs.E ("Rev not found" 5cd237e9598b11065c344d1eb33bc8c15cd237e9)) |}];
   Vcs.Graph.add_nodes graph ~log:[ Root { rev = r1 } ];
   set_ref_r1 ();
   print_s [%sexp (Vcs.Graph.refs graph : Vcs.Refs.t)];
@@ -696,16 +696,18 @@ let%expect_test "debug graph" =
   require_does_raise [%here] (fun () -> get_node_exn 5);
   [%expect
     {|
-    ("Node index out of bounds" (
-      (index      5)
-      (node_count 5)))
+    (Vcs.E (
+      "Node index out of bounds" (
+        (index      5)
+        (node_count 5))))
     |}];
   require_does_raise [%here] (fun () -> get_node_exn (-1));
   [%expect
     {|
-    ("Node index out of bounds" (
-      (index      -1)
-      (node_count 5)))
+    (Vcs.E (
+      "Node index out of bounds" (
+        (index      -1)
+        (node_count 5))))
     |}];
   ()
 ;;

lib/vcs_command/src/vcs_command.ml

@@ -39,9 +39,12 @@ let find_enclosing_repo_root vcs ~from =
   match Vcs.find_enclosing_repo_root vcs ~from ~store:[ Fsegment.dot_git, `Git ] with
   | Some (`Git, repo_root) -> repo_root
   | None ->
-    Vcs.Exn.raise_s
-      "Failed to locate enclosing repo root from directory"
-      [%sexp { from : Absolute_path.t }]
+    raise
+      (Vcs.E
+         (Vcs.Err.create_s
+            [%sexp
+              "Failed to locate enclosing repo root from directory"
+              , { from : Absolute_path.t }]))
 ;;
 
 let initialize ~env =
@@ -57,7 +60,9 @@ let relativize ~repo_root ~cwd ~path =
     Absolute_path.chop_prefix path ~prefix:(repo_root |> Vcs.Repo_root.to_absolute_path)
   with
   | Some relative_path -> Vcs.Path_in_repo.of_relative_path relative_path
-  | None -> Vcs.Exn.raise_s "Path is not in repo" [%sexp { path : Absolute_path.t }]
+  | None ->
+    raise
+      (Vcs.E (Vcs.Err.create_s [%sexp "Path is not in repo", { path : Absolute_path.t }]))
 ;;
 
 let add_cmd =
@@ -463,13 +468,10 @@ let branch_revision_cmd =
        with
        | Some ref -> ref.rev
        | None ->
-         (* This line is covered in tests, but we need to disable coverage
-            reporting here. The reason is that bisect_ppx inserts an unvisitable
-            coverage point at the out-edge of this raising call, which would
-            otherwise result in a false negative in our test coverage. *)
-         Vcs.Exn.raise_s
-           "Branch not found"
-           [%sexp { branch_name : Vcs.Branch_name.t }] [@coverage off]
+         raise
+           (Vcs.E
+              (Vcs.Err.create_s
+                 [%sexp "Branch not found", { branch_name : Vcs.Branch_name.t }]))
      in
      print_sexp [%sexp (rev : Vcs.Rev.t)];
      ())
@@ -492,7 +494,8 @@ let greatest_common_ancestors_cmd =
        List.map revs ~f:(fun rev ->
          match Vcs.Graph.find_rev graph ~rev with
          | Some node -> node
-         | None -> Vcs.Exn.raise_s "Rev not found" [%sexp { rev : Vcs.Rev.t }])
+         | None ->
+           raise (Vcs.E (Vcs.Err.create_s [%sexp "Rev not found", { rev : Vcs.Rev.t }])))
      in
      let gca =
        Vcs.Graph.greatest_common_ancestors graph nodes

lib/vcs_git_provider/src/log.ml

@@ -22,14 +22,29 @@
 open! Import
 
 let parse_log_line_exn ~line:str : Vcs.Log.Line.t =
-  match String.split (String.strip str) ~on:' ' with
-  | [ rev ] -> Root { rev = Vcs.Rev.v rev }
-  | [ rev; parent ] -> Commit { rev = Vcs.Rev.v rev; parent = Vcs.Rev.v parent }
-  | [ rev; parent1; parent2 ] ->
-    Merge
-      { rev = Vcs.Rev.v rev; parent1 = Vcs.Rev.v parent1; parent2 = Vcs.Rev.v parent2 }
-  | [] -> assert false
-  | _ :: _ :: _ :: _ -> raise_s [%sexp "Invalid log line", (str : string)]
+  match
+    Vcs.Exn.Private.try_with (fun () ->
+      match String.split (String.strip str) ~on:' ' with
+      | [ rev ] -> Vcs.Log.Line.Root { rev = Vcs.Rev.v rev }
+      | [ rev; parent ] -> Commit { rev = Vcs.Rev.v rev; parent = Vcs.Rev.v parent }
+      | [ rev; parent1; parent2 ] ->
+        Merge
+          { rev = Vcs.Rev.v rev
+          ; parent1 = Vcs.Rev.v parent1
+          ; parent2 = Vcs.Rev.v parent2
+          }
+      | [] -> assert false
+      | _ :: _ :: _ :: _ ->
+        raise (Vcs.E (Vcs.Err.error_string "Too many words (expected 1, 2, or 3)")))
+  with
+  | Ok t -> t
+  | Error err ->
+    raise
+      (Vcs.E
+         (Vcs.Err.add_context
+            err
+            ~step:
+              [%sexp "Vcs_git_provider.Log.parse_log_line_exn", { line = (str : string) }]))
 ;;
 
 module Make (Runtime : Runtime.S) = struct

lib/vcs_git_provider/src/munged_path.ml

@@ -38,27 +38,29 @@ include T
 let arrow = lazy (String.Search_pattern.create " => ")
 
 let parse_exn str =
-  try
-    match String.Search_pattern.split_on (force arrow) str with
-    | [ str ] -> One_file (Vcs.Path_in_repo.v str)
-    | [ left; right ] ->
-      (match String.rsplit2 left ~on:'{' with
-       | None ->
-         Two_files { src = Vcs.Path_in_repo.v left; dst = Vcs.Path_in_repo.v right }
-       | Some (prefix, left_of_arrow) ->
-         let right_of_arrow, suffix = String.lsplit2_exn right ~on:'}' in
-         Two_files
-           { src = Vcs.Path_in_repo.v (prefix ^ left_of_arrow ^ suffix)
-           ; dst = Vcs.Path_in_repo.v (prefix ^ right_of_arrow ^ suffix)
-           })
-    | _ :: _ :: _ -> raise_s [%sexp "Too many '=>'"] [@coverage off]
-    | [] -> assert false
+  match
+    Vcs.Exn.Private.try_with (fun () ->
+      match String.Search_pattern.split_on (force arrow) str with
+      | [ str ] -> One_file (Vcs.Path_in_repo.v str)
+      | [ left; right ] ->
+        (match String.rsplit2 left ~on:'{' with
+         | None ->
+           Two_files { src = Vcs.Path_in_repo.v left; dst = Vcs.Path_in_repo.v right }
+         | Some (prefix, left_of_arrow) ->
+           let right_of_arrow, suffix = String.lsplit2_exn right ~on:'}' in
+           Two_files
+             { src = Vcs.Path_in_repo.v (prefix ^ left_of_arrow ^ suffix)
+             ; dst = Vcs.Path_in_repo.v (prefix ^ right_of_arrow ^ suffix)
+             })
+      | _ :: _ :: _ -> raise (Vcs.E (Vcs.Err.error_string "Too many '=>'"))
+      | [] -> assert false)
   with
-  | exn ->
-    raise_s
-      [%sexp
-        "Vcs_git_provider.Munged_path.parse_exn"
-        , "invalid path"
-        , (str : string)
-        , (exn : Exn.t)]
+  | Ok t -> t
+  | Error err ->
+    raise
+      (Vcs.E
+         (Vcs.Err.add_context
+            err
+            ~step:
+              [%sexp "Vcs_git_provider.Munged_path.parse_exn", { path = (str : string) }]))
 ;;

lib/vcs_git_provider/src/name_status.ml

@@ -46,7 +46,7 @@ module Diff_status = struct
 
   let parse_exn str : t =
     if String.is_empty str
-    then raise_s [%sexp "Unexpected empty diff status"] [@coverage off];
+    then raise (Vcs.E (Vcs.Err.error_string "Unexpected empty diff status"));
     match str.[0] with
     | 'A' -> `A
     | 'D' -> `D
@@ -64,30 +64,42 @@ module Diff_status = struct
 end
 
 let parse_line_exn ~line : Vcs.Name_status.Change.t =
-  match String.split line ~on:'\t' with
-  | [] -> assert false
-  | [ _ ] -> raise_s [%sexp "Unexpected output from git status", (line : string)]
-  | status :: path :: rest ->
-    (match Diff_status.parse_exn status with
-     | `A -> Added (Vcs.Path_in_repo.v path)
-     | `D -> Removed (Vcs.Path_in_repo.v path)
-     | `M -> Modified (Vcs.Path_in_repo.v path)
-     | (`R | `C) as diff_status ->
-       let similarity =
-         String.sub status ~pos:1 ~len:(String.length status - 1) |> Int.of_string
-       in
-       let path2 =
-         match List.hd rest with
-         | Some hd -> Vcs.Path_in_repo.v hd
-         | None ->
-           raise_s
-             [%sexp "Unexpected output from git status", (line : string)] [@coverage off]
-       in
-       (match diff_status with
-        | `R -> Renamed { src = Vcs.Path_in_repo.v path; dst = path2; similarity }
-        | `C -> Copied { src = Vcs.Path_in_repo.v path; dst = path2; similarity })
-     | other ->
-       raise_s [%sexp "Unexpected status", (status : string), (other : Diff_status.t)])
+  match
+    Vcs.Exn.Private.try_with (fun () ->
+      match String.split line ~on:'\t' with
+      | [] -> assert false
+      | [ _ ] -> raise (Vcs.E (Vcs.Err.error_string "Unexpected output from git status"))
+      | status :: path :: rest ->
+        (match Diff_status.parse_exn status with
+         | `A -> Vcs.Name_status.Change.Added (Vcs.Path_in_repo.v path)
+         | `D -> Removed (Vcs.Path_in_repo.v path)
+         | `M -> Modified (Vcs.Path_in_repo.v path)
+         | (`R | `C) as diff_status ->
+           let similarity =
+             String.sub status ~pos:1 ~len:(String.length status - 1) |> Int.of_string
+           in
+           let path2 =
+             match List.hd rest with
+             | Some hd -> Vcs.Path_in_repo.v hd
+             | None ->
+               raise (Vcs.E (Vcs.Err.error_string "Unexpected output from git status"))
+           in
+           (match diff_status with
+            | `R -> Renamed { src = Vcs.Path_in_repo.v path; dst = path2; similarity }
+            | `C -> Copied { src = Vcs.Path_in_repo.v path; dst = path2; similarity })
+         | other ->
+           raise
+             (Vcs.E
+                (Vcs.Err.create_s
+                   [%sexp "Unexpected status", (status : string), (other : Diff_status.t)]))))
+  with
+  | Ok t -> t
+  | Error err ->
+    raise
+      (Vcs.E
+         (Vcs.Err.add_context
+            err
+            ~step:[%sexp "Vcs_git_provider.Name_status.parse_line_exn", { line : string }]))
 ;;
 
 let parse_lines_exn ~lines = List.map lines ~f:(fun line -> parse_line_exn ~line)

lib/vcs_git_provider/src/num_status.ml

@@ -44,23 +44,35 @@ module Status_code = struct
 end
 
 let parse_line_exn ~line : Vcs.Num_status.Change.t =
-  match String.split line ~on:'\t' with
-  | [] -> assert false
-  | [ _ ] | [ _; _ ] | _ :: _ :: _ :: _ :: _ ->
-    raise_s [%sexp "Unexpected output from git diff", (line : string)]
-  | [ insertions; deletions; munged_path ] ->
-    { Vcs.Num_status.Change.key = Munged_path.parse_exn munged_path
-    ; num_stat =
-        (match Status_code.parse insertions, Status_code.parse deletions with
-         | Dash, Dash -> Binary_file
-         | Num insertions, Num deletions -> Num_lines_in_diff { insertions; deletions }
-         | insertions, deletions ->
-           raise_s
-             [%sexp
-               "Unexpected output from git diff"
-               , { line : string; insertions : Status_code.t; deletions : Status_code.t }]
-           [@coverage off])
-    }
+  match
+    Vcs.Exn.Private.try_with (fun () ->
+      match String.split line ~on:'\t' with
+      | [] -> assert false
+      | [ _ ] | [ _; _ ] | _ :: _ :: _ :: _ :: _ ->
+        raise (Vcs.E (Vcs.Err.error_string "Unexpected output from git diff"))
+      | [ insertions; deletions; munged_path ] ->
+        { Vcs.Num_status.Change.key = Munged_path.parse_exn munged_path
+        ; num_stat =
+            (match Status_code.parse insertions, Status_code.parse deletions with
+             | Dash, Dash -> Binary_file
+             | Num insertions, Num deletions ->
+               Num_lines_in_diff { insertions; deletions }
+             | insertions, deletions ->
+               raise
+                 (Vcs.E
+                    (Vcs.Err.create_s
+                       [%sexp
+                         "Unexpected output from git diff"
+                         , { insertions : Status_code.t; deletions : Status_code.t }])))
+        })
+  with
+  | Ok t -> t
+  | Error err ->
+    raise
+      (Vcs.E
+         (Vcs.Err.add_context
+            err
+            ~step:[%sexp "Vcs_git_provider.Num_status.parse_line_exn", { line : string }]))
 ;;
 
 let parse_lines_exn ~lines = List.map lines ~f:(fun line -> parse_line_exn ~line)