Add reproduction for some locate issues

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)

src/analysis/locate.ml

@@ -294,14 +294,38 @@ 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. *)
     let sourcefile_in_builddir =
       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 () ->

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)

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 =

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 <exe/main.ml | jq '.value'
+  []
+
+FIXME: Dune should also provide a configuration for the original sources
+  $ $MERLIN single errors -filename dep/dep.ml <dep/dep.ml | jq '.value'
+  [
+    {
+      "type": "config",
+      "sub": [],
+      "valid": true,
+      "message": "No config found for file dep/dep.ml. Try calling 'dune build'."
+    }
+  ]

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)))
 

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 <<EOF
+  > (lang dune 2.0)
+  > EOF
+
+  $ mkdir lib
+  $ cat >lib/lib.ml <<EOF
+  > let message = "hello"
+  > EOF
+  $ cat >lib/dune <<EOF
+  > (library
+  >  (name lib)
+  >  (preprocess (action (run sed "s/hello/world/g" %{input-file}))))
+  > EOF
+
+  $ mkdir lib2
+  $ cat >lib2/lib.ml <<EOF
+  > let message = "hello"
+  > EOF
+  $ cat >lib2/dune <<EOF
+  > (library
+  >  (name lib2)
+  >  (preprocess (action (run sed "s/hello/world/g" %{input-file}))))
+  > EOF
+
+
+  $ cat >main.ml <<EOF
+  > module M = Lib
+  > let () = print_endline M.message
+  > EOF
+
+  $ cat >dune <<EOF
+  > (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 <main.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/lib/lib.ml",
+      "pos": {
+        "line": 1,
+        "col": 0
+      }
+    },
+    "notifications": []
+  }

tests/test-dirs/locate/ill-typed/issue1580.t

@@ -0,0 +1,101 @@
+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 <test.ml 
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 6,
+          "col": 22
+        },
+        "end": {
+          "line": 6,
+          "col": 29
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "The value compare has type 'a -> '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 <test.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/test.ml",
+    "pos": {
+      "line": 2,
+      "col": 6
+    }
+  }
+
+
+  $ $MERLIN single locate -position 6:25 \
+  > -filename test.ml <test.ml | jq '.value'
+  {
+    "file": "lib/ocaml/stdlib.mli",
+    "pos": {
+      "line": 162,
+      "col": 9
+    }
+  }
+
+Issue #1588:
+
+  $ cat >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 <test.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/test.ml",
+    "pos": {
+      "line": 1,
+      "col": 4
+    }
+  }
+
+  $ $MERLIN single errors -filename test.ml <test.ml 
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 27
+        },
+        "end": {
+          "line": 3,
+          "col": 28
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "The value f has type unit -> $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": []
+  }

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 <ill.ml | jq '.value'
-  "Not in environment 'problem'"
+  {
+    "file": "$TESTCASE_ROOT/ill.ml",
+    "pos": {
+      "line": 10,
+      "col": 6
+    }
+  }