diff --git a/src/dune_pkg/lock_dir.ml b/src/dune_pkg/lock_dir.ml index cb4efcc0e33..afc9a16500d 100644 --- a/src/dune_pkg/lock_dir.ml +++ b/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 = diff --git a/src/dune_pkg/lock_dir.mli b/src/dune_pkg/lock_dir.mli index 0c9d3a7386a..21218c0d33a 100644 --- a/src/dune_pkg/lock_dir.mli +++ b/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 diff --git a/src/dune_rules/fetch_rules.ml b/src/dune_rules/fetch_rules.ml index c323c09607e..2e5e0c90b92 100644 --- a/src/dune_rules/fetch_rules.ml +++ b/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) -> diff --git a/src/dune_rules/lock_dir.ml b/src/dune_rules/lock_dir.ml index 0863390f087..c3904fd6fbf 100644 --- a/src/dune_rules/lock_dir.ml +++ b/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 diff --git a/src/dune_rules/lock_dir.mli b/src/dune_rules/lock_dir.mli index cf0e60caf93..d49c7a4c600 100644 --- a/src/dune_rules/lock_dir.mli +++ b/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 diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml index c41a94fc2bd..2c9c10f2f38 100644 --- a/src/dune_rules/pkg_rules.ml +++ b/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