Aggregate "root" lookup failures

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,20 +183,33 @@ 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)
   | `Parent (`Parent_module e) -> kind_of_error (e :> Tools_error.any)
   | `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 ()

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

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. *)

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

test/xref2/resolve/test.md

@@ -1638,13 +1638,13 @@ Functor app nightmare:
   *)
     |}
 File "<test>":
-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 "<test>":
-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 "<test>":
 Failed to compile expansion for module type expression identifier((param (root Root).Foo T), false).T OpaqueModule
 File "<test>":
 Failed to compile expansion for module type expression identifier((param (root Root).Foo T), false).T OpaqueModule
+File "<test>":
+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 "<test>":
+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);

test/xref2/warnings.t/run.t

@@ -30,15 +30,17 @@ 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:
   End of text is not allowed in '{!...}' (cross-reference).
   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: