Add reproduction for some locate issues

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

@@ -5408,7 +5408,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
@@ -5524,6 +5524,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/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
+    }
+  }

tests/test-dirs/locate/issue1610.t

@@ -0,0 +1,27 @@
+  $ cat >main.ml <<EOF
+  > 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 <main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/main.ml",
+    "pos": {
+      "line": 11,
+      "col": 5
+    }
+  }
+
+The issue appears to reside in "reconstruct identifier".
+A fix was attempted in https://github.com/ocaml/merlin/pull/1611.

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 <test.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/test.ml",
+      "pos": {
+        "line": 7,
+        "col": 6
+      }
+    },
+    "notifications": []
+  }