bug#45135: 28.0.50; [PATCH] Add option to print file names in *xref* buffer relative to project root

[Dmitry Gutov <dgutov@yandex.ru>]

[-- Attachment #1: Type: text/plain, Size: 752 bytes --]

On 23.12.2020 04:16, Dmitry Gutov wrote:
> Re: patch 2, I have an idea that would make it a bit simpler and less 
> coupled to project.el, but behave the same in the usual cases. Stay tuned.

Not as clean as I hoped, but here's something that should work just as 
well, and a lot faster to boot (project-current lookup for every file 
name is slow when there are a lot of matches, even if each individual 
project-current call looks fast).

We could remove the explicit dependency on the "current project" if it 
was always passed in from the outside (e.g. by project-find-regexp's 
setup), but we probably want this display mode to work with 
xref-find-references as well.

Also simplified the docstring a bit.

Tobias, please try the attached patch.

[-- Attachment #2: xref-file-name-display-relative.diff --]
[-- Type: text/x-patch, Size: 4552 bytes --]

diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 181f94b0bc..d7f9fd91f5 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -109,12 +109,20 @@ xref-match-length
 
 (defcustom xref-file-name-display 'abs
   "Style of file name display in *xref* buffers.
+
 If the value is the symbol `abs', the default, show the file names
 in their full absolute form.
+
 If `nondirectory', show only the nondirectory (a.k.a. \"base name\")
-part of the file name."
+part of the file name.
+
+If `relative', show only the path fragment relative to the
+current project root.  If there is no current project, or if the
+file name resides outside of its root, show that particular file
+in its full absolute form."
   :type '(choice (const :tag "absolute file name" abs)
-                 (const :tag "nondirectory file name" nondirectory))
+                 (const :tag "nondirectory file name" nondirectory)
+                 (const :tag "relative to project root" relative))
   :version "27.1")
 
 ;; FIXME: might be useful to have an optional "hint" i.e. a string to
@@ -149,10 +157,21 @@ xref-location-marker
             (forward-char column))
           (point-marker))))))
 
+(defvar-local xref--search-root nil
+  "The current search root.")
+
 (cl-defmethod xref-location-group ((l xref-file-location))
   (cl-ecase xref-file-name-display
-    (abs (oref l file))
-    (nondirectory (file-name-nondirectory (oref l file)))))
+    (abs
+     (oref l file))
+    (nondirectory
+     (file-name-nondirectory (oref l file)))
+    (relative
+     (let ((file (oref l file)))
+       (if (and xref--search-root
+                (string-prefix-p xref--search-root file))
+           (substring file (length xref--search-root))
+         file)))))
 
 (defclass xref-buffer-location (xref-location)
   ((buffer :type buffer :initarg :buffer)
@@ -273,10 +292,7 @@ xref-backend-references
      (xref-references-in-directory identifier dir))
    (let ((pr (project-current t)))
      (cons
-      (if (fboundp 'project-root)
-          (project-root pr)
-        (with-no-warnings
-          (project-roots pr)))
+      (xref--project-root pr)
       (project-external-roots pr)))))
 
 (cl-defgeneric xref-backend-apropos (backend pattern)
@@ -902,26 +918,39 @@ xref--analyze
 
 (defun xref--show-xref-buffer (fetcher alist)
   (cl-assert (functionp fetcher))
-  (let* ((xrefs
-          (or
-           (assoc-default 'fetched-xrefs alist)
-           (funcall fetcher)))
-         (xref-alist (xref--analyze xrefs)))
+  (let ((xrefs
+         (or
+          (assoc-default 'fetched-xrefs alist)
+          (funcall fetcher))))
     (with-current-buffer (get-buffer-create xref-buffer-name)
       (xref--xref-buffer-mode)
-      (xref--show-common-initialize xref-alist fetcher alist)
+      (xref--show-common-initialize xrefs fetcher alist)
       (pop-to-buffer (current-buffer))
       (current-buffer))))
 
-(defun xref--show-common-initialize (xref-alist fetcher alist)
+(defun xref--project-root (project)
+  (if (fboundp 'project-root)
+      (project-root project)
+    (with-no-warnings
+      (project-roots project))))
+
+(defun xref--expanded-seach-root (alist)
+  (let ((root
+         (or (assoc-default 'search-root alist)
+             (let ((pr (project-current)))
+               (and pr (xref--project-root pr))))))
+    (and root (expand-file-name root))))
+
+(defun xref--show-common-initialize (xrefs fetcher alist)
   (setq buffer-undo-list nil)
   (let ((inhibit-read-only t)
         (buffer-undo-list t))
+    (setq xref--original-window (assoc-default 'window alist)
+          xref--original-window-intent (assoc-default 'display-action alist)
+          xref--search-root (xref--expanded-seach-root alist))
     (erase-buffer)
-    (xref--insert-xrefs xref-alist)
     (goto-char (point-min))
-    (setq xref--original-window (assoc-default 'window alist)
-          xref--original-window-intent (assoc-default 'display-action alist))
+    (xref--insert-xrefs (xref--analyze xrefs))
     (setq xref--fetcher fetcher)))
 
 (defun xref-revert-buffer ()
@@ -965,7 +994,7 @@ xref--show-defs-buffer-at-bottom
      (t
       (with-current-buffer (get-buffer-create xref-buffer-name)
         (xref--transient-buffer-mode)
-        (xref--show-common-initialize (xref--analyze xrefs) fetcher alist)
+        (xref--show-common-initialize xrefs fetcher alist)
         (pop-to-buffer (current-buffer)
                        '(display-buffer-in-direction . ((direction . below))))
         (current-buffer))))))