Report failures when resolving references

src/xref2/errors.ml

@@ -9,6 +9,8 @@ module Tools_error = struct
       [ `Module of Cpath.module_ ]
       (* Failed to resolve a module path when applying a fragment item *) ]
 
+  type reference_kind = [ `S | `T | `C | `CT | `Page | `Cons | `Field | `Label ]
+
   type signature_of_module_error =
     [ `OpaqueModule (* The module does not have an expansion *)
     | `UnresolvedForwardPath
@@ -63,6 +65,7 @@ module Tools_error = struct
     | `Class_replaced
       (* Class was replaced with a destructive substitution and we're not sure
           what to do now *)
+    | `OpaqueClass (* Couldn't resolve class signature. *)
     | `Find_failure
       (* Internal error: the type was not found in the parent signature *)
     | `Lookup_failureT of
@@ -83,7 +86,15 @@ module Tools_error = struct
     | `Parent_module of
       simple_module_lookup_error
       (* Error found while looking up parent module *)
+    | `Parent_type of simple_type_lookup_error
     | `Fragment_root (* Encountered unexpected fragment root *)
+    | `Parent of parent_lookup_error
+    | `Reference of reference_lookup_error ]
+
+  and reference_lookup_error =
+    [ `Wrong_kind of reference_kind list * reference_kind (* Expected, got *)
+    | `Lookup_by_name of [ reference_kind | `Any ] * string
+    | `Find_by_name of [ reference_kind | `Any ] * string
     | `Parent of parent_lookup_error ]
 
   type any =
@@ -94,10 +105,25 @@ module Tools_error = struct
     | signature_of_module_error
     | parent_lookup_error ]
 
+  let pp_reference_kind fmt k =
+    let k =
+      match k with
+      | `S -> "signature"
+      | `T -> "type"
+      | `C -> "class"
+      | `CT -> "class type"
+      | `Page -> "page"
+      | `Cons -> "constructor"
+      | `Field -> "field"
+      | `Label -> "label"
+    in
+    Format.pp_print_string fmt k
+
   let rec pp : Format.formatter -> any -> unit =
    fun fmt err ->
     match err with
     | `OpaqueModule -> Format.fprintf fmt "OpaqueModule"
+    | `OpaqueClass -> Format.fprintf fmt "Class is abstract"
     | `UnresolvedForwardPath -> Format.fprintf fmt "Unresolved forward path"
     | `UnresolvedPath (`Module (p, e)) ->
         Format.fprintf fmt "Unresolved module path %a (%a)"
@@ -138,6 +164,22 @@ module Tools_error = struct
     | `Parent_expr e -> Format.fprintf fmt "Parent_expr: %a" pp (e :> any)
     | `Parent_module e -> Format.fprintf fmt "Parent_module: %a" pp (e :> any)
     | `Fragment_root -> Format.fprintf fmt "Fragment root"
+    | `Parent_type e -> Format.fprintf fmt "Parent_type: %a" pp (e :> any)
+    | `Reference e -> pp_reference_lookup_error fmt e
+
+  and pp_reference_lookup_error fmt = function
+    | `Wrong_kind (expected, got) ->
+        let pp_sep fmt () = Format.fprintf fmt " or " in
+        Format.fprintf fmt "is of kind %a but expected %a" pp_reference_kind got
+          (Format.pp_print_list ~pp_sep pp_reference_kind)
+          expected
+    | `Lookup_by_name (kind, name) | `Find_by_name (kind, name) -> (
+        match kind with
+        | `Any -> Format.fprintf fmt "Couldn't find %S" name
+        | #reference_kind as kind ->
+            Format.fprintf fmt "Couldn't find %a %S" pp_reference_kind kind name
+        )
+    | `Parent e -> pp fmt (e :> any)
 end
 
 (* Ugh. we need to determine whether this was down to an unexpanded module type error. This is horrendous. *)
@@ -154,6 +196,7 @@ let is_unexpanded_module_type_of =
     | `Parent_module_type p -> inner (p :> any)
     | `Parent_expr p -> inner (p :> any)
     | `Parent_module p -> inner (p :> any)
+    | `Parent_type p -> inner (p :> any)
     | `Fragment_root -> false
     | `OpaqueModule -> false
     | `UnresolvedForwardPath -> false
@@ -166,6 +209,9 @@ let is_unexpanded_module_type_of =
     | `Lookup_failureT _ -> false
     | `LocalType _ -> false
     | `Class_replaced -> false
+    | `OpaqueClass -> false
+    | `Reference (`Parent p) -> inner (p :> any)
+    | `Reference _ -> false
   in
   inner
 
@@ -231,7 +277,8 @@ type what =
   | `With_type of Cfrag.type_
   | `Module_type_expr of Component.ModuleType.expr
   | `Module_type_u_expr of Component.ModuleType.U.expr
-  | `Child of Reference.t ]
+  | `Child of Reference.t
+  | `Reference of Reference.t ]
 
 let report ~(what : what) ?tools_error action =
   let action =
@@ -277,6 +324,7 @@ let report ~(what : what) ?tools_error action =
     | `Module_type_u_expr cexpr ->
         r "module type u expression" u_module_type_expr cexpr
     | `Child rf -> r "child reference" model_reference rf
+    | `Reference ref -> r "reference" model_reference ref
   in
   match kind_of_error ~what tools_error with
   | Some (`Root name) -> Lookup_failures.report_root ~name

src/xref2/link.ml

@@ -132,26 +132,24 @@ let rec comment_inline_element :
   match x with
   | `Styled (s, ls) ->
       `Styled (s, List.map (with_location (comment_inline_element env)) ls)
-  | `Reference (r, []) -> (
-      (* Format.fprintf Format.err_formatter "XXXXXXXXXX about to resolve reference: %a\n%!" (Component.Fmt.model_reference) r; *)
+  | `Reference (r, content) as orig -> (
       match Ref_tools.resolve_reference env r with
-      | Some (`Identifier (#Id.Label.t as i) as r) ->
-          (* Format.fprintf Format.err_formatter "XXXXXXXXXX resolved reference: %a\n%!" (Component.Fmt.model_resolved_reference) r; *)
+      | Ok x ->
           let content =
-            match Env.lookup_section_title i env with Some x -> x | None -> []
+            (* In case of labels, use the heading text as reference text if
+               it's not specified. *)
+            match (content, x) with
+            | [], `Identifier (#Id.Label.t as i) -> (
+                match Env.lookup_section_title i env with
+                | Some x -> x
+                | None -> [])
+            | content, _ -> content
           in
-          `Reference (`Resolved r, content)
-      | Some x ->
-          (* Format.fprintf Format.err_formatter "XXXXXXXXXX resolved reference: %a\n%!" (Component.Fmt.model_resolved_reference) x; *)
-          `Reference (`Resolved x, [])
-      | None ->
-          (* Format.fprintf Format.err_formatter "XXXXXXXXXX FAILED to resolve reference: %a\n%!" (Component.Fmt.model_reference) r; *)
-          `Reference (r, []))
-  | `Reference (r, content) as orig -> (
-      (* Format.fprintf Format.err_formatter "XXXXXXXXXX about to resolve contentful reference: %a\n" (Component.Fmt.model_reference) r; *)
-      match Ref_tools.resolve_reference env r with
-      | Some x -> `Reference (`Resolved x, content)
-      | None -> orig)
+          `Reference (`Resolved x, content)
+      | Error e ->
+          Errors.report ~what:(`Reference r) ~tools_error:(`Reference e)
+            `Resolve;
+          orig)
   | y -> y
 
 and paragraph env elts =
@@ -178,14 +176,18 @@ and comment_nestable_block_element env parent
         List.map
           (fun (r : Comment.module_reference) ->
             match Ref_tools.resolve_module_reference env r.module_reference with
-            | Some (r, _, m) ->
+            | Ok (r, _, m) ->
                 let module_synopsis =
                   Opt.map
                     (resolve_external_synopsis env)
                     (synopsis_of_module env m)
                 in
                 { Comment.module_reference = `Resolved r; module_synopsis }
-            | None -> r)
+            | Error e ->
+                Errors.report
+                  ~what:(`Reference (r.module_reference :> Paths.Reference.t))
+                  ~tools_error:(`Reference e) `Resolve;
+                r)
           refs
       in
       `Modules refs
@@ -889,8 +891,8 @@ let page env page =
     List.fold_right
       (fun child res ->
         match Ref_tools.resolve_reference env child with
-        | Some r -> `Resolved r :: res
-        | None ->
+        | Ok r -> `Resolved r :: res
+        | Error _ ->
             Errors.report ~what:(`Child child) `Resolve;
             res)
       page.Odoc_model.Lang.Page.children []