[B] SOURCE_ROOT, UNIT_NAME and WRAPPING_PREFIX

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 4.16
 ===========
 Mon Jun 10 17:35:42 CEST 2024

src/dot-merlin/dot_merlin_reader.ml

@@ -92,6 +92,12 @@ module Cache = File_cache.Make (struct
             includes := String.trim (String.drop 2 line) :: !includes
           else if String.is_prefixed ~by:"STDLIB " line then
             tell (`STDLIB (String.drop 7 line))
+          else if String.is_prefixed ~by:"SOURCE_ROOT " line then
+            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
@@ -305,6 +311,7 @@ type config = {
   pass_forward : Merlin_dot_protocol.Directive.no_processing_required list;
   to_canonicalize : (string * Merlin_dot_protocol.Directive.include_path) list;
   stdlib : string option;
+  source_root : string option;
   packages_to_load : string list;
   findlib : string option;
   findlib_path : string list;
@@ -315,6 +322,7 @@ let empty_config = {
   pass_forward      = [];
   to_canonicalize   = [];
   stdlib            = None;
+  source_root       = None;
   packages_to_load  = [];
   findlib           = None;
   findlib_path      = [];
@@ -327,7 +335,11 @@ let prepend_config ~cwd ~cfg =
     | `B _ | `S _ | `CMI _ | `CMT _  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 }
@@ -339,6 +351,9 @@ let prepend_config ~cwd ~cfg =
         log ~title:"conflicting paths for stdlib" "%s\n%s" p canon_path
       end;
       { cfg with stdlib = Some canon_path }
+    | `SOURCE_ROOT path ->
+      let canon_path = canonicalize_filename ~cwd path in
+      { cfg with source_root = Some canon_path }
     | `FINDLIB path ->
       let canon_path = canonicalize_filename ~cwd path in
       begin match cfg.stdlib with

src/dot-protocol/merlin_dot_protocol.ml

@@ -37,6 +37,9 @@ module Directive = struct
     [ `EXT of string list
     | `FLG of string list
     | `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
@@ -85,6 +88,9 @@ module Sexp = struct
         | "CMI" -> `CMI value
         | "CMT" -> `CMT value
         | "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" ->
@@ -114,6 +120,10 @@ module Sexp = struct
         | `S s -> ("S", single s)
         | `CMI s -> ("CMI", single s)
         | `CMT s -> ("CMT", single s)
+        | `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)

src/dot-protocol/merlin_dot_protocol.mli

@@ -49,6 +49,9 @@ module Directive : sig
     [ `EXT of string list
     | `FLG of string list
     | `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

src/kernel/mconfig.ml

@@ -75,6 +75,9 @@ type merlin = {
   extensions  : string list;
   suffixes    : (string * string) list;
   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;
@@ -113,6 +116,9 @@ let dump_merlin x =
         ]) x.suffixes
     );
     "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"
@@ -241,6 +247,14 @@ let merge_merlin_config dot merlin ~failures ~config_path =
     extensions = dot.extensions @ merlin.extensions;
     suffixes = dot.suffixes @ merlin.suffixes;
     stdlib = (if dot.stdlib = None then merlin.stdlib else dot.stdlib);
+    source_root =
+      (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
@@ -612,6 +626,9 @@ let initial = {
     extensions  = [];
     suffixes    = [(".ml", ".mli"); (".re", ".rei")];
     stdlib      = None;
+    source_root = None;
+    unit_name   = None;
+    wrapping_prefix = None;
     reader      = [];
     protocol    = `Json;
     log_file    = None;
@@ -784,4 +801,12 @@ let global_modules ?(include_current=false) config = (
 
 let filename t = t.query.filename
 
-let unitname t = Misc.unitname t.query.filename
+let unitname t =
+  match t.merlin.unit_name with
+  | Some name -> Misc.unitname name
+  | None ->
+    let basename = Misc.unitname t.query.filename in
+    begin match t.merlin.wrapping_prefix with
+    | Some prefix -> prefix ^ basename
+    | None -> basename
+    end

src/kernel/mconfig.mli

@@ -34,6 +34,9 @@ type merlin = {
   extensions  : string list;
   suffixes    : (string * string) list;
   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;
@@ -56,7 +59,7 @@ val dump_merlin : merlin -> json
 
 (** {1 Some flags affecting queries} *)
 
-module Verbosity : sig 
+module Verbosity : sig
   type t = Smart | Lvl of int
 
   (** the default value for verbosity, i.e., [Lvl 0] *)

src/kernel/mconfig_dot.ml

@@ -41,6 +41,9 @@ type config = {
   extensions   : string list;
   suffixes     : (string * string) list;
   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;
@@ -55,6 +58,9 @@ let empty_config = {
   suffixes     = [];
   flags        = [];
   stdlib       = None;
+  source_root  = None;
+  unit_name    = None;
+  wrapping_prefix = None;
   reader       = [];
   exclude_query_dir = false;
   use_ppx_cache = false;
@@ -246,6 +252,12 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config =
       {config with flags = flags :: config.flags}, errors
     | `STDLIB path ->
       {config with stdlib = Some path}, errors
+    | `SOURCE_ROOT path ->
+      {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 ->
@@ -274,6 +286,9 @@ let postprocess_config config =
     suffixes     = clean config.suffixes;
     flags        = clean config.flags;
     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;

src/kernel/mconfig_dot.mli

@@ -43,6 +43,9 @@ type config = {
   extensions   : string list;
   suffixes     : (string * string) list;
   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;

tests/test-dirs/config/dot-merlin-reader/load-config.t

@@ -0,0 +1,63 @@
+This test comes from: https://github.com/janestreet/merlin-jst/pull/59
+
+  $ cat > .merlin <<EOF
+  > B build/dir
+  > S source/dir
+  > BH build-hidden/dir
+  > SH source-hidden/dir
+  > EOF
+
+  $ FILE=$(pwd)/test.ml; dot-merlin-reader <<EOF | sed 's#[0-9]*:#?:#g'
+  > (4:File${#FILE}:$FILE)
+  > EOF
+  ((?:B?:$TESTCASE_ROOT/build/dir)(?:S?:$TESTCASE_ROOT/source/dir)(?:ERROR?:Unknown tag in .merlin?: BH)(?:ERROR?:Unknown tag in .merlin?: SH))
+
+  $ echo | $MERLIN single dump-configuration -filename test.ml 2> /dev/null | jq '.value.merlin'
+  {
+    "build_path": [
+      "$TESTCASE_ROOT/build/dir"
+    ],
+    "source_path": [
+      "$TESTCASE_ROOT/source/dir"
+    ],
+    "cmi_path": [],
+    "cmt_path": [],
+    "flags_applied": [],
+    "extensions": [],
+    "suffixes": [
+      {
+        "impl": ".ml",
+        "intf": ".mli"
+      },
+      {
+        "impl": ".re",
+        "intf": ".rei"
+      }
+    ],
+    "stdlib": null,
+    "source_root": null,
+    "unit_name": null,
+    "wrapping_prefix": null,
+    "reader": [],
+    "protocol": "json",
+    "log_file": null,
+    "log_sections": [],
+    "flags_to_apply": [],
+    "failures": [
+      "Unknown tag in .merlin: SH",
+      "Unknown tag in .merlin: BH"
+    ],
+    "assoc_suffixes": [
+      {
+        "extension": ".re",
+        "reader": "reason"
+      },
+      {
+        "extension": ".rei",
+        "reader": "reason"
+      }
+    ],
+    "cache_lifespan": "5"
+  }
+
+  $ rm .merlin

tests/test-dirs/config/dot-merlin-reader/quoting.t

@@ -51,6 +51,9 @@
       }
     ],
     "stdlib": null,
+    "source_root": null,
+    "unit_name": null,
+    "wrapping_prefix": null,
     "reader": [],
     "protocol": "json",
     "log_file": null,