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) 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/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/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/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 %{os_type} Win32))) diff --git a/tests/test-dirs/locate/dune-pp.t b/tests/test-dirs/locate/dune-pp.t new file mode 100644 index 0000000000..ca6af76eb2 --- /dev/null +++ b/tests/test-dirs/locate/dune-pp.t @@ -0,0 +1,63 @@ +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 + +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. +The current workaround should work in most cases but is not a definitive answer. +See discussion in [#1934](https://github.com/ocaml/merlin/issues/1934) + $ $MERLIN single locate locate -look-for ml -position 1:12 -filename main.ml 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": [] + } + +The typing recovery allows Merlin to perform the correct jump here: + + $ $MERLIN single locate -position 6:16 \ + > -filename test.ml -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": [] + } diff --git a/tests/test-dirs/locate/ill-typed/locate-non-fun.t b/tests/test-dirs/locate/ill-typed/locate-non-fun.t index cfebf714db..d6cd96f11e 100644 --- a/tests/test-dirs/locate/ill-typed/locate-non-fun.t +++ b/tests/test-dirs/locate/ill-typed/locate-non-fun.t @@ -27,16 +27,16 @@ When some typing error happens { "start": { "line": 15, - "col": 33 + "col": 11 }, "end": { "line": 15, - "col": 42 + "col": 79 }, "type": "typer", "sub": [], "valid": true, - "message": "The value Int.equal has type int -> 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 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 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 /dev/null + $ dune build 2>/dev/null And confirm that locate works on both deps: