master 13b59c6: Add 'project-relative' as value for 'xref-file-name-display'

[Dmitry Gutov]

branch: master
commit 13b59c690ada05f670d8056a6710045b22097c88
Author: Dmitry Gutov <dgutov@yandex.ru>
Commit: Dmitry Gutov <dgutov@yandex.ru>

    Add 'project-relative' as value for 'xref-file-name-display'
    
    * lisp/progmodes/xref.el (xref-file-name-display): Document new value.
    (xref-location-group ((l xref-file-location))): Handle the new value.
    (xref--project-root): Extract from the default method of
    'xref-backend-references' so it can be used in above's new code.
    Also fix an old bug in the "backward compat" branch.
    
    * lisp/progmodes/xref.el (xref--project-root-memo): New variable.
    
    * test/lisp/progmodes/xref-tests.el: Add test cases for the three
    possible settings of 'xref-file-name-display'.
    
    Co-authored-by: Tobias Rittweiler <trittweiler@gmail.com>
---
 etc/NEWS                          |  5 ++++
 lisp/progmodes/xref.el            | 48 ++++++++++++++++++++++++++++++++-------
 test/lisp/progmodes/xref-tests.el | 31 +++++++++++++++++++++++++
 3 files changed, 76 insertions(+), 8 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 765c032..1b49b01 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1302,6 +1302,11 @@ have been renamed to have "proper" public names and 
documented
 ('xref-show-definitions-buffer' and
 'xref-show-definitions-buffer-at-bottom').
 
+---
+*** New value 'project-relative' for 'xref-file-name-display'
+If chosen, file names in *xref* buffers will be displayed relative
+to the 'project-root' of the current project, when available.
+
 ** json.el
 
 ---
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 6f71256..2d45870 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -109,12 +109,20 @@ This is typically the filename.")
 
 (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 `project-relative', show only the file name relative to the
+current project root.  If there is no current project, or if the
+file resides outside of its root, show that particular file name
+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" project-relative))
   :version "27.1")
 
 ;; FIXME: might be useful to have an optional "hint" i.e. a string to
@@ -149,10 +157,31 @@ Line numbers start from 1 and columns from 0.")
             (forward-char column))
           (point-marker))))))
 
+(defvar xref--project-root-memo nil
+  "Cons mapping `default-directory' value to the 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)))
+    (project-relative
+     (unless (and xref--project-root-memo
+                  (equal (car xref--project-root-memo)
+                         default-directory))
+       (setq xref--project-root-memo
+             (cons default-directory
+                   (let ((root
+                          (let ((pr (project-current)))
+                            (and pr (xref--project-root pr)))))
+                     (and root (expand-file-name root))))))
+     (let ((file (oref l file))
+           (search-root (cdr xref--project-root-memo)))
+       (if (and search-root
+                (string-prefix-p search-root file))
+           (substring file (length search-root))
+         file)))))
 
 (defclass xref-buffer-location (xref-location)
   ((buffer :type buffer :initarg :buffer)
@@ -273,10 +302,7 @@ current project's main and external roots."
      (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)
@@ -913,6 +939,12 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
       (pop-to-buffer (current-buffer))
       (current-buffer))))
 
+(defun xref--project-root (project)
+  (if (fboundp 'project-root)
+      (project-root project)
+    (with-no-warnings
+      (car (project-roots project)))))
+
 (defun xref--show-common-initialize (xref-alist fetcher alist)
   (setq buffer-undo-list nil)
   (let ((inhibit-read-only t)
diff --git a/test/lisp/progmodes/xref-tests.el 
b/test/lisp/progmodes/xref-tests.el
index e1efbe8..ea3cbc8 100644
--- a/test/lisp/progmodes/xref-tests.el
+++ b/test/lisp/progmodes/xref-tests.el
@@ -97,3 +97,34 @@
     (should (null (marker-position (cdr (nth 0 (cdr cons1))))))
     (should (null (marker-position (car (nth 0 (cdr cons2))))))
     (should (null (marker-position (cdr (nth 0 (cdr cons2))))))))
+
+(ert-deftest xref--xref-file-name-display-is-abs ()
+  (let ((xref-file-name-display 'abs))
+    (should (equal (delete-dups
+                    (mapcar 'xref-location-group
+                            (xref-tests--locations-in-data-dir 
"\\(bar\\|foo\\)")))
+                   (list
+                    (concat xref-tests--data-dir "file1.txt")
+                    (concat xref-tests--data-dir "file2.txt"))))))
+
+(ert-deftest xref--xref-file-name-display-is-nondirectory ()
+  (let ((xref-file-name-display 'nondirectory))
+    (should (equal (delete-dups
+                    (mapcar 'xref-location-group
+                            (xref-tests--locations-in-data-dir 
"\\(bar\\|foo\\)")))
+                   (list
+                    "file1.txt"
+                    "file2.txt")))))
+
+(ert-deftest xref--xref-file-name-display-is-relative-to-project-root ()
+  (let* ((data-parent-dir
+          (file-name-directory (directory-file-name xref-tests--data-dir)))
+         (project-find-functions
+          #'(lambda (_) (cons 'transient data-parent-dir)))
+        (xref-file-name-display 'project-relative))
+    (should (equal (delete-dups
+                    (mapcar 'xref-location-group
+                            (xref-tests--locations-in-data-dir 
"\\(bar\\|foo\\)")))
+                   (list
+                    "xref-resources/file1.txt"
+                    "xref-resources/file2.txt")))))