From df27557226933d9fe3434e03fcb064f352d33d39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 17 May 2024 10:25:53 +0200 Subject: [PATCH] Revert: remove raparsing of longident to index modules in paths This reparsing has very bad performances. The correct way to deal with issue is to have the compiler store precise locations in longidents. --- src/analysis/occurrences.ml | 42 ++---------- src/analysis/occurrences.mli | 1 - src/frontend/query_commands.ml | 3 +- tests/test-dirs/occurrences/mod-in-path-2.t | 21 +----- tests/test-dirs/occurrences/mod-in-path-3.t | 21 +----- tests/test-dirs/occurrences/mod-in-path.t | 73 +-------------------- 6 files changed, 10 insertions(+), 151 deletions(-) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index a1236a483..c3ce3abbe 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -25,7 +25,7 @@ let decl_of_path_or_lid env namespace path lid = end | _ -> Env_lookup.by_path path namespace env -let index_buffer_ ~config ~source ~current_buffer_path ~local_defs () = +let index_buffer_ ~current_buffer_path ~local_defs () = let {Logger. log} = Logger.for_section "index" in let defs = Hashtbl.create 64 in let module Shape_reduce = @@ -80,38 +80,6 @@ let index_buffer_ ~config ~source ~current_buffer_path ~local_defs () = index_decl () end in - let f ~namespace env path (lid : Longident.t Location.loc) = - (* The compiler lacks sufficient location information to precisely hihglight - modules in paths. This function hacks around that issue when looking for - occurrences in the current buffer only. *) - (* We rely on a custom re-parsing of the longidents that provide us with - location information and match these with the real path and longident. *) - let rec iter_on_path ~namespace (path : Path.t) lid reparsed = - log ~title:"iter_on_path" "Path %a, lid: %a" - Logger.fmt (Fun.flip Path.print path) - Logger.fmt (Fun.flip Pprintast.longident lid.Location.txt); - match path, lid.txt, reparsed with - | Pdot (path', n), (Ldot (_, s) | Lident s), _ - when n <> s && String.lowercase_ascii n = n -> - iter_on_path ~namespace path' lid reparsed - | (Pdot _ | Pident _), Lident s, [{ Location.txt = name; loc}] - when name = s -> - log ~title:"iter_on_path" "Last %a, lid: %a" - Logger.fmt (Fun.flip Path.print path) - Logger.fmt (Fun.flip Pprintast.longident lid.Location.txt); - f ~namespace env path { lid with loc = loc } - | Pdot (path', _), Ldot (lid', s), { txt = name; loc} :: tl when name = s -> - let () = f ~namespace env path { lid with loc = loc } in - iter_on_path ~namespace:Module path' { lid with txt = lid' } tl - | Papply _, _, _ -> f ~namespace env path lid - | _, _, _ -> f ~namespace env path lid - in - let reparsed_lid = - Misc_utils.parse_identifier (config, source) lid.loc.loc_end - |> List.rev - in - iter_on_path ~namespace path lid reparsed_lid - in Ast_iterators.iter_on_usages ~f local_defs; defs @@ -119,7 +87,7 @@ let index_buffer = (* Right now, we only cache the last used index. We could do better by caching the index for every known buffer. *) let cache = ref None in - fun ~config ~source ~current_buffer_path ~stamp ~local_defs () -> + fun ~current_buffer_path ~stamp ~local_defs () -> let {Logger. log} = Logger.for_section "index" in match !cache with | Some (path, stamp', value) when @@ -131,7 +99,7 @@ let index_buffer = | _ -> log ~title:"index_cache" "No valid cache found, reindexing."; let result = - index_buffer_ ~config ~source ~current_buffer_path ~local_defs () + index_buffer_ ~current_buffer_path ~local_defs () in cache := Some (current_buffer_path, stamp, result); result @@ -189,7 +157,7 @@ let comp_unit_of_uid = function | Item { comp_unit; _ } -> Some comp_unit | Internal | Predef _ -> None -let locs_of ~config ~source ~env ~typer_result ~pos path = +let locs_of ~config ~env ~typer_result ~pos path = log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" path (Lexing.print_position () pos); @@ -233,7 +201,7 @@ let locs_of ~config ~source ~env ~typer_result ~pos path = log ~title:"locs_of" "Indexing current buffer"; let buffer_index = let stamp = Mtyper.get_stamp typer_result in - index_buffer ~config ~source ~current_buffer_path ~stamp ~local_defs () + index_buffer ~current_buffer_path ~stamp ~local_defs () in let buffer_locs = Hashtbl.find_opt buffer_index def_uid in let locs = Option.value ~default:LidSet.empty buffer_locs in diff --git a/src/analysis/occurrences.mli b/src/analysis/occurrences.mli index 871341430..eea7b6b3e 100644 --- a/src/analysis/occurrences.mli +++ b/src/analysis/occurrences.mli @@ -1,6 +1,5 @@ val locs_of : config:Mconfig.t - -> source:Msource.t -> env:Env.t -> typer_result:Mtyper.result -> pos:Lexing.position diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index e5b1518ff..b2686fbe5 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -797,7 +797,6 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | Occurrences (`Ident_at pos, _) -> let config = Mpipeline.final_config pipeline in - let source = Mpipeline.raw_source pipeline in let typer_result = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in let env, _node = Mbrowse.leaf_node (Mtyper.node_at typer_result pos) in @@ -810,7 +809,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = path in let locs = - Occurrences.locs_of ~config ~source ~env ~typer_result ~pos path + Occurrences.locs_of ~config ~env ~typer_result ~pos path |> Result.value ~default:[] in let loc_start l = l.Location.loc_start in diff --git a/tests/test-dirs/occurrences/mod-in-path-2.t b/tests/test-dirs/occurrences/mod-in-path-2.t index 1f120c0a2..b335bca5e 100644 --- a/tests/test-dirs/occurrences/mod-in-path-2.t +++ b/tests/test-dirs/occurrences/mod-in-path-2.t @@ -7,6 +7,7 @@ > | Mod.A -> () > EOF +FIXME: we could expect module appearing in paths to be highlighted $ $MERLIN single occurrences -identifier-at 1:8 -filename test.ml jq '.value' [ @@ -19,26 +20,6 @@ "line": 1, "col": 10 } - }, - { - "start": { - "line": 5, - "col": 8 - }, - "end": { - "line": 5, - "col": 11 - } - }, - { - "start": { - "line": 6, - "col": 4 - }, - "end": { - "line": 6, - "col": 7 - } } ] diff --git a/tests/test-dirs/occurrences/mod-in-path-3.t b/tests/test-dirs/occurrences/mod-in-path-3.t index 6ba604a26..e0f972739 100644 --- a/tests/test-dirs/occurrences/mod-in-path-3.t +++ b/tests/test-dirs/occurrences/mod-in-path-3.t @@ -8,6 +8,7 @@ > | Mod.A r -> r.lbl > EOF +FIXME: we could expect module appearing in paths to be highlighted $ $MERLIN single occurrences -identifier-at 4:9 -filename test.ml jq '.value' [ @@ -20,26 +21,6 @@ "line": 1, "col": 10 } - }, - { - "start": { - "line": 4, - "col": 8 - }, - "end": { - "line": 4, - "col": 11 - } - }, - { - "start": { - "line": 7, - "col": 4 - }, - "end": { - "line": 7, - "col": 7 - } } ] diff --git a/tests/test-dirs/occurrences/mod-in-path.t b/tests/test-dirs/occurrences/mod-in-path.t index eeadb5848..010ec9054 100644 --- a/tests/test-dirs/occurrences/mod-in-path.t +++ b/tests/test-dirs/occurrences/mod-in-path.t @@ -13,6 +13,7 @@ > let _ = let open Mod in Nod.x > EOF +FIXME: we could expect module appearing in paths to be highlighted $ $MERLIN single occurrences -identifier-at 6:13 -filename test.ml jq '.value' [ @@ -25,50 +26,10 @@ "line": 2, "col": 12 } - }, - { - "start": { - "line": 6, - "col": 12 - }, - "end": { - "line": 6, - "col": 15 - } - }, - { - "start": { - "line": 7, - "col": 14 - }, - "end": { - "line": 7, - "col": 17 - } - }, - { - "start": { - "line": 9, - "col": 0 - }, - "end": { - "line": 9, - "col": 3 - } - }, - { - "start": { - "line": 12, - "col": 24 - }, - "end": { - "line": 12, - "col": 27 - } } ] - +FIXME: we could expect module appearing in paths to be highlighted $ $MERLIN single occurrences -identifier-at 12:18 -filename test.ml jq '.value' [ @@ -82,36 +43,6 @@ "col": 10 } }, - { - "start": { - "line": 6, - "col": 8 - }, - "end": { - "line": 6, - "col": 11 - } - }, - { - "start": { - "line": 7, - "col": 8 - }, - "end": { - "line": 7, - "col": 11 - } - }, - { - "start": { - "line": 8, - "col": 8 - }, - "end": { - "line": 8, - "col": 11 - } - }, { "start": { "line": 12,