Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Perform incremental indexation of the buffer when typing #1777

Merged
merged 3 commits into from
Jun 4, 2024
Merged

Perform incremental indexation of the buffer when typing #1777

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
1577d8f
refactor: properly define mtyper cache type
voodoos Jun 3, 2024
a4bb508
occurrences: incrementally index the buffer in Mtyper
voodoos Jun 3, 2024
dd4312e
Add changelog for #1777
voodoos Jun 4, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions CHANGES.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ UNRELEASED
use when looking for occurrences.
- A new `UNIT_NAME` configuration directive that can be used to tell Merlin
the correct name of the current unit in the presence of wrapping (#1776)
- Perform incremental indexation of the buffer when typing. (#1777)
+ editor modes
- emacs: add basic support for project-wide occurrences (#1766)

Expand Down
4 changes: 4 additions & 0 deletions src/analysis/ast_iterators.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -139,3 +139,7 @@ let iter_on_usages ~f (local_defs : Mtyper.typedtree) =
begin match local_defs with
| `Interface signature -> iter.signature iter signature
| `Implementation structure -> iter.structure iter structure end

let iterator_on_usages ~f =
let occ_iter = Cmt_format.iter_on_occurrences ~f in
iter_only_visible occ_iter
96 changes: 96 additions & 0 deletions src/analysis/index_occurrences.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,96 @@
open Std
module Lid_set = Index_format.Lid_set
let {Logger. log} = Logger.for_section "index-occurrences"

let set_fname ~file (loc : Location.t) =
let pos_fname = file in
{ loc with
loc_start = { loc.loc_start with pos_fname };
loc_end = { loc.loc_end with pos_fname }}

let decl_of_path_or_lid env namespace path lid =
match (namespace : Shape.Sig_component_kind.t) with
| Constructor ->
begin match Env.find_constructor_by_name lid env with
| exception Not_found -> None
| {cstr_uid; cstr_loc; _ } ->
Some { Env_lookup.uid = cstr_uid; loc = cstr_loc; namespace }
end
| Label ->
begin match Env.find_label_by_name lid env with
| exception Not_found -> None
| {lbl_uid; lbl_loc; _ } ->
Some { Env_lookup.uid = lbl_uid; loc = lbl_loc; namespace }
end
| _ -> Env_lookup.by_path path namespace env

let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid =
let add uid loc =
Stamped_hashtable.add index ~stamp (uid, loc) ()
in
let f ~namespace env path (lid : Longident.t Location.loc) =
log ~title:"index_buffer" "Path: %a" Logger.fmt (Fun.flip Path.print path);
let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in
let index_decl () =
begin match decl_of_path_or_lid env namespace path lid.txt with
| exception _ | None -> log ~title:"index_buffer" "Declaration not found"
| Some decl ->
log ~title:"index_buffer" "Found declaration: %a"
Logger.fmt (Fun.flip Location.print_loc decl.loc);
add decl.uid lid
end
in
if not_ghost lid then
match Env.shape_of_path ~namespace env path with
| exception Not_found -> ()
| path_shape ->
log ~title:"index_buffer" "Shape of path: %a"
Logger.fmt (Fun.flip Shape.print path_shape);
let result = reduce_for_uid env path_shape in
begin match Locate.uid_of_result ~traverse_aliases:false result with
| Some uid, false ->
log ~title:"index_buffer" "Found %a (%a) wiht uid %a"
Logger.fmt (Fun.flip Pprintast.longident lid.txt)
Logger.fmt (Fun.flip Location.print_loc lid.loc)
Logger.fmt (Fun.flip Shape.Uid.print uid);
add uid lid
| Some uid, true ->
log ~title:"index_buffer" "Shape is approximative, found uid: %a"
Logger.fmt (Fun.flip Shape.Uid.print uid);
index_decl ()
| None, _ ->
log ~title:"index_buffer" "Reduction failed: missing uid";
index_decl ()
end
in
Ast_iterators.iterator_on_usages ~f

let items ~index ~stamp (config : Mconfig.t) items =
let module Shape_reduce =
Shape_reduce.Make (struct
let fuel = 10

let read_unit_shape ~unit_name =
log ~title:"read_unit_shape" "inspecting %s" unit_name;
let cmt = Format.sprintf "%s.cmt" unit_name in
match Cmt_cache.read (Load_path.find_normalized cmt) with
| { cmt_infos = { cmt_impl_shape; _ }; _ } ->
log ~title:"read_unit_shape" "shapes loaded for %s" unit_name;
cmt_impl_shape
| exception _ ->
log ~title:"read_unit_shape" "failed to find %s" unit_name;
None
end)
in
let current_buffer_path =
Filename.concat config.query.directory config.query.filename
in
let reduce_for_uid = Shape_reduce.reduce_for_uid in
let iterator = iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid in
match items with
| `Impl items ->
List.iter ~f:(iterator.structure_item iterator) items
| `Intf items ->
List.iter ~f:(iterator.signature_item iterator) items

123 changes: 11 additions & 112 deletions src/analysis/occurrences.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,114 +5,14 @@ let {Logger. log} = Logger.for_section "occurrences"

type t = { locs: Warnings.loc list; status: Query_protocol.occurrences_status }

let () = Mtyper.set_index_items Index_occurrences.items

let set_fname ~file (loc : Location.t) =
let pos_fname = file in
{ loc with
loc_start = { loc.loc_start with pos_fname };
loc_end = { loc.loc_end with pos_fname }}

let decl_of_path_or_lid env namespace path lid =
match (namespace : Shape.Sig_component_kind.t) with
| Constructor ->
begin match Env.find_constructor_by_name lid env with
| exception Not_found -> None
| {cstr_uid; cstr_loc; _ } ->
Some { Env_lookup.uid = cstr_uid; loc = cstr_loc; namespace }
end
| Label ->
begin match Env.find_label_by_name lid env with
| exception Not_found -> None
| {lbl_uid; lbl_loc; _ } ->
Some { Env_lookup.uid = lbl_uid; loc = lbl_loc; namespace }
end
| _ -> Env_lookup.by_path path namespace env

let index_buffer_ ~current_buffer_path ~local_defs () =
let {Logger. log} = Logger.for_section "index" in
let defs = Hashtbl.create 64 in
let add tbl uid locs =
try
let locations = Hashtbl.find tbl uid in
Hashtbl.replace tbl uid (Lid_set.union locs locations)
with Not_found -> Hashtbl.add tbl uid locs
in
let module Shape_reduce =
Shape_reduce.Make (struct
let fuel = 10

let read_unit_shape ~unit_name =
log ~title:"read_unit_shape" "inspecting %s" unit_name;
let cmt = Format.sprintf "%s.cmt" unit_name in
match Cmt_cache.read (Load_path.find_normalized cmt) with
| { cmt_infos = { cmt_impl_shape; _ }; _ } ->
log ~title:"read_unit_shape" "shapes loaded for %s" unit_name;
cmt_impl_shape
| exception _ ->
log ~title:"read_unit_shape" "failed to find %s" unit_name;
None
end)
in
let f ~namespace env path (lid : Longident.t Location.loc) =
log ~title:"index_buffer" "Path: %a" Logger.fmt (Fun.flip Path.print path);
let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in
let index_decl () =
begin match decl_of_path_or_lid env namespace path lid.txt with
| exception _ | None -> log ~title:"index_buffer" "Declaration not found"
| Some decl ->
log ~title:"index_buffer" "Found declaration: %a"
Logger.fmt (Fun.flip Location.print_loc decl.loc);
add defs decl.uid (Lid_set.singleton lid)
end
in
if not_ghost lid then
match Env.shape_of_path ~namespace env path with
| exception Not_found -> ()
| path_shape ->
log ~title:"index_buffer" "Shape of path: %a"
Logger.fmt (Fun.flip Shape.print path_shape);
let result = Shape_reduce.reduce_for_uid env path_shape in
begin match Locate.uid_of_result ~traverse_aliases:false result with
| Some uid, false ->
log ~title:"index_buffer" "Found %a (%a) wiht uid %a"
Logger.fmt (Fun.flip Pprintast.longident lid.txt)
Logger.fmt (Fun.flip Location.print_loc lid.loc)
Logger.fmt (Fun.flip Shape.Uid.print uid);
add defs uid (Lid_set.singleton lid)
| Some uid, true ->
log ~title:"index_buffer" "Shape is approximative, found uid: %a"
Logger.fmt (Fun.flip Shape.Uid.print uid);
index_decl ()
| None, _ ->
log ~title:"index_buffer" "Reduction failed: missing uid";
index_decl ()
end
in
Ast_iterators.iter_on_usages ~f local_defs;
defs

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 ~scope ~current_buffer_path ~stamp ~local_defs () ->
let {Logger. log} = Logger.for_section "index" in
match !cache with
| Some (path, stamp', scope', value) when
String.equal path current_buffer_path
&& Int.equal stamp' stamp
&& scope' = scope ->
log ~title:"index_cache" "Reusing cached value for path %s and stamp %i."
path stamp';
value
| _ ->
log ~title:"index_cache" "No valid cache found, reindexing.";
let result =
index_buffer_ ~current_buffer_path ~local_defs ()
in
cache := Some (current_buffer_path, stamp, scope, result);
result

(* A longident can have the form: A.B.x Right now we are only interested in
values, but we will eventually want to index all occurrences of modules in
such longidents. However there is an issue with that: we only have the
Expand Down Expand Up @@ -210,6 +110,13 @@ end = struct
| None -> cache_and_return (stat t file)
end

let get_buffer_locs result uid =
Stamped_hashtable.fold
(fun (uid', loc) () acc ->
if Shape.Uid.equal uid uid' then Lid_set.add loc acc else acc)
(Mtyper.get_index result)
Lid_set.empty

let locs_of ~config ~env ~typer_result ~pos ~scope path =
log ~title:"occurrences" "Looking for occurences of %s (pos: %s)"
path
Expand Down Expand Up @@ -253,11 +160,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
Logger.fmt (fun fmt -> Shape.Uid.print fmt def_uid)
Logger.fmt (fun fmt -> Location.print_loc fmt def_loc);
log ~title:"locs_of" "Indexing current buffer";
let buffer_index =
let stamp = Mtyper.get_stamp typer_result in
index_buffer ~scope ~current_buffer_path ~stamp ~local_defs ()
in
let buffer_locs = Hashtbl.find_opt buffer_index def_uid in
let buffer_locs = get_buffer_locs typer_result def_uid in
let external_locs =
if scope = `Buffer then []
else List.filter_map config.merlin.index_files ~f:(fun file ->
Expand Down Expand Up @@ -291,11 +194,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
(Lid_set.union acc_locs locs, String.Set.union acc_files files))
(external_locs)
in
let locs =
match buffer_locs with
| Some buffer_locs -> Lid_set.union buffer_locs external_locs
| None -> external_locs
in
let locs = Lid_set.union buffer_locs external_locs in
let locs =
log ~title:"occurrences" "Found %i locs" (Lid_set.cardinal locs);
Lid_set.elements locs
Expand Down
Loading
Loading