Merge pull request ocaml#1788 from liam923/wrapping-prefix

`WRAPPING_PREFIX` directive
voodoos · Jun 20, 2024 · b6ff2d4 · b6ff2d4
2 parents ce00b5b + 1c59eda
commit b6ff2d4
Show file tree

Hide file tree

Showing 13 changed files with 235 additions and 6 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -1,3 +1,10 @@
+unreleased
+==========
+
+  + merlin binary
+    - A new `WRAPPING_PREFIX` configuration directive that can be used to tell Merlin
+      what to append to the current unit name in the presence of wrapping (#1788)
+
 merlin 5.1
 ==========
 Tue Jun 18 12:00:42 CEST 2024

diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml
@@ -102,6 +102,8 @@ module Cache = File_cache.Make (struct
             tell (`SOURCE_ROOT (String.drop 12 line))
           else if String.is_prefixed ~by:"UNIT_NAME " line then
             tell (`UNIT_NAME (String.drop 10 line))
+          else if String.is_prefixed ~by:"WRAPPING_PREFIX " line then
+            tell (`WRAPPING_PREFIX (String.drop 16 line))
           else if String.is_prefixed ~by:"FINDLIB " line then
             tell (`FINDLIB (String.drop 8 line))
           else if String.is_prefixed ~by:"SUFFIX " line then
@@ -316,7 +318,6 @@ type config = {
   to_canonicalize : (string * Merlin_dot_protocol.Directive.include_path) list;
   stdlib : string option;
   source_root : string option;
-  unit_name   : string option;
   packages_to_load : string list;
   findlib : string option;
   findlib_path : string list;
@@ -328,7 +329,6 @@ let empty_config = {
   to_canonicalize   = [];
   stdlib            = None;
   source_root       = None;
-  unit_name         = None;
   packages_to_load  = [];
   findlib           = None;
   findlib_path      = [];
@@ -341,7 +341,11 @@ let prepend_config ~cwd ~cfg =
     | `B _ | `S _ | `BH _ | `SH _ | `CMI _ | `CMT _ | `INDEX _ as directive ->
       { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize }
     | `EXT _ | `SUFFIX _ | `FLG _ | `READER _
-    | (`EXCLUDE_QUERY_DIR | `USE_PPX_CACHE | `UNKNOWN_TAG _) as directive ->
+    | (`EXCLUDE_QUERY_DIR
+      | `USE_PPX_CACHE
+      | `UNIT_NAME _
+      | `WRAPPING_PREFIX _
+      | `UNKNOWN_TAG _) as directive ->
       { cfg with pass_forward = directive :: cfg.pass_forward }
     | `PKG ps ->
       { cfg with packages_to_load = ps @ cfg.packages_to_load }
@@ -356,8 +360,6 @@ let prepend_config ~cwd ~cfg =
     | `SOURCE_ROOT path ->
       let canon_path = canonicalize_filename ~cwd path in
       { cfg with source_root = Some canon_path }
-    | `UNIT_NAME name ->
-      { cfg with unit_name = Some name }
     | `FINDLIB path ->
       let canon_path = canonicalize_filename ~cwd path in
       begin match cfg.stdlib with

diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml
@@ -45,6 +45,7 @@ module Directive = struct
     | `STDLIB of string
     | `SOURCE_ROOT of string
     | `UNIT_NAME of string
+    | `WRAPPING_PREFIX of string
     | `SUFFIX of string
     | `READER of string list
     | `EXCLUDE_QUERY_DIR
@@ -98,6 +99,7 @@ module Sexp = struct
         | "STDLIB" -> `STDLIB value
         | "SOURCE_ROOT" -> `SOURCE_ROOT value
         | "UNIT_NAME" -> `UNIT_NAME value
+        | "WRAPPING_PREFIX" -> `WRAPPING_PREFIX value
         | "SUFFIX" -> `SUFFIX value
         | "ERROR" -> `ERROR_MSG value
         | "FLG" ->
@@ -132,6 +134,7 @@ module Sexp = struct
         | `INDEX s -> ("INDEX", single s)
         | `SOURCE_ROOT s -> ("SOURCE_ROOT", single s)
         | `UNIT_NAME s -> ("UNIT_NAME", single s)
+        | `WRAPPING_PREFIX s -> ("WRAPPING_PREFIX", single s)
         | `EXT ss -> ("EXT", [ List (atoms_of_strings ss) ])
         | `FLG ss -> ("FLG", [ List (atoms_of_strings ss) ])
         | `STDLIB s -> ("STDLIB", single s)

diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli
@@ -57,6 +57,7 @@ module Directive : sig
     | `STDLIB of string
     | `SOURCE_ROOT of string
     | `UNIT_NAME of string
+    | `WRAPPING_PREFIX of string
     | `SUFFIX of string
     | `READER of string list
     | `EXCLUDE_QUERY_DIR

diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml
@@ -82,6 +82,7 @@ type merlin = {
   stdlib      : string option;
   source_root : string option;
   unit_name   : string option;
+  wrapping_prefix : string option;
   reader      : string list;
   protocol    : [`Json | `Sexp];
   log_file    : string option;
@@ -125,6 +126,7 @@ let dump_merlin x =
     "stdlib"       , Json.option Json.string x.stdlib;
     "source_root"  , Json.option Json.string x.source_root;
     "unit_name"    , Json.option Json.string x.unit_name;
+    "wrapping_prefix" , Json.option Json.string x.wrapping_prefix;
     "reader"       , `List (List.map ~f:Json.string x.reader);
     "protocol"     , (match x.protocol with
         | `Json -> `String "json"
@@ -260,6 +262,10 @@ let merge_merlin_config dot merlin ~failures ~config_path =
       (if dot.source_root = None then merlin.source_root else dot.source_root);
     unit_name =
       (if dot.unit_name = None then merlin.unit_name else dot.unit_name);
+    wrapping_prefix =
+      if dot.wrapping_prefix = None
+      then merlin.wrapping_prefix
+      else dot.wrapping_prefix;
     reader =
       if dot.reader = []
       then merlin.reader
@@ -662,6 +668,7 @@ let initial = {
     stdlib      = None;
     source_root = None;
     unit_name   = None;
+    wrapping_prefix = None;
     reader      = [];
     protocol    = `Json;
     log_file    = None;
@@ -842,4 +849,9 @@ let filename t = t.query.filename
 let unitname t =
   match t.merlin.unit_name with
   | Some name -> Misc.unitname name
-  | None -> Misc.unitname t.query.filename
+  | None ->
+    let basename = Misc.unitname t.query.filename in
+    begin match t.merlin.wrapping_prefix with
+    | Some prefix -> prefix ^ basename
+    | None -> basename
+    end
diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli
@@ -40,6 +40,7 @@ type merlin = {
   stdlib      : string option;
   source_root : string option;
   unit_name   : string option;
+  wrapping_prefix : string option;
   reader      : string list;
   protocol    : [`Json | `Sexp];
   log_file    : string option;

diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml
@@ -46,6 +46,7 @@ type config = {
   stdlib       : string option;
   source_root  : string option;
   unit_name    : string option;
+  wrapping_prefix : string option;
   reader       : string list;
   exclude_query_dir : bool;
   use_ppx_cache : bool;
@@ -65,6 +66,7 @@ let empty_config = {
   stdlib       = None;
   source_root  = None;
   unit_name    = None;
+  wrapping_prefix = None;
   reader       = [];
   exclude_query_dir = false;
   use_ppx_cache = false;
@@ -264,6 +266,8 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config =
       {config with source_root = Some path}, errors
     | `UNIT_NAME name ->
       {config with unit_name = Some name}, errors
+    | `WRAPPING_PREFIX prefix ->
+      {config with wrapping_prefix = Some prefix}, errors
     | `READER reader ->
       {config with reader}, errors
     | `EXCLUDE_QUERY_DIR ->
@@ -297,6 +301,7 @@ let postprocess_config config =
     stdlib      = config.stdlib;
     source_root = config.source_root;
     unit_name   = config.unit_name;
+    wrapping_prefix = config.wrapping_prefix;
     reader      = config.reader;
     exclude_query_dir = config.exclude_query_dir;
     use_ppx_cache = config.use_ppx_cache;

diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli
@@ -48,6 +48,7 @@ type config = {
   stdlib       : string option;
   source_root  : string option;
   unit_name    : string option;
+  wrapping_prefix : string option;
   reader       : string list;
   exclude_query_dir : bool;
   use_ppx_cache : bool;

diff --git a/tests/test-dirs/config/dot-merlin-reader/load-config.t b/tests/test-dirs/config/dot-merlin-reader/load-config.t
@@ -44,6 +44,7 @@ This test comes from: https://github.com/janestreet/merlin-jst/pull/59
     "stdlib": null,
     "source_root": null,
     "unit_name": null,
+    "wrapping_prefix": null,
     "reader": [],
     "protocol": "json",
     "log_file": null,

diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t
@@ -56,6 +56,7 @@
     "stdlib": null,
     "source_root": null,
     "unit_name": null,
+    "wrapping_prefix": null,
     "reader": [],
     "protocol": "json",
     "log_file": null,

diff --git a/tests/test-dirs/occurrences/project-wide/prefix.t/a.ml b/tests/test-dirs/occurrences/project-wide/prefix.t/a.ml
@@ -0,0 +1,2 @@
+let foo = B.x
+let bar = foo + B.x
diff --git a/tests/test-dirs/occurrences/project-wide/prefix.t/b.ml b/tests/test-dirs/occurrences/project-wide/prefix.t/b.ml
@@ -0,0 +1,2 @@
+let x = 10
+let y = x + 20
diff --git a/tests/test-dirs/occurrences/project-wide/prefix.t/run.t b/tests/test-dirs/occurrences/project-wide/prefix.t/run.t
@@ -0,0 +1,191 @@
+Compile a libary with prefixes, like dune
+
+  $ cat >mylib.ml <<'EOF'
+  > module A = Mylib__A
+  > module B = Mylib__B
+  > EOF
+
+  $ ocamlc -bin-annot -bin-annot-occurrences -w -49 -no-alias-deps -o mylib.cmo -c -impl mylib.ml
+
+  $ ocamlc -bin-annot -bin-annot-occurrences -open Mylib -o mylib__B.cmo -c b.ml
+
+  $ ocamlc -bin-annot -bin-annot-occurrences -open Mylib -o mylib__A.cmo -c a.ml
+
+Create an index
+
+  $ ocaml-index aggregate *.cmt -o .merlin-index
+
+  $ ocaml-index dump .merlin-index
+  9 uids:
+  {uid: Mylib__A; locs: "Mylib__A": File "mylib.ml", line 1, characters 11-19
+   uid: Mylib__B; locs: "Mylib__B": File "mylib.ml", line 2, characters 11-19
+   uid: Mylib.0; locs: "A": File "mylib.ml", line 1, characters 7-8
+   uid: Mylib.1; locs: "B": File "mylib.ml", line 2, characters 7-8
+   uid: Mylib__A.0; locs:
+     "foo": File "a.ml", line 1, characters 4-7;
+     "foo": File "a.ml", line 2, characters 10-13
+   uid: Mylib__A.1; locs: "bar": File "a.ml", line 2, characters 4-7
+   uid: Mylib__B.0; locs:
+     "B.x": File "a.ml", line 1, characters 10-13;
+     "B.x": File "a.ml", line 2, characters 16-19;
+     "x": File "b.ml", line 1, characters 4-5;
+     "x": File "b.ml", line 2, characters 8-9
+   uid: Mylib__B.1; locs: "y": File "b.ml", line 2, characters 4-5
+   uid: Stdlib.53; locs:
+     "+": File "a.ml", line 2, characters 14-15;
+     "+": File "b.ml", line 2, characters 10-11
+   }, 0 approx shapes: {}, and shapes for CUS .
+
+Merlin fails to find occurrences outside of file because of the module prefixes
+
+  $ cat >.merlin <<'EOF'
+  > INDEX .merlin-index
+  > EOF
+
+  $ $MERLIN single occurrences -scope project -identifier-at 1:4 -filename b.ml < b.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "file": "$TESTCASE_ROOT/b.ml",
+        "start": {
+          "line": 1,
+          "col": 4
+        },
+        "end": {
+          "line": 1,
+          "col": 5
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/b.ml",
+        "start": {
+          "line": 2,
+          "col": 8
+        },
+        "end": {
+          "line": 2,
+          "col": 9
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+Merlin successfully finds occurrences outside file when UNIT_NAME directive is used
+
+  $ cat >.merlin <<'EOF'
+  > INDEX .merlin-index
+  > UNIT_NAME Mylib__B
+  > EOF
+
+  $ $MERLIN single occurrences -scope project -identifier-at 1:4 -filename b.ml < b.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "file": "$TESTCASE_ROOT/b.ml",
+        "start": {
+          "line": 1,
+          "col": 4
+        },
+        "end": {
+          "line": 1,
+          "col": 5
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/a.ml",
+        "start": {
+          "line": 1,
+          "col": 12
+        },
+        "end": {
+          "line": 1,
+          "col": 13
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/a.ml",
+        "start": {
+          "line": 2,
+          "col": 18
+        },
+        "end": {
+          "line": 2,
+          "col": 19
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/b.ml",
+        "start": {
+          "line": 2,
+          "col": 8
+        },
+        "end": {
+          "line": 2,
+          "col": 9
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+Merlin successfully finds occurrences outside file when WRAPPING_PREFIX directive is used
+
+  $ cat >.merlin <<'EOF'
+  > INDEX .merlin-index
+  > WRAPPING_PREFIX Mylib__
+  > EOF
+
+  $ $MERLIN single occurrences -scope project -identifier-at 1:4 -filename b.ml < b.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "file": "$TESTCASE_ROOT/b.ml",
+        "start": {
+          "line": 1,
+          "col": 4
+        },
+        "end": {
+          "line": 1,
+          "col": 5
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/a.ml",
+        "start": {
+          "line": 1,
+          "col": 12
+        },
+        "end": {
+          "line": 1,
+          "col": 13
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/a.ml",
+        "start": {
+          "line": 2,
+          "col": 18
+        },
+        "end": {
+          "line": 2,
+          "col": 19
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/b.ml",
+        "start": {
+          "line": 2,
+          "col": 8
+        },
+        "end": {
+          "line": 2,
+          "col": 9
+        }
+      }
+    ],
+    "notifications": []
+  }