Skip to content

Commit

Permalink
Backports for release 4.13-500 (#1718)
Browse files Browse the repository at this point in the history
from voodoos/500-backports
  • Loading branch information
voodoos committed Dec 18, 2023
2 parents a335fff + b91791a commit 0fe8dd9
Show file tree
Hide file tree
Showing 20 changed files with 259 additions and 74 deletions.
10 changes: 5 additions & 5 deletions .github/workflows/main.yml
Original file line number Diff line number Diff line change
Expand Up @@ -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 }}

Expand All @@ -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
Expand Down
16 changes: 16 additions & 0 deletions CHANGES.md
Original file line number Diff line number Diff line change
@@ -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
Expand Down
3 changes: 2 additions & 1 deletion doc/dev/CACHING.md
Original file line number Diff line number Diff line change
Expand Up @@ -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.

Expand Down
8 changes: 7 additions & 1 deletion emacs/merlin.el
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
86 changes: 40 additions & 46 deletions src/analysis/locate.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand All @@ -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
Expand Down
2 changes: 2 additions & 0 deletions src/frontend/ocamlmerlin/new/new_merlin.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 0 additions & 1 deletion src/frontend/ocamlmerlin/ocamlmerlin_server.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
12 changes: 7 additions & 5 deletions src/kernel/mbrowse.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
16 changes: 14 additions & 2 deletions src/kernel/mconfig.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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",
Expand Down Expand Up @@ -615,6 +626,7 @@ let initial = {

failures = [];
extension_to_reader = [(".re","reason");(".rei","reason")];
cache_lifespan = 5;
};
query = {
filename = "*buffer*";
Expand Down
3 changes: 2 additions & 1 deletion src/kernel/mconfig.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion src/ocaml/preprocess/dune
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 3 additions & 1 deletion src/ocaml/typing/typedecl.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 *)
Expand Down
4 changes: 3 additions & 1 deletion src/ocaml/typing/typetexp.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 = [];
Expand Down
3 changes: 2 additions & 1 deletion tests/test-dirs/config/dot-merlin-reader/quoting.t
Original file line number Diff line number Diff line change
Expand Up @@ -66,7 +66,8 @@
"extension": ".rei",
"reader": "reason"
}
]
],
"cache_lifespan": "5"
}
$ rm .merlin
4 changes: 2 additions & 2 deletions tests/test-dirs/document/issue1513.t
Original file line number Diff line number Diff line change
Expand Up @@ -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 \
Expand Down

0 comments on commit 0fe8dd9

Please sign in to comment.