From b91791a938fd414f076978451d8694d88ad2400a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 18 Dec 2023 16:18:16 +0100 Subject: [PATCH] [B] Backports from 501 - #1701 from voodoos/501-backports - #1715 from voodoos/501-backports --- .github/workflows/main.yml | 10 +-- CHANGES.md | 16 ++++ doc/dev/CACHING.md | 3 +- emacs/merlin.el | 8 +- src/analysis/locate.ml | 86 +++++++++---------- src/frontend/ocamlmerlin/new/new_merlin.ml | 2 + .../ocamlmerlin/ocamlmerlin_server.ml | 1 - src/kernel/mbrowse.ml | 12 +-- src/kernel/mconfig.ml | 16 +++- src/kernel/mconfig.mli | 3 +- src/ocaml/preprocess/dune | 2 +- src/ocaml/typing/typedecl.ml | 4 +- src/ocaml/typing/typetexp.ml | 4 +- .../config/dot-merlin-reader/quoting.t | 3 +- tests/test-dirs/document/issue1513.t | 4 +- .../errors/issue1704-wrong-message.t | 59 +++++++++++++ tests/test-dirs/locate/local-build-scheme.t | 48 +++++++++++ .../locate/non-local/ignore-kept-locs.t/run.t | 13 +-- tests/test-dirs/server-tests/cache-time.t | 37 ++++++++ vim/merlin/autoload/merlin.vim | 2 +- 20 files changed, 259 insertions(+), 74 deletions(-) create mode 100644 tests/test-dirs/errors/issue1704-wrong-message.t create mode 100644 tests/test-dirs/locate/local-build-scheme.t create mode 100644 tests/test-dirs/server-tests/cache-time.t diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index a49dfc9aa4..964f914976 100644 --- a/.github/workflows/main.yml +++ b/.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 diff --git a/CHANGES.md b/CHANGES.md index 88fc8bcfbb..e55d02bb29 100644 --- a/CHANGES.md +++ b/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 diff --git a/doc/dev/CACHING.md b/doc/dev/CACHING.md index 4f237121ee..a272e6633d 100644 --- a/doc/dev/CACHING.md +++ b/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. diff --git a/emacs/merlin.el b/emacs/merlin.el index c13fac943a..9100dfa360 100644 --- a/emacs/merlin.el +++ b/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 diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index b28029f66b..44236c0df5 100644 --- a/src/analysis/locate.ml +++ b/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,14 +361,15 @@ 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" @@ -374,7 +377,11 @@ let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace = 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 diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml index ef16dbca8b..2d6f16808b 100644 --- a/src/frontend/ocamlmerlin/new/new_merlin.ml +++ b/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 diff --git a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml index c74d8bc7ab..0cc4cbc29b 100644 --- a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml +++ b/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 diff --git a/src/kernel/mbrowse.ml b/src/kernel/mbrowse.ml index 7c8b68bfde..9ee7c27f87 100644 --- a/src/kernel/mbrowse.ml +++ b/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 diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 8f46224317..637653207f 100644 --- a/src/kernel/mconfig.ml +++ b/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}), " 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*"; diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index 2906337f09..b70847b302 100644 --- a/src/kernel/mconfig.mli +++ b/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 diff --git a/src/ocaml/preprocess/dune b/src/ocaml/preprocess/dune index c172777d31..ee9c283fab 100644 --- a/src/ocaml/preprocess/dune +++ b/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 diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index cc674ef95e..653a326359 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/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 *) diff --git a/src/ocaml/typing/typetexp.ml b/src/ocaml/typing/typetexp.ml index 61f5095866..f73893441a 100644 --- a/src/ocaml/typing/typetexp.ml +++ b/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 = []; diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t index a9363083d5..b9ae8c7eee 100644 --- a/tests/test-dirs/config/dot-merlin-reader/quoting.t +++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t @@ -66,7 +66,8 @@ "extension": ".rei", "reader": "reason" } - ] + ], + "cache_lifespan": "5" } $ rm .merlin diff --git a/tests/test-dirs/document/issue1513.t b/tests/test-dirs/document/issue1513.t index b9e18604f9..245bfed984 100644 --- a/tests/test-dirs/document/issue1513.t +++ b/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 &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 \ diff --git a/tests/test-dirs/errors/issue1704-wrong-message.t b/tests/test-dirs/errors/issue1704-wrong-message.t new file mode 100644 index 0000000000..b6e7faa11d --- /dev/null +++ b/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 experimental/m_intf.ml <<'EOF' + > module type S = sig val x : int end (* diff *) + > EOF + + $ cat >experimental/exp.ml <<'EOF' + > module M_intf = M_intf + > EOF + + $ cat >unix/m_intf.ml <<'EOF' + > module type S = sig val x : int end + > EOF + + $ cat >unix/unix.ml <<'EOF' + > module M_intf = M_intf + > EOF + + $ cat >hack.ml <<'EOF' + > let f (module R : Exp.M_intf.S) = + > let _ = R.x in + > () + > EOF + + $ cd experimental + $ $OCAMLC -keep-locs -bin-annot m_intf.ml exp.ml + $ cd .. + + $ cd unix + $ $OCAMLC -keep-locs -bin-annot m_intf.ml unix.ml + $ cd .. + + $ $OCAMLC -keep-locs -bin-annot -I experimental/ -I linux/ hack.ml + + $ $MERLIN single locate -position 2:12 -look-for implementation \ + > -build-path experimental -build-path unix \ + > -source-path . -source-path unix -source-path experimental \ + > -filename hack.ml sed 's/"file": ".*experimental.*"/"file": "experimental"/' | jq '.value' + { + "file": "experimental", + "pos": { + "line": 1, + "col": 20 + } + } + diff --git a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t index 218681b389..3a0fc89d37 100644 --- a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t +++ b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t @@ -20,8 +20,8 @@ available: } $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d' - Loading the shapes for unit "A" - Shapes successfully loaded, looking for A.0 + Loading the cmt for unit "A" + Looking for A.0 in the uid_to_loc table Found location: File "a.ml", line 1, characters 4-9 $ rm log @@ -41,8 +41,8 @@ available: } $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d' - Loading the shapes for unit "A" - Shapes successfully loaded, looking for A.0 + Loading the cmt for unit "A" + Looking for A.0 in the uid_to_loc table Found location: File "a.ml", line 1, characters 4-9 $ rm log @@ -66,6 +66,9 @@ In the absence of cmt though, fallbacking to the cmi loc makes sense: } $ grep -A1 from_uid log | grep -v from_uid - No UID found, fallbacking to lookup location. + Loading the cmt for unit "A" + -- + Failed to load the cmt file. + Fallbacking to lookup location: File "a.ml", line 1, characters 4-9 $ rm log diff --git a/tests/test-dirs/server-tests/cache-time.t b/tests/test-dirs/server-tests/cache-time.t new file mode 100644 index 0000000000..010b8373d7 --- /dev/null +++ b/tests/test-dirs/server-tests/cache-time.t @@ -0,0 +1,37 @@ + $ $MERLIN server stop-server + + $ cat >dune-project < (lang dune 2.0) + > EOF + + $ cat >dune < + > (executable + > (name main) + > (modules main) + > EOF + + $ cat > main.ml < let () = print_int 0 + > EOF + +Let's populate file cache + $ $MERLIN server errors -log-file merlin_logs -cache-lifespan 45 \ + > -filename main.ml 1> /dev/null -filename main.ml 1> /dev/null | tail -1 | sed 's/\ ".*\"//' + keeping + +When cache time is set to 0, file cache gets flushed + $ $MERLIN server errors -log-file merlin_logs -cache-lifespan 0 \ + > -filename main.ml 1> /dev/null | tail -1 | sed 's/\ ".*\"//' + removing + +Stop server + $ $MERLIN server stop-server diff --git a/vim/merlin/autoload/merlin.vim b/vim/merlin/autoload/merlin.vim index c743c60310..f78424cdd1 100644 --- a/vim/merlin/autoload/merlin.vim +++ b/vim/merlin/autoload/merlin.vim @@ -1,7 +1,7 @@ if !exists('g:merlin') | let g:merlin = {} | endif | let s:c = g:merlin if !exists('g:merlin_python_version') - if has('python3') + if has('python3') || has('python3_dynamic') let g:merlin_python_version = 3 elseif has('python') || has('python2') let g:merlin_python_version = 2