From fef5cec5ce121e4cd472214b43ff6364aaa4f522 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 2 May 2025 14:16:09 +0200 Subject: [PATCH 01/11] Add a reproduction case for #1580 and #1588 --- tests/test-dirs/locate/ill-typed/issue1580.t | 79 ++++++++++++++++++++ 1 file changed, 79 insertions(+) create mode 100644 tests/test-dirs/locate/ill-typed/issue1580.t diff --git a/tests/test-dirs/locate/ill-typed/issue1580.t b/tests/test-dirs/locate/ill-typed/issue1580.t new file mode 100644 index 0000000000..0d9762753c --- /dev/null +++ b/tests/test-dirs/locate/ill-typed/issue1580.t @@ -0,0 +1,79 @@ +Issue #1580: + + $ cat >test.ml << 'EOF' + > module type S = sig + > val foo : unit -> ('a -> 'a -> bool) -> unit + > end + > + > module F (M : S) = struct + > let z () = M.foo () compare + > end + > EOF + + $ $MERLIN single errors -filename test.ml 'a -> int + but an expression was expected of type 'a -> 'a -> bool + Type int is not compatible with type bool" + } + ], + "notifications": [] + } + +FIXME: the typing recovery would be improved for Merlin to perform the correct +jump here: + + $ $MERLIN single locate -position 6:16 \ + > -filename test.ml test.ml <<'EOF' + > let test ~f:(_ : unit -> unit) = () + > type t = F : { f : unit -> 'fn } -> t + > let call (F { f }) = test ~f + > EOF + + $ $MERLIN single locate -position 3:23 \ + > -filename test.ml $fn but an expression was expected of type + unit -> unit + Type $fn is not compatible with type unit + Hint: $fn is an existential type bound by the constructor F." + } + ], + "notifications": [] + } From 9e894cc67b0db2f92fa1fcf725486d5df2f504d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 22 May 2023 15:02:27 +0200 Subject: [PATCH 02/11] Add a test illustrating issue #1610 --- tests/test-dirs/locate/issue1610.t | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 tests/test-dirs/locate/issue1610.t diff --git a/tests/test-dirs/locate/issue1610.t b/tests/test-dirs/locate/issue1610.t new file mode 100644 index 0000000000..453fdd882a --- /dev/null +++ b/tests/test-dirs/locate/issue1610.t @@ -0,0 +1,24 @@ + $ cat >main.ml < module type T = sig + > type 'a t + > end + > + > module M (T : T) = struct + > type t = int T.t + > end + > + > module T = struct type 'a t end + > + > type t = M(T).t + > EOF + +FIXME: we should jump to the functor's body, not the current definition + $ $MERLIN single locate -look-for ml -position 11:15 \ + > -filename main.ml Date: Fri, 2 May 2025 14:45:03 +0200 Subject: [PATCH 03/11] Add a test illustrating issue ocaml/merlin#1610 --- tests/test-dirs/locate/issue1610.t | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tests/test-dirs/locate/issue1610.t b/tests/test-dirs/locate/issue1610.t index 453fdd882a..4184082626 100644 --- a/tests/test-dirs/locate/issue1610.t +++ b/tests/test-dirs/locate/issue1610.t @@ -19,6 +19,9 @@ FIXME: we should jump to the functor's body, not the current definition "file": "$TESTCASE_ROOT/main.ml", "pos": { "line": 11, - "col": 0 + "col": 5 } } + +The issue appears to reside in "reconstruct identifier". +A fix was attempted in https://github.com/ocaml/merlin/pull/1611. From 6dcf5a74798c8569d9f09a54a287ef0bb90b1d28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 2 May 2025 15:56:07 +0200 Subject: [PATCH 04/11] Illustrate issue #1595 --- tests/test-dirs/config/copy-issue.t | 36 +++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100644 tests/test-dirs/config/copy-issue.t diff --git a/tests/test-dirs/config/copy-issue.t b/tests/test-dirs/config/copy-issue.t new file mode 100644 index 0000000000..d44e68810e --- /dev/null +++ b/tests/test-dirs/config/copy-issue.t @@ -0,0 +1,36 @@ + $ cat >dune-project <<'EOF' + > (lang dune 3.0) + > EOF + + $ mkdir dep + $ cat >dep/dep.ml <<'EOF' + > let txt = "Hello!" + > EOF + + $ mkdir exe + $ cat >exe/main.ml << 'EOF' + > print_endline Dep.txt + > EOF + + $ cat >exe/dune << 'EOF' + > (executable + > (name main)) + > (copy_files# %{project_root}/dep/*.ml) + > EOF + + $ dune exec ./exe/main.exe + Hello! + + $ $MERLIN single errors -filename exe/main.ml Date: Fri, 2 May 2025 17:44:03 +0200 Subject: [PATCH 05/11] Add a recovery layer around type_argument. Fixes ocaml/merlin#1580 and ocaml/merlin#1588 --- src/ocaml/typing/typecore.ml | 32 ++++++++++++++++++- tests/test-dirs/locate/ill-typed/issue1580.t | 30 ++++++++++++++--- .../locate/ill-typed/locate-non-fun.t | 16 +++++++--- 3 files changed, 68 insertions(+), 10 deletions(-) diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index 06e56fbe34..237363f4aa 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -5409,7 +5409,7 @@ and type_label_exp create env loc ty_expected if is_poly then check_univars env "field value" arg label.lbl_arg vars; (lid, label, {arg with exp_type = instance arg.exp_type}) -and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = +and type_argument_ ?explanation ?recarg env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) let no_labels ty = let ls, tvar = list_labels env ty in @@ -5525,6 +5525,36 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = unify_exp ~sexp:sarg env texp ty_expected; texp +and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = + Msupport.with_saved_types + ~warning_attribute:sarg.pexp_attributes ?save_part:None + (fun () -> + let saved = save_levels () in + try + type_argument_ ?explanation ?recarg env sarg ty_expected' ty_expected + with exn -> + Msupport.erroneous_type_register ty_expected; + raise_error exn; + set_levels saved; + let loc = sarg.pexp_loc in + { + exp_desc = Texp_ident + (Path.Pident (Ident.create_local "*type-error*"), + Location.mkloc (Longident.Lident "*type-error*") loc, + { Types. + val_type = ty_expected; + val_kind = Val_reg; + val_loc = loc; + val_attributes = []; + val_uid = Uid.internal_not_actually_unique; + }); + exp_loc = loc; + exp_extra = []; + exp_type = ty_expected; + exp_env = env; + exp_attributes = Msupport.recovery_attributes sarg.pexp_attributes; + }) + and type_application env funct sargs = (* funct.exp_type may be generic *) let result_type omitted ty_fun = diff --git a/tests/test-dirs/locate/ill-typed/issue1580.t b/tests/test-dirs/locate/ill-typed/issue1580.t index 0d9762753c..7c0d2d0d69 100644 --- a/tests/test-dirs/locate/ill-typed/issue1580.t +++ b/tests/test-dirs/locate/ill-typed/issue1580.t @@ -34,12 +34,28 @@ Issue #1580: "notifications": [] } -FIXME: the typing recovery would be improved for Merlin to perform the correct -jump here: +The typing recovery allows Merlin to perform the correct jump here: $ $MERLIN single locate -position 6:16 \ > -filename test.ml -filename test.ml -filename test.ml int -> bool but an expression was expected of type Float.t -> Float.t -> bool Type int is not compatible with type Float.t = float" + "message": "This expression has type Float.t list but an expression was expected of type unit" } Merlin is still able to inspect part of the ill-typed tree @@ -55,7 +55,13 @@ Merlin is still able to inspect part of the ill-typed tree "tail": "no" } -FIXME: And locate should as well... +And locate should as well... $ $MERLIN single locate -position 15:70 \ > -filename ill.ml Date: Tue, 6 May 2025 15:31:34 +0200 Subject: [PATCH 06/11] Add a test illustration issue #1929 --- src/analysis/test.ml | 10 ++++++++++ tests/test-dirs/locate/issue1929.t | 31 ++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100644 src/analysis/test.ml create mode 100644 tests/test-dirs/locate/issue1929.t diff --git a/src/analysis/test.ml b/src/analysis/test.ml new file mode 100644 index 0000000000..e8b0cbc040 --- /dev/null +++ b/src/analysis/test.ml @@ -0,0 +1,10 @@ +module Foo = struct + type t = { foo : int; bar : int } + + let foo = "hello" +end + +let _ = + let foo = 10 in + let bar = 10 in + ({ Foo.foo; bar } : Foo.t) diff --git a/tests/test-dirs/locate/issue1929.t b/tests/test-dirs/locate/issue1929.t new file mode 100644 index 0000000000..51189e714c --- /dev/null +++ b/tests/test-dirs/locate/issue1929.t @@ -0,0 +1,31 @@ + $ cat >test.ml <<'EOF' + > module Foo = struct + > type t = + > { foo : int + > ; bar : int + > } + > + > let foo = "hello" + > end + > + > let _ = + > let foo = 10 in + > let bar = 10 in + > ({ Foo.foo; bar } : Foo.t) + > ;; + > EOF + +FIXME: this answer is wrong. The correct value jumping to `foo` line 11 + $ $MERLIN single locate -position 13:10 \ + > -filename test.ml Date: Tue, 20 May 2025 15:02:36 +0200 Subject: [PATCH 07/11] Add a test illustrating #1924 and #1821 --- tests/test-dirs/locate/dune-pp.t | 55 ++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 tests/test-dirs/locate/dune-pp.t diff --git a/tests/test-dirs/locate/dune-pp.t b/tests/test-dirs/locate/dune-pp.t new file mode 100644 index 0000000000..67f079ce56 --- /dev/null +++ b/tests/test-dirs/locate/dune-pp.t @@ -0,0 +1,55 @@ +This test reproduces the issue described in: +https://github.com/ocaml/merlin/issues/1934 + + + $ cat >dune-project < (lang dune 2.0) + > EOF + + $ mkdir lib + $ cat >lib/lib.ml < let message = "hello" + > EOF + $ cat >lib/dune < (library + > (name lib) + > (preprocess (action (run sed "s/hello/world/g" %{input-file})))) + > EOF + + $ mkdir lib2 + $ cat >lib2/lib.ml < let message = "hello" + > EOF + $ cat >lib2/dune < (library + > (name lib2) + > (preprocess (action (run sed "s/hello/world/g" %{input-file})))) + > EOF + + + $ cat >main.ml < module M = Lib + > let () = print_endline M.message + > EOF + + $ cat >dune < (executable + > (name main) + > (libraries lib lib2)) + > EOF + + $ $DUNE exec ./main.exe + world + + $ ls _build/default/lib/*.ml + _build/default/lib/lib.ml + _build/default/lib/lib.pp.ml + +FIXME Merlin should treat Dune's .pp. files in a correct, ad-hoc way. Right it +appears that the digest of the original source file is not generated properly. + $ $MERLIN single locate -look-for ml -position 1:12 -filename main.ml Date: Mon, 23 Jun 2025 11:02:00 +0200 Subject: [PATCH 08/11] Disable all locate test on windows since they almost always print paths. --- tests/test-dirs/locate/dune | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/tests/test-dirs/locate/dune b/tests/test-dirs/locate/dune index 3121931a35..5ae54f242b 100755 --- a/tests/test-dirs/locate/dune +++ b/tests/test-dirs/locate/dune @@ -1,8 +1,5 @@ (cram - (applies_to looping-substitution mutually-recursive partial-cmt includes - issue802 issue845 issue1848 issue1199 issue1524 sig-substs l-413-features - module-aliases locate-constrs without-implem without-sig module-decl-aliases - in-implicit-trans-dep distinguish-files) + (applies_to :whole_subtree) (enabled_if (<> %{os_type} Win32))) From 43f62f16c324211cdcf4512798555aa51de62144 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 23 Jun 2025 16:01:04 +0200 Subject: [PATCH 09/11] Workaround dune usage of BUILD_PREFIX_MAP to rewrite paths in locate heuristics. --- src/analysis/locate.ml | 37 ++++++++++++++++++++++++++------ tests/test-dirs/locate/dune-pp.t | 14 +++++++++--- 2 files changed, 42 insertions(+), 9 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 51967b5f45..6aeb10c730 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -294,7 +294,23 @@ module Utils = struct | CMT _ | CMTI _ -> Mconfig.cmt_path config end -let move_to filename cmt_infos = +let reroot_build_dir ~root path = + let sep = + try String.get Filename.dir_sep 0 with Invalid_argument _ -> '/' + in + let segments = path |> String.split_on_char ~sep in + let rec strip_prefix = function + | [] -> [] + | "_build" :: _ as l -> l + | _ :: tl -> strip_prefix tl + in + match strip_prefix segments with + | [] -> path + | l -> + let sep = Printf.sprintf "%c" sep in + Filename.concat root (String.concat ~sep l) + +let move_to (config : Mconfig.t) filename cmt_infos = let digest = (* [None] only for packs, and we wouldn't have a trie if the cmt was for a pack. *) @@ -302,6 +318,14 @@ let move_to filename cmt_infos = Filename.concat cmt_infos.Cmt_format.cmt_builddir (Option.get cmt_infos.cmt_sourcefile) in + let sourcefile_in_builddir = + (* This workaround is meant to fix issues with Dune's BUILD_PREFIX_MAP It + will not work when the [_build] folder is not located at the source + root. See [#1934](https://github.com/ocaml/merlin/issues/1934). *) + match config.merlin.source_root with + | None -> sourcefile_in_builddir + | Some root -> reroot_build_dir ~root sourcefile_in_builddir + in match sourcefile_in_builddir |> String.split_on_char ~sep:'.' |> List.rev with @@ -332,7 +356,7 @@ let load_cmt ~config ?(with_fallback = true) comp_unit = let cmt_infos = (Cmt_cache.read path).cmt_infos in let source_file = cmt_infos.cmt_sourcefile in let source_file = Option.value ~default:"*pack*" source_file in - move_to path cmt_infos; + move_to config.mconfig path cmt_infos; Ok (source_file, cmt_infos) | None -> Error () @@ -622,13 +646,14 @@ let find_loc_of_comp_unit ~config uid comp_unit = let find_loc_of_uid ~config ~local_defs ?ident ?fallback (uid : Shape.Uid.t) = let find_loc_of_item ~comp_unit = - match find_loc_of_item ~config ~local_defs uid comp_unit, fallback, ident with + match + (find_loc_of_item ~config ~local_defs uid comp_unit, fallback, ident) + with | Some { loc; txt }, _, Some ident when String.equal txt ident -> (* Checking the ident prevent returning nonsensical results when some uid were swaped but the cmt files were not rebuilt. *) Some (uid, loc) - | Some { loc; _ }, _, None -> - Some (uid, loc) + | Some { loc; _ }, _, None -> Some (uid, loc) | (Some _ | None), Some fallback, _ -> find_loc_of_item ~config ~local_defs fallback comp_unit |> Option.map ~f:(fun { Location.loc; _ } -> (fallback, loc)) @@ -672,7 +697,7 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path = ~with_fallback:false unit_name with | Ok (filename, cmt_infos) -> - move_to filename cmt_infos; + move_to config.mconfig filename cmt_infos; log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; cmt_infos.cmt_impl_shape | Error () -> diff --git a/tests/test-dirs/locate/dune-pp.t b/tests/test-dirs/locate/dune-pp.t index 67f079ce56..ca6af76eb2 100644 --- a/tests/test-dirs/locate/dune-pp.t +++ b/tests/test-dirs/locate/dune-pp.t @@ -45,11 +45,19 @@ https://github.com/ocaml/merlin/issues/1934 _build/default/lib/lib.ml _build/default/lib/lib.pp.ml -FIXME Merlin should treat Dune's .pp. files in a correct, ad-hoc way. Right it +Merlin should treat Dune's .pp. files in a correct, ad-hoc way. Right it appears that the digest of the original source file is not generated properly. - $ $MERLIN single locate -look-for ml -position 1:12 -filename main.ml Date: Tue, 24 Jun 2025 15:21:33 +0200 Subject: [PATCH 10/11] Add a changelog entry for #1930 --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 679c421a94..848c020372 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -19,6 +19,8 @@ unreleased the symbol itself. (#1942) - Fix destruct hanging when printing patterns with (::). (#1944, fixes ocaml/ocaml-lsp#1489) + - Reproduce and fix a handful of jump-to-definition (locate) issues (#1930, + fixes #1580 and #1588, workaround for #1934) + ocaml-index - Improve the granularity of index reading by segmenting the marshalization of the involved data-structures. (#1889) From abec239a0f118c88dcbfacca72df3b9990374ff2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 24 Jun 2025 15:30:02 +0200 Subject: [PATCH 11/11] Don't override BUILD_PATH_PREFIX_MAP in the tests --- tests/test-dirs/pp/dot-pp-dot-ml-dune.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/test-dirs/pp/dot-pp-dot-ml-dune.t b/tests/test-dirs/pp/dot-pp-dot-ml-dune.t index 952a180bac..0d21e1fe5e 100644 --- a/tests/test-dirs/pp/dot-pp-dot-ml-dune.t +++ b/tests/test-dirs/pp/dot-pp-dot-ml-dune.t @@ -68,7 +68,7 @@ Then our test files: Now build with dune: - $ BUILD_PATH_PREFIX_MAP= dune build 2>/dev/null + $ dune build 2>/dev/null And confirm that locate works on both deps: