Add semantic anchors for extension constructors

They get an entry in the `uid_to_loc` table, so we need to add them to the
`loc_to_ident` table as well for semantic anchor to work.

Signed-off-by: Paul-Elliot <[email protected]>

Author: panglesd

src/loader/ident_env.cppo.ml

@@ -63,8 +63,10 @@ type item = [
   | `Class of Ident.t * Ident.t * Ident.t * Ident.t option * bool * Warnings.loc option
   | `ClassType of Ident.t * Ident.t * Ident.t option * bool * Warnings.loc option
   | `Exception of Ident.t * Warnings.loc option
-  (* Exceptions are never hidden, but we need to add it to the [loc_to_ident]
-     table. *)
+  (* Exceptions needs to be added to the [loc_to_ident] table. *)
+  | `Extension of Ident.t * Warnings.loc option
+  (* Extension constructor also need to be added to the [loc_to_ident] table,
+     since they get an entry in the [uid_to_loc] table. *)
 ]
 
 type items =
@@ -315,6 +317,14 @@ let rec extract_structure_tree_items : bool -> Typedtree.structure_item list ->
        `Exception (tyexn_constructor.ext_id, Some tyexn_constructor.ext_loc) :: extract_structure_tree_items hide_item rest
 #endif
 
+#if OCAML_VERSION < (4,14,0)
+    | { str_desc = Tstr_typext _; _} :: rest -> extract_structure_tree_items hide_item rest
+#else
+  | { str_desc = Tstr_typext { tyext_constructors; _ }; _} :: rest ->
+    let x = List.map (fun { ext_id; ext_loc; _ } -> `Extension (ext_id, Some ext_loc)) tyext_constructors in
+    x @ extract_structure_tree_items hide_item rest
+#endif
+
 #if OCAML_VERSION < (4,3,0)
     | { str_desc = Tstr_value (_, vbs ); _} :: rest ->
 #else
@@ -387,8 +397,7 @@ let rec extract_structure_tree_items : bool -> Typedtree.structure_item list ->
 #endif
     | { str_desc = Tstr_primitive {val_id; _}; str_loc; _ } :: rest ->
       [`Value (val_id, false, Some str_loc)] @ extract_structure_tree_items hide_item rest
-    | { str_desc = Tstr_eval _; _} :: rest 
-    | { str_desc = Tstr_typext _; _} :: rest -> extract_structure_tree_items hide_item rest
+    | { str_desc = Tstr_eval _; _} :: rest -> extract_structure_tree_items hide_item rest
     | [] -> []
 
 
@@ -400,6 +409,7 @@ let flatten_extracted : items list -> item list = fun items ->
     | `Value _
     | `Class _
     | `Exception _
+    | `Extension _
     | `ClassType _ as x -> [x]
     | `Include xs -> xs) items |> List.flatten
 
@@ -443,6 +453,12 @@ let env_of_items : Id.Signature.t -> item list -> t -> t = fun parent items env
       (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
       inner rest env
 
+    | `Extension (t, loc) :: rest ->
+      let name = Ident.name t in
+      let identifier = Mk.extension(parent, ExtensionName.make_std name) in
+      (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
+      inner rest env
+
     | `Value (t, is_hidden_item, loc) :: rest ->
       let name = Ident.name t in
       let is_hidden = is_hidden_item || value_name_exists name rest in

src/loader/ident_env.cppo.mli

@@ -26,6 +26,7 @@ type item =
   | `Class of
     Ident.t * Ident.t * Ident.t * Ident.t option * bool * Warnings.loc option
   | `Exception of Ident.t * Warnings.loc option
+  | `Extension of Ident.t * Warnings.loc option
   | `ClassType of
     Ident.t * Ident.t * Ident.t option * bool * Warnings.loc option ]
 

test/sources/lookup_def.t/run.t

@@ -22,6 +22,6 @@ Show the locations:
   [{"`Value":[{"`Root":["None","A"]},"a"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"value-a"]}}]
   [{"`Exception":[{"`Root":["None","A"]},"Exn"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"exception-Exn"]}}]
   [{"`Type":[{"`Root":["None","A"]},"ext"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"type-ext"]}}]
-  [{"`Extension":[{"`Root":["None","A"]},"Ext"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"def_11"]}}]
+  [{"`Extension":[{"`Root":["None","A"]},"Ext"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"extension-Ext"]}}]
   [{"`Class":[{"`Root":["None","A"]},"cls"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"class-cls"]}}]
   [{"`ClassType":[{"`Root":["None","A"]},"clst"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"class_type-clst"]}}]

test/sources/source.t/a.ml

@@ -1,5 +1,7 @@
 type t = string
 
+type truc = A | B
+
 let x = 2
 let y = x + 1
 let z a = if x = 1 || true then x + y else 0
@@ -11,7 +13,7 @@ module type T = sig end
 module type U = T
 
 type ext = ..
-type ext += Foo
+type ext += Foo | Bar
 
 exception Exn
 

test/sources/source.t/run.t

@@ -3,6 +3,8 @@ Files containing some values:
   $ cat a.ml
   type t = string
 
+  type truc = A | B
+  
   let x = 2
   let y = x + 1
   let z a = if x = 1 || true then x + y else 0
@@ -14,7 +16,7 @@ Files containing some values:
   module type U = T
 
   type ext = ..
-  type ext += Foo
+  type ext += Foo | Bar
 
   exception Exn
 
@@ -67,6 +69,10 @@ Source links generated in the documentation:
       <div class="spec type anchored" id="type-t">
        <a href="#type-t" class="anchor"></a>
        <a href="../root/source/a.ml.html#type-t" class="source_link">Source</a>
+  --
+      <div class="spec type anchored" id="type-truc">
+       <a href="#type-truc" class="anchor"></a>
+       <a href="../root/source/a.ml.html#type-truc" class="source_link">Source
   --
       <div class="spec value anchored" id="val-y">
        <a href="#val-y" class="anchor"></a>
@@ -98,7 +104,7 @@ Source links generated in the documentation:
   --
       <div class="spec type extension anchored" id="extension-decl-Foo">
        <a href="#extension-decl-Foo" class="anchor"></a>
-       <a href="../root/source/a.ml.html#def_10" class="source_link">Source</a>
+       <a href="../root/source/a.ml.html#extension-Foo" class="source_link">
   --
       <div class="spec exception anchored" id="exception-Exn">
        <a href="#exception-Exn" class="anchor"></a>
@@ -146,23 +152,23 @@ Ids generated in the source code:
   id="L21"
   id="L22"
   id="L23"
+  id="L24"
+  id="L25"
   id="type-t"
+  id="type-truc"
   id="value-{x}2"
   id="value-y"
   id="value-z"
-  id="local_a_47"
+  id="local_a_66"
   id="module-A"
   id="module-B"
   id="module_type-T"
   id="module_type-U"
   id="type-ext"
-  id="def_10"
+  id="extension-Foo"
+  id="extension-Bar"
   id="exception-Exn"
   id="class-cls"
   id="class-cls'"
   id="class_type-ct"
   id="value-x"
-
-  $ firefox html/root/source/a.ml.html
-  Gtk-Message: 12:16:26.688: Failed to load module "xapp-gtk3-module"
-  Gtk-Message: 12:16:26.689: Not loading module "atk-bridge": The functionality is provided by GTK natively. Please try to not load it.