Return [result] when loading lockdir (#10847)

Adds versions of functions that load lockdirs that return [Error] when
loading fails rather than raising an exception.

Signed-off-by: Stephen Sherratt <[email protected]>

Author: gridbugs

src/dune_pkg/lock_dir.ml

@@ -634,32 +634,35 @@ struct
     let open Io.O in
     Io.stats_kind lock_dir_path
     >>| function
-    | Ok S_DIR -> ()
+    | Ok S_DIR -> Ok ()
     | Error (Unix.ENOENT, _, _) ->
-      User_error.raise
-        ~hints:
-          [ Pp.concat
-              ~sep:Pp.space
-              [ Pp.text "Run"
-              ; User_message.command "dune pkg lock"
-              ; Pp.text "to generate it."
-              ]
-            |> Pp.hovbox
-          ]
-        [ Pp.textf "%s does not exist." (Path.Source.to_string lock_dir_path) ]
+      Error
+        (User_error.make
+           ~hints:
+             [ Pp.concat
+                 ~sep:Pp.space
+                 [ Pp.text "Run"
+                 ; User_message.command "dune pkg lock"
+                 ; Pp.text "to generate it."
+                 ]
+               |> Pp.hovbox
+             ]
+           [ Pp.textf "%s does not exist." (Path.Source.to_string lock_dir_path) ])
     | Error e ->
-      User_error.raise
-        [ Pp.textf "%s is not accessible" (Path.Source.to_string lock_dir_path)
-        ; Pp.textf "reason: %s" (Unix_error.Detailed.to_string_hum e)
-        ]
+      Error
+        (User_error.make
+           [ Pp.textf "%s is not accessible" (Path.Source.to_string lock_dir_path)
+           ; Pp.textf "reason: %s" (Unix_error.Detailed.to_string_hum e)
+           ])
     | _ ->
-      User_error.raise
-        [ Pp.textf "%s is not a directory." (Path.Source.to_string lock_dir_path) ]
+      Error
+        (User_error.make
+           [ Pp.textf "%s is not a directory." (Path.Source.to_string lock_dir_path) ])
   ;;
 
   let check_packages packages ~lock_dir_path =
     match validate_packages packages with
-    | Ok () -> ()
+    | Ok () -> Ok ()
     | Error (`Missing_dependencies missing_dependencies) ->
       List.iter missing_dependencies ~f:(fun { dependant_package; dependency; loc } ->
         User_message.prerr
@@ -673,50 +676,60 @@ struct
                  (Package_name.to_string dependency)
                  (Path.Source.to_string_maybe_quoted lock_dir_path)
              ]));
-      User_error.raise
-        ~hints:
-          [ Pp.concat
-              ~sep:Pp.space
-              [ Pp.text
-                  "This could indicate that the lockdir is corrupted. Delete it and then \
-                   regenerate it by running:"
-              ; User_message.command "dune pkg lock"
-              ]
-          ]
-        [ Pp.textf
-            "At least one package dependency is itself not present as a package in the \
-             lockdir %s."
-            (Path.Source.to_string_maybe_quoted lock_dir_path)
-        ]
+      Error
+        (User_error.make
+           ~hints:
+             [ Pp.concat
+                 ~sep:Pp.space
+                 [ Pp.text
+                     "This could indicate that the lockdir is corrupted. Delete it and \
+                      then regenerate it by running:"
+                 ; User_message.command "dune pkg lock"
+                 ]
+             ]
+           [ Pp.textf
+               "At least one package dependency is itself not present as a package in \
+                the lockdir %s."
+               (Path.Source.to_string_maybe_quoted lock_dir_path)
+           ])
   ;;
 
   let load lock_dir_path =
     let open Io.O in
-    let* () = check_path lock_dir_path in
-    let* version, dependency_hash, ocaml, repos, expanded_solver_variable_bindings =
-      load_metadata (Path.Source.relative lock_dir_path metadata_filename)
-    in
-    let+ packages =
-      Io.readdir_with_kinds lock_dir_path
-      >>| List.filter_map ~f:(fun (name, (kind : Unix.file_kind)) ->
-        match kind with
-        | S_REG -> Package_filename.to_package_name name |> Result.to_option
-        | _ ->
-          (* TODO *)
-          None)
-      >>= Io.parallel_map ~f:(fun package_name ->
-        let+ pkg = load_pkg ~version ~lock_dir_path package_name in
-        package_name, pkg)
-      >>| Package_name.Map.of_list_exn
-    in
-    check_packages packages ~lock_dir_path;
-    { version
-    ; dependency_hash
-    ; packages
-    ; ocaml
-    ; repos
-    ; expanded_solver_variable_bindings
-    }
+    let* result = check_path lock_dir_path in
+    match result with
+    | Error e -> Io.return (Error e)
+    | Ok () ->
+      let* version, dependency_hash, ocaml, repos, expanded_solver_variable_bindings =
+        load_metadata (Path.Source.relative lock_dir_path metadata_filename)
+      in
+      let+ packages =
+        Io.readdir_with_kinds lock_dir_path
+        >>| List.filter_map ~f:(fun (name, (kind : Unix.file_kind)) ->
+          match kind with
+          | S_REG -> Package_filename.to_package_name name |> Result.to_option
+          | _ ->
+            (* TODO *)
+            None)
+        >>= Io.parallel_map ~f:(fun package_name ->
+          let+ pkg = load_pkg ~version ~lock_dir_path package_name in
+          package_name, pkg)
+        >>| Package_name.Map.of_list_exn
+      in
+      check_packages packages ~lock_dir_path
+      |> Result.map ~f:(fun () ->
+        { version
+        ; dependency_hash
+        ; packages
+        ; ocaml
+        ; repos
+        ; expanded_solver_variable_bindings
+        })
+  ;;
+
+  let load_exn lock_dir_path =
+    let open Io.O in
+    load lock_dir_path >>| User_error.ok_exn
   ;;
 end
 
@@ -740,7 +753,7 @@ module Load_immediate = Make_load (struct
     let with_lexbuf_from_file path ~f = Io.with_lexbuf_from_file (Path.source path) ~f
   end)
 
-let read_disk = Load_immediate.load
+let read_disk = Load_immediate.load_exn
 
 let transitive_dependency_closure t start =
   let missing_packages =

src/dune_pkg/lock_dir.mli

@@ -100,7 +100,8 @@ module Make_load (Io : sig
     val with_lexbuf_from_file : Path.Source.t -> f:(Lexing.lexbuf -> 'a) -> 'a t
     val stats_kind : Path.Source.t -> (File_kind.t, Unix_error.Detailed.t) result t
   end) : sig
-  val load : Path.Source.t -> t Io.t
+  val load : Path.Source.t -> (t, User_message.t) result Io.t
+  val load_exn : Path.Source.t -> t Io.t
 end
 
 (** [transitive_dependency_closure t names] returns the set of package names

src/dune_rules/fetch_rules.ml

@@ -158,6 +158,7 @@ let find_checksum, find_url =
     Memo.lazy_ (fun () ->
       Per_context.list ()
       >>= Memo.parallel_map ~f:Lock_dir.get
+      >>| List.filter_map ~f:Result.to_option
       >>| List.fold_left
             ~init:(Checksum.Map.empty, Digest.Map.empty)
             ~f:(fun (checksums, urls) (lockdir : Dune_pkg.Lock_dir.t) ->

src/dune_rules/lock_dir.ml

@@ -128,18 +128,23 @@ let get_workspace_lock_dir ctx =
   Workspace.find_lock_dir workspace path
 ;;
 
-let get (ctx : Context_name.t) : t Memo.t =
-  let* lock_dir = get_path ctx >>| Option.value_exn >>= Load.load in
-  let+ workspace_lock_dir = get_workspace_lock_dir ctx in
-  (match workspace_lock_dir with
-   | None -> ()
-   | Some workspace_lock_dir ->
-     Solver_stats.Expanded_variable_bindings.validate_against_solver_env
-       lock_dir.expanded_solver_variable_bindings
-       (workspace_lock_dir.solver_env |> Option.value ~default:Solver_env.empty));
-  lock_dir
+let get ctx =
+  let* result = get_path ctx >>| Option.value_exn >>= Load.load in
+  match result with
+  | Error e -> Memo.return (Error e)
+  | Ok lock_dir ->
+    let+ workspace_lock_dir = get_workspace_lock_dir ctx in
+    (match workspace_lock_dir with
+     | None -> ()
+     | Some workspace_lock_dir ->
+       Solver_stats.Expanded_variable_bindings.validate_against_solver_env
+         lock_dir.expanded_solver_variable_bindings
+         (workspace_lock_dir.solver_env |> Option.value ~default:Solver_env.empty));
+    Ok lock_dir
 ;;
 
+let get_exn ctx = get ctx >>| User_error.ok_exn
+
 let lock_dir_active ctx =
   if !Clflags.ignore_lock_dir
   then Memo.return false

src/dune_rules/lock_dir.mli

@@ -3,7 +3,8 @@ module Pkg = Dune_pkg.Lock_dir.Pkg
 
 type t := Dune_pkg.Lock_dir.t
 
-val get : Context_name.t -> t Memo.t
+val get : Context_name.t -> (t, User_message.t) result Memo.t
+val get_exn : Context_name.t -> t Memo.t
 val lock_dir_active : Context_name.t -> bool Memo.t
 val get_path : Context_name.t -> Path.Source.t option Memo.t
 

src/dune_rules/pkg_rules.ml

@@ -1135,7 +1135,7 @@ module DB = struct
   let get =
     let dune = Package.Name.Set.singleton (Package.Name.of_string "dune") in
     fun context ->
-      let+ all = Lock_dir.get context in
+      let+ all = Lock_dir.get_exn context in
       { all = all.packages; system_provided = dune }
   ;;
 end
@@ -1872,7 +1872,7 @@ let setup_rules ~components ~dir ctx =
 ;;
 
 let ocaml_toolchain context =
-  (let* lock_dir = Lock_dir.get context in
+  (let* lock_dir = Lock_dir.get_exn context in
    let* db = DB.get context in
    match lock_dir.ocaml with
    | None -> Memo.return `System_provided