Backports for release 4.13-500 (#1718)

from voodoos/500-backports

.github/workflows/main.yml

@@ -38,9 +38,9 @@ jobs:
  os:
  - macos-latest
  - ubuntu-latest
- - windows-latest
+ # - windows-latest
  ocaml-compiler:
- - '5.0'
+ - "5.0"
  # The type of runner that the job will run on
  runs-on: ${{ matrix.os }}
 
@@ -51,12 +51,12 @@ jobs:
  # Steps represent a sequence of tasks that will be executed as part of the job
  steps:
  # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it
- - uses: actions/checkout@v3
+ - name: Checkout tree
+ uses: actions/checkout@v4
 
- - name: Set up OCaml ${{ matrix.ocaml-compiler }}
+ - name: Set-up OCaml ${{ matrix.ocaml-compiler }}
  uses: ocaml/setup-ocaml@v2
  with:
- # Version of the OCaml compiler to initialise
  ocaml-compiler: ${{ matrix.ocaml-compiler }}
 
  - name: Install dependencies

CHANGES.md

@@ -1,3 +1,19 @@
+merlin 4.13
+===========
+Mon Dec 18 16:42:00 CET 2023
+
+ + merlin binary
+ - Fix a follow-up issue to the preference of non-ghost nodes introduced in #1660 (#1690, fixes #1689)
+ - Add `-cache-lifespan` flag, that sets cache invalidation period. (#1698,
+ #1705)
+ - 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
 ===========
 Tue Sep 26 17:45:42 CEST 2023

doc/dev/CACHING.md

@@ -77,7 +77,8 @@ 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 300 seconds.
+entries that haven't been used in the last 5 minutes. This behavior can be
+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,6 +194,10 @@ 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-lifespan nil
+ "If non-nil, use this value for cache period (measured in minutes)."
+ :group 'merlin :type 'natnum)
+
 (defcustom merlin-arrow-keys-type-enclosing t
  "If non-nil, after a type enclosing, C-up and C-down are used
 to go up and down the AST. In addition, C-w copies the type to the
@@ -550,6 +554,8 @@ argument (lookup appropriate binary, setup logging, pass global settings)"
  (cons "-flags" merlin-buffer-flags))
  (when filename
  (cons "-filename" filename))
+ (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

@@ -91,6 +91,8 @@ let run = function
  (* Start processing query *)
  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_lifespan))) ();
  File_id.with_cache @@ fun () ->
  let source = Msource.make (Misc.string_of_file stdin) in
  let pipeline = Mpipeline.make config source in

src/frontend/ocamlmerlin/ocamlmerlin_server.ml

@@ -33,7 +33,6 @@ module Server = struct
 
  let server_accept merlinid server =
  let rec loop total =
- Mocaml.flush_caches ~older_than:300.0 ();
  let merlinid' = File_id.get Sys.executable_name in
  if total > merlin_timeout ||
  not (File_id.check merlinid merlinid') then

src/kernel/mbrowse.ml

@@ -120,11 +120,13 @@ let compare_locations pos l1 l2 =
  Location_aux.compare_pos pos l2
  with
  | 0, 0 ->
- (* Cursor inside both locations: favor closer to the end *)
- if l1.Location.loc_ghost then 1
- else if l2.Location.loc_ghost then -1
- else
- Lexing.compare_pos l1.Location.loc_end l2.Location.loc_end
+ (* Cursor inside both locations: favor non-ghost closer to the end *)
+ begin match l1.Location.loc_ghost, l2.Location.loc_ghost with
+ | true, false -> 1
+ | false, true -> -1
+ | _ ->
+ Lexing.compare_pos l1.Location.loc_end l2.Location.loc_end
+ end
  (* Cursor inside one location: it has priority *)
  | 0, _ -> t1_first
  | _, 0 -> t2_first

src/kernel/mconfig.ml

@@ -90,8 +90,9 @@ type merlin = {
  flags_applied : string list with_workdir list;
 
  failures : string list;
- extension_to_reader : (string * string) list
+ extension_to_reader : (string * string) list;
 
+ cache_lifespan : int
 }
 
 let dump_merlin x =
@@ -127,7 +128,8 @@ let dump_merlin x =
  "extension", `String suffix;
  "reader", `String reader;
  ]) x.extension_to_reader
- )
+ );
+ "cache_lifespan" , Json.string (string_of_int x.cache_lifespan)
  ]
 
 module Verbosity = struct
@@ -356,6 +358,15 @@ let merlin_flags = [
  marg_path (fun path merlin -> {merlin with stdlib = Some path}),
  "<path> Change path of ocaml standard library"
  );
+ (
+ "-cache-lifespan",
+ Marg.param "int" (fun prot merlin ->
+ 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. \
+ Default value is 5."
+ );
  (
  (* Legacy support for janestreet. Ignored. To be removed soon. *)
  "-attributes-allowed",
@@ -615,6 +626,7 @@ let initial = {
 
  failures = [];
  extension_to_reader = [(".re","reason");(".rei","reason")];
+ cache_lifespan = 5;
  };
  query = {
  filename = "*buffer*";

src/kernel/mconfig.mli

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

src/ocaml/preprocess/dune

@@ -9,7 +9,7 @@
 (menhir
  (modules parser_raw)
  (enabled_if (<> %{profile} "release"))
- (mode promote)
+ (mode (promote (only parser_raw.ml parser_raw.mli)))
  (flags :standard --inspection --table --cmly))
 
 (rule

src/ocaml/typing/typedecl.ml

@@ -957,7 +957,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

@@ -194,9 +194,11 @@ let rec transl_type env policy styp =
  try
  transl_type_aux env policy 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

@@ -66,7 +66,8 @@
  "extension": ".rei",
  "reader": "reason"
  }
- ]
+ ],
+ "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 \