oxcaml · liam923 · Oct 24, 2024 · Oct 16, 2024 · Oct 16, 2024 · Oct 17, 2024
diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml
@@ -162,6 +162,8 @@ let iter_on_usages ~f (local_defs : Mtyper.typedtree) =
     | `Implementation structure -> iter.structure iter structure
   end
 
-let iterator_on_usages ~f =
+let iterator_on_usages ~include_hidden ~f =
   let occ_iter = Cmt_format.iter_on_occurrences ~f in
-  iter_only_visible occ_iter
+  match include_hidden with
+  | false -> iter_only_visible occ_iter
+  | true -> occ_iter
diff --git a/src/analysis/index_occurrences.ml b/src/analysis/index_occurrences.ml
@@ -25,11 +25,23 @@ let decl_of_path_or_lid env namespace path lid =
   end
   | _ -> Env_lookup.by_path path namespace env
 
+let should_ignore_lid (lid : Longident.t Location.loc) =
+  (* Ignore occurrence if the location of the identifier is "none" because there is not a
+     useful location to report to the user. This can occur when the occurrence is in ppx
+     generated code and the ppx does not give location information.
+
+     An alternative implementation could instead ignore the occurrence if the location is
+     marked as "ghost". However, this seems too aggressive for two reasons:
+      - The expression being bound in a punned let expression is marked as ghost
+      - Ppx-generated code is often "ghost", but occurrences within ppx-generated code may
+        be useful
+  *)
+  Location.is_none lid.loc
+
 let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid =
   let add uid loc = Stamped_hashtable.add index ~stamp (uid, loc) () in
   let f ~namespace env path (lid : Longident.t Location.loc) =
     log ~title:"index_buffer" "Path: %a" Logger.fmt (Fun.flip Path.print path);
-    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
     let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in
     let index_decl () =
       begin
@@ -42,7 +54,7 @@ let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid =
           add decl.uid lid
       end
     in
-    if not_ghost lid then
+    if not (should_ignore_lid lid) then
       match Env.shape_of_path ~namespace env path with
       | exception Not_found -> ()
       | path_shape ->
@@ -69,7 +81,7 @@ let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid =
             index_decl ()
         end
   in
-  Ast_iterators.iterator_on_usages ~f
+  Ast_iterators.iterator_on_usages ~include_hidden:true ~f
 
 let items ~index ~stamp (config : Mconfig.t) items =
   let module Shape_reduce = Shape_reduce.Make (struct

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
@@ -15,6 +15,17 @@ let set_fname ~file (loc : Location.t) =
     loc_end = { loc.loc_end with pos_fname }
   }
 
+(* Merlin-jst: Upstream Merlin only includes the location of the last segment of an
+   identifier. (ex: If the user wrote "Foo.bar", only the location of "bar") is included.
+   We instead choose to include the entire "Foo.bar", for two reasons:
+   1. We think that this is a slightly better user experience
+   2. Upstream Merlin does not include occurrences within ppx generated code, but we do.
+      Because of this, it is not always true for us that the reported location in the
+      buffer is text corresponding to the identifier. (For example, the location may
+      correspond to a ppx extension node.) In such a case, attempting to modify the
+      location to only include the last segment of the identifier is nonsensical. Since we
+      don't have a way to detect such a case, it forces us to not try. *)
+(*
 (* A longident can have the form: A.B.x Right now we are only interested in
    values, but we will eventually want to index all occurrences of modules in
    such longidents. However there is an issue with that: we only have the
@@ -39,6 +50,7 @@ let last_loc (loc : Location.t) lid =
           { loc.loc_end with pos_cnum = loc.loc_end.pos_cnum - last_size }
       }
     else loc
+*)
 
 let uid_and_loc_of_node env node =
   let open Browse_raw in
@@ -200,18 +212,25 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
             Option.map external_locs ~f:(fun (index, locs) ->
                 let stats = Stat_check.create ~cache_size:128 index in
                 ( Lid_set.filter
-                    (fun { loc; _ } ->
-                      (* We ignore external results that concern the current buffer *)
-                      let file = loc.Location.loc_start.Lexing.pos_fname in
-                      let file, buf =
-                        match config.merlin.source_root with
-                        | Some root ->
-                          (Filename.concat root file, current_buffer_path)
-                        | None -> (file, config.query.filename)
+                    (fun ({ loc; _ } as lid) ->
+                      let is_current_buffer =
+                        (* We filter external results that concern the current buffer *)
+                        let file = loc.Location.loc_start.Lexing.pos_fname in
+                        let file, buf =
+                          match config.merlin.source_root with
+                          | Some root ->
+                            (Filename.concat root file, current_buffer_path)
+                          | None -> (file, config.query.filename)
+                        in
+                        let file = Misc.canonicalize_filename file in
+                        let buf = Misc.canonicalize_filename buf in
+                        String.equal file buf
                       in
-                      let file = Misc.canonicalize_filename file in
-                      let buf = Misc.canonicalize_filename buf in
-                      if String.equal file buf then false
+                      let should_be_ignored =
+                        (* We ignore results that don't have a location *)
+                        Index_occurrences.should_ignore_lid lid
+                      in
+                      if is_current_buffer || should_be_ignored then false
                       else begin
                         (* We ignore external results if their source was modified *)
                         let check = Stat_check.check stats ~file in
@@ -249,7 +268,9 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
              let lid = try Longident.head txt with _ -> "not flat lid" in
              log ~title:"occurrences" "Found occ: %s %a" lid Logger.fmt
                (Fun.flip Location.print_loc loc);
-             let loc = last_loc loc txt in
+             (* Merlin-jst: See comment at the commented-out definition of last_loc for
+                explanation of why this is commented out. *)
+             (* let loc = last_loc loc txt in *)
              let fname = loc.Location.loc_start.Lexing.pos_fname in
              if not (Filename.is_relative fname) then Some loc
              else

diff --git a/tests/test-dirs/let-punning.t/run.t b/tests/test-dirs/let-punning.t/run.t
@@ -248,8 +248,6 @@ Test that finding occurrences of a variable includes usages in a punned let. i.e
 finding occurrences of x on line 1 returns the definition on line 1 and the usage on
 line 2.
 
-TODO: fix these tests
-
 let*
   $ occurrences 12:8
   Occurrences of:
@@ -258,6 +256,9 @@ let*
   Occurrence at 12:8-9:
       let a = return 1 in
           ^
+  Occurrence at 13:9-10:
+      let* a in
+           ^
 
 parallel let*
   $ occurrences 18:8
@@ -267,13 +268,19 @@ parallel let*
   Occurrence at 18:8-9:
       let a = return 1 in
           ^
+  Occurrence at 20:9-10:
+      let* a and* b in
+           ^
   $ occurrences 19:8
   Occurrences of:
       let b = return 1 in
           ^
   Occurrence at 19:8-9:
       let b = return 1 in
           ^
+  Occurrence at 20:16-17:
+      let* a and* b in
+                  ^
 
 sequential let*
   $ occurrences 25:8
@@ -283,10 +290,16 @@ sequential let*
   Occurrence at 25:8-9:
       let a = return 1 in
           ^
+  Occurrence at 27:9-10:
+      let* a in
+           ^
   $ occurrences 26:8
   Occurrences of:
       let b = return 1 in
           ^
   Occurrence at 26:8-9:
       let b = return 1 in
           ^
+  Occurrence at 28:9-10:
+      let* b in
+           ^
diff --git a/tests/test-dirs/occurrences/issue827.t/run.t b/tests/test-dirs/occurrences/issue827.t/run.t
@@ -17,7 +17,7 @@ Reproduction case:
       {
         "start": {
           "line": 4,
-          "col": 10
+          "col": 8
         },
         "end": {
           "line": 4,
@@ -76,7 +76,7 @@ work:
       {
         "start": {
           "line": 4,
-          "col": 10
+          "col": 8
         },
         "end": {
           "line": 4,

diff --git a/tests/test-dirs/occurrences/lid-locs.t b/tests/test-dirs/occurrences/lid-locs.t
@@ -30,7 +30,7 @@ The parenthesis are typed as an open statement
       {
         "start": {
           "line": 4,
-          "col": 10
+          "col": 8
         },
         "end": {
           "line": 4,
@@ -40,7 +40,7 @@ The parenthesis are typed as an open statement
       {
         "start": {
           "line": 5,
-          "col": 11
+          "col": 8
         },
         "end": {
           "line": 5,
@@ -69,8 +69,8 @@ The parenthesis are typed as an open statement
       },
       {
         "start": {
-          "line": 9,
-          "col": 2
+          "line": 8,
+          "col": 8
         },
         "end": {
           "line": 9,

diff --git a/tests/test-dirs/occurrences/mod-in-path-2.t b/tests/test-dirs/occurrences/mod-in-path-2.t
@@ -39,7 +39,7 @@ FIXME: we could expect module appearing in paths to be highlighted
     {
       "start": {
         "line": 5,
-        "col": 12
+        "col": 8
       },
       "end": {
         "line": 5,
@@ -49,7 +49,7 @@ FIXME: we could expect module appearing in paths to be highlighted
     {
       "start": {
         "line": 6,
-        "col": 8
+        "col": 4
       },
       "end": {
         "line": 6,

diff --git a/tests/test-dirs/occurrences/mod-in-path-3.t b/tests/test-dirs/occurrences/mod-in-path-3.t
@@ -40,7 +40,7 @@ FIXME: we could expect module appearing in paths to be highlighted
     {
       "start": {
         "line": 4,
-        "col": 12
+        "col": 8
       },
       "end": {
         "line": 4,
@@ -50,7 +50,7 @@ FIXME: we could expect module appearing in paths to be highlighted
     {
       "start": {
         "line": 7,
-        "col": 8
+        "col": 4
       },
       "end": {
         "line": 7,

diff --git a/tests/test-dirs/occurrences/project-wide/prefix.t/run.t b/tests/test-dirs/occurrences/project-wide/prefix.t/run.t
@@ -98,7 +98,7 @@ Merlin successfully finds occurrences outside file when UNIT_NAME directive is u
         "file": "$TESTCASE_ROOT/a.ml",
         "start": {
           "line": 1,
-          "col": 12
+          "col": 10
         },
         "end": {
           "line": 1,
@@ -109,7 +109,7 @@ Merlin successfully finds occurrences outside file when UNIT_NAME directive is u
         "file": "$TESTCASE_ROOT/a.ml",
         "start": {
           "line": 2,
-          "col": 18
+          "col": 16
         },
         "end": {
           "line": 2,
@@ -157,7 +157,7 @@ Merlin successfully finds occurrences outside file when WRAPPING_PREFIX directiv
         "file": "$TESTCASE_ROOT/a.ml",
         "start": {
           "line": 1,
-          "col": 12
+          "col": 10
         },
         "end": {
           "line": 1,
@@ -168,7 +168,7 @@ Merlin successfully finds occurrences outside file when WRAPPING_PREFIX directiv
         "file": "$TESTCASE_ROOT/a.ml",
         "start": {
           "line": 2,
-          "col": 18
+          "col": 16
         },
         "end": {
           "line": 2,

diff --git a/tests/test-dirs/occurrences/project-wide/punning.t/definitions.ml b/tests/test-dirs/occurrences/project-wide/punning.t/definitions.ml
@@ -0,0 +1,4 @@
+let a = Some 1
+
+type t = { value : string }
+let value = "hello"
diff --git a/tests/test-dirs/occurrences/project-wide/punning.t/run.t b/tests/test-dirs/occurrences/project-wide/punning.t/run.t
@@ -0,0 +1,48 @@
+Test project-wide occurrences in the presence of punning (both let and record punning)
+
+Compile project, create index file, and configure Merlin to use index file
+  $ $OCAMLC -bin-annot -bin-annot-occurrences -c definitions.ml usages.ml
+  $ ocaml-index aggregate definitions.cmt usages.cmt
+  $ cat > .merlin << EOF
+  > INDEX project.ocaml-index
+  > EOF
+
+Convenience function for querying occurrences
+  $ occurrences () {
+  >   file="$1"
+  >   location="$2"
+  >   $MERLIN single occurrences -scope project -identifier-at "$location" -filename "$file" < "$file" | \
+  >     jq -r '.value[] | "\(.file) \(.start.line):\(.start.col)-\(.end.col)"'
+  > }
+
+Get occurrences of an identifier that is used as the expression part of a punned let
+expression
+FIXME: this should also include the occurrence on line 6 of usages.ml
+  $ occurrences definitions.ml 1:4
+  $TESTCASE_ROOT/definitions.ml 1:4-5
+
+Get occurrences, with the cursor pointing at the identifier in a punned let.
+Merlin returns the occurrences of the new variable bound in that let, rather than the
+expression being assigned to the variable.
+  $ occurrences usages.ml 6:7
+  $TESTCASE_ROOT/usages.ml 6:7-8
+  $TESTCASE_ROOT/usages.ml 7:7-8
+
+Get occurrences of a record field, where there is an instance of punning that field while
+creating a record
+  $ occurrences definitions.ml 3:13
+  $TESTCASE_ROOT/definitions.ml 3:11-16
+  $TESTCASE_ROOT/usages.ml 10:10-15
+
+Get occurrences of a variable that is used as the value being placed into a record in a
+punned record field expression
+  $ occurrences definitions.ml 4:6
+  $TESTCASE_ROOT/definitions.ml 4:4-9
+  $TESTCASE_ROOT/usages.ml 10:10-15
+
+Get occurrences, with the cursor pointing at a punned record field expression.
+Merlin finds occurrences of the value being placed into the record rather than the record
+field
+  $ occurrences usages.ml 10:12
+  $TESTCASE_ROOT/definitions.ml 4:4-9
+  $TESTCASE_ROOT/usages.ml 10:10-15
diff --git a/tests/test-dirs/occurrences/project-wide/punning.t/usages.ml b/tests/test-dirs/occurrences/project-wide/punning.t/usages.ml
@@ -0,0 +1,10 @@
+include Definitions
+
+(* Let punning *)
+let _ =
+  let (let*) = Option.bind in
+  let* a in
+  Some a
+
+(* Record field punning *)
+let _ = { value }
diff --git a/tests/test-dirs/occurrences/project-wide/pwo-basic.t b/tests/test-dirs/occurrences/project-wide/pwo-basic.t
@@ -53,7 +53,7 @@
         "file": "$TESTCASE_ROOT/main.ml",
         "start": {
           "line": 1,
-          "col": 26
+          "col": 22
         },
         "end": {
           "line": 1,

diff --git a/tests/test-dirs/occurrences/project-wide/pwo-canonicalize.t b/tests/test-dirs/occurrences/project-wide/pwo-canonicalize.t
@@ -44,7 +44,7 @@
       "file": "$TESTCASE_ROOT/main.ml",
       "start": {
         "line": 1,
-        "col": 26
+        "col": 22
       },
       "end": {
         "line": 1,