refactor-open qualify uses short-paths

CHANGES.md

@@ -10,6 +10,13 @@ git version
     - add new module holes that can replace module expressions (#1333)
     - add a new command `construct` that builds a list of possible terms when
       called on a typed hole (#1318)
+    - `refactor-open qualify` improvements (#1313)
+      - do not make paths absolute, simply prefix with the identifier under the cursor
+        ```ocaml
+        open Foo (* calling refactor-open qualify on this open *)
+        let _ = Foo.bar (* previously could result in [Dune__exe.Foo.bar] *)
+        ```
+      - does not return identical (duplicate) edits
   + editor modes
     - vim: add a simple interface to the new `construct` command:
       `MerlinConstruct`. When several results are suggested, `<c-i>` and `<c-u>`

src/frontend/query_commands.ml

@@ -481,18 +481,22 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     let typer = Mpipeline.typer_result pipeline in
     let pos = Mpipeline.get_lexing_pos pipeline pos in
     begin match Mbrowse.select_open_node (Mtyper.node_at typer pos) with
-      | None | Some (_, []) -> []
-      | Some (path, ((_, node) :: _)) ->
+      | None | Some (_, _, []) -> []
+      | Some (path, longident, ((_, node) :: _)) ->
         let paths =
           Browse_tree.all_occurrences_of_prefix ~strict_prefix:true path node in
         let paths = List.concat_map ~f:snd paths in
+        let leftmost_ident = Longident.flatten longident |> List.hd in
         let rec path_to_string acc (p : Path.t) =
           match p with
           | Pident ident ->
             String.concat ~sep:"." (Ident.name ident :: acc)
           | Pdot (path', s) when
               mode = `Unqualify && Path.same path path' ->
             String.concat ~sep:"." (s :: acc)
+          | Pdot (path', s) when
+              mode = `Qualify && s = leftmost_ident ->
+            String.concat ~sep:"." (s :: acc)
           | Pdot (path', s) ->
             path_to_string (s :: acc) path'
           | _ -> raise Not_found
@@ -504,7 +508,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
               with Not_found -> None
             else None
           )
-        |> List.sort
+        |> List.sort_uniq
           ~cmp:(fun (_,l1) (_,l2) ->
               Lexing.compare_pos l1.Location.loc_start l2.Location.loc_start)
     end

src/kernel/mbrowse.ml

@@ -176,26 +176,26 @@ let rec select_open_node =
   function[@warning "-9"]
   | (_, ( Structure_item ({str_desc =
                              Tstr_open { open_expr =
-                                           { mod_desc = Tmod_ident (p, _) }}},
+                                           { mod_desc = Tmod_ident (p, {txt = longident}) }}},
                           _)))
     :: ancestors ->
-    Some (p, ancestors)
+    Some (p, longident, ancestors)
   | (_, ( Signature_item ({sig_desc = Tsig_open op}, _))) :: ancestors ->
-    Some (fst op.open_expr, ancestors)
+    let (p, { Asttypes.txt = longident; }) = op.open_expr in
+    Some (p, longident, ancestors)
+  | (_, Expression { exp_desc =
+          Texp_open ({ open_expr =
+                        { mod_desc = Tmod_ident (p, {txt = longident})}}, _); _})
+    :: _ as ancestors ->
+      Some (p, longident, ancestors)
   | (_, Pattern {pat_extra; _}) :: ancestors
     when List.exists pat_extra
-        ~f:(function (Tpat_open _, _ ,_) -> true | _ -> false) ->
-    let p = List.find_map pat_extra
-        ~f:(function | Tpat_open (p,_,_), _ ,_ -> Some p
+          ~f:(function (Tpat_open _, _ ,_) -> true | _ -> false) ->
+    let (p, longident) = List.find_map pat_extra
+        ~f:(function | Tpat_open (p,{ txt = longident; },_), _ ,_ -> Some (p, longident)
                      | _ -> None)
     in
-    Some (p, ancestors)
-  | (_, Expression { exp_desc =
-                       Texp_open ({ open_expr =
-                                      { mod_desc = Tmod_ident (p, _)}}, _);
-                     _
-                   }) :: _ as ancestors ->
-    Some (p, ancestors)
+    Some (p, longident, ancestors)
   | [] -> None
   | _ :: ancestors -> select_open_node ancestors
 

src/kernel/mbrowse.mli

@@ -47,7 +47,7 @@ val drop_leaf : t -> t option
 val deepest_before : Lexing.position -> t list -> t
 
 
-val select_open_node : t -> (Path.t * t) option
+val select_open_node : t -> (Path.t * Longident.t * t) option
 
 val enclosing : Lexing.position -> t list -> t
 

tests/test-dirs/refactor-open/qualify.t

@@ -0,0 +1,123 @@
+Can qualify module located in the same file
+  $ $MERLIN single refactor-open -action qualify -position 4:6 <<EOF
+  > module M = struct
+  >   let u = ()
+  > end
+  > open M
+  > let u = u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 8
+        },
+        "end": {
+          "line": 5,
+          "col": 9
+        },
+        "content": "M.u"
+      }
+    ],
+    "notifications": []
+  }
+
+Can qualify nested modules located in the same file
+
+  $ $MERLIN single refactor-open -action qualify -position 6:6 <<EOF
+  > module M = struct
+  >   module N = struct
+  >     let u = ()
+  >   end
+  > end
+  > open M.N
+  > let u = u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 8
+        },
+        "end": {
+          "line": 7,
+          "col": 9
+        },
+        "content": "M.N.u"
+      }
+    ],
+    "notifications": []
+  }
+
+Can qualify a module from an external library
+
+  $ $MERLIN single refactor-open -action qualify -position 1:6 <<EOF
+  > open Unix
+  > let times = times ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 12
+        },
+        "end": {
+          "line": 2,
+          "col": 17
+        },
+        "content": "Unix.times"
+      }
+    ],
+    "notifications": []
+  }
+
+Can qualify nested modules from the same file, including open statements, and 
+does not return duplicate edits
+
+  $ $MERLIN single refactor-open -action qualify -position 8:6 <<EOF
+  > module L = struct
+  >   module M = struct
+  >     module N = struct
+  >       let u = ()
+  >     end
+  >   end
+  > end
+  > open L 
+  > open M.N
+  > let () = u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 9,
+          "col": 5
+        },
+        "end": {
+          "line": 9,
+          "col": 8
+        },
+        "content": "L.M.N"
+      },
+      {
+        "start": {
+          "line": 10,
+          "col": 9
+        },
+        "end": {
+          "line": 10,
+          "col": 10
+        },
+        "content": "L.M.N.u"
+      }
+    ],
+    "notifications": []
+  }
+

tests/test-dirs/refactor-open/qualify_short_paths.t

@@ -0,0 +1,29 @@
+refactor open qualify should use short paths
+
+  $ $MERLIN single refactor-open -action qualify -position 7:6 <<EOF
+  > module Dune__exe = struct
+  >   module M = struct
+  >     let u = ()
+  >   end
+  > end
+  > open Dune__exe
+  > open M
+  > let u = u
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 8,
+          "col": 8
+        },
+        "end": {
+          "line": 8,
+          "col": 9
+        },
+        "content": "M.u"
+      }
+    ],
+    "notifications": []
+  }

tests/test-dirs/refactor-open/record_field.t

@@ -23,3 +23,38 @@ FIXME refactor open rewriting the whole record instead of a field label
     ],
     "notifications": []
   }
+
+Refactor open for record disambiguation
+
+  $ $MERLIN single refactor-open -action qualify -position 1:6 <<EOF
+  > open Unix
+  > let f x = x.tms_stime, x.tms_utime
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 12
+        },
+        "end": {
+          "line": 2,
+          "col": 21
+        },
+        "content": "Unix.tms_stime"
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 25
+        },
+        "end": {
+          "line": 2,
+          "col": 34
+        },
+        "content": "Unix.tms_utime"
+      }
+    ],
+    "notifications": []
+  }