Merge pull request ocaml#1715 from voodoos/501-backports

501 backports

CHANGES.md

@@ -1,13 +1,20 @@
-merlin NEXT_VERSION
-===================
+merlin 4.13
+===========
+Fri Dec  1 15:00:42 CET 2023
 
   + merlin binary
     - Fix a follow-up issue to the preference of non-ghost nodes introduced in #1660 (#1690, fixes #1689)
-    - Add `--cache-period` flag, that sets cache invalidation period. (#1698)
+    - Add `-cache-lifespan` flag, that sets cache invalidation period. (#1698,
+      #1705)
     - Ignore the new 5.1 `cmi-file` flag instead of rejecting it (#1710, fixes
       #1703)
+    - Fix Merlin locate not fallbacking on the correct file in case of ambiguity
+      (@goldfirere, #1699)
+    - Fix Merlin reporting errors provoked by the recovery itself (#1709, fixes
+      #1704)
   + editor modes
     - vim: load merlin when Vim is compiled with +python3/dyn (e.g. MacVim)
+    - emacs: highlight only first error line by default (#1693, fixes #1663)
 
 merlin 4.12
 ===========

doc/dev/CACHING.md

@@ -78,7 +78,7 @@ to be used anymore.
 `Mocaml.flush_caches` remove all files that have changed on disk or that
 haven't been used for some time.  By default, `ocamlmerlin_server` remove
 entries that haven't been used in the last 5 minutes. This behavior can be
-changed with `--cache-period` flag.
+changed with `-cache-lifespan` flag.
 
 Since this involve stating each entry, the check is done after answering.
 

emacs/merlin.el

@@ -153,7 +153,7 @@ If a string list, check only if the extension of the buffer-file-name
   "If non-nil, display errors in fringe"
   :group 'merlin :type 'boolean)
 
-(defcustom merlin-error-on-single-line nil
+(defcustom merlin-error-on-single-line t
   "Only highlight first line of multi-line error messages"
   :group 'merlin :type 'boolean)
 
@@ -194,7 +194,7 @@ a new window or not."
   "If non-nil, use this file for the log file (should be an absolute path)."
   :group 'merlin :type 'file)
 
-(defcustom merlin-cache-period nil
+(defcustom merlin-cache-lifespan nil
   "If non-nil, use this value for cache period (measured in minutes)."
   :group 'merlin :type 'natnum)
 
@@ -554,8 +554,8 @@ argument (lookup appropriate binary, setup logging, pass global settings)"
                   (cons "-flags" merlin-buffer-flags))
                 (when filename
                   (cons "-filename" filename))
-                (when merlin-cache-period
-                  (cons "-cache-period" (number-to-string merlin-cache-period)))
+                (when merlin-cache-lifespan
+                  (cons "-cache-lifespan" (number-to-string merlin-cache-lifespan)))
                 args))
     ;; Log last commands
     (setq merlin-debug-last-commands

src/analysis/locate.ml

@@ -182,7 +182,9 @@ end = struct
   let reset () = state := None
 
   let move_to ~digest file =
-    log ~title:"File_switching.move_to" "%s" file;
+    log ~title:"File_switching.move_to" "file: %s\ndigest: %s" file
+    @@ Digest.to_hex digest;
+
     state := Some { last_file_visited = file ; digest }
 
   let where_am_i () = Option.map !state ~f:last_file_visited
@@ -359,22 +361,27 @@ let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace =
         ~namespace:Shape.Sig_component_kind.Module env (Pident id)
     end)
   in
-  match ml_or_mli with
-  | `MLI ->
-    let uid = scrape_alias ~fallback_uid:decl_uid ~env ~namespace path in
-    log ~title:"uid_of_path" "Declaration uid: %a"
-      Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid);
-    log ~title:"uid_of_path" "Alias scrapped: %a"
+  let unalias fallback_uid =
+    let uid = scrape_alias ~fallback_uid ~env ~namespace path in
+    log ~title:"uid_of_path" "Unaliasing uid: %a -> %a"
+      Logger.fmt (fun fmt -> Shape.Uid.print fmt fallback_uid)
       Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-    Some uid
+    uid
+  in
+  match ml_or_mli with
+  | `MLI -> unalias decl_uid
   | `ML ->
     let shape = Env.shape_of_path ~namespace env path in
     log ~title:"shape_of_path" "initial: %a"
       Logger.fmt (fun fmt -> Shape.print fmt shape);
     let r = Shape_reduce.weak_reduce env shape in
     log ~title:"shape_of_path" "reduced: %a"
       Logger.fmt (fun fmt -> Shape.print fmt r);
-    r.uid
+    match r.uid with
+    | Some uid -> uid
+    | None ->
+      log ~title:"shape_of_path" "No uid found; fallbacking to declaration uid";
+      unalias decl_uid
 
 let from_uid ~config ~ml_or_mli uid loc path =
   let loc_of_comp_unit comp_unit =
@@ -387,61 +394,48 @@ let from_uid ~config ~ml_or_mli uid loc path =
   in
   let title = "from_uid" in
   match uid with
-  | Some (Shape.Uid.Item { comp_unit; _ } as uid) ->
+  | Shape.Uid.Item { comp_unit; _ } ->
     let locopt =
-      if Env.get_unit_name () = comp_unit then begin
-        log ~title "We look for %a in the current compilation unit."
+      let log_and_return msg = log ~title msg; None in
+      let uid_to_loc_tbl =
+        if Env.get_unit_name () = comp_unit then begin
+          log ~title "We look for %a in the current compilation unit."
+            Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+          Some (Env.get_uid_to_loc_tbl ())
+        end else begin
+          log ~title "Loading the cmt for unit %S" comp_unit;
+          match load_cmt ~config comp_unit ml_or_mli with
+          | Ok (_pos_fname, cmt) -> Some cmt.cmt_uid_to_loc
+          | Error () -> log_and_return "Failed to load the cmt file."
+        end
+      in
+      Option.bind uid_to_loc_tbl ~f:(fun tbl ->
+        log ~title "Looking for %a in the uid_to_loc table"
           Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-        let tbl = Env.get_uid_to_loc_tbl () in
         match Shape.Uid.Tbl.find_opt tbl uid with
         | Some loc ->
           log ~title "Found location: %a"
             Logger.fmt (fun fmt -> Location.print_loc fmt loc);
           Some (uid, loc)
-        | None ->
-          log ~title
-            "Uid not found in the local table.\
-            Fallbacking to the node's location: %a"
-          Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-          Some (uid, loc)
-      end else begin
-        log ~title "Loading the shapes for unit %S" comp_unit;
-        match load_cmt ~config comp_unit ml_or_mli with
-        | Ok (_pos_fname, cmt) ->
-          log ~title "Shapes successfully loaded, looking for %a"
-            Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-          begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_loc uid with
-            | Some loc ->
-              log ~title "Found location: %a"
-                Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-              Some (uid, loc)
-            | None ->
-              log ~title "Uid not found in the cmt table. \
-                Fallbacking to the node's location: %a"
-                Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-              Some (uid, loc)
-          end
-        | _ ->
-          log ~title "Failed to load the shapes";
-          None
-      end
+        | None -> log_and_return  "Uid not found in the table.")
     in
     begin match locopt with
     | Some (uid, loc) -> `Found (Some uid, loc)
-    | None -> `Not_found (Path.name path, None)
+    | None ->
+      log ~title "Fallbacking to lookup location: %a"
+        Logger.fmt (fun fmt -> Location.print_loc fmt loc);
+      `Found (Some uid, loc)
     end
-  | Some (Compilation_unit comp_unit as uid) ->
+  | Compilation_unit comp_unit ->
     begin
       log ~title "Got the uid of a compilation unit: %a"
         Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
       match loc_of_comp_unit comp_unit with
       | Some loc -> `Found (Some uid, loc)
-      | _ -> log ~title "Failed to load the shapes";
+      | _ -> log ~title "Failed to load the CU's cmt";
         `Not_found (Path.name path, None)
     end
-  | Some (Predef _ | Internal) -> assert false
-  | None -> log ~title "No UID found, fallbacking to lookup location.";
-      `Found (None, loc)
+  | Predef _ | Internal -> assert false
 
 let locate ~config ~env ~ml_or_mli decl_uid loc path ns =
   let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns in

src/frontend/ocamlmerlin/new/new_merlin.ml

@@ -92,7 +92,7 @@ let run = function
         Logger.with_log_file Mconfig.(config.merlin.log_file)
           ~sections:Mconfig.(config.merlin.log_sections) @@ fun () ->
         Mocaml.flush_caches
-          ~older_than:(float_of_int (60 * Mconfig.(config.merlin.cache_period))) ();
+          ~older_than:(float_of_int (60 * Mconfig.(config.merlin.cache_lifespan))) ();
         File_id.with_cache @@ fun () ->
         let source = Msource.make (Misc.string_of_file stdin) in
         let pipeline = Mpipeline.make config source in

src/kernel/mconfig.ml

@@ -92,7 +92,7 @@ type merlin = {
   failures : string list;
   extension_to_reader : (string * string) list;
 
-  cache_period : int
+  cache_lifespan : int
 }
 
 let dump_merlin x =
@@ -129,7 +129,7 @@ let dump_merlin x =
           "reader", `String reader;
         ]) x.extension_to_reader
     );
-    "cache_period"   , Json.string (string_of_int x.cache_period)
+    "cache_lifespan"   , Json.string (string_of_int x.cache_lifespan)
   ]
 
 module Verbosity = struct
@@ -359,9 +359,9 @@ let merlin_flags = [
     "<path> Change path of ocaml standard library"
   );
   (
-    "-cache-period",
+    "-cache-lifespan",
     Marg.param "int" (fun prot merlin ->
-        try {merlin with cache_period = (int_of_string prot)}
+        try {merlin with cache_lifespan = (int_of_string prot)}
         with _ -> invalid_arg "Valid value is int";
       ),
     "Change file cache retention period. It's measured in minutes. \
@@ -626,7 +626,7 @@ let initial = {
 
     failures = [];
     extension_to_reader = [(".re","reason");(".rei","reason")];
-    cache_period = 5;
+    cache_lifespan = 5;
   };
   query = {
     filename = "*buffer*";

src/kernel/mconfig.mli

@@ -49,7 +49,7 @@ type merlin = {
 
   failures : string list;
   extension_to_reader : (string * string) list;
-  cache_period : int
+  cache_lifespan : int
 }
 
 val dump_merlin : merlin -> json

src/ocaml/typing/typedecl.ml

@@ -1154,7 +1154,9 @@ let transl_type_decl env rec_flag sdecl_list =
     (fun sdecl tdecl ->
       let decl = tdecl.typ_type in
        match Ctype.closed_type_decl decl with
-         Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+         Some ty ->
+          if not (Msupport.erroneous_type_check ty) then
+            raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
        | None   -> ())
     sdecl_list tdecls;
   (* Check that constraints are enforced *)

src/ocaml/typing/typetexp.ml

@@ -416,9 +416,11 @@ let rec transl_type env ~policy ?(aliased=false) ~row_context styp =
        try
          transl_type_aux env ~policy ~aliased ~row_context styp
        with exn ->
+         let ty = new_global_var () in
+         Msupport.erroneous_type_register ty;
          Msupport.raise_error exn;
            { ctyp_desc = Ttyp_any;
-             ctyp_type = new_global_var ();
+             ctyp_type = ty;
              ctyp_env = env;
              ctyp_loc = styp.ptyp_loc;
              ctyp_attributes = [];

tests/test-dirs/config/dot-merlin-reader/quoting.t

@@ -67,7 +67,7 @@
         "reader": "reason"
       }
     ],
-    "cache_period": "5"
+    "cache_lifespan": "5"
   }
 
   $ rm .merlin

tests/test-dirs/document/issue1513.t

@@ -20,8 +20,8 @@ FIXME: We should not rely on "fallbacking". This requires a compiler change.
   $ $MERLIN single document -position 1:13 \
   > -log-file - -log-section locate \
   > -filename main.ml <main.ml 2>&1 | 
-  > grep "Uid not found in the cmt table"
-  Uid not found in the cmt table. Fallbacking to the node's location: File "naux.ml", line 2, characters 2-5
+  > grep "Uid not found in the table."
+  Uid not found in the table.
 
 FIXME: expected "B Comment"
   $ $MERLIN single document -position 2:13 \

tests/test-dirs/errors/issue1704-wrong-message.t

@@ -0,0 +1,59 @@
+  $ cat >test.ml <<'EOF'
+  > type foo = {
+  >   bar: X.t;
+  > }
+  > type foo2 = X.t
+  > type foo3 = bar
+  > EOF
+
+Merlin should not report unbound variable errors in that case since it is
+due to it's own type recovery.
+  $ $MERLIN single errors -filename test.ml <test.ml 
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 7
+        },
+        "end": {
+          "line": 2,
+          "col": 10
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module X"
+      },
+      {
+        "start": {
+          "line": 4,
+          "col": 12
+        },
+        "end": {
+          "line": 4,
+          "col": 15
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound module X"
+      },
+      {
+        "start": {
+          "line": 5,
+          "col": 12
+        },
+        "end": {
+          "line": 5,
+          "col": 15
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "Unbound type constructor bar"
+      }
+    ],
+    "notifications": []
+  }