Add support for project-wide occurrences to Merlin 4.14-502

emacs/merlin.el

@@ -1784,24 +1784,20 @@ Empty string defaults to jumping to all these."
       (let ((inhibit-read-only t)
             (buffer-undo-list t)
             (pending-line)
-            (pending-lines-text))
+            (pending-lines-text)
+            (previous-buf))
         (erase-buffer)
         (occur-mode)
-        (insert (propertize (format "%d occurrences in buffer: %s"
-                                    (length lst)
-                                    src-buff)
-                            'font-lock-face list-matching-lines-buffer-name-face
-                            'read-only t
-                            'occur-title (get-buffer src-buff)))
-        (insert "\n")
         (dolist (pos positions)
-          (let* ((marker (cdr (assoc 'marker pos)))
-                 (start (assoc 'start pos))
+          (let* ((start (assoc 'start pos))
                  (end (assoc 'end pos))
+                 (occ-buff (find-file-noselect (cdr (assoc 'file pos))))
+                 (marker (with-current-buffer occ-buff
+                          (copy-marker (merlin--point-of-pos start))))
                  (line (cdr (assoc 'line start)))
-                 (start-buf-pos (with-current-buffer src-buff
+                 (start-buf-pos (with-current-buffer occ-buff
                                   (merlin--point-of-pos start)))
-                 (end-buf-pos (with-current-buffer src-buff
+                 (end-buf-pos (with-current-buffer occ-buff
                                 (merlin--point-of-pos end)))
                  (prefix-length 8)
                  (start-offset (+ prefix-length
@@ -1813,8 +1809,7 @@ Empty string defaults to jumping to all these."
                                             marker
                                             start-buf-pos
                                             end-buf-pos
-                                            src-buff))))
-
+                                            occ-buff))))
             ;; Insert the critical text properties that occur-mode
             ;; makes use of
             (add-text-properties start-offset
@@ -1828,9 +1823,22 @@ Empty string defaults to jumping to all these."
             ;; found in order to accumulate multiple matches within
             ;; one line.
             (when (and pending-lines-text
-                       (not (equal line pending-line)))
+                       (or (not (equal line pending-line))
+                           (not (equal previous-buf occ-buff))))
               (insert pending-lines-text))
+
+            (when (not (equal previous-buf occ-buff))
+              (insert (propertize (format "Occurrences in buffer: %s"
+                                          ;(length lst)
+                                          occ-buff)
+                                  'font-lock-face
+                                    list-matching-lines-buffer-name-face
+                                  'read-only t
+                                  'occur-title occ-buff))
+              (insert "\n"))
+
             (setq pending-line line)
+            (setq previous-buf occ-buff)
             (setq pending-lines-text lines-text)))
 
         ;; Catch final pending text
@@ -1860,6 +1868,19 @@ Empty string defaults to jumping to all these."
           (merlin-occurrences-list r)
         (error "%s" r)))))
 
+(defun merlin--project-occurrences ()
+  (merlin-call "occurrences" "-scope" "project" "-identifier-at"
+    (merlin-unmake-point (point))))
+
+(defun merlin-project-occurrences ()
+  "List all occurrences of identifier under cursor in buffer."
+  (interactive)
+  (let ((r (merlin--project-occurrences)))
+    (when r
+      (if (listp r)
+          (merlin-occurrences-list r)
+        (error "%s" r)))))
+
 ;;;;;;;;;;;;;;;;;;;
 ;; OPEN REFACTOR ;;
 ;;;;;;;;;;;;;;;;;;;

src/analysis/dune

@@ -10,16 +10,19 @@
   -open Merlin_utils
   -open Merlin_specific
   -open Merlin_extend
-  -open Merlin_kernel)
+  -open Merlin_kernel
+  -open Merlin_index_format)
  (libraries
   merlin_config
   merlin_specific
   merlin_extend
   merlin_kernel
   merlin_utils
+  merlin_index_format
   ocaml_parsing
   ocaml_preprocess
   query_protocol
   ocaml_typing
   ocaml_utils
-  str))
+  str
+  unix))

src/analysis/occurrences.ml

@@ -1,8 +1,10 @@
 open Std
-module LidSet = Index_format.LidSet
+module Lid_set = Index_format.Lid_set
 
 let {Logger. log} = Logger.for_section "occurrences"
 
+type res = { locs: Warnings.loc list; synced: bool }
+
 let set_fname ~file (loc : Location.t) =
   let pos_fname = file in
   { loc with
@@ -25,9 +27,15 @@ let decl_of_path_or_lid env namespace path lid =
     end
   | _ -> Env_lookup.loc path namespace env
 
-let index_buffer_ ~current_buffer_path ~local_defs () =
+let index_buffer_ ~scope ~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
@@ -54,7 +62,7 @@ let index_buffer_ ~current_buffer_path ~local_defs () =
       | Some decl ->
         log ~title:"index_buffer" "Found declaration: %a"
           Logger.fmt (Fun.flip Location.print_loc decl.loc);
-        Index_format.(add defs decl.uid (LidSet.singleton lid))
+        add defs decl.uid (Lid_set.singleton lid)
       end
     in
      if not_ghost lid then
@@ -70,7 +78,7 @@ let index_buffer_ ~current_buffer_path ~local_defs () =
             (Longident.head lid.txt)
             Logger.fmt (Fun.flip Location.print_loc lid.loc)
             Logger.fmt (Fun.flip Shape.Uid.print uid);
-            Index_format.(add defs uid (LidSet.singleton lid))
+            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);
@@ -86,6 +94,7 @@ let index_buffer_ ~current_buffer_path ~local_defs () =
        occurrences in the current buffer only. *)
     let rec iter_on_path ~namespace path ({Location.txt; loc} as lid) =
       let () = f ~namespace env path lid in
+      if scope = `Buffer then
       match path, txt with
       | Pdot (path, _), Ldot (lid, s) ->
         let length_with_dot = String.length s + 1 in
@@ -106,19 +115,20 @@ 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 ~current_buffer_path ~stamp ~local_defs () ->
+  fun ~scope ~current_buffer_path ~stamp ~local_defs () ->
     let {Logger. log} = Logger.for_section "index" in
     match !cache with
-    | Some (path, stamp', value) when
+    | Some (path, stamp', scope', value) when
         String.equal path current_buffer_path
-        && Int.equal stamp' stamp ->
+        && 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, result);
+      let result = index_buffer_ ~current_buffer_path ~scope ~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
@@ -163,7 +173,24 @@ let comp_unit_of_uid = function
   | Item { comp_unit; _ } -> Some comp_unit
   | Internal | Predef _ -> None
 
-let locs_of ~config ~env ~typer_result ~pos path =
+let check Index_format.{ stats; _ } file =
+  let open Index_format in
+  match Stats.find_opt file stats with
+  | None -> log ~title:"stat_check" "No mtime found for file %S." file; true
+  | Some { size; _ } ->
+    try
+      let stats = Unix.stat file in
+      let equal =
+        (* This is fast but approximative. A better option would be to check
+           [mtime] and then [source_digest] if the times differ. *)
+         Int.equal stats.st_size size
+      in
+      log ~title:"stat_check"
+        "File %s has been modified since the index was built." file;
+      equal
+    with Unix.Unix_error _ -> false
+
+let locs_of ~config ~env ~typer_result ~pos ~scope path =
   log ~title:"occurrences" "Looking for occurences of %s (pos: %s)"
     path
     (Lexing.print_position () pos);
@@ -173,28 +200,29 @@ let locs_of ~config ~env ~typer_result ~pos path =
     ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML}
     ~env ~local_defs ~pos path
   in
-  let def =
+  (* When we fail to find an exact definition we restrict scope to `Buffer *)
+  let def, scope =
     match locate_result with
     | `At_origin ->
       log ~title:"locs_of" "Cursor is on definition / declaration";
       (* We are on  a definition / declaration so we look for the node's uid  *)
       let browse = Mbrowse.of_typedtree local_defs in
       let env, node = Mbrowse.leaf_node (Mbrowse.enclosing pos [browse]) in
-      uid_and_loc_of_node env node
+      uid_and_loc_of_node env node, scope
     | `Found { uid; location; approximated = false; _ } ->
         log ~title:"locs_of" "Found definition uid using locate: %a "
           Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-        Some (uid, location)
+        Some (uid, location), scope
     | `Found { decl_uid; location; approximated = true; _ } ->
-        log ~title:"locs_of" "Approx: %a "
+        log ~title:"locs_of" "Approx. definition: %a "
           Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid);
-        Some (decl_uid, location)
+        Some (decl_uid, location), `Buffer
     | `Builtin (uid, s) ->
         log ~title:"locs_of" "Locate found a builtin: %s" s;
-        Some (uid, Location.none)
+        Some (uid, Location.none), scope
     | _ ->
         log ~title:"locs_of" "Locate failed to find a definition.";
-        None
+        None, `Buffer
   in
   let current_buffer_path =
     Filename.concat config.query.directory config.query.filename
@@ -207,23 +235,73 @@ let locs_of ~config ~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 ~current_buffer_path ~stamp ~local_defs ()
+      index_buffer ~scope ~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
+    let external_locs, desync =
+      if scope = `Buffer then [], false else begin
+      let file_changed = ref false in
+      let locs = List.filter_map config.merlin.index_files ~f:(fun file ->
+        let external_locs = try
+            let external_index = Index_cache.read file in
+            Index_format.Uid_map.find_opt def_uid external_index.defs
+            |> Option.map ~f:(fun uid_locs -> external_index, uid_locs)
+          with
+          | Index_format.Not_an_index _ | Sys_error _ ->
+              log ~title:"external_index" "Could not load index %s" file;
+              None
+        in
+        Option.map external_locs ~f:(fun (file, locs) -> Lid_set.filter (fun {loc; _} ->
+          (* We ignore external results that concern the current buffer *)
+          let fname = loc.Location.loc_start.Lexing.pos_fname in
+          if String.equal fname current_buffer_path then false
+          else begin
+            (* We ignore external results if the index is not up-to-date *)
+            (* We could return partial results from up-to-date file *)
+            if not (check file fname) then begin
+              log ~title:"locs_of" "File %s might be out-of-sync." fname;
+              file_changed := true;
+              false
+            end else
+              true
+          end) locs))
+        in
+        locs, !file_changed
+      end
+    in
+    if desync then log ~title:"locs_of" "External index might be out-of-sync.";
+    let locs =
+      let all_locs =
+        match buffer_locs with
+        | Some buffer_locs -> buffer_locs :: external_locs
+        | None -> external_locs
+      in
+      List.fold_left ~init:Lid_set.empty ~f:Lid_set.union all_locs
+    in
     let locs =
-        log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs);
-        LidSet.elements locs
-        |> List.map ~f:(fun {Location.txt; loc} ->
-          log ~title:"occurrences" "Found occ: %s %a"
-            (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc);
-          last_loc loc txt)
+      log ~title:"occurrences" "Found %i locs" (Lid_set.cardinal locs);
+      Lid_set.elements locs
+      |> List.filter_map ~f:(fun {Location.txt; loc} ->
+        log ~title:"occurrences" "Found occ: %s %a"
+          (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc);
+        let loc = last_loc loc txt in
+        let fname = loc.Location.loc_start.Lexing.pos_fname in
+        if Filename.is_relative fname then begin
+          match Locate.find_source ~config loc fname with
+          | `Found (file, _) -> Some (set_fname ~file loc)
+          | `File_not_found msg ->
+              log ~title:"occurrences" "%s" msg;
+              None
+        end else Some loc)
     in
     let def_uid_is_in_current_unit =
       let uid_comp_unit = comp_unit_of_uid def_uid in
       Option.value_map ~default:false uid_comp_unit
         ~f:(String.equal @@ Env.get_unit_name ())
     in
-    if not def_uid_is_in_current_unit then Ok locs
-    else Ok (set_fname ~file:current_buffer_path def_loc :: locs)
-  | None -> Error "Could not find the uid of the definition."
+    let synced = not desync in
+    if not def_uid_is_in_current_unit then Ok { locs; synced }
+    else
+      let locs = set_fname ~file:current_buffer_path def_loc :: locs in
+      Ok { locs;  synced }
+  | None -> Error "Could not find the definition [uid]"

src/analysis/occurrences.mli

@@ -1,7 +1,10 @@
+type res = { locs: Warnings.loc list; synced: bool }
+
 val locs_of
   : config:Mconfig.t
   -> env:Env.t
   -> typer_result:Mtyper.result
   -> pos:Lexing.position
+  -> scope:[`Project | `Buffer]
   -> string
-  -> (Warnings.loc list, string) result
+  -> (res, string) result