Merge pull request #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": []
+ }