Skip to content

Commit 5731826

Browse files
trefistrefis
authored
Merge pull request #1314 from ulugbekna/refactor-open-no-change
refactor-open: don't return useless edits
2 parents 6060708 + 9f40421 commit 5731826

File tree

5 files changed

+153
-33
lines changed

5 files changed

+153
-33
lines changed

‎CHANGES.md

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,8 @@ git version
1616
open Foo (* calling refactor-open qualify on this open *)
1717
let _ = Foo.bar (* previously could result in [Dune__exe.Foo.bar] *)
1818
```
19-
- does not return identical (duplicate) edits
19+
- do not return identical (duplicate) edits
20+
- do not return unnecessary edits that when applied do not change the document
2021
+ editor modes
2122
- vim: add a simple interface to the new `construct` command:
2223
`MerlinConstruct`. When several results are suggested, `<c-i>` and `<c-u>`

‎src/frontend/query_commands.ml

Lines changed: 43 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -487,30 +487,42 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
487487
Browse_tree.all_occurrences_of_prefix ~strict_prefix:true path node in
488488
let paths = List.concat_map ~f:snd paths in
489489
let leftmost_ident = Longident.flatten longident |> List.hd in
490-
let rec path_to_string acc (p : Path.t) =
491-
match p with
492-
| Pident ident ->
493-
String.concat ~sep:"." (Ident.name ident :: acc)
494-
| Pdot (path', s) when
495-
mode = `Unqualify && Path.same path path' ->
496-
String.concat ~sep:"." (s :: acc)
497-
| Pdot (path', s) when
498-
mode = `Qualify && s = leftmost_ident ->
499-
String.concat ~sep:"." (s :: acc)
500-
| Pdot (path', s) ->
501-
path_to_string (s :: acc) path'
502-
| _ -> raise Not_found
490+
let qual_or_unqual_path p =
491+
let rec aux acc (p : Path.t) =
492+
match p with
493+
| Pident ident ->
494+
Ident.name ident :: acc
495+
| Pdot (path', s) when
496+
mode = `Unqualify && Path.same path path' ->
497+
s :: acc
498+
| Pdot (path', s) when
499+
mode = `Qualify && s = leftmost_ident ->
500+
s :: acc
501+
| Pdot (path', s) ->
502+
aux (s :: acc) path'
503+
| _ -> raise Not_found
504+
in
505+
aux [] p |> String.concat ~sep:"."
506+
in
507+
(* checks if the (un)qualified longident has a different length, i.e., has changed
508+
509+
XXX(Ulugbek): computes longident length using [loc_start] and [loc_end], hence
510+
it doesn't work for multiline longidents because we can't compute their length *)
511+
let same_longident new_lident { Location. loc_start; loc_end; _ } =
512+
let old_longident_len = Lexing.column loc_end - Lexing.column loc_start in
513+
loc_start.Lexing.pos_lnum = loc_end.Lexing.pos_lnum &&
514+
String.length new_lident = old_longident_len
503515
in
504516
List.filter_map paths ~f:(fun {Location. txt = path; loc} ->
505517
if not loc.Location.loc_ghost &&
506518
Location_aux.compare_pos pos loc <= 0 then
507-
try Some (path_to_string [] path, loc)
508-
with Not_found -> None
519+
match qual_or_unqual_path path with
520+
| s when same_longident s loc -> None
521+
| s -> Some (s, loc)
522+
| exception Not_found -> None
509523
else None
510524
)
511-
|> List.sort_uniq
512-
~cmp:(fun (_,l1) (_,l2) ->
513-
Lexing.compare_pos l1.Location.loc_start l2.Location.loc_start)
525+
|> List.sort_uniq ~cmp:(fun (_,l1) (_,l2) -> Location_aux.compare l1 l2)
514526
end
515527

516528
| Document (patho, pos) ->
@@ -815,24 +827,22 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
815827
let typer = Mpipeline.typer_result pipeline in
816828
let str = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
817829
let pos = Mpipeline.get_lexing_pos pipeline pos in
818-
let tnode =
819-
let should_ignore_tnode = function
830+
let enclosing = Mbrowse.enclosing pos [str] in
831+
let curr_node =
832+
let is_wildcard_pat = function
820833
| Browse_raw.Pattern {pat_desc = Typedtree.Tpat_any; _} -> true
821834
| _ -> false
822835
in
823-
let rec find = function
824-
| [] -> Browse_tree.dummy
825-
| (env, node)::rest ->
826-
if should_ignore_tnode node
827-
then find rest
828-
else Browse_tree.of_node ~env node
829-
in
830-
find (Mbrowse.enclosing pos [str])
836+
List.find_some enclosing ~f:(fun (_, node) ->
837+
(* it doesn't make sense to find occurrences of a wildcard pattern *)
838+
not (is_wildcard_pat node))
839+
|> Option.map ~f:(fun (env, node) -> Browse_tree.of_node ~env node)
840+
|> Option.value ~default:Browse_tree.dummy
831841
in
832842
let str = Browse_tree.of_browse str in
833843
let get_loc {Location.txt = _; loc} = loc in
834844
let ident_occurrence () =
835-
let paths = Browse_raw.node_paths tnode.Browse_tree.t_node in
845+
let paths = Browse_raw.node_paths curr_node.Browse_tree.t_node in
836846
let under_cursor p = Location_aux.compare_pos pos (get_loc p) = 0 in
837847
Logger.log ~section:"occurrences" ~title:"Occurrences paths" "%a"
838848
Logger.json (fun () ->
@@ -855,13 +865,14 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
855865
let loc (_t,paths) = List.map ~f:get_loc paths in
856866
List.concat_map ~f:loc ts
857867

858-
and constructor_occurrence d =
859-
let ts = Browse_tree.all_constructor_occurrences (tnode,d) str in
868+
in
869+
let constructor_occurrence d =
870+
let ts = Browse_tree.all_constructor_occurrences (curr_node,d) str in
860871
List.map ~f:get_loc ts
861872

862873
in
863874
let locs =
864-
match Browse_raw.node_is_constructor tnode.Browse_tree.t_node with
875+
match Browse_raw.node_is_constructor curr_node.Browse_tree.t_node with
865876
| Some d -> constructor_occurrence d.Location.txt
866877
| None -> ident_occurrence ()
867878
in

‎src/ocaml/parsing/location_aux.ml

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,12 @@ type t
3232
= Location.t
3333
= { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool }
3434

35+
let compare (l1: t) (l2: t) =
36+
match Lexing.compare_pos l1.loc_start l2.loc_start with
37+
| (-1 | 1) as r -> r
38+
| 0 -> Lexing.compare_pos l1.loc_end l2.loc_end
39+
| _ -> assert false
40+
3541
let compare_pos pos loc =
3642
if Lexing.compare_pos pos loc.Location.loc_start < 0 then
3743
-1

‎src/ocaml/parsing/location_aux.mli

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,9 @@ type t
3030
= Location.t
3131
= { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool }
3232

33+
(** [compare l1 l2] compares start positions, if equal compares end positions *)
34+
val compare : t -> t -> int
35+
3336
val compare_pos: Lexing.position -> t -> int
3437

3538
(** Return the smallest location covered by both arguments,

‎tests/test-dirs/refactor-open/unqualify.t

Lines changed: 99 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,99 @@
1+
Can unqualify module located in the same file
2+
$ $MERLIN single refactor-open -action unqualify -position 4:6 <<EOF
3+
> module M = struct
4+
> let u = ()
5+
> end
6+
> open M
7+
> let u = M.u
8+
> EOF
9+
{
10+
"class": "return",
11+
"value": [
12+
{
13+
"start": {
14+
"line": 5,
15+
"col": 8
16+
},
17+
"end": {
18+
"line": 5,
19+
"col": 11
20+
},
21+
"content": "u"
22+
}
23+
],
24+
"notifications": []
25+
}
26+
27+
Can unqualify nested modules located in the same file
28+
29+
$ $MERLIN single refactor-open -action unqualify -position 6:6 <<EOF
30+
> module M = struct
31+
> module N = struct
32+
> let u = ()
33+
> end
34+
> end
35+
> open M.N
36+
> let u = M.N.u
37+
> EOF
38+
{
39+
"class": "return",
40+
"value": [
41+
{
42+
"start": {
43+
"line": 7,
44+
"col": 8
45+
},
46+
"end": {
47+
"line": 7,
48+
"col": 13
49+
},
50+
"content": "u"
51+
}
52+
],
53+
"notifications": []
54+
}
55+
56+
Shouldn't return anything, as nothing to unqualify (for multiline identifiers)
57+
58+
$ $MERLIN single refactor-open -action unqualify -position 1:6 <<EOF
59+
> open Unix
60+
> let f x = x.
61+
> tms_stime
62+
> EOF
63+
{
64+
"class": "return",
65+
"value": [],
66+
"notifications": []
67+
}
68+
69+
FIXME shouldn't return anything, as nothing to unqualify (for multi-line identifiers)
70+
71+
$ $MERLIN single refactor-open -action unqualify -position 6:6 <<EOF
72+
> module M = struct
73+
> module N = struct
74+
> let u = ()
75+
> end
76+
> end
77+
> open M
78+
> let u = N.
79+
> u
80+
> EOF
81+
{
82+
"class": "return",
83+
"value": [
84+
{
85+
"start": {
86+
"line": 7,
87+
"col": 8
88+
},
89+
"end": {
90+
"line": 8,
91+
"col": 1
92+
},
93+
"content": "N.u"
94+
}
95+
],
96+
"notifications": []
97+
}
98+
99+

0 commit comments

Comments
 (0)