Let pun occurrences test

src/analysis/index_occurrences.ml

@@ -25,11 +25,13 @@ 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) =
+  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 +44,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 ->

src/analysis/occurrences.ml

@@ -200,18 +200,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

src/ocaml/typing/cmt_format.ml

@@ -391,14 +391,12 @@ let index_occurrences binary_annots =
     ref []
   in
   let f ~namespace env path lid =
-    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
-    if not_ghost lid then
-      match Env.shape_of_path ~namespace env path with
-      | exception Not_found -> ()
-      | { uid = Some (Predef _); _ } -> ()
-      | path_shape ->
-        let result = Shape_reduce.local_reduce_for_uid env path_shape in
-        index := (lid, result) :: !index
+    match Env.shape_of_path ~namespace env path with
+    | exception Not_found -> ()
+    | { uid = Some (Predef _); _ } -> ()
+    | path_shape ->
+      let result = Shape_reduce.local_reduce_for_uid env path_shape in
+      index := (lid, result) :: !index
   in
   iter_on_annots (iter_on_occurrences ~f) binary_annots;
   Array.of_list !index

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
+           ^

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"

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
+  $ occurrences definitions.ml 1:4
+  $TESTCASE_ROOT/definitions.ml 1:4-5
+  $TESTCASE_ROOT/usages.ml 6:7-8
+
+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

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 }

tests/test-dirs/occurrences/punning.t/run.t

@@ -0,0 +1,45 @@
+Test occurrences in the presence of punning (both let and record punning)
+
+Convenience function for querying occurrences
+  $ occurrences () {
+  >   location="$1"
+  >   $MERLIN single occurrences -identifier-at "$location" -filename test.ml < test.ml | \
+  >     jq -r '.value[] | "\(.start.line):\(.start.col)-\(.end.col)"'
+  > }
+
+Get occurrences of an identifier that is used as the expression part of a punned let
+expression
+  $ occurrences 4:6
+  4:6-7
+  5:7-8
+
+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 5:7
+  5:7-8
+  6:7-8
+
+Get occurrences of an identifier that was defined in a punned let expression
+  $ occurrences 5:7
+  5:7-8
+  6:7-8
+
+Get occurrences of a record field, where there is an instance of punning that field while
+creating a record
+  $ occurrences 9:13
+  9:11-16
+  11: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 10:4
+  10:4-9
+  11: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 10:4
+  10:4-9
+  11:10-15

tests/test-dirs/occurrences/punning.t/test.ml

@@ -0,0 +1,11 @@
+(* Let punning *)
+let _ =
+  let (let*) = Option.bind in
+  let a = Some 1 in
+  let* a in
+  Some a
+
+(* Record field punning *)
+type t = { value : string }
+let value = "hello"
+let _ = { value }

upstream/ocaml_flambda/base-rev.txt

@@ -1 +1 @@
-69c04271e033a9c4420b2391b9e77427bf3c0c9a
+0568366c21ca4c1bf1fb2db3dd62f65879100a4a

upstream/ocaml_flambda/file_formats/cmt_format.ml

@@ -374,14 +374,12 @@ let index_occurrences binary_annots =
     ref []
   in
   let f ~namespace env path lid =
-    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
-    if not_ghost lid then
-      match Env.shape_of_path ~namespace env path with
-      | exception Not_found -> ()
-      | { uid = Some (Predef _); _ } -> ()
-      | path_shape ->
-        let result = Shape_reduce.local_reduce_for_uid env path_shape in
-        index := (lid, result) :: !index
+    match Env.shape_of_path ~namespace env path with
+    | exception Not_found -> ()
+    | { uid = Some (Predef _); _ } -> ()
+    | path_shape ->
+      let result = Shape_reduce.local_reduce_for_uid env path_shape in
+      index := (lid, result) :: !index
   in
   iter_on_annots (iter_on_occurrences ~f) binary_annots;
   Array.of_list !index