occurrences: handle project wide queries

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 _ ->

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 "@[<hov 2>shape: %a; locs:@ @[<v>%a@]@]@;" Shape.print
-        shape
+    (fun uid locs ->
+      Format.fprintf fmt "@[<hov 2>uid: %a; locs:@ @[<v>%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 "@[<hov 2>shape: %a; locs:@ @[<v>%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)

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"

tests/test-dirs/occurrences/fields-in-patterns.t

@@ -0,0 +1,37 @@
+  $ cat >main.ml <<EOF
+  > 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 <main.ml 
+  {
+    "class": "return",
+    "value": [
+      {
+        "file": "$TESTCASE_ROOT/main.ml",
+        "start": {
+          "line": 3,
+          "col": 6
+        },
+        "end": {
+          "line": 3,
+          "col": 11
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/main.ml",
+        "start": {
+          "line": 3,
+          "col": 24
+        },
+        "end": {
+          "line": 3,
+          "col": 29
+        }
+      }
+    ],
+    "notifications": []
+  }

tests/test-dirs/occurrences/project-wide/simple.t

@@ -0,0 +1,91 @@
+  $ cat >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 <exe/main.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "file": "$TESTCASE_ROOT/lib/lib.ml",
+        "start": {
+          "line": 1,
+          "col": 4
+        },
+        "end": {
+          "line": 1,
+          "col": 5
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/exe/main.ml",
+        "start": {
+          "line": 1,
+          "col": 14
+        },
+        "end": {
+          "line": 1,
+          "col": 15
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/lib/lib.ml",
+        "start": {
+          "line": 2,
+          "col": 8
+        },
+        "end": {
+          "line": 2,
+          "col": 9
+        }
+      }
+    ],
+    "notifications": []
+  }