[B] Fix occurrences of extension constructors (ocaml#1662)

from voodoos/fix-occurrences-ext-constr

CHANGES.md

@@ -13,6 +13,7 @@ unreleased
     - Support parsing negative numbers in sexps (#1655)
     - Fix construct not working with inline records (#1658)
     - Improve behavior of `type-enclosing` on let/and operators (#1653)
+    - Fix occurrences of extension constructors (#1662)
   + editor modes
     - emacs: call merlin-client-logger with "interrupted" if the
       merlin binary itself is interrupted, not just the parsing of the

src/analysis/browse_tree.ml

@@ -70,12 +70,13 @@ and normalize_type_decl env decl = match decl.Types.type_manifest with
   | Some expr -> normalize_type_expr env expr
   | None -> decl
 
-let id_of_constr_decl c = c.Types.cd_id
+let id_of_constr_decl c = `Id c.Types.cd_id
 
 let same_constructor env a b =
   let name = function
     | `Description d -> d.Types.cstr_name
     | `Declaration d -> Ident.name d.Typedtree.cd_id
+    | `Extension_constructor ec -> Ident.name ec.Typedtree.ext_id
   in
   if name a <> name b then false
   else begin
@@ -85,14 +86,24 @@ let same_constructor env a b =
         begin match ty.Types.type_kind with
         | Types.Type_variant (decls, _) ->
           List.map decls ~f:id_of_constr_decl
+        | Type_open ->
+          [`Uid d.cstr_uid]
         | _ -> assert false
         end
       | `Declaration d ->
-        [d.Typedtree.cd_id]
+        [`Id d.Typedtree.cd_id]
+      | `Extension_constructor ext_cons ->
+        let des = Env.find_ident_constructor ext_cons.Typedtree.ext_id env in
+        [`Uid des.cstr_uid]
     in
     let a = get_decls a in
     let b = get_decls b in
-    List.exists a ~f:(fun id -> List.exists b ~f:(Ident.same id))
+    let same a b = match a, b with
+      | `Id a, `Id b -> Ident.same a b
+      | `Uid a, `Uid b -> Shape.Uid.equal a b
+      | _, _ -> false
+    in
+    List.exists a ~f:(fun id -> List.exists b ~f:(same id))
   end
 
 let all_occurrences path =

src/analysis/browse_tree.mli

@@ -48,7 +48,8 @@ val dummy : t
 val all_occurrences : Path.t -> t -> (t * Path.t Location.loc list) list
 val all_constructor_occurrences :
   t * [ `Description of Types.constructor_description
-      | `Declaration of Typedtree.constructor_declaration ]
+      | `Declaration of Typedtree.constructor_declaration
+      | `Extension_constructor of Typedtree.extension_constructor ]
   -> t -> t Location.loc list
 
 val all_occurrences_of_prefix :

src/ocaml/merlin_specific/browse_raw.ml

@@ -933,6 +933,9 @@ let node_is_constructor = function
     Some {loc with Location.txt = `Description desc}
   | Pattern {pat_desc = Tpat_construct (loc, desc, _, _)} ->
     Some {loc with Location.txt = `Description desc}
+  | Extension_constructor ext_cons ->
+    Some { Location.loc = ext_cons.ext_loc;
+           txt = `Extension_constructor ext_cons}
   | _ -> None
 
 let node_of_binary_part env part =

src/ocaml/merlin_specific/browse_raw.mli

@@ -116,7 +116,9 @@ val node_paths_and_longident : node -> (Path.t Location.loc * Longident.t) list
 
 val node_is_constructor : node ->
   [ `Description of Types.constructor_description
-  | `Declaration of Typedtree.constructor_declaration ] Location.loc option
+  | `Declaration of Typedtree.constructor_declaration
+  | `Extension_constructor of Typedtree.extension_constructor ]
+    Location.loc option
 
 val node_of_binary_part : Env.t -> Cmt_format.binary_part -> node
 

tests/test-dirs/occurrences/ext-variant.t

@@ -0,0 +1,73 @@
+See issue #1185 on vscode-ocaml-platform
+
+  $ cat >main.ml <<EOF
+  > (*type t = ..*)
+  > type t  = A
+  > 
+  > let foo (x : t) = match x with
+  > | A -> 1
+  > | _ -> 0
+  > EOF
+
+  $ $MERLIN single occurrences -identifier-at 5:2 \
+  > -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 10
+      },
+      "end": {
+        "line": 2,
+        "col": 11
+      }
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 2
+      },
+      "end": {
+        "line": 5,
+        "col": 3
+      }
+    }
+  ]
+
+
+  $ cat >main.ml <<EOF
+  > type t = ..
+  > type t += A
+  > 
+  > let foo (x : t) = match x with
+  > | A -> 1
+  > | _ -> 0
+  > EOF
+
+FIXME: we can do better than that
+  $ $MERLIN single occurrences -identifier-at 5:2 \
+  > -log-file - -log-section occurrences \
+  > -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 10
+      },
+      "end": {
+        "line": 2,
+        "col": 11
+      }
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 2
+      },
+      "end": {
+        "line": 5,
+        "col": 3
+      }
+    }
+  ]
+