diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml index 4d42be677..83644c6f2 100644 --- 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 index 66aa9720e..ad23bb454 100644 --- 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 index ba57ffd36..19e67546a 100644 --- 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 index a3334a9c6..da397861f 100644 --- 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,6 +268,9 @@ 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 @@ -274,6 +278,9 @@ parallel let* 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,6 +290,9 @@ 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 @@ -290,3 +300,6 @@ sequential let* 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 index f521cec89..922bd797c 100644 --- 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 index cc9bc650c..838684b73 100644 --- 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 index b335bca5e..057a5b2f2 100644 --- 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 index e0f972739..83e51c292 100644 --- 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 index b7bcbe2fb..26e5de0d9 100644 --- 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 new file mode 100644 index 000000000..046d60aed --- /dev/null +++ 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 new file mode 100644 index 000000000..ba9a54ced --- /dev/null +++ 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 new file mode 100644 index 000000000..051a50714 --- /dev/null +++ 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 index b70afa0ff..cfa4893e7 100644 --- 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 index 5a7b91f72..6d67aaae4 100644 --- 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, diff --git a/tests/test-dirs/occurrences/project-wide/pwo-relative.t b/tests/test-dirs/occurrences/project-wide/pwo-relative.t index 1c9e928b5..5be3372de 100644 --- a/tests/test-dirs/occurrences/project-wide/pwo-relative.t +++ b/tests/test-dirs/occurrences/project-wide/pwo-relative.t @@ -74,7 +74,7 @@ Perform the occurrences query "file": "$TESTCASE_ROOT/main/main.ml", "start": { "line": 1, - "col": 12 + "col": 8 }, "end": { "line": 1, @@ -85,7 +85,7 @@ Perform the occurrences query "file": "$TESTCASE_ROOT/main/main.ml", "start": { "line": 2, - "col": 26 + "col": 22 }, "end": { "line": 2, diff --git a/tests/test-dirs/occurrences/punning.t/run.t b/tests/test-dirs/occurrences/punning.t/run.t new file mode 100644 index 000000000..fa40df83b --- /dev/null +++ b/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 diff --git a/tests/test-dirs/occurrences/punning.t/test.ml b/tests/test-dirs/occurrences/punning.t/test.ml new file mode 100644 index 000000000..540562bef --- /dev/null +++ b/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 } diff --git a/tests/test-dirs/server-tests/pwo-uid-stability.t b/tests/test-dirs/server-tests/pwo-uid-stability.t index 6bbb1dd20..66a908d13 100644 --- a/tests/test-dirs/server-tests/pwo-uid-stability.t +++ b/tests/test-dirs/server-tests/pwo-uid-stability.t @@ -40,7 +40,7 @@ "file": "$TESTCASE_ROOT/main.ml", "start": { "line": 1, - "col": 13 + "col": 9 }, "end": { "line": 1, @@ -87,7 +87,7 @@ We are not missing the occurrence in main.ml "file": "$TESTCASE_ROOT/main.ml", "start": { "line": 1, - "col": 13 + "col": 9 }, "end": { "line": 1, @@ -132,7 +132,7 @@ We are not missing the occurrence in main.ml "file": "$TESTCASE_ROOT/main.ml", "start": { "line": 1, - "col": 13 + "col": 9 }, "end": { "line": 1,