From a95627fc85b1079f2ea7c0fa6024879b2130cbac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 12:28:14 +0200 Subject: [PATCH] [B] SOURCE_ROOT, UNIT_NAME and WRAPPING_PREFIX --- CHANGES.md | 7 +++ src/dot-merlin/dot_merlin_reader.ml | 17 ++++- src/dot-protocol/merlin_dot_protocol.ml | 10 +++ src/dot-protocol/merlin_dot_protocol.mli | 3 + src/kernel/mconfig.ml | 27 +++++++- src/kernel/mconfig.mli | 5 +- src/kernel/mconfig_dot.ml | 15 +++++ src/kernel/mconfig_dot.mli | 3 + .../config/dot-merlin-reader/load-config.t | 63 +++++++++++++++++++ .../config/dot-merlin-reader/quoting.t | 3 + 10 files changed, 150 insertions(+), 3 deletions(-) create mode 100644 tests/test-dirs/config/dot-merlin-reader/load-config.t diff --git a/CHANGES.md b/CHANGES.md index b3676bc2fe..bedae6d5c3 100644 --- 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 4.16 =========== Mon Jun 10 17:35:42 CEST 2024 diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index e3a1aaba00..349bd81476 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/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 diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index 97648d9317..181175cca7 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/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) diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index c238b813ae..1b96bf2f2c 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/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 diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index e79b9c36fb..5842d1cfef 100644 --- a/src/kernel/mconfig.ml +++ b/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 diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index e018a9418f..d53583bc29 100644 --- a/src/kernel/mconfig.mli +++ b/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] *) diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index 13ad8eba99..0a17f4671c 100644 --- a/src/kernel/mconfig_dot.ml +++ b/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; diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 926fb928a8..1cb93ebac7 100644 --- a/src/kernel/mconfig_dot.mli +++ b/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; diff --git a/tests/test-dirs/config/dot-merlin-reader/load-config.t b/tests/test-dirs/config/dot-merlin-reader/load-config.t new file mode 100644 index 0000000000..ee9af398bf --- /dev/null +++ b/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 < B build/dir + > S source/dir + > BH build-hidden/dir + > SH source-hidden/dir + > EOF + + $ FILE=$(pwd)/test.ml; dot-merlin-reader < (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 diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t index b9ae8c7eee..9458ffd34f 100644 --- a/tests/test-dirs/config/dot-merlin-reader/quoting.t +++ b/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,