diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index f2b4721998..46c2f9f77e 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -169,9 +169,8 @@ let is_unexpanded_module_type_of = in inner -(** To use as [Lookup_failures.kind]. *) let rec kind_of_module_cpath = function - | `Root _ -> Some `Root + | `Root name -> Some (`Root name) | `Substituted p' | `Dot (p', _) -> kind_of_module_cpath p' | `Apply (a, b) -> ( match kind_of_module_cpath a with @@ -184,10 +183,14 @@ let rec kind_of_module_type_cpath = function | `Dot (p', _) -> kind_of_module_cpath p' | _ -> None +(** [Some (`Root _)] for errors during lookup of root modules or [None] for + other errors. *) let rec kind_of_error = function | `UnresolvedPath (`Module (cp, _)) -> kind_of_module_cpath cp | `UnresolvedPath (`ModuleType (cp, _)) -> kind_of_module_type_cpath cp - | `Lookup_failure (`Root _) | `Lookup_failure_root _ -> Some `Root + | `Lookup_failure (`Root (_, name)) -> + Some (`Root (Names.ModuleName.to_string name)) + | `Lookup_failure_root name -> Some (`Root name) | `Parent (`Parent_sig e) -> kind_of_error (e :> Tools_error.any) | `Parent (`Parent_module_type e) -> kind_of_error (e :> Tools_error.any) | `Parent (`Parent_expr e) -> kind_of_error (e :> Tools_error.any) @@ -195,9 +198,18 @@ let rec kind_of_error = function | `Parent (`Parent _ as e) -> kind_of_error (e :> Tools_error.any) | `OpaqueModule -> (* Don't turn OpaqueModule warnings into errors *) - Some `Root + Some `OpaqueModule | _ -> None +let kind_of_error ~what = function + | Some e -> kind_of_error (e :> Tools_error.any) + | None -> ( + match what with + | `Include (Component.Include.Alias cp) -> kind_of_module_cpath cp + | `Module (`Root (_, name)) -> + Some (`Root (Names.ModuleName.to_string name)) + | _ -> None) + open Paths type what = @@ -222,15 +234,6 @@ type what = | `Child of Reference.t ] let report ~(what : what) ?tools_error action = - let kind = - match tools_error with - | Some e -> kind_of_error (e :> Tools_error.any) - | None -> ( - match what with - | `Include (Component.Include.Alias cp) -> kind_of_module_cpath cp - | `Module (`Root _) -> Some `Root - | _ -> None) - in let action = match action with | `Lookup -> "lookup" @@ -243,32 +246,39 @@ let report ~(what : what) ?tools_error action = | Some e -> Format.fprintf fmt " %a" Tools_error.pp (e :> Tools_error.any) | None -> () in - let r ?(kind = kind) subject pp_a a = - Lookup_failures.report ?kind "Failed to %s %s %a%a" action subject pp_a a - pp_tools_error tools_error - in let open Component.Fmt in - let fmt_id fmt id = model_identifier fmt (id :> Paths.Identifier.t) in - match what with - | `Functor_parameter id -> r "functor parameter" fmt_id id - | `Value id -> r "value" fmt_id id - | `Class id -> r "class" fmt_id id - | `Class_type id -> r "class type" fmt_id id - | `Module id -> r "module" fmt_id id - | `Module_type id -> r "module type" fmt_id id - | `Module_path path -> r "module path" module_path path - | `Module_type_path path -> r "module type path" module_type_path path - | `Module_type_U expr -> r "module type expr" u_module_type_expr expr - | `Include decl -> r "include" include_decl decl - | `Package path -> - r "module package" module_type_path (path :> Cpath.module_type) - | `Type cfrag -> r "type" type_fragment cfrag - | `Type_path path -> r "type" type_path path - | `With_module frag -> r "module substitution" module_fragment frag - | `With_module_type frag -> - r "module type substitution" module_type_fragment frag - | `With_type frag -> r "type substitution" type_fragment frag - | `Module_type_expr cexpr -> r "module type expression" module_type_expr cexpr - | `Module_type_u_expr cexpr -> - r "module type u expression" u_module_type_expr cexpr - | `Child rf -> r "child reference" model_reference rf + let report_internal_error () = + let r subject pp_a a = + Lookup_failures.report_internal "Failed to %s %s %a%a" action subject pp_a + a pp_tools_error tools_error + in + let fmt_id fmt id = model_identifier fmt (id :> Paths.Identifier.t) in + match what with + | `Functor_parameter id -> r "functor parameter" fmt_id id + | `Value id -> r "value" fmt_id id + | `Class id -> r "class" fmt_id id + | `Class_type id -> r "class type" fmt_id id + | `Module id -> r "module" fmt_id id + | `Module_type id -> r "module type" fmt_id id + | `Module_path path -> r "module path" module_path path + | `Module_type_path path -> r "module type path" module_type_path path + | `Module_type_U expr -> r "module type expr" u_module_type_expr expr + | `Include decl -> r "include" include_decl decl + | `Package path -> + r "module package" module_type_path (path :> Cpath.module_type) + | `Type cfrag -> r "type" type_fragment cfrag + | `Type_path path -> r "type" type_path path + | `With_module frag -> r "module substitution" module_fragment frag + | `With_module_type frag -> + r "module type substitution" module_type_fragment frag + | `With_type frag -> r "type substitution" type_fragment frag + | `Module_type_expr cexpr -> + r "module type expression" module_type_expr cexpr + | `Module_type_u_expr cexpr -> + r "module type u expression" u_module_type_expr cexpr + | `Child rf -> r "child reference" model_reference rf + in + match kind_of_error ~what tools_error with + | Some (`Root name) -> Lookup_failures.report_root ~name + | Some `OpaqueModule -> report_internal_error () + | None -> report_internal_error () diff --git a/src/xref2/lookup_failures.ml b/src/xref2/lookup_failures.ml index 98420e83e2..db53861516 100644 --- a/src/xref2/lookup_failures.ml +++ b/src/xref2/lookup_failures.ml @@ -1,36 +1,68 @@ open Odoc_model -type kind = [ `Root | `Internal | `Warning ] - let loc_acc = ref None -let with_location' loc f = - let prev_loc = !loc_acc in - loc_acc := Some loc; - let r = f () in - loc_acc := prev_loc; - r - -let add ~kind msg = - let w = - match !loc_acc with - | Some (`Filename_only filename) -> Error.filename_only "%s" msg filename - | Some (`Full_loc loc) -> Error.make "%s" msg loc - | None -> failwith "Lookup_failures: Uncaught failure." +let acc = ref [] + +let with_ref r x f = + let saved = !r in + r := x; + let v = f () in + let x = !r in + r := saved; + (v, x) + +let with_location' loc f = fst (with_ref loc_acc (Some loc) f) + +let add f = acc := f :: !acc + +(** Raise a single message for root errors. *) +let raise_root_errors ~filename failures = + let roots = + List.fold_left + (fun acc -> function `Root name -> name :: acc | `Warning _ -> acc) + [] failures + |> List.sort_uniq String.compare in - ignore kind; - Error.raise_warning ~non_fatal:true w + match roots with + | [] -> () + | _ :: _ -> + Error.raise_warning ~non_fatal:true + (Error.filename_only "Couldn't find the following modules:@;<1 2>@[%a@]" + Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string) + roots filename) + +(** Raise the other warnings. *) +let raise_warnings ~filename failures = + List.iter + (function + | `Root _ -> () + | `Warning (msg, loc, non_fatal) -> + let err = + match loc with + | Some loc -> Error.make "%s" msg loc + | None -> Error.filename_only "%s" msg filename + in + Error.raise_warning ~non_fatal err) + failures let catch_failures ~filename f = - with_location' (`Filename_only filename) (fun () -> Error.catch_warnings f) + let r, failures = with_ref acc [] f in + Error.catch_warnings (fun () -> + raise_root_errors ~filename failures; + raise_warnings ~filename failures; + r) let kasprintf k fmt = Format.(kfprintf (fun _ -> k (flush_str_formatter ())) str_formatter fmt) -(** Report a lookup failure to the enclosing [catch_failures] call. *) -let report ?(kind = `Internal) fmt = - (* Render the message into a string first because [Error.kmake] is not - exposed. *) - kasprintf (add ~kind) fmt +let report ~non_fatal fmt = + kasprintf (fun msg -> add (`Warning (msg, !loc_acc, non_fatal))) fmt + +let report_internal fmt = report ~non_fatal:true fmt + +let report_root ~name = add (`Root name) + +let report_warning fmt = report ~non_fatal:false fmt -let with_location loc f = with_location' (`Full_loc loc) f +let with_location loc f = with_location' loc f diff --git a/src/xref2/lookup_failures.mli b/src/xref2/lookup_failures.mli index cef0914135..8cee5ef7aa 100644 --- a/src/xref2/lookup_failures.mli +++ b/src/xref2/lookup_failures.mli @@ -1,27 +1,24 @@ (** Report non-fatal errors. - This is internally using {!Odoc_model.Error}. The main difference is that no - precise location is attached to each failures, instead a filename is given - to {!catch_failures}. - - Each failure has a [kind] which specify whether it's a lookup failure - ([`Root] or [`Internal]) or a warning. [`Root] failures are never turned - into fatal warnings. *) + The main difference with {!Odoc_model.Error} is that no precise location is + attached to each failures, instead a filename is given to {!catch_failures}. *) open Odoc_model -type kind = [ `Root | `Internal | `Warning ] -(** [`Root] failures won't be turned into fatal warnings. [`Internal] is for - lookup failures other than root modules and [`Warning] for messages to the - users. They may be turned into fatal warnings depending on [~warn_error]. *) - val catch_failures : filename:string -> (unit -> 'a) -> 'a Error.with_warnings -(** Catch failures thrown by [report]. [filename] is the initial location of - generated errors, more precise locations can be specified with +(** Catch failures that are reported by [f]. [filename] is the initial location + of generated errors, more precise locations can be specified with [with_location]. *) -val report : ?kind:kind -> ('fmt, Format.formatter, unit, unit) format4 -> 'fmt -(** Report a lookup failure to the enclosing [catch_failures] call. *) +val report_internal : ('fmt, Format.formatter, unit, unit) format4 -> 'fmt +(** Internal errors happens during compiling and linking. *) + +val report_root : name:string -> unit +(** Root errors happens when a dependency couldn't be loaded. These errors won't + be made fatal in "warn error" mode. *) + +val report_warning : ('fmt, Format.formatter, unit, unit) format4 -> 'fmt +(** Warnings are user errors. *) val with_location : Location_.span -> (unit -> 'a) -> 'a (** Failures reported indirectly by this function will have a location attached. *) diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index e64240a3ef..89bc736d99 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -101,7 +101,7 @@ let ref_kind_of_find = function let ambiguous_ref_warning name results = let pp_sep pp () = Format.fprintf pp ", " and pp_kind pp r = Format.fprintf pp "%s-%s" r name in - Lookup_failures.report ~kind:`Warning + Lookup_failures.report_warning "Reference to '%s' is ambiguous. Please specify its kind: %a." name (Format.pp_print_list ~pp_sep pp_kind) results diff --git a/test/xref2/resolve/test.md b/test/xref2/resolve/test.md index 6feff4d1bf..cc5953780a 100644 --- a/test/xref2/resolve/test.md +++ b/test/xref2/resolve/test.md @@ -1638,13 +1638,13 @@ Functor app nightmare: *) |} File "": -Failed to compile expansion for module type expression identifier((param (root Root).App.result F), false)(identifier((param (root Root).App T), false)).T OpaqueModule -File "": -Failed to compile expansion for module type expression identifier((param (root Root).App.result F), false)(identifier((param (root Root).App T), false)).T OpaqueModule -File "": Failed to compile expansion for module type expression identifier((param (root Root).Foo T), false).T OpaqueModule File "": Failed to compile expansion for module type expression identifier((param (root Root).Foo T), false).T OpaqueModule +File "": +Failed to compile expansion for module type expression identifier((param (root Root).App.result F), false)(identifier((param (root Root).App T), false)).T OpaqueModule +File "": +Failed to compile expansion for module type expression identifier((param (root Root).App.result F), false)(identifier((param (root Root).App T), false)).T OpaqueModule - : Odoc_model.Lang.Compilation_unit.t = {Odoc_model.Lang.Compilation_unit.id = `Root (Some (`Page (None, None)), Root); diff --git a/test/xref2/warnings.t/run.t b/test/xref2/warnings.t/run.t index 2785d00156..a7513a4c64 100644 --- a/test/xref2/warnings.t/run.t +++ b/test/xref2/warnings.t/run.t @@ -30,7 +30,8 @@ A contains linking errors: $ odoc link a.odoc File "a.odoc": - Failed to lookup type unresolvedroot(B).t Parent_module: Lookup failure (root module): B + Couldn't find the following modules: + B $ odoc errors a.odocl File "a.mli", line 8, characters 23-23: @@ -38,7 +39,8 @@ A contains linking errors: File "a.mli", line 8, characters 22-23: Identifier in reference should not be empty. File "a.odoc": - Failed to lookup type unresolvedroot(B).t Parent_module: Lookup failure (root module): B + Couldn't find the following modules: + B It is possible to hide the warnings too: