do not look for class when resolving a fragment_type_parent

This changes the error message, from "wrong type", to unresolved.

Signed-off-by: Paul-Elliot <peada@free.fr>

Author: panglesd

src/model/paths_types.ml

@@ -500,8 +500,7 @@ module rec Reference : sig
 
   type tag_datatype = [ `TUnknown | `TType ]
 
-  type tag_parent =
-    [ `TUnknown | `TModule | `TModuleType | `TClass | `TClassType | `TType ]
+  type tag_parent = [ `TUnknown | `TModule | `TModuleType | `TType ]
 
   type tag_label_parent =
     [ `TUnknown

src/xref2/component.ml

@@ -519,6 +519,8 @@ module Element = struct
 
   type label_parent = [ signature | type_ | page ]
 
+  type fragment_type_parent = [ signature | datatype ]
+
   type any =
     [ signature
     | value

src/xref2/component.mli

@@ -487,6 +487,8 @@ module Element : sig
 
   type label_parent = [ signature | type_ | page ]
 
+  type fragment_type_parent = [ signature | datatype ]
+
   type any =
     [ signature
     | value

src/xref2/env.ml

@@ -593,6 +593,11 @@ let s_label_parent : Component.Element.label_parent scope =
     | #Component.Element.label_parent as r -> Some r
     | _ -> None)
 
+let s_fragment_type_parent : Component.Element.fragment_type_parent scope =
+  make_scope ~root:lookup_root_module_fallback (function
+    | #Component.Element.fragment_type_parent as r -> Some r
+    | _ -> None)
+
 let len = ref 0
 
 let n = ref 0

src/xref2/env.mli

@@ -148,6 +148,8 @@ val s_field : Component.Element.field scope
 
 val s_label_parent : Component.Element.label_parent scope
 
+val s_fragment_type_parent : Component.Element.fragment_type_parent scope
+
 (* val open_component_signature :
    Paths_types.Identifier.signature -> Component.Signature.t -> t -> t *)
 

src/xref2/ref_tools.ml

@@ -30,6 +30,9 @@ type label_parent_lookup_result =
   | type_lookup_result
   | `P of page_lookup_result ]
 
+type fragment_type_parent_lookup_result =
+  [ `S of signature_lookup_result | `T of datatype_lookup_result ]
+
 type 'a ref_result =
   ('a, Errors.Tools_error.reference_lookup_error) Result.result
 (** The result type for every functions in this module. *)
@@ -277,6 +280,16 @@ module DT = struct
   let of_component _env t ~parent_ref name = Ok (`Type (parent_ref, name), t)
 
   let of_element _env (`Type (id, t)) : t = (`Identifier id, t)
+
+  let in_env env name =
+    env_lookup_by_name Env.s_datatype name env >>= fun e ->
+    Ok (of_element env e)
+
+  let in_signature _env ((parent', parent_cp, sg) : signature_lookup_result)
+      name =
+    let sg = Tools.prefix_signature (parent_cp, sg) in
+    find Find.datatype_in_sig sg name >>= function
+    | `FType (name, t) -> Ok (`T (`Type (parent', name), t))
 end
 
 module T = struct
@@ -396,6 +409,24 @@ module EX = struct
     Ok (`Exception (parent', name))
 end
 
+module FTP = struct
+  (** Fragment type parent *)
+
+  type t = fragment_type_parent_lookup_result
+
+  let of_element env : _ -> t ref_result = function
+    | `Module _ as e ->
+        M.of_element env e |> module_lookup_to_signature_lookup env >>= fun r ->
+        Ok (`S r)
+    | `ModuleType _ as e ->
+        MT.of_element env e |> module_type_lookup_to_signature_lookup env
+        >>= fun r -> Ok (`S r)
+    | `Type _ as e -> Ok (`T (DT.of_element env e))
+
+  let in_env env name =
+    env_lookup_by_name Env.s_fragment_type_parent name env >>= of_element env
+end
+
 module CS = struct
   (** Constructor *)
 
@@ -409,7 +440,7 @@ module CS = struct
     (* Let's pretend we didn't see the field and say we didn't find anything. *)
     Error (`Find_by_name (`Cons, name))
 
-  let in_parent _env (parent : label_parent_lookup_result) name =
+  let in_parent _env (parent : fragment_type_parent_lookup_result) name =
     let name_s = ConstructorName.to_string name in
     match parent with
     | `S (parent', parent_cp, sg) -> (
@@ -423,7 +454,6 @@ module CS = struct
         | `FField _ -> got_a_field name_s
         | `FConstructor _ ->
             Ok (`Constructor ((parent' : Resolved.DataType.t), name)))
-    | (`C _ | `CT _ | `P _) as r -> wrong_kind_error [ `S; `T ] r
 
   let of_component _env parent name =
     Ok
@@ -444,7 +474,7 @@ module F = struct
     (* Let's pretend we didn't see the constructor and say we didn't find anything. *)
     Error (`Find_by_name (`Field, name))
 
-  let in_parent _env (parent : label_parent_lookup_result) name =
+  let in_parent _env (parent : fragment_type_parent_lookup_result) name =
     let name_s = FieldName.to_string name in
     match parent with
     | `S (parent', parent_cp, sg) -> (
@@ -459,7 +489,6 @@ module F = struct
         find Find.any_in_type t name_s >>= function
         | `FConstructor _ -> got_a_constructor name_s
         | `FField _ -> Ok (`Field ((parent' :> Resolved.FieldParent.t), name)))
-    | (`C _ | `CT _ | `P _) as r -> wrong_kind_error [ `S; `T ] r
 
   let of_component _env parent name =
     Ok
@@ -591,6 +620,27 @@ let rec resolve_label_parent_reference env r =
       resolve_signature_reference env (`Root (name, `TModule)) >>= fun s ->
       Ok (`S s)
 
+and resolve_fragment_type_parent_reference (env : Env.t)
+    (r : FragmentTypeParent.t) : (fragment_type_parent_lookup_result, _) result
+    =
+  let fragment_type_parent_res_of_type_res : datatype_lookup_result -> _ =
+   fun r -> Ok (`T r)
+  in
+  match r with
+  | `Resolved _ -> failwith "unimplemented"
+  | `Root (name, `TUnknown) -> FTP.in_env env name
+  | (`Module _ | `ModuleType _ | `Root (_, (`TModule | `TModuleType))) as sr ->
+      resolve_signature_reference env sr >>= fun s -> Ok (`S s)
+  | `Root (name, `TType) ->
+      DT.in_env env name >>= fragment_type_parent_res_of_type_res
+  | `Type (parent, name) ->
+      resolve_signature_reference env parent >>= fun p ->
+      DT.in_signature env p (TypeName.to_string name)
+  | `Dot (parent, name) ->
+      resolve_label_parent_reference env parent
+      >>= signature_lookup_result_of_label_parent
+      >>= fun p -> DT.in_signature env p name
+
 and resolve_signature_reference :
     Env.t -> Signature.t -> signature_lookup_result ref_result =
  fun env' r ->
@@ -778,9 +828,8 @@ let resolve_reference =
     | `Dot (parent, name) -> resolve_reference_dot env parent name
     | `Root (name, `TConstructor) -> CS.in_env env name >>= resolved1
     | `Constructor (parent, name) ->
-        resolve_label_parent_reference env
-          (parent : FragmentTypeParent.t :> LabelParent.t)
-        >>= fun p -> CS.in_parent env p name >>= resolved1
+        resolve_fragment_type_parent_reference env parent >>= fun p ->
+        CS.in_parent env p name >>= resolved1
     | `Root (name, `TException) -> EX.in_env env name >>= resolved1
     | `Exception (parent, name) ->
         resolve_signature_reference env parent >>= fun p ->
@@ -791,9 +840,8 @@ let resolve_reference =
         EC.in_signature env p name >>= resolved1
     | `Root (name, `TField) -> F.in_env env name >>= resolved1
     | `Field (parent, name) ->
-        resolve_label_parent_reference env
-          (parent : FragmentTypeParent.t :> LabelParent.t)
-        >>= fun p -> F.in_parent env p name >>= resolved1
+        resolve_fragment_type_parent_reference env parent >>= fun p ->
+        F.in_parent env p name >>= resolved1
     | `Root (name, `TMethod) -> MM.in_env env name >>= resolved1
     | `Method (parent, name) ->
         resolve_class_signature_reference env parent >>= fun p ->

test/xref2/github_issue_447.t/run.t

@@ -10,7 +10,7 @@ faulty reference.
 
   $ odoc link a.odoc
   File "a.mli", line 15, characters 4-22:
-  Warning: Failed to resolve reference unresolvedroot(t).A is of kind class but expected signature or type
+  Warning: Failed to resolve reference unresolvedroot(t).A Couldn't find "t"
 
 Let's now check that the reference point to the right page/anchor: