diff --git a/bin/common.ml b/bin/common.ml index 50921455cb0..52a42eec35e 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -175,7 +175,7 @@ let init ?log_file c = ~cache_debug_flags:c.cache_debug_flags ~handler:(Option.map c.rpc ~f:Dune_rpc_impl.Server.build_handler); Only_packages.Clflags.set c.only_packages; - Clflags.debug_dep_path := c.debug_dep_path; + Dune_util.Report_error.print_memo_stacks := c.debug_dep_path; Clflags.debug_findlib := c.debug_findlib; Clflags.debug_backtraces c.debug_backtraces; Clflags.debug_artifact_substitution := c.debug_artifact_substitution; diff --git a/bin/main.ml b/bin/main.ml index a2e48196f5f..09c230786b8 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -93,5 +93,5 @@ let () = | Scheduler.Run.Shutdown_requested -> exit 0 | exn -> let exn = Exn_with_backtrace.capture exn in - Dune_engine.Report_error.report exn; + Dune_util.Report_error.report exn; exit 1 diff --git a/otherlibs/action-plugin/test/depends-on-its-target-by-read-dir/run.t b/otherlibs/action-plugin/test/depends-on-its-target-by-read-dir/run.t index 8045f57c183..e9826f675f8 100644 --- a/otherlibs/action-plugin/test/depends-on-its-target-by-read-dir/run.t +++ b/otherlibs/action-plugin/test/depends-on-its-target-by-read-dir/run.t @@ -13,7 +13,7 @@ $ cp ./bin/foo.exe ./ $ dune build some_file - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/some_file [1] diff --git a/otherlibs/action-plugin/test/depends-on-its-target/run.t b/otherlibs/action-plugin/test/depends-on-its-target/run.t index d7b4884779c..743378c9c42 100644 --- a/otherlibs/action-plugin/test/depends-on-its-target/run.t +++ b/otherlibs/action-plugin/test/depends-on-its-target/run.t @@ -19,11 +19,11 @@ $ cp ./bin/foo2.exe ./ $ dune build some_file1 - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/some_file1 [1] $ dune build some_file2 - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/some_file2 [1] diff --git a/otherlibs/site/src/plugins/meta_parser.ml b/otherlibs/site/src/plugins/meta_parser.ml index d47334694e2..d69230c9a21 100644 --- a/otherlibs/site/src/plugins/meta_parser.ml +++ b/otherlibs/site/src/plugins/meta_parser.ml @@ -34,7 +34,7 @@ module Meta_parser = Dune_meta_parser.Meta_parser.Make (struct type t = unit end - let raise ?loc:_ ?hints:_ ?annot:_ texts = + let raise ?loc:_ ?hints:_ ?annots:_ texts = invalid_arg (String.concat " " texts) end end) diff --git a/otherlibs/stdune-unstable/user_error.ml b/otherlibs/stdune-unstable/user_error.ml index 00ede9a1c27..67e6394cd71 100644 --- a/otherlibs/stdune-unstable/user_error.ml +++ b/otherlibs/stdune-unstable/user_error.ml @@ -34,9 +34,15 @@ module Annot = struct in format := f end + + module Has_embedded_location = Make (struct + type payload = unit + + let to_dyn = Unit.to_dyn + end) end -exception E of User_message.t * Annot.t option +exception E of User_message.t * Annot.t list let prefix = Pp.seq (Pp.tag User_message.Style.Error (Pp.verbatim "Error")) (Pp.char ':') @@ -44,14 +50,31 @@ let prefix = let make ?loc ?hints paragraphs = User_message.make ?loc ?hints paragraphs ~prefix -let raise ?loc ?hints ?annot paragraphs = - raise (E (make ?loc ?hints paragraphs, annot)) +let raise ?loc ?hints ?(annots = []) paragraphs = + raise (E (make ?loc ?hints paragraphs, annots)) + +let is_loc_none loc = + match loc with + | None -> true + | Some loc -> loc = Loc0.none + +let has_embed_location annots = + List.exists annots ~f:(fun annot -> + Annot.Has_embedded_location.check annot (fun () -> true) (fun () -> false)) + +let has_location (msg : User_message.t) annots = + (not (is_loc_none msg.loc)) || has_embed_location annots let () = Printexc.register_printer (function - | E (t, None) -> Some (Format.asprintf "%a@?" Pp.to_fmt (User_message.pp t)) - | E (t, Some annot) -> - Some - (Format.asprintf "%a (annotations: %a)@?" Pp.to_fmt (User_message.pp t) - Pp.to_fmt (!Annot.format annot)) + | E (t, []) -> Some (Format.asprintf "%a@?" Pp.to_fmt (User_message.pp t)) + | E (t, annots) -> + let open Pp.O in + let pp = + User_message.pp t + ++ Pp.vbox + (Pp.concat_map annots ~f:(fun annot -> + Pp.box (!Annot.format annot) ++ Pp.cut)) + in + Some (Format.asprintf "%a" Pp.to_fmt pp) | _ -> None) diff --git a/otherlibs/stdune-unstable/user_error.mli b/otherlibs/stdune-unstable/user_error.mli index 4fc5ffd5d49..a369eb39138 100644 --- a/otherlibs/stdune-unstable/user_error.mli +++ b/otherlibs/stdune-unstable/user_error.mli @@ -16,6 +16,9 @@ module Annot : sig val to_dyn : payload -> Dyn.t end) : S with type payload = M.payload + + (** The message has a location embed in the text. *) + module Has_embedded_location : S with type payload = unit end (** User errors are errors that users need to fix themselves in order to make @@ -24,14 +27,14 @@ end The additional [Annot.t] is intended to carry extra context for other, non-user-facing purposes (such as data for the RPC). *) -exception E of User_message.t * Annot.t option +exception E of User_message.t * Annot.t list (** Raise a user error. The arguments are interpreted in the same way as [User_message.make]. The first paragraph is prefixed with "Error:". *) val raise : ?loc:Loc0.t -> ?hints:User_message.Style.t Pp.t list - -> ?annot:Annot.t + -> ?annots:Annot.t list -> User_message.Style.t Pp.t list -> _ @@ -44,3 +47,11 @@ val make : (** The "Error:" prefix *) val prefix : User_message.Style.t Pp.t + +(** Returns [true] if the message has an explicit location or one embed in the + text. *) +val has_location : User_message.t -> Annot.t list -> bool + +(** Returns [true] if the following list of annotations contains + [Annot.Has_embedded_location]. *) +val has_embed_location : Annot.t list -> bool diff --git a/src/dune_engine/action.ml b/src/dune_engine/action.ml index b135e52c7a1..74093912396 100644 --- a/src/dune_engine/action.ml +++ b/src/dune_engine/action.ml @@ -30,7 +30,7 @@ module Prog = struct in Utils.program_not_found_message ?hint ~loc ~context program - let raise t = raise (User_error.E (user_message t, None)) + let raise t = raise (User_error.E (user_message t, [])) let to_dyn { context; program; hint; loc = _ } = let open Dyn.Encoder in diff --git a/src/dune_engine/action_builder.ml b/src/dune_engine/action_builder.ml index a7fcadc997e..9287c1c9843 100644 --- a/src/dune_engine/action_builder.ml +++ b/src/dune_engine/action_builder.ml @@ -381,13 +381,7 @@ struct | true -> exec then_ | false -> exec else_) | Catch (t, on_error) -> ( - let+ res = - Memo.Build.map_reduce_errors - (module Monoid.Unit) - ~on_error:(fun _ -> Memo.Build.return ()) - (fun () -> exec t) - in - match res with + Memo.Build.swallow_errors (fun () -> exec t) >>| function | Ok r -> r | Error () -> (on_error, Dep.Map.empty)) | Memo m -> Memo_poly.eval m diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 0c21cec77f6..941909a0217 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -367,10 +367,11 @@ module Error = struct (fun () -> None) let info (t : t) = - let exn, deps = Dep_path.unwrap_exn t.exn in - match exn with - | User_error.E (msg, annot) -> (msg, deps, Option.bind ~f:extract_dir annot) - | e -> (User_message.make [ Pp.text (Printexc.to_string e) ], deps, None) + match t.exn with + | User_error.E (msg, annots) -> (msg, List.find_map annots ~f:extract_dir) + | e -> + (* CR-someday jeremiedimino: Use [Report_error.get_user_message] here. *) + (User_message.make [ Pp.text (Printexc.to_string e) ], None) end module type Rule_generator = sig @@ -1218,10 +1219,18 @@ let expand_alias_gen alias ~eval_build_request = User_error.raise ?loc [ Pp.textf "No rule found for %s" alias_descr ] | Some alias_definitions -> Memo.Build.parallel_map alias_definitions ~f:(fun (loc, definition) -> - let on_error exn = Dep_path.reraise exn (Alias (loc, alias)) in - Memo.Build.with_error_handler ~on_error (fun () -> + Memo.push_stack_frame + (fun () -> let+ (), facts = eval_build_request definition in - facts)) + facts) + ~human_readable_description:(fun () -> + let loc_suffix = + if Loc.is_none loc then + "" + else + " in " ^ Loc.to_file_colon_line loc + in + Pp.textf "alias %s%s" (Alias.describe alias) loc_suffix)) type rule_execution_result = { deps : Dep.Fact.t Dep.Map.t @@ -1269,10 +1278,12 @@ and Exported : sig val execute_rule : Rule.t -> rule_execution_result Memo.Build.t - (** Exported to inspect memoization cycles. *) - val build_file_memo : (Path.t, Digest.t) Memo.t + (* The below two definitions are useless, but if we remove them we get an + "Undefined_recursive_module" exception. *) - val build_alias_memo : (Alias.t, Dep.Fact.Files.t) Memo.t + val build_file_memo : (Path.t, Digest.t) Memo.t [@@warning "-32"] + + val build_alias_memo : (Alias.t, Dep.Fact.Files.t) Memo.t [@@warning "-32"] end = struct open Used_recursively @@ -1661,313 +1672,336 @@ end = struct Source_tree.execution_parameters_of_dir dir | _ -> Execution_parameters.default in - Memo.Build.of_reproducible_fiber - (let open Fiber.O in - let build_deps deps = Memo.Build.run (build_deps deps) in - report_evaluated_rule t; - let* () = Memo.Build.run (Fs.mkdir_p dir) in - let is_action_dynamic = Action.is_dynamic action.action in - let sandbox_mode = - match Action.is_useful_to_sandbox action.action with - | Clearly_not -> - let config = Dep.Map.sandbox_config deps in - if Sandbox_config.mem config Sandbox_mode.none then - Sandbox_mode.none - else - User_error.raise ~loc - [ Pp.text - "Rule dependencies are configured to require sandboxing, but \ - the rule has no actions that could potentially require \ - sandboxing." - ] - | Maybe -> - select_sandbox_mode ~loc - (Dep.Map.sandbox_config deps) - ~sandboxing_preference:t.sandboxing_preference - in - let always_rerun = - let is_test = - (* jeremiedimino: what about: + let wrap_fiber f = + Memo.Build.of_reproducible_fiber + (if Loc.is_none loc then + f () + else + Fiber.with_error_handler f ~on_error:(fun exn -> + match exn.exn with + | User_error.E (msg, annots) + when not (User_error.has_location msg annots) -> + let msg = { msg with loc = Some loc } in + Exn_with_backtrace.reraise + { exn with exn = User_error.E (msg, annots) } + | _ -> Exn_with_backtrace.reraise exn)) + in + wrap_fiber (fun () -> + let open Fiber.O in + let build_deps deps = Memo.Build.run (build_deps deps) in + report_evaluated_rule t; + let* () = Memo.Build.run (Fs.mkdir_p dir) in + let is_action_dynamic = Action.is_dynamic action.action in + let sandbox_mode = + match Action.is_useful_to_sandbox action.action with + | Clearly_not -> + let config = Dep.Map.sandbox_config deps in + if Sandbox_config.mem config Sandbox_mode.none then + Sandbox_mode.none + else + User_error.raise ~loc + [ Pp.text + "Rule dependencies are configured to require sandboxing, \ + but the rule has no actions that could potentially \ + require sandboxing." + ] + | Maybe -> + select_sandbox_mode ~loc + (Dep.Map.sandbox_config deps) + ~sandboxing_preference:t.sandboxing_preference + in + let always_rerun = + let is_test = + (* jeremiedimino: what about: - {v (rule (alias runtest) (targets x) (action ...)) v} + {v (rule (alias runtest) (targets x) (action ...)) v} - These will be treated as [Normal_rule], and the bellow match means - that [--force] will have no effect on them. Is that what we want? + These will be treated as [Normal_rule], and the bellow match + means that [--force] will have no effect on them. Is that what we + want? - The doc says: + The doc says: - -f, --force Force actions associated to aliases to be re-executed - even if their dependencies haven't changed. + -f, --force Force actions associated to aliases to be re-executed + even if their dependencies haven't changed. - So it seems to me that such rules should be re-executed. TBC *) - match rule_kind with - | Normal_rule - | Anonymous_action -> - false - | Anonymous_action_attached_to_alias -> true - in - let force_rerun = !Clflags.force && is_test in - force_rerun || Dep.Map.has_universe deps - in - let rule_digest = - compute_rule_digest rule ~deps ~action ~sandbox_mode - ~execution_parameters - in - let can_go_in_shared_cache = - action.can_go_in_shared_cache - && not - (always_rerun || is_action_dynamic - || Action.is_useful_to_memoize action.action = Clearly_not) - in - (* We don't need to digest target names here, as these are already part of - the rule digest. *) - let digest_of_target_digests l = Digest.generic (List.map l ~f:snd) in - (* Here we determine if we need to execute the action based on information - stored in [Trace_db]. If we need to, then [targets_and_digests] will be - [None], otherwise it will be [Some l] where [l] is the list of targets - and their digests. *) - let* (targets_and_digests : - ((Path.Build.t * Digest.t) list, _) Cache_result.t) = - if always_rerun then - Fiber.return (Cache_result.Miss `Always_rerun) - else - (* [prev_trace] will be [None] if rule is run for the first time. *) - let prev_trace = Trace_db.get (Path.build head_target) in - let prev_trace_with_targets_and_digests = - match prev_trace with - | None -> Cache_result.Miss `No_previous_record - | Some prev_trace -> ( - if prev_trace.rule_digest <> rule_digest then - Cache_result.Miss - (`Rule_changed (prev_trace.rule_digest, rule_digest)) - else - (* [targets_and_digests] will be [None] if not all targets were - built. *) - match compute_target_digests targets with - | None -> Cache_result.Miss `Targets_missing - | Some targets_and_digests -> - if - Digest.equal prev_trace.targets_digest - (digest_of_target_digests targets_and_digests) - then - Hit (prev_trace, targets_and_digests) - else - Cache_result.Miss `Targets_changed) + So it seems to me that such rules should be re-executed. TBC *) + match rule_kind with + | Normal_rule + | Anonymous_action -> + false + | Anonymous_action_attached_to_alias -> true in - match prev_trace_with_targets_and_digests with - | Cache_result.Miss reason -> Fiber.return (Cache_result.Miss reason) - | Hit (prev_trace, targets_and_digests) -> - (* CR-someday aalekseyev: If there's a change at one of the last - stages, we still re-run all the previous stages, which is a bit - of a waste. We could remember what stage needs re-running and - only re-run that (and later stages). *) - let rec loop stages = - match stages with - | [] -> Fiber.return (Cache_result.Hit targets_and_digests) - | (deps, old_digest) :: rest -> - let deps = Action_exec.Dynamic_dep.Set.to_dep_set deps in - let* deps = build_deps deps in - let new_digest = - Dep.Facts.digest deps ~sandbox_mode ~env:action.env - in - if old_digest = new_digest then - loop rest + let force_rerun = !Clflags.force && is_test in + force_rerun || Dep.Map.has_universe deps + in + let rule_digest = + compute_rule_digest rule ~deps ~action ~sandbox_mode + ~execution_parameters + in + let can_go_in_shared_cache = + action.can_go_in_shared_cache + && not + (always_rerun || is_action_dynamic + || Action.is_useful_to_memoize action.action = Clearly_not) + in + (* We don't need to digest target names here, as these are already part + of the rule digest. *) + let digest_of_target_digests l = Digest.generic (List.map l ~f:snd) in + (* Here we determine if we need to execute the action based on + information stored in [Trace_db]. If we need to, then + [targets_and_digests] will be [None], otherwise it will be [Some l] + where [l] is the list of targets and their digests. *) + let* (targets_and_digests : + ((Path.Build.t * Digest.t) list, _) Cache_result.t) = + if always_rerun then + Fiber.return (Cache_result.Miss `Always_rerun) + else + (* [prev_trace] will be [None] if rule is run for the first time. *) + let prev_trace = Trace_db.get (Path.build head_target) in + let prev_trace_with_targets_and_digests = + match prev_trace with + | None -> Cache_result.Miss `No_previous_record + | Some prev_trace -> ( + if prev_trace.rule_digest <> rule_digest then + Cache_result.Miss + (`Rule_changed (prev_trace.rule_digest, rule_digest)) else - Fiber.return (Cache_result.Miss `Dynamic_deps_changed) + (* [targets_and_digests] will be [None] if not all targets + were built. *) + match compute_target_digests targets with + | None -> Cache_result.Miss `Targets_missing + | Some targets_and_digests -> + if + Digest.equal prev_trace.targets_digest + (digest_of_target_digests targets_and_digests) + then + Hit (prev_trace, targets_and_digests) + else + Cache_result.Miss `Targets_changed) in - loop prev_trace.dynamic_deps_stages - in - let* targets_and_digests = - match targets_and_digests with - | Hit x -> Fiber.return x - | Miss miss_reason -> - report_workspace_local_cache_miss - ~cache_debug_flags:t.cache_debug_flags ~head_target miss_reason; - (* Step I. Remove stale targets both from the digest table and from - the build directory. *) - Path.Build.Set.iter targets ~f:(fun target -> - Cached_digest.remove (Path.build target); - Path.Build.unlink_no_err target); - (* Step II. Try to restore artifacts from the shared cache if the - following conditions are met. - - 1. The rule can be cached, i.e. [can_go_in_shared_cache] is [true]. - - 2. The shared cache is [Enabled]. - - 3. The rule is not selected for a reproducibility check. *) - let targets_and_digests_from_cache : - (_, Shared_cache_miss_reason.t) Cache_result.t = - match (can_go_in_shared_cache, t.cache_config) with - | false, _ -> Miss Shared_cache_miss_reason.Can't_go_in_shared_cache - | _, Disabled -> Miss Shared_cache_miss_reason.Cache_disabled - | true, Enabled { storage_mode = mode; reproducibility_check } -> ( - match - Dune_cache.Config.Reproducibility_check.sample - reproducibility_check - with - | true -> - (* CR-someday amokhov: Here we re-execute the rule, as in Jenga. - To make [check_probability] more meaningful, we could first - make sure that the shared cache actually does contain an - entry for [rule_digest]. *) - Cache_result.Miss - Shared_cache_miss_reason.Rerunning_for_reproducibility_check - | false -> - try_to_restore_from_shared_cache - ~debug_shared_cache:t.cache_debug_flags.shared_cache ~mode - ~rule_digest ~head_target ~target_dir:rule.dir) - in - let* targets_and_digests, trace_db_entry = - match targets_and_digests_from_cache with - | Hit targets_and_digests -> - Fiber.return - ( targets_and_digests - , ({ rule_digest - ; dynamic_deps_stages = - (* Rules with dynamic deps can't be stored to the - shared-cache (see the [is_action_dynamic] check - above), so we know this is not a dynamic action, so - returning an empty list is correct. The lack of - information to fill in [dynamic_deps_stages] here is - precisely the reason why we don't store dynamic - actions in the shared cache. *) - [] - ; targets_digest = - digest_of_target_digests targets_and_digests - } - : Trace_db.Entry.t) ) - | Miss shared_cache_miss_reason -> - report_shared_cache_miss ~cache_debug_flags:t.cache_debug_flags - ~rule_digest ~head_target shared_cache_miss_reason; - (* Step III. Execute the build action. *) - let* exec_result = - execute_action_for_rule t ~rule_digest ~action ~deps ~loc - ~context ~execution_parameters ~sandbox_mode ~dir ~targets - in - let* targets_and_digests = - (* Step IV. Store results to the shared cache and if that step - fails, post-process targets by removing write permissions and - computing their digets. *) - match t.cache_config with - | Enabled { storage_mode = mode; reproducibility_check = _ } - when can_go_in_shared_cache -> ( - let+ targets_and_digests = - try_to_store_to_shared_cache ~mode ~rule_digest ~targets - ~action:action.action + match prev_trace_with_targets_and_digests with + | Cache_result.Miss reason -> + Fiber.return (Cache_result.Miss reason) + | Hit (prev_trace, targets_and_digests) -> + (* CR-someday aalekseyev: If there's a change at one of the last + stages, we still re-run all the previous stages, which is a bit + of a waste. We could remember what stage needs re-running and + only re-run that (and later stages). *) + let rec loop stages = + match stages with + | [] -> Fiber.return (Cache_result.Hit targets_and_digests) + | (deps, old_digest) :: rest -> + let deps = Action_exec.Dynamic_dep.Set.to_dep_set deps in + let* deps = build_deps deps in + let new_digest = + Dep.Facts.digest deps ~sandbox_mode ~env:action.env in - match targets_and_digests with - | Some targets_and_digets -> targets_and_digets - | None -> - compute_target_digests_or_raise_error execution_parameters - ~loc targets) - | _ -> - Fiber.return - (compute_target_digests_or_raise_error execution_parameters - ~loc targets) - in - let dynamic_deps_stages = - List.map exec_result.dynamic_deps_stages - ~f:(fun (deps, fact_map) -> - ( deps - , Dep.Facts.digest fact_map ~sandbox_mode ~env:action.env )) - in - let targets_digest = - digest_of_target_digests targets_and_digests - in - Fiber.return - ( targets_and_digests - , ({ rule_digest; dynamic_deps_stages; targets_digest } - : Trace_db.Entry.t) ) - in - Trace_db.set (Path.build head_target) trace_db_entry; - Fiber.return targets_and_digests - in - let* () = - match (mode, !Clflags.promote) with - | (Standard | Fallback | Ignore_source_files), _ - | Promote _, Some Never -> - Fiber.return () - | Promote { lifetime; into; only }, (Some Automatically | None) -> - Fiber.parallel_iter_set - (module Path.Build.Set) - targets - ~f:(fun path -> - let consider_for_promotion = - match only with - | None -> true - | Some pred -> - Predicate_lang.Glob.exec pred - (Path.reach (Path.build path) ~from:(Path.build dir)) - ~standard:Predicate_lang.any + if old_digest = new_digest then + loop rest + else + Fiber.return (Cache_result.Miss `Dynamic_deps_changed) in - match consider_for_promotion with - | false -> Fiber.return () - | true -> - let in_source_tree = Path.Build.drop_build_context_exn path in - let in_source_tree = - match into with - | None -> in_source_tree - | Some { loc; dir } -> - Path.Source.relative - (Path.Source.relative - (Path.Source.parent_exn in_source_tree) - dir ~error_loc:loc) - (Path.Source.basename in_source_tree) + loop prev_trace.dynamic_deps_stages + in + let* targets_and_digests = + match targets_and_digests with + | Hit x -> Fiber.return x + | Miss miss_reason -> + report_workspace_local_cache_miss + ~cache_debug_flags:t.cache_debug_flags ~head_target miss_reason; + (* Step I. Remove stale targets both from the digest table and from + the build directory. *) + Path.Build.Set.iter targets ~f:(fun target -> + Cached_digest.remove (Path.build target); + Path.Build.unlink_no_err target); + (* Step II. Try to restore artifacts from the shared cache if the + following conditions are met. + + 1. The rule can be cached, i.e. [can_go_in_shared_cache] is + [true]. + + 2. The shared cache is [Enabled]. + + 3. The rule is not selected for a reproducibility check. *) + let targets_and_digests_from_cache : + (_, Shared_cache_miss_reason.t) Cache_result.t = + match (can_go_in_shared_cache, t.cache_config) with + | false, _ -> + Miss Shared_cache_miss_reason.Can't_go_in_shared_cache + | _, Disabled -> Miss Shared_cache_miss_reason.Cache_disabled + | true, Enabled { storage_mode = mode; reproducibility_check } + -> ( + match + Dune_cache.Config.Reproducibility_check.sample + reproducibility_check + with + | true -> + (* CR-someday amokhov: Here we re-execute the rule, as in + Jenga. To make [check_probability] more meaningful, we + could first make sure that the shared cache actually does + contain an entry for [rule_digest]. *) + Cache_result.Miss + Shared_cache_miss_reason.Rerunning_for_reproducibility_check + | false -> + try_to_restore_from_shared_cache + ~debug_shared_cache:t.cache_debug_flags.shared_cache ~mode + ~rule_digest ~head_target ~target_dir:rule.dir) + in + let* targets_and_digests, trace_db_entry = + match targets_and_digests_from_cache with + | Hit targets_and_digests -> + Fiber.return + ( targets_and_digests + , ({ rule_digest + ; dynamic_deps_stages = + (* Rules with dynamic deps can't be stored to the + shared-cache (see the [is_action_dynamic] check + above), so we know this is not a dynamic action, so + returning an empty list is correct. The lack of + information to fill in [dynamic_deps_stages] here is + precisely the reason why we don't store dynamic + actions in the shared cache. *) + [] + ; targets_digest = + digest_of_target_digests targets_and_digests + } + : Trace_db.Entry.t) ) + | Miss shared_cache_miss_reason -> + report_shared_cache_miss ~cache_debug_flags:t.cache_debug_flags + ~rule_digest ~head_target shared_cache_miss_reason; + (* Step III. Execute the build action. *) + let* exec_result = + execute_action_for_rule t ~rule_digest ~action ~deps ~loc + ~context ~execution_parameters ~sandbox_mode ~dir ~targets in - let* () = - let dir = Path.Source.parent_exn in_source_tree in - Memo.Build.run (Source_tree.find_dir dir) >>| function - | Some _ -> () - | None -> - let loc = - match into with - | Some into -> into.loc - | None -> - Code_error.raise - "promoting into directory that does not exist" - [ ("in_source_tree", Path.Source.to_dyn in_source_tree) - ] + let* targets_and_digests = + (* Step IV. Store results to the shared cache and if that step + fails, post-process targets by removing write permissions + and computing their digets. *) + match t.cache_config with + | Enabled { storage_mode = mode; reproducibility_check = _ } + when can_go_in_shared_cache -> ( + let+ targets_and_digests = + try_to_store_to_shared_cache ~mode ~rule_digest ~targets + ~action:action.action in - User_error.raise ~loc - [ Pp.textf "directory %S does not exist" - (Path.Source.to_string_maybe_quoted dir) - ] + match targets_and_digests with + | Some targets_and_digets -> targets_and_digets + | None -> + compute_target_digests_or_raise_error execution_parameters + ~loc targets) + | _ -> + Fiber.return + (compute_target_digests_or_raise_error + execution_parameters ~loc targets) in - let dst = in_source_tree in - let in_source_tree = Path.source in_source_tree in - let* is_up_to_date = - Memo.Build.run - (let open Memo.Build.O in - Fs_memo.path_exists in_source_tree >>= function - | false -> Memo.Build.return false - | true -> - let in_build_dir_digest = Cached_digest.build_file path in - let+ in_source_tree_digest = - Fs_memo.file_digest in_source_tree - in - Digest.equal in_build_dir_digest in_source_tree_digest) + let dynamic_deps_stages = + List.map exec_result.dynamic_deps_stages + ~f:(fun (deps, fact_map) -> + ( deps + , Dep.Facts.digest fact_map ~sandbox_mode ~env:action.env + )) in - if is_up_to_date then - Fiber.return () - else ( - if lifetime = Until_clean then - Promoted_to_delete.add in_source_tree; - let* () = Scheduler.ignore_for_watch in_source_tree in - (* The file in the build directory might be read-only if it - comes from the shared cache. However, we want the file in - the source tree to be writable by the user, so we - explicitly set the user writable bit. *) - let chmod n = n lor 0o200 in - t.promote_source ~src:path ~dst ~chmod context - )) - in - t.rule_done <- t.rule_done + 1; - let+ () = - Handler.report_progress t.handler ~rule_done:t.rule_done - ~rule_total:t.rule_total - in - targets_and_digests) + let targets_digest = + digest_of_target_digests targets_and_digests + in + Fiber.return + ( targets_and_digests + , ({ rule_digest; dynamic_deps_stages; targets_digest } + : Trace_db.Entry.t) ) + in + Trace_db.set (Path.build head_target) trace_db_entry; + Fiber.return targets_and_digests + in + let* () = + match (mode, !Clflags.promote) with + | (Standard | Fallback | Ignore_source_files), _ + | Promote _, Some Never -> + Fiber.return () + | Promote { lifetime; into; only }, (Some Automatically | None) -> + Fiber.parallel_iter_set + (module Path.Build.Set) + targets + ~f:(fun path -> + let consider_for_promotion = + match only with + | None -> true + | Some pred -> + Predicate_lang.Glob.exec pred + (Path.reach (Path.build path) ~from:(Path.build dir)) + ~standard:Predicate_lang.any + in + match consider_for_promotion with + | false -> Fiber.return () + | true -> + let in_source_tree = Path.Build.drop_build_context_exn path in + let in_source_tree = + match into with + | None -> in_source_tree + | Some { loc; dir } -> + Path.Source.relative + (Path.Source.relative + (Path.Source.parent_exn in_source_tree) + dir ~error_loc:loc) + (Path.Source.basename in_source_tree) + in + let* () = + let dir = Path.Source.parent_exn in_source_tree in + Memo.Build.run (Source_tree.find_dir dir) >>| function + | Some _ -> () + | None -> + let loc = + match into with + | Some into -> into.loc + | None -> + Code_error.raise + "promoting into directory that does not exist" + [ ( "in_source_tree" + , Path.Source.to_dyn in_source_tree ) + ] + in + User_error.raise ~loc + [ Pp.textf "directory %S does not exist" + (Path.Source.to_string_maybe_quoted dir) + ] + in + let dst = in_source_tree in + let in_source_tree = Path.source in_source_tree in + let* is_up_to_date = + Memo.Build.run + (let open Memo.Build.O in + Fs_memo.path_exists in_source_tree >>= function + | false -> Memo.Build.return false + | true -> + let in_build_dir_digest = + Cached_digest.build_file path + in + let+ in_source_tree_digest = + Fs_memo.file_digest in_source_tree + in + Digest.equal in_build_dir_digest in_source_tree_digest) + in + if is_up_to_date then + Fiber.return () + else ( + if lifetime = Until_clean then + Promoted_to_delete.add in_source_tree; + let* () = Scheduler.ignore_for_watch in_source_tree in + (* The file in the build directory might be read-only if it + comes from the shared cache. However, we want the file in + the source tree to be writable by the user, so we + explicitly set the user writable bit. *) + let chmod n = n lor 0o200 in + t.promote_source ~src:path ~dst ~chmod context + )) + in + t.rule_done <- t.rule_done + 1; + let+ () = + Handler.report_progress t.handler ~rule_done:t.rule_done + ~rule_total:t.rule_total + in + targets_and_digests) (* jeremidimino: we need to include the dependencies discovered while running the action here. Otherwise, package dependencies are broken in the presence of dynamic actions *) @@ -2145,13 +2179,16 @@ end = struct as its digest. *) let build_file_impl path = let t = t () in - let on_error exn = Dep_path.reraise exn (Path path) in - Memo.Build.with_error_handler ~on_error (fun () -> - get_rule_or_source t path >>= function - | Source digest -> Memo.Build.return digest - | Rule (path, rule) -> - let+ { deps = _; targets } = execute_rule rule in - Path.Build.Map.find_exn targets path) + get_rule_or_source t path >>= function + | Source digest -> Memo.Build.return digest + | Rule (path, rule) -> + let+ { deps = _; targets } = + Memo.push_stack_frame + (fun () -> execute_rule rule) + ~human_readable_description:(fun () -> + Pp.text (Path.to_string_maybe_quoted (Path.build path))) + in + Path.Build.Map.find_exn targets path let build_alias_impl alias = let+ l = expand_alias_gen alias ~eval_build_request:exec_build_request in @@ -2239,23 +2276,15 @@ open Exported let eval_pred = Pred.eval -let get_human_readable_info stack_frame = - match Memo.Stack_frame.as_instance_of ~of_:build_file_memo stack_frame with - | Some p -> Some (Pp.verbatim (Path.to_string_maybe_quoted p)) - | None -> ( - match Memo.Stack_frame.as_instance_of ~of_:build_alias_memo stack_frame with - | Some alias -> Some (Pp.verbatim ("alias " ^ Alias.describe alias)) - | None -> None) - let process_memcycle (cycle_error : Memo.Cycle_error.t) = let cycle = Memo.Cycle_error.get cycle_error - |> List.filter_map ~f:get_human_readable_info + |> List.filter_map ~f:Memo.Stack_frame.human_readable_description in match List.last cycle with | None -> let frames = Memo.Cycle_error.get cycle_error in - Code_error.raise "dependency cycle that does not involve any files" + Code_error.raise "internal dependency cycle" [ ("frames", Dyn.Encoder.(list Memo.Stack_frame.to_dyn) frames) ] | Some last -> let first = List.hd cycle in @@ -2266,9 +2295,7 @@ let process_memcycle (cycle_error : Memo.Cycle_error.t) = last :: cycle in User_error.raise - [ Pp.text "Dependency cycle between the following files:" - ; Pp.chain cycle ~f:(fun p -> p) - ] + [ Pp.text "Dependency cycle between:"; Pp.chain cycle ~f:(fun p -> p) ] let package_deps ~packages_of (pkg : Package.t) files = let rules_seen = ref Rule.Set.empty in @@ -2313,11 +2340,14 @@ module Alias = Alias0 let process_exn_and_reraise exn = let open Fiber.O in let exn = - Exn_with_backtrace.map exn - ~f: - (Dep_path.map ~f:(function + Exn_with_backtrace.map exn ~f:(fun exn -> + match exn with + | Memo.Cycle_error.E cycle_error -> process_memcycle cycle_error + | Memo.Error.E e -> ( + match Memo.Error.get e with | Memo.Cycle_error.E cycle_error -> process_memcycle cycle_error - | _ as exn -> exn)) + | _ -> exn) + | _ -> exn) in let t = t () in t.errors <- exn :: t.errors; diff --git a/src/dune_engine/build_system.mli b/src/dune_engine/build_system.mli index 95a593f4f40..6d79d8b040a 100644 --- a/src/dune_engine/build_system.mli +++ b/src/dune_engine/build_system.mli @@ -11,7 +11,7 @@ module Error : sig (** Errors when building a target *) type t - val info : t -> User_message.t * Dep_path.Entry.t list option * Path.t option + val info : t -> User_message.t * Path.t option end (** The current set of active errors *) diff --git a/src/dune_engine/clflags.ml b/src/dune_engine/clflags.ml index 3c974fd8164..a3223e20576 100644 --- a/src/dune_engine/clflags.ml +++ b/src/dune_engine/clflags.ml @@ -6,8 +6,6 @@ end let debug_findlib = ref false -let debug_dep_path = ref false - let debug_artifact_substitution = ref false let debug_digests = ref false diff --git a/src/dune_engine/clflags.mli b/src/dune_engine/clflags.mli index 4aeca365bd8..cc6b10e88e4 100644 --- a/src/dune_engine/clflags.mli +++ b/src/dune_engine/clflags.mli @@ -1,8 +1,5 @@ (** Command line flags *) -(** Print dependency path in case of error *) -val debug_dep_path : bool ref - (** Debug the findlib implementation *) val debug_findlib : bool ref diff --git a/src/dune_engine/dep_path.ml b/src/dune_engine/dep_path.ml deleted file mode 100644 index fc6eb4f474e..00000000000 --- a/src/dune_engine/dep_path.ml +++ /dev/null @@ -1,143 +0,0 @@ -open! Stdune - -module Entry = struct - module Lib = struct - type t = - { path : Path.t - ; name : Lib_name.t - } - - let pp { path; name } = - Pp.textf "library %S in %s" (Lib_name.to_string name) - (Path.to_string_maybe_quoted path) - end - - module Implements_via = struct - type t = - | Variant of Variant.t - | Default_for of Lib.t - - let pp = function - | Variant v -> Pp.textf "via variant %S" (Variant.to_string v) - | Default_for l -> - Pp.seq (Pp.text "via default implementation for ") (Lib.pp l) - end - - type t = - | Path of Path.t - | Alias of (Loc.t * Alias.t) - | Library of Lib.t * Implements_via.t option - | Executables of (Loc.t * string) list - | Preprocess of Lib_name.t list - | Loc of Loc.t - - let pp = function - | Path p -> Pp.text (Dpath.describe_path p) - | Alias (loc, a) -> - let loc_suffix = - if Loc.is_none loc then - "" - else - " in " ^ Loc.to_file_colon_line loc - in - Pp.textf "alias %s%s" (Alias.describe a) loc_suffix - | Library (lib, via) -> ( - match via with - | None -> Lib.pp lib - | Some via -> - Pp.concat ~sep:Pp.space [ Lib.pp lib; Implements_via.pp via ]) - | Executables [ (loc, name) ] -> - Pp.textf "executable %s in %s" name (Loc.to_file_colon_line loc) - | Executables names -> - let loc, _ = List.hd names in - Pp.textf "executables %s in %s" - (String.enumerate_and (List.map ~f:snd names)) - (Loc.to_file_colon_line loc) - | Preprocess l -> - Pp.textf "%s" - (Dyn.to_string - (List [ String "pps"; Dyn.Encoder.(list Lib_name.to_dyn) l ])) - | Loc loc -> Pp.text (Loc.to_file_colon_line loc) -end - -module Entries = struct - type t = Entry.t list - - let pp t = - Pp.vbox - (Pp.concat ~sep:Pp.cut - (List.map t ~f:(fun x -> - Pp.box ~indent:3 - (Pp.seq (Pp.verbatim "-> ") - (Pp.seq (Pp.text "required by ") (Entry.pp x)))))) -end - -exception E of exn * Entry.t list - -let () = - Memo.unwrap_exn := - function - | E (exn, _) -> exn - | exn -> exn - -let prepend_exn exn entry = - match exn with - | E (exn, entries) -> E (exn, entry :: entries) - | exn -> E (exn, [ entry ]) - -let reraise exn entry = - Exn_with_backtrace.map_and_reraise exn ~f:(fun exn -> prepend_exn exn entry) - -let is_loc_none loc = - match loc with - | None -> true - | Some loc -> Loc.is_none loc - -(* Similar to [output_starts_with_location] in process.ml but operating on - [Pp.t]. *) -let message_starts_with_location msg = - (* The implementation is heavy handed but it doesn't seem worth optimising - now. Indeed, we have been discussing the idea of extracting the location - from command run by Dune more systematically, so it's likely that this code - will go away eventually. *) - String.is_prefix - (Format.asprintf "%a" Pp.to_fmt (User_message.pp msg)) - ~prefix:"File " - -let recover_loc (entries : Entry.t list) = - match entries with - (* In principle it makes sense to recover loc for more than just aliases, but - for the sake of preserving behavior we're minimizing the effect of this - feature, in particular to avoid overlap with [Rule_fn.loc ()] in - build_system.ml, which serves a similar purpose. *) - | Alias (loc, _) :: _ -> Some loc - | _ -> None - -let augment_user_error_loc entries exn = - match exn with - | User_error.E (msg, annot) -> - if is_loc_none msg.loc && not (message_starts_with_location msg) then - match recover_loc entries with - | None -> exn - | Some loc -> User_error.E ({ msg with loc = Some loc }, annot) - else - exn - | _ -> exn - -let unwrap_exn = function - | E (exn, entries) -> - let exn = augment_user_error_loc entries exn in - (exn, Some entries) - | exn -> (exn, None) - -let map ~f = function - | E (exn, entries) -> ( - match f exn with - | E (exn, entries') -> E (exn, entries' @ entries) - | exn -> E (exn, entries)) - | exn -> f exn - -let () = - Printexc.register_printer (function - | E (exn, _) -> Some (Printexc.to_string exn) - | _ -> None) diff --git a/src/dune_engine/dep_path.mli b/src/dune_engine/dep_path.mli deleted file mode 100644 index 2e1b72fb3fb..00000000000 --- a/src/dune_engine/dep_path.mli +++ /dev/null @@ -1,45 +0,0 @@ -(** Dependency path *) - -open! Stdune - -module Entry : sig - module Lib : sig - type t = - { path : Path.t - ; name : Lib_name.t - } - end - - module Implements_via : sig - type t = - | Variant of Variant.t - | Default_for of Lib.t - end - - type t = - | Path of Path.t - | Alias of (Loc.t * Alias.t) - | Library of Lib.t * Implements_via.t option - | Executables of (Loc.t * string) list - | Preprocess of Lib_name.t list - | Loc of Loc.t -end - -module Entries : sig - type t = Entry.t list - - val pp : t -> _ Pp.t -end - -(** Re-raise an exception and augment it's dependency path with the given entry. - The raised exception will be wrapped. *) -val reraise : Exn_with_backtrace.t -> Entry.t -> _ - -(** Extend the required_by stack of an exception *) -val prepend_exn : exn -> Entry.t -> exn - -(** Extract a wrapped exception *) -val unwrap_exn : exn -> exn * Entry.t list option - -(** Apply [f] to the underlying exception. *) -val map : f:(exn -> exn) -> exn -> exn diff --git a/src/dune_engine/dune_engine.ml b/src/dune_engine/dune_engine.ml index a7495e863ba..23138c179f8 100644 --- a/src/dune_engine/dune_engine.ml +++ b/src/dune_engine/dune_engine.ml @@ -40,7 +40,6 @@ module Cram_test = Cram_test module Clflags = Clflags module Include_stanza = Include_stanza module Response_file = Response_file -module Dep_path = Dep_path module Predicate = Predicate module File_selector = File_selector module Action_mapper = Action_mapper @@ -51,7 +50,6 @@ module Scheduler = Scheduler module Hooks = Hooks module Promotion = Promotion module Cached_digest = Cached_digest -module Report_error = Report_error module Pform = Pform module Cm_kind = Cm_kind module Mode = Mode diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index 55a861f028e..708e10e1ca7 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -372,18 +372,43 @@ module Exit_status = struct (* In this module, we don't need the "Error: " prefix given that it is already included in the error message from the command. *) - let fail ~dir paragraphs = + let fail ~dir ~has_embedded_location paragraphs = let dir = match dir with | None -> Path.of_string (Sys.getcwd ()) | Some dir -> dir in - raise - (User_error.E - (User_message.make paragraphs, Some (With_directory_annot.make dir))) + let annots = [ With_directory_annot.make dir ] in + let annots = + if has_embedded_location then + User_error.Annot.Has_embedded_location.make () :: annots + else + annots + in + raise (User_error.E (User_message.make paragraphs, annots)) + + (* Check if the command output starts with a location, ignoring ansi escape + sequences *) + let outputs_starts_with_location = + let rec loop s pos len prefix = + match prefix with + | [] -> true + | c :: rest -> ( + pos < len + && + match s.[pos] with + | '\027' -> ( + match String.index_from s pos 'm' with + | None -> false + | Some pos -> loop s (pos + 1) len prefix) + | c' -> c = c' && loop s (pos + 1) len rest) + in + fun output -> + loop output 0 (String.length output) [ 'F'; 'i'; 'l'; 'e'; ' ' ] let handle_verbose t ~id ~output ~command_line ~dir = let open Pp.O in + let has_embedded_location = outputs_starts_with_location output in let output = parse_output output in match t with | Ok n -> @@ -401,7 +426,7 @@ module Exit_status = struct | Failed n -> sprintf "exited with code %d" n | Signaled signame -> sprintf "got signal %s" signame in - fail ~dir + fail ~dir ~has_embedded_location (Pp.tag User_message.Style.Kwd (Pp.verbatim "Command") ++ Pp.space ++ pp_id id ++ Pp.space ++ Pp.text msg ++ Pp.char ':' :: @@ -409,28 +434,10 @@ module Exit_status = struct ++ Pp.char ' ' ++ command_line :: Option.to_list output) - (* Check if the command output starts with a location, ignoring ansi escape - sequences *) - let outputs_starts_with_location = - let rec loop s pos len prefix = - match prefix with - | [] -> true - | c :: rest -> ( - pos < len - && - match s.[pos] with - | '\027' -> ( - match String.index_from s pos 'm' with - | None -> false - | Some pos -> loop s (pos + 1) len prefix) - | c' -> c = c' && loop s (pos + 1) len rest) - in - fun output -> - loop output 0 (String.length output) [ 'F'; 'i'; 'l'; 'e'; ' ' ] - let handle_non_verbose t ~display ~purpose ~output ~prog ~command_line ~dir ~has_unexpected_stdout ~has_unexpected_stderr = let open Pp.O in + let has_embedded_location = outputs_starts_with_location output in let show_command = let show_full_command_on_error = !Clflags.always_show_command_line @@ -439,7 +446,7 @@ module Exit_status = struct they are executed locally or in the CI. *) (Config.inside_ci && not Config.inside_dune) in - show_full_command_on_error || not (outputs_starts_with_location output) + show_full_command_on_error || not has_embedded_location in let output = parse_output output in let _, progname, _ = Fancy.split_prog prog in @@ -478,10 +485,10 @@ module Exit_status = struct (String.enumerate_and unexpected_outputs) | _ -> sprintf "(exit %d)" n else - fail ~dir (Option.to_list output) + fail ~dir ~has_embedded_location (Option.to_list output) | Signaled signame -> sprintf "(got signal %s)" signame in - fail ~dir + fail ~dir ~has_embedded_location (progname_and_purpose Error ++ Pp.char ' ' ++ Pp.tag User_message.Style.Error (Pp.verbatim msg) :: diff --git a/src/dune_engine/report_error.ml b/src/dune_engine/report_error.ml deleted file mode 100644 index 4dc86175923..00000000000 --- a/src/dune_engine/report_error.ml +++ /dev/null @@ -1,33 +0,0 @@ -open Import - -let () = Hooks.End_of_build.always Dune_util.Report_error.clear_reported - -let report (e : Exn_with_backtrace.t) = - let exn, dependency_path = Dep_path.unwrap_exn e.exn in - let extra (loc : Loc.t option) = - let dependency_path = - let dependency_path = Option.value dependency_path ~default:[] in - if !Clflags.debug_dep_path then - dependency_path - else - (* Only keep the part that doesn't come from the build system *) - let rec drop : Dep_path.Entries.t -> _ = function - | (Path _ | Alias _) :: l -> drop l - | l -> l - in - match loc with - | None -> drop dependency_path - | Some loc -> - if Filename.is_relative loc.start.pos_fname then - (* If the error points to a local file, no need to print the - dependency stack *) - [] - else - drop dependency_path - in - if dependency_path <> [] then - Some (Dep_path.Entries.pp (List.rev dependency_path)) - else - None - in - Dune_util.Report_error.report ~extra { e with exn } diff --git a/src/dune_engine/report_error.mli b/src/dune_engine/report_error.mli deleted file mode 100644 index bcdc692ab5f..00000000000 --- a/src/dune_engine/report_error.mli +++ /dev/null @@ -1,4 +0,0 @@ -open Stdune - -(** Same as {!Stdune.Report_error.report} but also print the dependency path *) -val report : Exn_with_backtrace.t -> unit diff --git a/src/dune_engine/scheduler.ml b/src/dune_engine/scheduler.ml index 4c753c3b478..b8fe4695717 100644 --- a/src/dune_engine/scheduler.ml +++ b/src/dune_engine/scheduler.ml @@ -699,7 +699,7 @@ end = struct (module Monoid.Unit) f ~on_error:(fun e -> - Report_error.report e; + Dune_util.Report_error.report e; Fiber.return ())) in match Fiber.run fiber ~iter:(fun () -> iter t) with @@ -763,7 +763,7 @@ module Run = struct let* res = let on_error exn = (match t.status with - | Building -> Report_error.report exn + | Building -> Dune_util.Report_error.report exn | Shutting_down | Restarting_build -> () diff --git a/src/dune_engine/string_with_vars.ml b/src/dune_engine/string_with_vars.ml index d99f7d243f4..edb8ce5fa63 100644 --- a/src/dune_engine/string_with_vars.ml +++ b/src/dune_engine/string_with_vars.ml @@ -249,7 +249,7 @@ struct (* The [let+ () = A.return () in ...] is to delay the error until the evaluation of the applicative *) let+ () = A.return () in - raise (User_error.E (msg, None)) + raise (User_error.E (msg, [])) | Pform (source, p) -> let+ v = f ~source p in if t.quoted then @@ -320,7 +320,7 @@ let encode t = ; parts = List.map t.parts ~f:(function | Text s -> Dune_lang.Template.Text s - | Error (_, msg) -> raise (User_error.E (msg, None)) + | Error (_, msg) -> raise (User_error.E (msg, [])) | Pform (source, pform) -> ( match Pform.encode_to_latest_dune_lang_version pform with | Pform_was_deleted -> diff --git a/src/dune_engine/utils.ml b/src/dune_engine/utils.ml index ff9b7085862..34c8a7d8b13 100644 --- a/src/dune_engine/utils.ml +++ b/src/dune_engine/utils.ml @@ -45,12 +45,10 @@ let program_not_found_message ?context ?hint ~loc prog = prog let program_not_found ?context ?hint ~loc prog = - raise - (User_error.E (program_not_found_message ?context ?hint ~loc prog, None)) + raise (User_error.E (program_not_found_message ?context ?hint ~loc prog, [])) let library_not_found ?context ?hint lib = - raise - (User_error.E (not_found "Library %s not found" ?context ?hint lib, None)) + raise (User_error.E (not_found "Library %s not found" ?context ?hint lib, [])) let install_file ~(package : Package.Name.t) ~findlib_toolchain = let package = Package.Name.to_string package in diff --git a/src/dune_lang/decoder.ml b/src/dune_lang/decoder.ml index 35dd05f035c..319e509d4ee 100644 --- a/src/dune_lang/decoder.ml +++ b/src/dune_lang/decoder.ml @@ -594,7 +594,7 @@ let map_validate t ~f ctx state1 = | Some _ -> msg | None -> { msg with loc = Some (loc_between_states ctx state1 state2) } in - raise (User_error.E (msg, None)) + raise (User_error.E (msg, [])) (** TODO: Improve consistency of error messages, e.g. use %S consistently for field names: see [field_missing] and [field_present_too_many_times]. *) diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index 30e76713b70..f1a8792c1c4 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -3,7 +3,6 @@ open Fiber.O open Dune_rpc_server open Dune_rpc_private module Dep_conf = Dune_rules.Dep_conf -module Dep_path = Dune_engine.Dep_path module Build_system = Dune_engine.Build_system module Status = struct @@ -16,28 +15,14 @@ end type pending_build_action = Build of Dep_conf.t list * Status.t Fiber.Ivar.t -let target_of_dep_path_entry : Dep_path.Entry.t -> Dune_rpc_private.Target.t = - let open Dune_engine in - function - | Dep_path.Entry.Path p -> Path (Path.to_string p) - | Alias (_, a) -> Alias (Alias.describe a) - | Library (lib, _) -> Library (Lib_name.to_string lib.name) - | Executables es -> Executables (List.map ~f:(fun (_, e) -> e) es) - | Preprocess ps -> Preprocess (List.map ~f:Lib_name.to_string ps) - | Loc l -> Loc l - let diagnostic_of_error : Build_system.Error.t -> Dune_rpc_private.Diagnostic.t = fun m -> - let message, targets, dir = Build_system.Error.info m in - (* We need to reverse the list because [Build_system] stacks errors such that - the first element is the target initially requested by the user, which is - the opposite of what most clients probably care about. *) - let targets = List.rev (Option.value ~default:[] targets) in + let message, dir = Build_system.Error.info m in let loc = message.loc in let message = Pp.map_tags (Pp.concat message.paragraphs) ~f:(fun _ -> ()) in { severity = None - ; targets = List.map ~f:target_of_dep_path_entry targets + ; targets = [] ; message ; loc ; promotion = [] diff --git a/src/dune_rules/command.ml b/src/dune_rules/command.ml index 37d8c63a048..0b1be1b7263 100644 --- a/src/dune_rules/command.ml +++ b/src/dune_rules/command.ml @@ -10,8 +10,7 @@ module Args0 = struct | `Targets ] - type expand = - dir:Path.t -> (string list * Dep.Set.t, fail) result Memo.Build.t + type expand = dir:Path.t -> string list Action_builder.t (* Debugging tip: if you changed this file and Dune got broken in a weird way it's probably because of the [Fail] constructor. *) @@ -88,14 +87,7 @@ let rec expand : (Action_builder.map (Action_builder.deps deps) ~f:(fun () -> [])) | Hidden_targets fns -> Action_builder.with_targets ~targets:fns (Action_builder.return []) - | Expand f -> - Action_builder.with_no_targets - (let open Action_builder.O in - Action_builder.memo_build (f ~dir) >>= function - | Error e -> Action_builder.fail e - | Ok (args, deps) -> - let open Action_builder.O in - Action_builder.deps deps >>> Action_builder.return args) + | Expand f -> Action_builder.with_no_targets (f ~dir) and expand_no_targets ~dir (t : without_targets t) = let { Action_builder.With_targets.build; targets } = expand ~dir t in @@ -143,12 +135,13 @@ module Args = struct ~input:(module Path) (fun dir -> Memo.Build.return - (match Action_builder.static_eval (expand_no_targets ~dir t) with - | None -> assert false - | Some x -> Ok x - | exception exn -> Error { fail = (fun () -> raise exn) })) + (Action_builder.memoize "Command.Args.memo" + (expand_no_targets ~dir t))) in - Expand (fun ~dir -> Memo.exec memo dir) + Expand + (fun ~dir -> + let open Action_builder.O in + Action_builder.memo_build (Memo.exec memo dir) >>= Fun.id) end module Ml_kind = struct diff --git a/src/dune_rules/command.mli b/src/dune_rules/command.mli index 2299428e4d4..4d1f84ca9e5 100644 --- a/src/dune_rules/command.mli +++ b/src/dune_rules/command.mli @@ -42,11 +42,10 @@ module Args : sig (** The type [expand] captures the meaning of a [Command.Args.t] that has no target declarations: it is a way to construct functions that given a current working directory [dir] compute the list of command line arguments - of type [string list] and a set of dependencies of type [Dep.Set.t], or - fail. You can use the constructor [Expand] to specify the meaning - directly, which is sometimes useful, e.g. for memoization. *) - type expand = - dir:Path.t -> (string list * Dep.Set.t, fail) result Memo.Build.t + of type [string list] in the action builder monad. You can use the + constructor [Expand] to specify the meaning directly, which is sometimes + useful, e.g. for memoization. *) + type expand = dir:Path.t -> string list Action_builder.t type _ t = | A : string -> _ t diff --git a/src/dune_rules/coq_lib.ml b/src/dune_rules/coq_lib.ml index e4c13d9f4cb..92b7eec2857 100644 --- a/src/dune_rules/coq_lib.ml +++ b/src/dune_rules/coq_lib.ml @@ -41,7 +41,7 @@ let package l = l.package module Error = struct let make ?loc ?hints paragraphs = - Error (User_error.E (User_error.make ?loc ?hints paragraphs, None)) + Error (User_error.E (User_error.make ?loc ?hints paragraphs, [])) let duplicate_theory_name theory = let loc, name = theory.Coq_stanza.Theory.name in diff --git a/src/dune_rules/expander.ml b/src/dune_rules/expander.ml index 4cada76a3eb..792bdae76ba 100644 --- a/src/dune_rules/expander.ml +++ b/src/dune_rules/expander.ml @@ -139,7 +139,7 @@ let isn't_allowed_in_this_position_message ~source = ] let isn't_allowed_in_this_position ~source = - raise (User_error.E (isn't_allowed_in_this_position_message ~source, None)) + raise (User_error.E (isn't_allowed_in_this_position_message ~source, [])) let expand_artifact ~source t a s = match t.lookup_artifacts with diff --git a/src/dune_rules/findlib/findlib.ml b/src/dune_rules/findlib/findlib.ml index f6be1149cfe..c85860b4397 100644 --- a/src/dune_rules/findlib/findlib.ml +++ b/src/dune_rules/findlib/findlib.ml @@ -391,7 +391,7 @@ end = struct (Path.to_string src_dir) ; Pp.textf "error: %s" (Unix.error_message e) ] - , None )) + , [] )) | Ok files -> let ext = Cm_kind.ext Cmi in Result.List.filter_map files ~f:(fun fname -> @@ -410,7 +410,7 @@ end = struct (Loc.in_dir src_dir, name) with | Ok s -> Ok (Some s) - | Error e -> Error (User_error.E (e, None)))))) + | Error e -> Error (User_error.E (e, [])))))) in Lib_info.create ~path_kind:External ~loc ~name:t.name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ~synopsis ~main_module_name diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 4e9fc30e5b6..604231869f4 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -4,6 +4,79 @@ open Resolve.O (* Errors *) +module Dep_path : sig + module Entry : sig + module Lib : sig + type t = + { path : Path.t + ; name : Lib_name.t + } + + val pp : t -> _ Pp.t + end + + module Implements_via : sig + type t = + | Variant of Variant.t + | Default_for of Lib.t + end + + type t = + { lib : Lib.t + ; implements_via : Implements_via.t option + } + end + + type t = Entry.t list + + val pp : t -> _ Pp.t +end = struct + module Entry = struct + module Lib = struct + type t = + { path : Path.t + ; name : Lib_name.t + } + + let pp { path; name } = + Pp.textf "library %S in %s" (Lib_name.to_string name) + (Path.to_string_maybe_quoted path) + end + + module Implements_via = struct + type t = + | Variant of Variant.t + | Default_for of Lib.t + + let pp = function + | Variant v -> Pp.textf "via variant %S" (Variant.to_string v) + | Default_for l -> + Pp.seq (Pp.text "via default implementation for ") (Lib.pp l) + end + + type t = + { lib : Lib.t + ; implements_via : Implements_via.t option + } + + let pp { lib; implements_via } = + match implements_via with + | None -> Lib.pp lib + | Some via -> + Pp.concat ~sep:Pp.space [ Lib.pp lib; Implements_via.pp via ] + end + + type t = Entry.t list + + let pp t = + Pp.vbox + (Pp.concat ~sep:Pp.cut + (List.map t ~f:(fun x -> + Pp.box ~indent:3 + (Pp.seq (Pp.verbatim "-> ") + (Pp.seq (Pp.text "required by ") (Entry.pp x)))))) +end + (* The current module never raises. It returns all errors as [Result.Error (User_error.E _)] values instead. Errors are later inserted into [Action_builder.t] values so that they are only raised during the actual @@ -31,7 +104,7 @@ module Error = struct let info = Pp.box (pp_lib info) in match dp with | [] -> info - | _ -> Pp.vbox (Pp.concat ~sep:Pp.cut [ info; Dep_path.Entries.pp dp ]) + | _ -> Pp.vbox (Pp.concat ~sep:Pp.cut [ info; Dep_path.pp dp ]) let not_found ~loc ~name = make ~loc [ Pp.textf "Library %S not found." (Lib_name.to_string name) ] @@ -75,7 +148,7 @@ module Error = struct :: (match dp with | [] -> [] - | _ -> [ Dep_path.Entries.pp dp ])) + | _ -> [ Dep_path.pp dp ])) let overlap ~in_workspace ~installed = make @@ -764,7 +837,7 @@ module Dep_stack = struct Implements_via.to_dep_path_implements_via via in loop - (Dep_path.Entry.Library ({ path; name }, implements_via) :: acc) + ({ Dep_path.Entry.lib = { path; name }; implements_via } :: acc) l in loop [] t.stack @@ -1177,8 +1250,8 @@ end = struct in let src_dir = Lib_info.src_dir info in let map_error x = - let lib = { Dep_path.Entry.Lib.path = src_dir; name } in - Resolve.extend_dep_path (Library (lib, None)) x + Resolve.push_stack_frame x ~human_readable_description:(fun () -> + Dep_path.Entry.Lib.pp { name; path = src_dir }) in let requires = map_error requires in let ppx_runtime_deps = map_error ppx_runtime_deps in @@ -1602,7 +1675,7 @@ end = struct let req_by = Dep_stack.to_required_by stack ~stop_at:t.orig_stack in Error.make ~loc [ Pp.textf "Library %S was pulled in." (Lib_name.to_string lib.name) - ; Dep_path.Entries.pp req_by + ; Dep_path.pp req_by ] | None -> t.visited <- Set.add t.visited lib; @@ -1880,11 +1953,20 @@ module DB = struct (Lib_name.to_string lib.name) ] and+ res = res in - Resolve.extend_dep_path (Executables exes) + Resolve.push_stack_frame (Resolve_names.linking_closure_with_overlap_checks ~stack:Dep_stack.empty (Option.some_if (not allow_overlaps) t) - ~forbidden_libraries res)) + ~forbidden_libraries res) + ~human_readable_description:(fun () -> + match exes with + | [ (loc, name) ] -> + Pp.textf "executable %s in %s" name (Loc.to_file_colon_line loc) + | names -> + let loc, _ = List.hd names in + Pp.textf "executables %s in %s" + (String.enumerate_and (List.map ~f:snd names)) + (Loc.to_file_colon_line loc))) in let merlin_ident = Merlin_ident.for_exes ~names:(List.map ~f:snd exes) in { Compile.direct_requires = res diff --git a/src/dune_rules/preprocessing.ml b/src/dune_rules/preprocessing.ml index f420fc00d8b..80e5dd1e1da 100644 --- a/src/dune_rules/preprocessing.ml +++ b/src/dune_rules/preprocessing.ml @@ -301,7 +301,9 @@ let build_ppx_driver sctx ~scope ~target ~pps ~pp_names = Driver.select pps ~loc:(Dot_ppx (target, pp_names)) >>| Resolve.map ~f:(fun driver -> (driver, pps))) >>| (* Extend the dependency stack as we don't have locations at this point *) - Resolve.extend_dep_path (Preprocess pp_names) + Resolve.push_stack_frame ~human_readable_description:(fun () -> + Dyn.pp + (List [ String "pps"; Dyn.Encoder.(list Lib_name.to_dyn) pp_names ])) in (* CR-someday diml: what we should do is build the .cmx/.cmo once and for all at the point where the driver is defined. *) @@ -433,7 +435,7 @@ let get_cookies ~loc ~expander ~lib_name libs = [ "--cookie"; sprintf "%s=%S" name value ]) with | x -> Resolve.return x - | exception User_error.E (msg, None) -> Resolve.fail msg + | exception User_error.E (msg, []) -> Resolve.fail msg let ppx_driver_and_flags_internal sctx ~loc ~expander ~lib_name ~flags libs = let open Resolve.O in diff --git a/src/dune_rules/resolve.ml b/src/dune_rules/resolve.ml index 810716edca0..5e760f8d89d 100644 --- a/src/dune_rules/resolve.ml +++ b/src/dune_rules/resolve.ml @@ -1,25 +1,72 @@ open Stdune open Dune_engine -include Or_exn -let of_result t = t +type error = + { exn : exn + ; stack_frames : User_message.Style.t Pp.t Lazy.t list + } + +type 'a t = ('a, error) result + +let return x = Ok x + +let bind = Result.bind + +include Monad.Make (struct + type nonrec 'a t = 'a t + + let return = return + + let bind = bind +end) + +let error_equal { exn; stack_frames } b = + Exn.equal exn b.exn + && List.equal + (fun (lazy a) (lazy b) -> Poly.equal a b) + stack_frames b.stack_frames + +let equal f = Result.equal f error_equal + +let error_hash { exn; stack_frames } = + Poly.hash (Exn.hash exn, List.map stack_frames ~f:Lazy.force) + +let to_dyn f t = + Result.to_dyn f Exn.to_dyn (Result.map_error t ~f:(fun x -> x.exn)) + +let hash f = Result.hash f error_hash + +let of_result = Result.map_error ~f:(fun exn -> { exn; stack_frames = [] }) + +let error_to_memo_build { stack_frames; exn } = + let open Memo.Build.O in + let rec loop = function + | [] -> + let+ () = Memo.Build.return () in + raise exn + | x :: rest -> + Memo.push_stack_frame + ~human_readable_description:(fun () -> Lazy.force x) + (fun () -> loop rest) + in + loop stack_frames let read_memo_build = function | Ok x -> Memo.Build.return x - | Error exn -> - let open Memo.Build.O in - let+ () = Memo.Build.return () in - raise exn + | Error err -> error_to_memo_build err let read = function | Ok x -> Action_builder.return x - | Error exn -> Action_builder.delayed (fun () -> raise exn) + | Error err -> Action_builder.memo_build (error_to_memo_build err) -let args = function +let args t = + match t with | Ok args -> args - | Error exn -> Command.Args.Fail { fail = (fun () -> raise exn) } + | Error _ -> + let open Action_builder.O in + Command.Args.Dyn (read t >>| fun _ -> assert false) -let fail msg = Error (User_error.E (msg, None)) +let fail msg = Error { exn = User_error.E (msg, []); stack_frames = [] } let peek t = Result.map_error t ~f:ignore @@ -27,8 +74,11 @@ let is_ok t = Result.is_ok (peek t) let is_error t = Result.is_error (peek t) -let extend_dep_path entry t = - Result.map_error t ~f:(fun exn -> Dep_path.prepend_exn exn entry) +let push_stack_frame ~human_readable_description:f t = + match t with + | Ok _ -> t + | Error err -> + Error { err with stack_frames = Lazy.from_fun f :: err.stack_frames } module Build = struct let bind t ~f = diff --git a/src/dune_rules/resolve.mli b/src/dune_rules/resolve.mli index 00ad9524aa2..570c3f641ab 100644 --- a/src/dune_rules/resolve.mli +++ b/src/dune_rules/resolve.mli @@ -130,9 +130,9 @@ val is_error : 'a t -> bool actually evaluated. *) val fail : User_message.t -> _ t -(** Insert the following entry in the dependency path in case of failure. This - helps improve error messages. *) -val extend_dep_path : Dep_path.Entry.t -> 'a t -> 'a t +(** Similar to [Memo.push_stack_frame]. *) +val push_stack_frame : + human_readable_description:(unit -> User_message.Style.t Pp.t) -> 'a t -> 'a t val all : 'a t list -> 'a list t diff --git a/src/dune_rules/stanza_common.ml b/src/dune_rules/stanza_common.ml index ce49471728b..95870f0c38a 100644 --- a/src/dune_rules/stanza_common.ml +++ b/src/dune_rules/stanza_common.ml @@ -45,7 +45,7 @@ module Pkg = struct let default_exn ~loc project stanza = match default project stanza with | Ok p -> p - | Error msg -> raise (User_error.E ({ msg with loc = Some loc }, None)) + | Error msg -> raise (User_error.E ({ msg with loc = Some loc }, [])) let resolve (project : Dune_project.t) name = let packages = Dune_project.packages project in @@ -88,7 +88,7 @@ module Pkg = struct and+ loc, name = located Package.Name.decode in match resolve p name with | Ok x -> x - | Error e -> raise (User_error.E ({ e with loc = Some loc }, None)) + | Error e -> raise (User_error.E ({ e with loc = Some loc }, [])) let field ~stanza = map_validate diff --git a/src/dune_rules/watermarks.ml b/src/dune_rules/watermarks.ml index ca52cd55315..69b48e1277b 100644 --- a/src/dune_rules/watermarks.ml +++ b/src/dune_rules/watermarks.ml @@ -341,7 +341,7 @@ let subst vcs = let version = Dune_project.dune_version dune_project.project in let ok_exn = function | Ok s -> s - | Error e -> raise (User_error.E (e, None)) + | Error e -> raise (User_error.E (e, [])) in if version >= (3, 0) then metadata_from_dune_project () diff --git a/src/dune_util/dune b/src/dune_util/dune index 4ce2b46d856..a30db8afb5c 100644 --- a/src/dune_util/dune +++ b/src/dune_util/dune @@ -1,3 +1,3 @@ (library (name dune_util) - (libraries stdune dune_lang)) + (libraries stdune dune_lang memo)) diff --git a/src/dune_util/report_error.ml b/src/dune_util/report_error.ml index 029a0ab8ae7..daa66ebc94c 100644 --- a/src/dune_util/report_error.ml +++ b/src/dune_util/report_error.ml @@ -69,11 +69,23 @@ let report_backtraces b = report_backtraces_flag := b let clear_reported () = reported := Digest.Set.empty -let report ?(extra = fun _ -> None) { Exn_with_backtrace.exn; backtrace } = +let print_memo_stacks = ref false + +let report { Exn_with_backtrace.exn; backtrace } = + let exn, memo_stack = + match exn with + | Memo.Error.E err -> (Memo.Error.get err, Memo.Error.stack err) + | _ -> (exn, []) + in match exn with | Already_reported -> () | _ -> let who_is_responsible, msg = get_user_message exn in + let has_embed_location = + match exn with + | User_error.E (_, annots) -> User_error.has_embed_location annots + | _ -> false + in let msg = if msg.loc = Some Loc.none then { msg with loc = None } @@ -95,8 +107,41 @@ let report ?(extra = fun _ -> None) { Exn_with_backtrace.exn; backtrace } = (Printexc.raw_backtrace_to_string backtrace |> String.split_lines) ~f:(fun line -> Pp.box ~indent:2 (Pp.text line))) in + let memo_stack = + if !print_memo_stacks then + memo_stack + else + match msg.loc with + | None -> + if has_embed_location then + [] + else + memo_stack + | Some loc -> + if Filename.is_relative loc.start.pos_fname then + (* If the error points to a local file, we assume that we don't + need to explain to the user how we reached this error. *) + [] + else + memo_stack + in + let memo_stack = + match + List.filter_map memo_stack + ~f:Memo.Stack_frame.human_readable_description + with + | [] -> None + | pps -> + Some + (Pp.vbox + (Pp.concat ~sep:Pp.cut + (List.map pps ~f:(fun pp -> + Pp.box ~indent:3 + (Pp.seq (Pp.verbatim "-> ") + (Pp.seq (Pp.text "required by ") pp)))))) + in let msg = - match extra msg.loc with + match memo_stack with | None -> msg | Some pp -> append msg [ pp ] in diff --git a/src/dune_util/report_error.mli b/src/dune_util/report_error.mli index 551cdafe630..45d4a00417c 100644 --- a/src/dune_util/report_error.mli +++ b/src/dune_util/report_error.mli @@ -8,14 +8,8 @@ open Stdune keep a cache of reported errors and ignore errors that have already been reported. - We cache what is actually printed to the screen. - - [extra] is the extra material that is printed between the backtrace and the - hint. *) -val report : - ?extra:(Loc.t option -> User_message.Style.t Pp.t option) - -> Exn_with_backtrace.t - -> unit + We cache what is actually printed to the screen. *) +val report : Exn_with_backtrace.t -> unit val report_backtraces : bool -> unit @@ -26,3 +20,6 @@ exception Already_reported (** Clear the list of already reported errors. *) val clear_reported : unit -> unit + +(** Print the memo stacks of errors. *) +val print_memo_stacks : bool ref diff --git a/src/dune_util/stringlike.ml b/src/dune_util/stringlike.ml index ef9d128e7ad..524ca95b107 100644 --- a/src/dune_util/stringlike.ml +++ b/src/dune_util/stringlike.ml @@ -34,7 +34,7 @@ module Make (S : Stringlike_intf.S_base) = struct let parse_string_exn (loc, s) = match of_string_user_error (loc, s) with | Ok s -> s - | Error err -> raise (User_error.E (err, None)) + | Error err -> raise (User_error.E (err, [])) let conv = ( (fun s -> diff --git a/src/memo/memo.ml b/src/memo/memo.ml index 3757e936bbf..612fa9e5a12 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -53,6 +53,12 @@ module Build0 = struct let of_reproducible_fiber = Fun.id + let swallow_errors f = + Fiber.map_reduce_errors + (module Monoid.Unit) + f + ~on_error:(fun _ -> Fiber.return ()) + module Option = struct let iter option ~f = match option with @@ -84,8 +90,6 @@ module Build0 = struct let memo_build = Fun.id end -let unwrap_exn = ref Fun.id - module Allow_cutoff = struct type 'o t = | No @@ -98,17 +102,6 @@ module type Input = sig include Table.Key with type t := t end -module Exn_comparable = Comparable.Make (struct - type t = Exn_with_backtrace.t - - let compare { Exn_with_backtrace.exn; backtrace = _ } (t : t) = - Poly.compare (!unwrap_exn exn) (!unwrap_exn t.exn) - - let to_dyn = Exn_with_backtrace.to_dyn -end) - -module Exn_set = Exn_comparable.Set - module Spec = struct type ('i, 'o) t = { name : string option @@ -116,9 +109,10 @@ module Spec = struct ; allow_cutoff : 'o Allow_cutoff.t ; witness : 'i Type_eq.Id.t ; f : 'i -> 'o Fiber.t + ; human_readable_description : ('i -> User_message.Style.t Pp.t) option } - let create ~name ~input ?cutoff f = + let create ~name ~input ~human_readable_description ~cutoff f = let name = match name with | None when !track_locations_of_lazy_values -> @@ -133,7 +127,13 @@ module Spec = struct | None -> Allow_cutoff.No | Some equal -> Yes equal in - { name; input; allow_cutoff; witness = Type_eq.Id.create (); f } + { name + ; input + ; allow_cutoff + ; witness = Type_eq.Id.create () + ; f + ; human_readable_description + } end module Id = Id.Make () @@ -181,17 +181,31 @@ module Stack_frame_without_state = struct ] end -module Cycle_error = struct +module Error = struct type t = - { cycle : Stack_frame_without_state.t list - ; stack : Stack_frame_without_state.t list + { exn : exn + ; rev_stack : Stack_frame_without_state.t list } exception E of t - let get t = t.cycle + let get t = t.exn + + let stack t = List.rev t.rev_stack - let stack t = t.stack + let extend_stack exn ~stack_frame = + E + (match exn with + | E t -> { t with rev_stack = stack_frame :: t.rev_stack } + | _ -> { exn; rev_stack = [ stack_frame ] }) +end + +module Cycle_error = struct + type t = Stack_frame_without_state.t list + + exception E of t + + let get t = t end (* The user can wrap exceptions into the [Non_reproducible] constructor to tell @@ -199,6 +213,21 @@ end without the wrapper. *) exception Non_reproducible of exn +module Exn_comparable = Comparable.Make (struct + type t = Exn_with_backtrace.t + + let unwrap = function + | Error.E { exn; _ } -> exn + | exn -> exn + + let compare { Exn_with_backtrace.exn; backtrace = _ } (t : t) = + Poly.compare (unwrap exn) (unwrap t.exn) + + let to_dyn = Exn_with_backtrace.to_dyn +end) + +module Exn_set = Exn_comparable.Set + (* A value calculated during a "sample attempt". A sample attempt can fail for two reasons: @@ -218,10 +247,15 @@ module Value = struct } | Cancelled of { dependency_cycle : Cycle_error.t } - let get_exn = function + let get_exn t ~stack_frame = + match t with | Ok a -> Fiber.return a - | Error { exns; _ } -> Fiber.reraise_all (Exn_set.to_list exns) - | Cancelled { dependency_cycle } -> raise (Cycle_error.E dependency_cycle) + | Error { exns; _ } -> + Fiber.reraise_all + (Exn_set.to_list_map exns ~f:(fun exn -> + { exn with exn = Error.extend_stack exn.exn ~stack_frame })) + | Cancelled { dependency_cycle } -> + raise (Error.extend_stack (Cycle_error.E dependency_cycle) ~stack_frame) end module Dag : Dag.S with type value := Dep_node_without_state.packed = @@ -592,8 +626,8 @@ module Call_stack = struct let push_frame (frame : Stack_frame_with_state.t) f = let* stack = get_call_stack () in - Fiber.Var.set call_stack_var (frame :: stack) (fun () -> - Implicit_output.forbid f) + let stack = frame :: stack in + Fiber.Var.set call_stack_var stack (fun () -> Implicit_output.forbid f) end let pp_stack () = @@ -707,9 +741,7 @@ let add_dep_from_caller (type i o) (dep_node : (i, o) Dep_node.t) Deps_so_far.add_dep deps_so_far_of_caller dep_node.without_state.id (Dep_node.T dep_node); Fiber.return (Ok ()) - | Some cycle -> - let+ stack = Call_stack.get_call_stack_without_state () in - Error { Cycle_error.stack; cycle })) + | Some cycle -> Fiber.return (Error cycle))) type ('input, 'output) t = { spec : ('input, 'output) Spec.t @@ -726,25 +758,31 @@ module Stack_frame = struct match Type_eq.Id.same memo.spec.witness t.spec.witness with | Some Type_eq.T -> Some t.input | None -> None + + let human_readable_description (Dep_node_without_state.T t) = + Option.map t.spec.human_readable_description ~f:(fun f -> f t.input) end -let create_with_cache (type i o) name ~cache ~input ?cutoff (f : i -> o Fiber.t) - = - let spec = Spec.create ~name:(Some name) ~input ?cutoff f in +let create_with_cache (type i o) name ~cache ~input ~cutoff + ~human_readable_description (f : i -> o Fiber.t) = + let spec = + Spec.create ~name:(Some name) ~input ~cutoff ~human_readable_description f + in Caches.register ~clear:(fun () -> Store.clear cache); { cache; spec } let create_with_store (type i) name - ~store:(module S : Store_intf.S with type key = i) ~input ?cutoff f = + ~store:(module S : Store_intf.S with type key = i) ~input ?cutoff + ?human_readable_description f = let cache = Store.make (module S) in - create_with_cache name ~cache ~input ?cutoff f + create_with_cache name ~cache ~input ~cutoff ~human_readable_description f -let create (type i) name ~input:(module Input : Input with type t = i) ?cutoff f - = +let create (type i) name ~input:(module Input : Input with type t = i) ?cutoff + ?human_readable_description f = (* This mutable table is safe: the implementation tracks all dependencies. *) let cache = Store.of_table (Table.create (module Input) 16) in let input = (module Input : Store_intf.Input with type t = i) in - create_with_cache name ~cache ~input ?cutoff f + create_with_cache name ~cache ~input ~cutoff ~human_readable_description f let make_dep_node ~spec ~input : _ Dep_node.t = let dep_node_without_state : _ Dep_node_without_state.t = @@ -1026,13 +1064,15 @@ end = struct Fiber.return (Cache_lookup.Result.Failure (Cancelled { dependency_cycle })) - let exec_dep_node dep_node = + let exec_dep_node (dep_node : _ Dep_node.t) = Fiber.of_thunk (fun () -> + let stack_frame = Dep_node_without_state.T dep_node.without_state in consider_and_compute dep_node >>= function | Ok res -> let* res = res in - Value.get_exn res.value - | Error cycle_error -> raise (Cycle_error.E cycle_error)) + Value.get_exn res.value ~stack_frame + | Error cycle_error -> + raise (Error.extend_stack (Cycle_error.E cycle_error) ~stack_frame)) end let exec (type i o) (t : (i, o) t) i = Exec.exec_dep_node (dep_node t i) @@ -1129,14 +1169,21 @@ end module Implicit_output = Implicit_output module Store = Store_intf -let lazy_cell ?cutoff f = - let spec = Spec.create ~name:None ~input:(module Unit) ?cutoff f in +let lazy_cell ?cutoff ?human_readable_description f = + let spec = + Spec.create ~name:None + ~input:(module Unit) + ~cutoff ~human_readable_description f + in make_dep_node ~spec ~input:() -let lazy_ ?cutoff f = - let cell = lazy_cell ?cutoff f in +let lazy_ ?cutoff ?human_readable_description f = + let cell = lazy_cell ?cutoff ?human_readable_description f in fun () -> Cell.read cell +let push_stack_frame ~human_readable_description f = + Cell.read (lazy_cell ~human_readable_description f) + module Lazy = struct type 'a t = unit -> 'a Fiber.t diff --git a/src/memo/memo.mli b/src/memo/memo.mli index 0f049aafd7a..615e1022683 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -77,24 +77,9 @@ module Build : sig end [@@inline always] - (** The bellow functions will eventually disappear and are only exported for - the transition to the memo monad *) - - val with_error_handler : - (unit -> 'a t) -> on_error:(Exn_with_backtrace.t -> Nothing.t t) -> 'a t - - val map_reduce_errors : - (module Monoid with type t = 'a) - -> on_error:(Exn_with_backtrace.t -> 'a t) - -> (unit -> 'b t) - -> ('b, 'a) result t - - val collect_errors : - (unit -> 'a t) -> ('a, Exn_with_backtrace.t list) Result.t t - - val finalize : (unit -> 'a t) -> finally:(unit -> unit t) -> 'a t - - val reraise_all : Exn_with_backtrace.t list -> 'a t + (** [swallow_errors f] swallows any error raised during the execution of [f]. + Use this function if you are ok with a computation failing. *) + val swallow_errors : (unit -> 'a t) -> ('a, unit) Result.t t module Option : sig val iter : 'a option -> f:('a -> unit t) -> unit t @@ -126,6 +111,22 @@ module Stack_frame : sig (** Checks if the stack frame is a frame of the given memoized function and if so, returns [Some i] where [i] is the argument of the function. *) val as_instance_of : t -> of_:('input, _) memo -> 'input option + + val human_readable_description : t -> User_message.Style.t Pp.t option +end + +(** Errors raised by user-supplied memoized functions that have been augmented + with Memo call stack information. *) +module Error : sig + type t + + exception E of t + + (** Get the underlying exception.*) + val get : t -> exn + + (** Return the stack leading to the node which raised the exception.*) + val stack : t -> Stack_frame.t list end module Cycle_error : sig @@ -135,9 +136,6 @@ module Cycle_error : sig (** Get the list of stack frames in this cycle. *) val get : t -> Stack_frame.t list - - (** Return the stack leading to the node which raised the cycle. *) - val stack : t -> Stack_frame.t list end (** Mark an exception as non-reproducible to indicate that it shouldn't be @@ -205,12 +203,16 @@ end depend on it. Note that currently Dune wipes all memoization caches on every run, so this early cutoff optimisation is not effective. + If [human_readable_description] is passed, it will be used when displaying + the memo stack to the user. + Running the computation may raise [Memo.Cycle_error.E] if a dependency cycle is detected. *) val create : string -> input:(module Input with type t = 'i) -> ?cutoff:('o -> 'o -> bool) + -> ?human_readable_description:('i -> User_message.Style.t Pp.t) -> ('i -> 'o Build.t) -> ('i, 'o) t @@ -222,6 +224,7 @@ val create_with_store : -> store:(module Store.S with type key = 'i) -> input:(module Store.Input with type t = 'i) -> ?cutoff:('o -> 'o -> bool) + -> ?human_readable_description:('i -> User_message.Style.t Pp.t) -> ('i -> 'o Build.t) -> ('i, 'o) t @@ -244,6 +247,13 @@ val pp_stack : unit -> _ Pp.t Fiber.t (** Get the memoized call stack during the execution of a memoized function. *) val get_call_stack : unit -> Stack_frame.t list Build.t +(** Insert a stack frame to make call stacks more precise when showing them to + the user. *) +val push_stack_frame : + human_readable_description:(unit -> User_message.Style.t Pp.t) + -> (unit -> 'a Build.t) + -> 'a Build.t + module Run : sig (** A single build run. *) type t @@ -257,14 +267,22 @@ module Lazy : sig val of_val : 'a -> 'a t - val create : ?cutoff:('a -> 'a -> bool) -> (unit -> 'a Build.t) -> 'a t + val create : + ?cutoff:('a -> 'a -> bool) + -> ?human_readable_description:(unit -> User_message.Style.t Pp.t) + -> (unit -> 'a Build.t) + -> 'a t val force : 'a t -> 'a Build.t val map : 'a t -> f:('a -> 'b) -> 'b t end -val lazy_ : ?cutoff:('a -> 'a -> bool) -> (unit -> 'a Build.t) -> 'a Lazy.t +val lazy_ : + ?cutoff:('a -> 'a -> bool) + -> ?human_readable_description:(unit -> User_message.Style.t Pp.t) + -> (unit -> 'a Build.t) + -> 'a Lazy.t module Implicit_output : sig type 'o t @@ -355,8 +373,6 @@ end) : sig val eval : 'a Function.input -> 'a Function.output Build.t end -val unwrap_exn : (exn -> exn) ref - (** If [true], this module will record the location of [Lazy.t] values. This is a bit expensive to compute, but it helps debugging. *) val track_locations_of_lazy_values : bool ref diff --git a/src/meta_parser/meta_parser.ml b/src/meta_parser/meta_parser.ml index 6fecf1fe418..0126b594ade 100644 --- a/src/meta_parser/meta_parser.ml +++ b/src/meta_parser/meta_parser.ml @@ -33,7 +33,7 @@ module Make (Stdune : sig val raise : ?loc:Loc.t -> ?hints:User_message.Style.t Pp.t list - -> ?annot:Annot.t + -> ?annots:Annot.t list -> User_message.Style.t Pp.t list -> _ end diff --git a/test/blackbox-tests/test-cases/all-alias.t/run.t b/test/blackbox-tests/test-cases/all-alias.t/run.t index 5fcc15b0bba..18f4f67a3b2 100644 --- a/test/blackbox-tests/test-cases/all-alias.t/run.t +++ b/test/blackbox-tests/test-cases/all-alias.t/run.t @@ -23,6 +23,7 @@ $ dune build --root install-stanza @subdir/all Entering directory 'install-stanza' Error: No rule found for subdir/foobar + -> required by alias subdir/all [1] @all builds user defined rules diff --git a/test/blackbox-tests/test-cases/cinaps/include-subdirs.t/run.t b/test/blackbox-tests/test-cases/cinaps/include-subdirs.t/run.t index e3b7fb46975..52773dc0fab 100644 --- a/test/blackbox-tests/test-cases/cinaps/include-subdirs.t/run.t +++ b/test/blackbox-tests/test-cases/cinaps/include-subdirs.t/run.t @@ -21,6 +21,9 @@ cinaps doesn't work with (include_subdirs unqualified) > EOF $ dune runtest --diff-command diff 2>&1 | sed -E 's/[^ ]+sh/\$sh/' + File "sub/dune", line 1, characters 0-24: + 1 | (cinaps (files test.ml)) + ^^^^^^^^^^^^^^^^^^^^^^^^ sh (internal) (exit 1) (cd _build/default && $sh -c 'diff sub/test.ml sub/test.ml.cinaps-corrected') 2,3c2 diff --git a/test/blackbox-tests/test-cases/cinaps/multiple-cinaps.t b/test/blackbox-tests/test-cases/cinaps/multiple-cinaps.t index c878d5f31d5..e09e9b7edf0 100644 --- a/test/blackbox-tests/test-cases/cinaps/multiple-cinaps.t +++ b/test/blackbox-tests/test-cases/cinaps/multiple-cinaps.t @@ -24,4 +24,6 @@ Multiple cinaps stanzas in the same dune file _build/default/.cinaps.a7811055/cinaps.ml-gen: - dune:1 - dune:2 + -> required by alias cinaps in dune:1 + -> required by alias runtest [1] diff --git a/test/blackbox-tests/test-cases/cinaps/simple.t/run.t b/test/blackbox-tests/test-cases/cinaps/simple.t/run.t index cf5d3b86f04..c9cdf5ef13e 100644 --- a/test/blackbox-tests/test-cases/cinaps/simple.t/run.t +++ b/test/blackbox-tests/test-cases/cinaps/simple.t/run.t @@ -18,6 +18,9 @@ Test of cinaps integration The cinaps actions should be attached to the runtest alias: $ dune runtest --diff-command diff 2>&1 | sed -E 's/[^ ]+sh/\$sh/' + File "dune", line 1, characters 0-21: + 1 | (cinaps (files *.ml)) + ^^^^^^^^^^^^^^^^^^^^^ sh (internal) (exit 1) (cd _build/default && $sh -c 'diff test.ml test.ml.cinaps-corrected') 1a2 diff --git a/test/blackbox-tests/test-cases/coq/compose-cycle.t/run.t b/test/blackbox-tests/test-cases/coq/compose-cycle.t/run.t index ca8726b7041..1b63014d0b9 100644 --- a/test/blackbox-tests/test-cases/coq/compose-cycle.t/run.t +++ b/test/blackbox-tests/test-cases/coq/compose-cycle.t/run.t @@ -6,9 +6,9 @@ - b - a - b - -> required by a/a.vo - -> required by install lib/coq/user-contrib/a/a.vo - -> required by ccycle.install + -> required by _build/default/a/a.vo + -> required by _build/install/default/lib/coq/user-contrib/a/a.vo + -> required by _build/default/ccycle.install -> required by alias default in dune:1 File "b/dune", line 2, characters 7-8: 2 | (name b) @@ -17,8 +17,8 @@ - a - b - a - -> required by b/b.vo - -> required by install lib/coq/user-contrib/b/b.vo - -> required by ccycle.install + -> required by _build/default/b/b.vo + -> required by _build/install/default/lib/coq/user-contrib/b/b.vo + -> required by _build/default/ccycle.install -> required by alias default in dune:1 [1] diff --git a/test/blackbox-tests/test-cases/coq/compose-two-scopes.t/run.t b/test/blackbox-tests/test-cases/coq/compose-two-scopes.t/run.t index c7bc807042a..d8f218a07d2 100644 --- a/test/blackbox-tests/test-cases/coq/compose-two-scopes.t/run.t +++ b/test/blackbox-tests/test-cases/coq/compose-two-scopes.t/run.t @@ -3,8 +3,8 @@ 4 | (theories a)) ^ Error: Theory a not found - -> required by b/b.vo - -> required by install lib/coq/user-contrib/b/b.vo - -> required by cvendor.install + -> required by _build/default/b/b.vo + -> required by _build/install/default/lib/coq/user-contrib/b/b.vo + -> required by _build/default/cvendor.install -> required by alias default in dune:1 [1] diff --git a/test/blackbox-tests/test-cases/coq/public-dep-on-private.t/run.t b/test/blackbox-tests/test-cases/coq/public-dep-on-private.t/run.t index 564a56942bc..43e0f2d6739 100644 --- a/test/blackbox-tests/test-cases/coq/public-dep-on-private.t/run.t +++ b/test/blackbox-tests/test-cases/coq/public-dep-on-private.t/run.t @@ -4,8 +4,8 @@ ^^^^^^^ Error: Theory "private" is private, it cannot be a dependency of a public theory. You need to associate "private" to a package. - -> required by public/b.vo - -> required by install lib/coq/user-contrib/public/b.vo - -> required by public.install + -> required by _build/default/public/b.vo + -> required by _build/install/default/lib/coq/user-contrib/public/b.vo + -> required by _build/default/public.install -> required by alias default in dune:1 [1] diff --git a/test/blackbox-tests/test-cases/cram/kinds.t b/test/blackbox-tests/test-cases/cram/kinds.t index 1dd484b791a..77250659bf1 100644 --- a/test/blackbox-tests/test-cases/cram/kinds.t +++ b/test/blackbox-tests/test-cases/cram/kinds.t @@ -64,6 +64,7 @@ If there is no run.t file, an error message is displayed. $ echo "Contents of file a" > dir-no-run/dir.t/a $ dune runtest dir-no-run Error: Cram test directory dir-no-run/dir.t does not contain a run.t file. + -> required by alias dir-no-run/runtest [1] However, if the directory is empty, this check is skipped. (git can leave such diff --git a/test/blackbox-tests/test-cases/deps-conf-vars.t/run.t b/test/blackbox-tests/test-cases/deps-conf-vars.t/run.t index 541eaa66ea7..68d61f15047 100644 --- a/test/blackbox-tests/test-cases/deps-conf-vars.t/run.t +++ b/test/blackbox-tests/test-cases/deps-conf-vars.t/run.t @@ -12,11 +12,8 @@ for this feature. $ dune build --root dynamic Entering directory 'dynamic' - File "dune", line 1, characters 0-43: - 1 | (alias - 2 | (name default) - 3 | (deps %{read:foo})) Error: No rule found for foo + -> required by alias default in dune:1 [1] $ dune build --root alias-lib-file diff --git a/test/blackbox-tests/test-cases/dir-target-dep.t/run.t b/test/blackbox-tests/test-cases/dir-target-dep.t/run.t index e6aae7393f5..64d44e777f9 100644 --- a/test/blackbox-tests/test-cases/dir-target-dep.t/run.t +++ b/test/blackbox-tests/test-cases/dir-target-dep.t/run.t @@ -15,12 +15,8 @@ $ dune build --root dep Entering directory 'dep' - File "dune", line 1, characters 0-68: - 1 | (alias - 2 | (name default) - 3 | (deps dir) - 4 | (action (bash "cat %{deps}/*"))) Error: No rule found for dir + -> required by alias default in dune:1 [1] We should not be able to produce a directory in a rule that already exists diff --git a/test/blackbox-tests/test-cases/duplicate-target-no-loc.t/run.t b/test/blackbox-tests/test-cases/duplicate-target-no-loc.t/run.t index f5d38621462..f6b733c2f8d 100644 --- a/test/blackbox-tests/test-cases/duplicate-target-no-loc.t/run.t +++ b/test/blackbox-tests/test-cases/duplicate-target-no-loc.t/run.t @@ -6,4 +6,5 @@ Issue: https://github.com/ocaml/dune/issues/1405 Error: Multiple rules generated for _build/install/default/doc/foo/foo: - dune:3 - dune:3 + -> required by _build/default/foo.install [1] diff --git a/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t b/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t index 7c646adda47..cffbc03dbc6 100644 --- a/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t +++ b/test/blackbox-tests/test-cases/env/env-bin-pform.t/run.t @@ -3,9 +3,6 @@ binaries stanza. %{bin:foo} is visible on the other hand. $ dune build foo alias default this is foo.exe - File "dune", line 5, characters 0-54: - 5 | (alias - 6 | (name default) - 7 | (action (run %{exe:foo.exe}))) Error: No rule found for foo.exe + -> required by alias default in dune:5 [1] diff --git a/test/blackbox-tests/test-cases/github25.t/run.t b/test/blackbox-tests/test-cases/github25.t/run.t index d481c0de392..06ce37a4d89 100644 --- a/test/blackbox-tests/test-cases/github25.t/run.t +++ b/test/blackbox-tests/test-cases/github25.t/run.t @@ -15,3 +15,7 @@ We need ocamlfind to run this test Error: Library "une-lib-qui-nexiste-pas" not found. -> required by library "plop.ca-marche-pas" in .../plop + -> required by _build/default/root/META.pas-de-bol + -> required by _build/install/default/lib/pas-de-bol/META + -> required by _build/default/root/pas-de-bol.install + -> required by alias root/install diff --git a/test/blackbox-tests/test-cases/invalid-dune-package.t/run.t b/test/blackbox-tests/test-cases/invalid-dune-package.t/run.t index c3e9d9d593a..a4ce13c45dc 100644 --- a/test/blackbox-tests/test-cases/invalid-dune-package.t/run.t +++ b/test/blackbox-tests/test-cases/invalid-dune-package.t/run.t @@ -17,4 +17,5 @@ Now we attempt to use an invalid dune-package library: $ OCAMLPATH=$PWD/findlib dune exec ./foo.exe File "$TESTCASE_ROOT/findlib/baz/dune-package", line 1, characters 0-0: Error: Invalid first line, expected: (lang ) + -> required by _build/default/foo.exe [1] diff --git a/test/blackbox-tests/test-cases/invalid-module-name.t/run.t b/test/blackbox-tests/test-cases/invalid-module-name.t/run.t index 393fc294a13..685eb62e106 100644 --- a/test/blackbox-tests/test-cases/invalid-module-name.t/run.t +++ b/test/blackbox-tests/test-cases/invalid-module-name.t/run.t @@ -6,4 +6,6 @@ Dune does not report an invalid module name as an error $ touch foo.ml foo-as-bar.ml $ dune build @all Error: foo__Foo-as-bar corresponds to an invalid module name + -> required by _build/default/foo__.ml-gen + -> required by alias all [1] diff --git a/test/blackbox-tests/test-cases/lib-errors.t/run.t b/test/blackbox-tests/test-cases/lib-errors.t/run.t index b3b578395c1..953cc4b7c5d 100644 --- a/test/blackbox-tests/test-cases/lib-errors.t/run.t +++ b/test/blackbox-tests/test-cases/lib-errors.t/run.t @@ -11,6 +11,7 @@ Cycle detection -> "a" in _build/default -> required by library "c" in _build/default -> required by executable cycle in dune:17 + -> required by _build/default/cycle.exe [1] Select with no solution diff --git a/test/blackbox-tests/test-cases/loop.t/run.t b/test/blackbox-tests/test-cases/loop.t/run.t index 404348b2955..5d59f4a9a80 100644 --- a/test/blackbox-tests/test-cases/loop.t/run.t +++ b/test/blackbox-tests/test-cases/loop.t/run.t @@ -1,5 +1,5 @@ $ dune build a - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/a -> _build/default/b -> _build/default/a @@ -10,14 +10,14 @@ but the cycle doesn't involve result1. We must make sure the output does show a cycle. $ dune build result1 - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/result2 -> _build/default/input -> _build/default/result2 [1] $ dune build result1 --debug-dependency-path - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/result2 -> _build/default/input -> _build/default/result2 diff --git a/test/blackbox-tests/test-cases/missing-loc-run.t/run.t b/test/blackbox-tests/test-cases/missing-loc-run.t/run.t index 9b66d467590..b3727f0df9a 100644 --- a/test/blackbox-tests/test-cases/missing-loc-run.t/run.t +++ b/test/blackbox-tests/test-cases/missing-loc-run.t/run.t @@ -2,11 +2,8 @@ Exact path provided by the user: $ dune runtest --root precise-path Entering directory 'precise-path' - File "dune", line 1, characters 0-49: - 1 | (alias - 2 | (name runtest) - 3 | (action (run ./foo.exe))) Error: No rule found for foo.exe + -> required by alias runtest in dune:1 [1] Path that needs to be searched: @@ -24,9 +21,6 @@ Path in deps field of alias stanza $ dune runtest --root alias-deps-field Entering directory 'alias-deps-field' - File "dune", line 1, characters 0-38: - 1 | (alias - 2 | (name runtest) - 3 | (deps foobar)) Error: No rule found for foobar + -> required by alias runtest in dune:1 [1] diff --git a/test/blackbox-tests/test-cases/ocamldep-error-check.t b/test/blackbox-tests/test-cases/ocamldep-error-check.t index 6bbe3ec3658..9f597340997 100644 --- a/test/blackbox-tests/test-cases/ocamldep-error-check.t +++ b/test/blackbox-tests/test-cases/ocamldep-error-check.t @@ -20,6 +20,9 @@ Dune uses ocamldep to prevent a module from depending on itself. Foo is the main module of the library and is the only module exposed outside of the library. Consequently, it should be the one depending on all the other modules in the library. + -> required by _build/default/lib/.foo.objs/foo__Bar.impl.all-deps + -> required by _build/default/lib/foo.cma + -> required by alias lib/all [1] $ rm lib/bar.ml diff --git a/test/blackbox-tests/test-cases/overlapping-deps.t b/test/blackbox-tests/test-cases/overlapping-deps.t index 6062ff5efc3..b8654a136e2 100644 --- a/test/blackbox-tests/test-cases/overlapping-deps.t +++ b/test/blackbox-tests/test-cases/overlapping-deps.t @@ -67,6 +67,8 @@ And we see the error: $TESTCASE_ROOT/use/../external/_build/install/default/lib/some_package2 -> required by library "some_package1" in $TESTCASE_ROOT/use/../external/_build/install/default/lib/some_package1 + -> required by _build/default/proj2/.bar.objs/byte/bar.cmo + -> required by _build/default/proj2/bar.cma [1] We can fix the error by allow overlapping dependencies: @@ -103,4 +105,5 @@ We also make sure the error exists for executables: -> required by library "some_package1" in $TESTCASE_ROOT/use/../external/_build/install/default/lib/some_package1 -> required by executable bar in proj2/dune:2 + -> required by _build/default/proj2/bar.exe [1] diff --git a/test/blackbox-tests/test-cases/ppx-cross-context-issue.t/run.t b/test/blackbox-tests/test-cases/ppx-cross-context-issue.t/run.t index 7d69e51848d..05cf21797f8 100644 --- a/test/blackbox-tests/test-cases/ppx-cross-context-issue.t/run.t +++ b/test/blackbox-tests/test-cases/ppx-cross-context-issue.t/run.t @@ -6,7 +6,7 @@ ^^^^^^ Error: Library "fooppx" in _build/cross-environment/ppx is hidden (unsatisfied 'enabled_if'). - -> required by lib/lib.pp.ml (context cross-environment) + -> required by _build/cross-environment/lib/lib.pp.ml -> required by alias lib/all (context cross-environment) -> required by alias default (context cross-environment) [1] diff --git a/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t b/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t index d0a0191f92b..2824ca0604f 100644 --- a/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t +++ b/test/blackbox-tests/test-cases/ppx-runtime-dependencies.t/run.t @@ -66,6 +66,7 @@ Handling ppx_runtime_libraries dependencies correctly -> "a" in _build/default -> required by library "c" in _build/default -> required by executable main in bin/dune:2 + -> required by _build/default/bin/main.exe [1] ---------------------------------------------------------------------------------- @@ -170,4 +171,5 @@ Note that pps dependencies are separated by a runtime dependency. -> "gen_c" in _build/default -> required by library "c" in _build/default -> required by executable main in bin/dune:2 + -> required by _build/default/bin/main.exe [1] diff --git a/test/blackbox-tests/test-cases/report-all-errors.t b/test/blackbox-tests/test-cases/report-all-errors.t index 85a6876b5f4..09262d4986e 100644 --- a/test/blackbox-tests/test-cases/report-all-errors.t +++ b/test/blackbox-tests/test-cases/report-all-errors.t @@ -49,22 +49,14 @@ failing before it had a chance to start thinking about building `z`. $ echo 'exit 1' > fail.ml $ dune build - File "dune", line 1, characters 0-73: - 1 | (rule - 2 | (alias default) - 3 | (action - 4 | (progn - 5 | (cat %{read:x}) - 6 | (cat y)))) + File "dune", line 10, characters 0-42: + 10 | (rule (with-stdout-to y (run ./fail.exe))) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ fail y (exit 1) (cd _build/default && ./fail.exe) > _build/default/y - File "dune", line 1, characters 0-73: - 1 | (rule - 2 | (alias default) - 3 | (action - 4 | (progn - 5 | (cat %{read:x}) - 6 | (cat y)))) + File "dune", line 11, characters 0-42: + 11 | (rule (with-stdout-to z (run ./fail.exe))) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ fail z (exit 1) (cd _build/default && ./fail.exe) > _build/default/z [1] diff --git a/test/blackbox-tests/test-cases/reporting-of-cycles.t/run.t b/test/blackbox-tests/test-cases/reporting-of-cycles.t/run.t index 4a5b3a6b6e3..38b7c4f13f9 100644 --- a/test/blackbox-tests/test-cases/reporting-of-cycles.t/run.t +++ b/test/blackbox-tests/test-cases/reporting-of-cycles.t/run.t @@ -5,28 +5,28 @@ start running things. In the past, the error was only reported during the second run of dune. $ dune build @package-cycle - Error: Dependency cycle between the following files: + Error: Dependency cycle between: alias a/.a-files -> alias b/.b-files -> alias a/.a-files [1] $ dune build @simple-repro-case - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/x -> _build/default/y -> _build/default/x [1] $ dune build x1 - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/x2 -> _build/default/x3 -> _build/default/x2 [1] $ dune build @complex-repro-case - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/cd1 -> _build/default/cd4 -> _build/default/cd3 @@ -42,14 +42,12 @@ error message. $ echo 'val x : unit' > indirect/c.mli $ dune build @indirect-deps - File "indirect/dune", line 6, characters 0-43: - 6 | (alias - 7 | (name indirect-deps) - 8 | (deps a.exe)) Error: dependency cycle between modules in _build/default/indirect: A -> C -> A + -> required by _build/default/indirect/a.exe + -> required by alias indirect/indirect-deps in indirect/dune:6 [1] But when the cycle is due to the cmi files themselves, the message becomes @@ -57,7 +55,7 @@ cryptic and can involve unrelated files: $ echo 'val xx : B.t' >> indirect/c.mli $ dune build @indirect-deps - Error: Dependency cycle between the following files: + Error: Dependency cycle between: _build/default/indirect/.a.eobjs/a.impl.all-deps -> _build/default/indirect/.a.eobjs/b.impl.all-deps -> _build/default/indirect/.a.eobjs/c.intf.all-deps diff --git a/test/blackbox-tests/test-cases/strict-package-deps.t/run.t b/test/blackbox-tests/test-cases/strict-package-deps.t/run.t index 19505670748..2f724b4f08e 100644 --- a/test/blackbox-tests/test-cases/strict-package-deps.t/run.t +++ b/test/blackbox-tests/test-cases/strict-package-deps.t/run.t @@ -19,6 +19,8 @@ the package dependencies inferred by dune: $ dune build @install Error: Package foo is missing the following package dependencies - bar + -> required by _build/default/foo.install + -> required by alias install [1] $ cat >foo/dune < required by _build/default/foo.install + -> required by alias install [1] $ cd .. @@ -50,4 +54,6 @@ transitive deps. $ dune build @install Error: Package foo is missing the following package dependencies - baz + -> required by _build/default/foo.install + -> required by alias install [1] diff --git a/test/blackbox-tests/test-cases/virtual-libraries/double-implementation.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/double-implementation.t/run.t index 2ec1eeaca08..25a90548ffd 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/double-implementation.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/double-implementation.t/run.t @@ -1,13 +1,12 @@ Executable that tries to use two implementations for the same virtual lib $ dune build - File "dune", line 11, characters 0-49: - 11 | (alias - 12 | (name default) - 13 | (action (run ./foo.exe))) Error: Conflicting implementations for virtual library "vlib" in _build/default/vlib: - "impl1" in _build/default/impl1 -> required by library "bar" in _build/default - "impl2" in _build/default/impl2 This cannot work. + -> required by executable foo in dune:2 + -> required by _build/default/foo.exe + -> required by alias default in dune:11 [1] diff --git a/test/blackbox-tests/test-cases/virtual-libraries/missing-implementation.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/missing-implementation.t/run.t index b56ec733844..ea95323aacb 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/missing-implementation.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/missing-implementation.t/run.t @@ -1,9 +1,8 @@ Executable that tries to build against a virtual library without an implementation $ dune build - File "dune", line 5, characters 0-49: - 5 | (alias - 6 | (name default) - 7 | (action (run ./foo.exe))) Error: No implementation found for virtual library "vlib" in _build/default/vlib. + -> required by executable foo in dune:2 + -> required by _build/default/foo.exe + -> required by alias default in dune:5 [1] diff --git a/test/blackbox-tests/test-cases/virtual-libraries/vlib-wrong-default-impl.t/run.t b/test/blackbox-tests/test-cases/virtual-libraries/vlib-wrong-default-impl.t/run.t index 7d8bd38ffff..5a07430655d 100644 --- a/test/blackbox-tests/test-cases/virtual-libraries/vlib-wrong-default-impl.t/run.t +++ b/test/blackbox-tests/test-cases/virtual-libraries/vlib-wrong-default-impl.t/run.t @@ -2,11 +2,8 @@ Check that dune makes a proper error if the default implementation of a virtual library is not actually an implementation of the virtual library. $ dune build @default - File "exe/dune", line 5, characters 0-49: - 5 | (rule - 6 | (alias default) - 7 | (action (run ./exe.exe))) - Error: "not_an_implem" is not an implementation of "vlibfoo". Error: "not_an_implem" is not an implementation of "vlibfoo". -> required by executable exe in exe/dune:2 + -> required by _build/default/exe/exe.exe + -> required by alias exe/default in exe/dune:5 [1] diff --git a/test/blackbox-tests/test-cases/with-nested-exit-codes.t/run.t b/test/blackbox-tests/test-cases/with-nested-exit-codes.t/run.t index 0bb8a475923..8b03fbe18d1 100644 --- a/test/blackbox-tests/test-cases/with-nested-exit-codes.t/run.t +++ b/test/blackbox-tests/test-cases/with-nested-exit-codes.t/run.t @@ -79,6 +79,16 @@ > EOF $ echo "Hello, Dune!" > input $ dune build --display=short --root . @f5 + File "dune", line 32, characters 0-225: + 32 | (rule + 33 | (alias f5) + 34 | (action (with-accepted-exit-codes + 35 | 0 + 36 | (setenv VAR myvar + 37 | (with-stdin-from input + 38 | (chdir . + 39 | (with-stdout-to out2.txt + 40 | (run ./exit.exe 1)))))))) exit out2.txt (exit 1) (cd _build/default && ./exit.exe 1) < _build/default/input > _build/default/out2.txt [1] diff --git a/test/expect-tests/memo/memoize_tests.ml b/test/expect-tests/memo/memoize_tests.ml index 22f8daccf40..9e890f428e4 100644 --- a/test/expect-tests/memo/memoize_tests.ml +++ b/test/expect-tests/memo/memoize_tests.ml @@ -30,7 +30,9 @@ let int_fn_create name ~cutoff = Memo.create name ~input:(module Int) ~cutoff (* to run a computation *) let run m = Scheduler.run (Memo.Build.run m) -let run_memo f v = run (Memo.exec f v) +let run_memo f v = + try run (Memo.exec f v) with + | Memo.Error.E err -> raise (Memo.Error.get err) (* the trivial dependencies are simply the identity function *) let compdep x = Memo.Build.return (x ^ x) @@ -581,12 +583,23 @@ let print_result arg res = Format.printf "f %d = %a@." arg Pp.to_fmt (Dyn.pp (Result.to_dyn int (list Exn_with_backtrace.to_dyn) res)) +let run_collect_errors f = + let open Fiber.O in + Fiber.collect_errors (fun () -> Memo.Build.run (f ())) >>| function + | Ok _ as res -> res + | Error errs -> + Error + (List.map errs ~f:(fun (e : Exn_with_backtrace.t) -> + match e.exn with + | Memo.Error.E err -> { e with exn = Memo.Error.get err } + | _ -> e)) + let evaluate_and_print f x = let res = try Fiber.run ~iter:(fun () -> raise Exit) - (Memo.Build.run (Memo.Build.collect_errors (fun () -> Memo.exec f x))) + (run_collect_errors (fun () -> Memo.exec f x)) with | exn -> Error [ Exn_with_backtrace.capture exn ] in @@ -1358,11 +1371,7 @@ let%expect_test "Abandoned node with no cutoff is recomputed" = let print_exns f = let res = - match - Fiber.run - ~iter:(fun () -> raise Exit) - (Memo.Build.run (Memo.Build.collect_errors f)) - with + match Fiber.run ~iter:(fun () -> raise Exit) (run_collect_errors f) with | Ok _ -> assert false | Error exns -> Error (List.map exns ~f:(fun (e : Exn_with_backtrace.t) -> e.exn))