From a5c6f7687d981afce7a823696bac058320327cd2 Mon Sep 17 00:00:00 2001 From: Tobias Rittweiler Date: Tue, 8 Dec 2020 10:03:28 +0100 Subject: [PATCH 2/2] Add 'relative-to-project-root' as value for 'xref-file-name-display' * lisp/progmodes/xref.el (xref-file-name-display): Document new value. (xref-location-group) [relative-to-project-root]: Display files names in an xref buffer with prefixes cut off that match any of the root directories of the current project. (xref--project-roots): Extracted from default method of 'xref-backend-references' so it can be used in above's new code. Also make it more correct as the previous implementation would cons a list (return value of 'project-roots') onto another list (return value of 'project-external-roots'). * test/lisp/progmodes/xref-tests.el: Add test cases for the three possible settings of 'xref-file-name-display'. --- etc/NEWS | 5 ++++ lisp/progmodes/xref.el | 49 ++++++++++++++++++++++++------- test/lisp/progmodes/xref-tests.el | 31 +++++++++++++++++++ 3 files changed, 75 insertions(+), 10 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 83fe7a349e..60c4de5b55 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1210,6 +1210,11 @@ searches. These commands are bound respectively to 'P' and 'N', and navigate to the first item of the previous or next group in the "*xref*" buffer. +--- +*** New value 'relative-to-project-root' for 'xref-file-name-display' +If chosen, file names in *xref* buffers will be displayed relatively +to the 'project-root' of the current project, if available. + ** json.el --- diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 389b7cf247..b43af2b003 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -105,10 +105,23 @@ 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-to-project-root', show only the path fragment relative +to the root of the current project. If there is no current project, +or if a file name does not seem to be relative to the root, show +that particular file in its full absolute form. +For example \"foo/bar.c\" for \"~/src/quux.git/foo/bar.c\" +assuming \"~/src/quux.git/\" is the `project-root' of +`project-current'.) + +This customizable variable was introduced in Emacs 27.1. The +`relative-to-project-root' value was added in Emacs 28.1." :type '(choice (const :tag "absolute file name" abs) (const :tag "nondirectory file name" nondirectory)) :version "27.1") @@ -147,8 +160,22 @@ xref-location-marker (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-to-project-root + (let* ((file (oref l file)) + (expanded-file-name (expand-file-name file)) + (project (project-current nil)) + (project-roots (when project + (mapcar 'expand-file-name + (xref--project-roots project))))) + (cl-loop for root in project-roots + if (string-prefix-p root expanded-file-name) + return (substring expanded-file-name (length root)) + finally + return file))))) (defclass xref-buffer-location (xref-location) ((buffer :type buffer :initarg :buffer) @@ -267,13 +294,7 @@ xref-backend-references (mapcan (lambda (dir) (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))) - (project-external-roots pr))))) + (xref--project-roots (project-current t)))) (cl-defgeneric xref-backend-apropos (backend pattern) "Find all symbols that match PATTERN string. @@ -343,6 +364,14 @@ xref--search-property (cond (value) (t (goto-char start) nil)))) +(defun xref--project-roots (project) + "All root directories of `project'." + (let ((externals (project-external-roots project))) + (if (fboundp 'project-root) + (cons (project-root project) externals) + (with-no-warnings + (append (project-roots project) externals))))) + ;;; Marker stack (M-. pushes, M-, pops) diff --git a/test/lisp/progmodes/xref-tests.el b/test/lisp/progmodes/xref-tests.el index e52cc20053..61a6250519 100644 --- a/test/lisp/progmodes/xref-tests.el +++ b/test/lisp/progmodes/xref-tests.el @@ -97,3 +97,34 @@ xref--buf-pairs-iterator-cleans-up-markers (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 'relative-to-project-root)) + (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"))))) -- 2.25.1