Merge pull request #1785 from voodoos/at-origin-occurrences

At origin occurrences

CHANGES.md

@@ -18,6 +18,8 @@ UNRELEASED
       interface file (#1781)
     - Reset uid counters when restoring the typer cache so that uids are stable
       across re-typing (#1779)
+    - Improve the behavior on occurrences when the cursor is on a label /
+      constructor declaration (#1785)
   + editor modes
     - emacs: add basic support for project-wide occurrences (#1766)
     - vim: add basic support for project-wide occurrences (#1767, @Julow)

src/analysis/context.ml

@@ -153,7 +153,9 @@ let inspect_browse_tree ~cursor lid browse : t option =
     | Type_declaration _
     | Extension_constructor _
     | Module_binding_name _
-    | Module_declaration_name _ ->
+    | Module_declaration_name _
+    | Label_declaration _
+    | Constructor_declaration _ ->
       None
     | Module_expr _
     | Open_description _ -> Some Module_path

src/analysis/occurrences.ml

@@ -53,10 +53,10 @@ let uid_and_loc_of_node env node =
       Some (uid, name.loc)
   | Type_declaration { typ_type; typ_name; _ } ->
       Some (typ_type.type_uid, typ_name.loc)
-  | Label_declaration { ld_uid; ld_loc ; _ } ->
-      Some (ld_uid, ld_loc)
-  | Constructor_declaration { cd_uid; cd_loc ; _ } ->
-      Some (cd_uid, cd_loc)
+  | Label_declaration { ld_uid; ld_name ; _ } ->
+      Some (ld_uid, ld_name.loc)
+  | Constructor_declaration { cd_uid; cd_name ; _ } ->
+      Some (cd_uid, cd_name.loc)
   | Value_description { val_val; val_name; _ } ->
       Some (val_val.val_uid, val_name.loc)
   | _ -> None

tests/test-dirs/locate/context-detection/cd-test.t/run.t

@@ -39,18 +39,12 @@ Trying them all:
     "notifications": []
   }
 
-FIXME this should say "Already at definition point" (we're defining the label):
+This should say "Already at definition point" (we're defining the label):
 
   $ $MERLIN single locate -look-for ml -position 13:12 -filename ./test.ml < ./test.ml
   {
     "class": "return",
-    "value": {
-      "file": "$TESTCASE_ROOT/test.ml",
-      "pos": {
-        "line": 5,
-        "col": 4
-      }
-    },
+    "value": "Already at definition point",
     "notifications": []
   }
 

tests/test-dirs/occurrences/from-origin.t

@@ -0,0 +1,54 @@
+  $ cat >test.ml <<'EOF'
+  > type t = {
+  >   label_a : int
+  > }
+  > 
+  > let v = { label_a = 42 }
+  > let () = print_int v.label_a 
+  > EOF
+
+When cursor on the usage, all occurrences are highlighted
+  $ $MERLIN single occurrences -identifier-at 6:25 -filename test.ml <test.ml | 
+  > jq '.value[].start.line'
+  2
+  5
+  6
+
+When cursor on the definition, occurrences are not highlighted
+  $ $MERLIN single occurrences -identifier-at 2:5 -filename test.ml <test.ml |
+  > jq '.value[].start.line'
+  2
+  5
+  6
+
+Same test for constructors:
+  $ cat >test.ml <<'EOF'
+  > type t = Constr_a of int | No_param
+  > 
+  > let _ = Constr_a 42 
+  > let _ = No_param 
+  > EOF
+
+When cursor on the usage, all occurrences are highlighted
+  $ $MERLIN single occurrences -identifier-at 4:10 -filename test.ml <test.ml | 
+  > jq '.value[].start.line'
+  1
+  4
+
+When cursor on the definition, occurrences are not highlighted
+  $ $MERLIN single occurrences -identifier-at 1:30 -filename test.ml <test.ml |
+  > jq '.value[].start.line'
+  1
+  4
+
+When cursor on the usage, all occurrences are highlighted
+  $ $MERLIN single occurrences -identifier-at 3:10 -filename test.ml <test.ml | 
+  > jq '.value[].start.line'
+  1
+  3
+
+When cursor on the definition, occurrences are not highlighted
+  $ $MERLIN single occurrences -identifier-at 1:10 -filename test.ml <test.ml |
+  > jq '.value[].start.line'
+  1
+  3