From 160f73498bcece3f421d573871554cd2e2776d70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Oct 2023 16:44:17 +0200 Subject: [PATCH] occurrences: handle project wide queries --- src/analysis/context.ml | 2 + src/analysis/index_format.ml | 82 ++++++++--------- src/analysis/occurrences.ml | 38 +++++--- .../occurrences/fields-in-patterns.t | 37 ++++++++ .../occurrences/project-wide/simple.t | 91 +++++++++++++++++++ 5 files changed, 193 insertions(+), 57 deletions(-) create mode 100644 tests/test-dirs/occurrences/fields-in-patterns.t create mode 100644 tests/test-dirs/occurrences/project-wide/simple.t diff --git a/src/analysis/context.ml b/src/analysis/context.ml index 35abbb070c..66e51c87ef 100644 --- a/src/analysis/context.ml +++ b/src/analysis/context.ml @@ -141,6 +141,8 @@ let inspect_browse_tree ~cursor lid browse : t option = | Pattern p -> inspect_pattern ~cursor ~lid p | Value_description _ | Type_declaration _ + | Constructor_declaration _ + | Label_declaration _ | Extension_constructor _ | Module_binding_name _ | Module_declaration_name _ -> diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml index 45502fa4ff..643289db5b 100644 --- a/src/analysis/index_format.ml +++ b/src/analysis/index_format.ml @@ -1,3 +1,6 @@ + +exception Not_an_index of string + module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct type t = Longident.t Location.loc @@ -23,23 +26,20 @@ let add tbl uid locs = Hashtbl.replace tbl uid (LidSet.union locs locations) with Not_found -> Hashtbl.add tbl uid locs -type payload = { +type index = { defs : (Shape.Uid.t, LidSet.t) Hashtbl.t; - partials : (Shape.t, LidSet.t) Hashtbl.t; - unreduced : (Shape.t * Longident.t Location.loc) list; + approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t; load_path : string list; cu_shape : (string, Shape.t) Hashtbl.t; } -type file_format = V1 of payload - let pp_partials (fmt : Format.formatter) - (partials : (Shape.t, LidSet.t) Hashtbl.t) = + (partials : (Shape.Uid.t, LidSet.t) Hashtbl.t) = Format.fprintf fmt "{@["; Hashtbl.iter - (fun shape locs -> - Format.fprintf fmt "@[shape: %a; locs:@ @[%a@]@]@;" Shape.print - shape + (fun uid locs -> + Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" + Shape.Uid.print uid (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") (fun fmt { Location.txt; loc } -> @@ -50,19 +50,7 @@ let pp_partials (fmt : Format.formatter) partials; Format.fprintf fmt "@]}" -let pp_unreduced (fmt : Format.formatter) - (unreduced : (Shape.t * Longident.t Location.loc) list) = - Format.fprintf fmt "{@["; - List.iter - (fun (shape, { Location.txt; loc }) -> - Format.fprintf fmt "@[shape: %a; locs:@ @[%s: %a@]@]@;" - Shape.print shape - (try Longident.flatten txt |> String.concat "." with _ -> "") - Location.print_loc loc) - unreduced; - Format.fprintf fmt "@]}" - -let pp_payload (fmt : Format.formatter) pl = +let pp (fmt : Format.formatter) pl = Format.fprintf fmt "%i uids:@ {@[" (Hashtbl.length pl.defs); Hashtbl.iter (fun uid locs -> @@ -77,31 +65,41 @@ let pp_payload (fmt : Format.formatter) pl = (LidSet.elements locs)) pl.defs; Format.fprintf fmt "@]},@ "; - Format.fprintf fmt "%i partial shapes:@ @[%a@],@ " - (Hashtbl.length pl.partials) - pp_partials pl.partials; - Format.fprintf fmt "%i unreduced shapes:@ @[%a@]@ " (List.length pl.unreduced) - pp_unreduced pl.unreduced; + Format.fprintf fmt "%i approx shapes:@ @[%a@],@ " + (Hashtbl.length pl.approximated) + pp_partials pl.approximated; Format.fprintf fmt "and shapes for CUS %s.@ " (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq)) -let pp (fmt : Format.formatter) ff = - match ff with V1 tbl -> Format.fprintf fmt "V1@,%a" pp_payload tbl - let ext = "uideps" -let write ~file tbl = - let oc = open_out_bin file in - Marshal.to_channel oc (V1 tbl) []; - close_out oc +(* [magic_number] Must be the same lenght as cmt's magic numbers *) +let magic_number = "Merl2023I001" + +let write ~file index = + Merlin_utils.Misc.output_to_file_via_temporary ~mode:[ Open_binary ] file + (fun _temp_file_name oc -> + output_string oc magic_number; + output_value oc (index : index)) + +type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown let read ~file = let ic = open_in_bin file in - try - let payload = - match Marshal.from_channel ic with V1 payload -> payload - (* TODO is that "safe" ? We probably want some magic number *) - in - close_in ic; - payload - with e -> raise e (* todo *) + Merlin_utils.Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> + let file_magic_number = ref (Cmt_format.read_magic_number ic) in + let cmi_magic_number = Ocaml_utils.Config.cmi_magic_number in + let cmt_magic_number = Ocaml_utils.Config.cmt_magic_number in + (if String.equal !file_magic_number cmi_magic_number then + let _ = Cmi_format.input_cmi ic in + file_magic_number := Cmt_format.read_magic_number ic); + if String.equal !file_magic_number cmt_magic_number then + Cmt (input_value ic : Cmt_format.cmt_infos) + else if String.equal !file_magic_number magic_number then + Index (input_value ic : index) + else Unknown) + +let read_exn ~file = + match read ~file with Index index -> index | _ -> raise (Not_an_index file) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index b84d4b94f8..b4d35ba48d 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -41,10 +41,6 @@ let index_buffer ~env ~local_defs () = | _ -> ()); defs -let load_external_index ~index_file = - let uideps = Index_format.read ~file:index_file in - uideps - let merge_tbl ~into tbl = Hashtbl.iter (Index_format.add into) tbl (* A longident can have the form: A.B.x Right now we are only interested in @@ -76,6 +72,10 @@ let uid_and_loc_of_node env node = Some (uid, name.loc) | Type_declaration { typ_type; typ_name; _ } -> Some (typ_type.type_uid, typ_name.loc) + | Label_declaration { ld_uid; ld_loc ; _ } -> + Some (ld_uid, ld_loc) + | Constructor_declaration { cd_uid; cd_loc ; _ } -> + Some (cd_uid, cd_loc) | Value_description { val_val; val_name; _ } -> Some (val_val.val_uid, val_name.loc) | _ -> None @@ -122,21 +122,22 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path = log ~title:"locs_of" "Locate failed to find a definition."; None in + let current_buffer_path = + Filename.concat config.query.directory config.query.filename + in match def with - | Some (uid, loc) -> + | Some (uid, def_loc) -> log ~title:"locs_of" "Definition has uid %a (%a)" Logger.fmt (fun fmt -> Shape.Uid.print fmt uid) - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - (* Todo: use magic number instead and don't use the lib *) - let index_file = None (* todo *) in + Logger.fmt (fun fmt -> Location.print_loc fmt def_loc); log ~title:"locs_of" "Indexing current buffer"; let index = index_buffer ~env ~local_defs () in if scope = `Project then begin - match index_file with + match config.merlin.index_file with | None -> log ~title:"locs_of" "No external index specified" - | Some index_file -> - log ~title:"locs_of" "Using external index: %S" index_file; - let external_uideps = load_external_index ~index_file in + | Some file -> + log ~title:"locs_of" "Using external index: %S" file; + let external_uideps = Index_format.read_exn ~file in merge_tbl ~into:index external_uideps.defs end; (* TODO ignore externally indexed locs from the current buffer *) @@ -146,7 +147,11 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path = |> List.filter_map ~f:(fun lid -> let loc = last_loc lid.Location.loc lid.txt in let fname = loc.Location.loc_start.Lexing.pos_fname in - if Filename.is_relative fname then begin + if String.equal fname current_buffer_path then + (* ignore locs coming from the external index for the buffer *) + (* maybe filter before *) + None + else if Filename.is_relative fname then begin match Locate.find_source ~config loc fname with | `Found (Some file, _) -> Some { loc with loc_start = { loc.loc_start with pos_fname = file}} @@ -165,6 +170,9 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path = let by = Env.get_unit_name () |> String.lowercase_ascii in String.is_prefixed ~by (loc.loc_start.pos_fname |> String.lowercase_ascii) in - if scope = `Project || loc_in_unit loc then Ok (loc::locs) - else Ok locs + if loc_in_unit def_loc then + let def_loc = {def_loc with + loc_start = {def_loc.loc_start with pos_fname = current_buffer_path }} in + Ok (def_loc::locs) + else Ok locs | None -> Error "nouid" diff --git a/tests/test-dirs/occurrences/fields-in-patterns.t b/tests/test-dirs/occurrences/fields-in-patterns.t new file mode 100644 index 0000000000..50e6b2d492 --- /dev/null +++ b/tests/test-dirs/occurrences/fields-in-patterns.t @@ -0,0 +1,37 @@ + $ cat >main.ml < type t = { lbl_a : int } + > let f (x : t) = match x with + > | { lbl_a } -> ignore lbl_a + > EOF + + + $ $MERLIN single occurrences -identifier-at 3:8 -scope project \ + > -filename main.ml dune-workspace <<'EOF' + > (lang dune 3.11) + > (workspace_indexation enabled) + > EOF + + $ cat >dune-project <<'EOF' + > (lang dune 3.11) + > EOF + + $ mkdir lib + $ cat >lib/lib.ml <<'EOF' + > let x = 42 + > let y = x + > EOF + + $ cat >lib/dune <<'EOF' + > (library + > (name lib)) + > EOF + + $ mkdir exe + $ cat >exe/main.ml <<'EOF' + > print_int Lib.x + > EOF + + $ cat >exe/dune <<'EOF' + > (library + > (name main) + > (libraries lib)) + > EOF + + $ dune build @all + ld: warning: -undefined suppress is deprecated + ld: warning: -undefined suppress is deprecated + ld: warning: -undefined suppress is deprecated + ld: warning: -undefined suppress is deprecated + + $ ocaml-index dump _build/default/project.ocaml-index + 3 uids: + {uid: Lib.1; locs: + "y": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 4-5 + uid: Stdlib.313; locs: + "print_int": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 0-9 + uid: Lib.0; locs: + "Lib.x": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 10-15; + "x": File "$TESTCASE_ROOT/lib/lib.ml", line 1, characters 4-5; + "x": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 8-9 + }, 0 approx shapes: {}, and shapes for CUS . + +Occurrences of Lib.x + $ $MERLIN single occurrences -scope project -identifier-at 1:15 \ + > -filename exe/main.ml