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