diff options
Diffstat (limited to 'lisp/progmodes/xref.el')
| -rw-r--r-- | lisp/progmodes/xref.el | 525 |
1 files changed, 525 insertions, 0 deletions
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el new file mode 100644 index 00000000000..f3dc4bd4cfd --- /dev/null +++ b/lisp/progmodes/xref.el @@ -0,0 +1,525 @@ +;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- + +;; Copyright (C) 2014 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides a somewhat generic infrastructure for cross +;; referencing commands, in particular "find-definition". +;; +;; Some part of the functionality must be implemented in a language +;; dependent way and that's done by defining `xref-find-function', +;; `xref-identifier-at-point-function' and +;; `xref-identifier-completion-table-function', which see. +;; +;; A major mode should make these variables buffer-local first. +;; +;; `xref-find-function' can be called in several ways, see its +;; description. It has to operate with "xref" and "location" values. +;; +;; One would usually call `make-xref' and `xref-make-file-location', +;; `xref-make-buffer-location' or `xref-make-bogus-location' to create +;; them. +;; +;; Each identifier must be represented as a string. Implementers can +;; use string properties to store additional information about the +;; identifier, but they should keep in mind that values returned from +;; `xref-identifier-completion-table-function' should still be +;; distinct, because the user can't see the properties when making the +;; choice. +;; +;; See the functions `etags-xref-find' and `elisp-xref-find' for full +;; examples. + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'ring) + +(defgroup xref nil "Cross-referencing commands" + :group 'tools) + + +;;; Locations + +(defclass xref-location () () + :documentation "A location represents a position in a file or buffer.") + +;; If a backend decides to subclass xref-location it can provide +;; methods for some of the following functions: +(defgeneric xref-location-marker (location) + "Return the marker for LOCATION.") + +(defgeneric xref-location-group (location) + "Return a string used to group a set of locations. +This is typically the filename.") + +;;;; Commonly needed location classes are defined here: + +;; FIXME: might be useful to have an optional "hint" i.e. a string to +;; search for in case the line number is sightly out of date. +(defclass xref-file-location (xref-location) + ((file :type string :initarg :file) + (line :type fixnum :initarg :line) + (column :type fixnum :initarg :column)) + :documentation "A file location is a file/line/column triple. +Line numbers start from 1 and columns from 0.") + +(defun xref-make-file-location (file line column) + "Create and return a new xref-file-location." + (make-instance 'xref-file-location :file file :line line :column column)) + +(defmethod xref-location-marker ((l xref-file-location)) + (with-slots (file line column) l + (with-current-buffer + (or (get-file-buffer file) + (let ((find-file-suppress-same-file-warnings t)) + (find-file-noselect file))) + (save-restriction + (widen) + (save-excursion + (goto-char (point-min)) + (beginning-of-line line) + (move-to-column column) + (point-marker)))))) + +(defmethod xref-location-group ((l xref-file-location)) + (oref l :file)) + +(defclass xref-buffer-location (xref-location) + ((buffer :type buffer :initarg :buffer) + (position :type fixnum :initarg :position))) + +(defun xref-make-buffer-location (buffer position) + "Create and return a new xref-buffer-location." + (make-instance 'xref-buffer-location :buffer buffer :position position)) + +(defmethod xref-location-marker ((l xref-buffer-location)) + (with-slots (buffer position) l + (let ((m (make-marker))) + (move-marker m position buffer)))) + +(defmethod xref-location-group ((l xref-buffer-location)) + (with-slots (buffer) l + (or (buffer-file-name buffer) + (format "(buffer %s)" (buffer-name buffer))))) + +(defclass xref-bogus-location (xref-location) + ((message :type string :initarg :message + :reader xref-bogus-location-message)) + :documentation "Bogus locations are sometimes useful to +indicate errors, e.g. when we know that a function exists but the +actual location is not known.") + +(defun xref-make-bogus-location (message) + "Create and return a new xref-bogus-location." + (make-instance 'xref-bogus-location :message message)) + +(defmethod xref-location-marker ((l xref-bogus-location)) + (user-error "%s" (oref l :message))) + +(defmethod xref-location-group ((_ xref-bogus-location)) "(No location)") + +;; This should be in elisp-mode.el, but it's preloaded, and we can't +;; preload defclass and defmethod (at least, not yet). +(defclass xref-elisp-location (xref-location) + ((symbol :type symbol :initarg :symbol) + (type :type symbol :initarg :type) + (file :type string :initarg :file + :reader xref-location-group)) + :documentation "Location of an Emacs Lisp symbol definition.") + +(defun xref-make-elisp-location (symbol type file) + (make-instance 'xref-elisp-location :symbol symbol :type type :file file)) + +(defmethod xref-location-marker ((l xref-elisp-location)) + (with-slots (symbol type file) l + (let ((buffer-point + (pcase type + (`defun (find-function-search-for-symbol symbol nil file)) + ((or `defvar `defface) + (find-function-search-for-symbol symbol type file)) + (`feature + (cons (find-file-noselect file) 1))))) + (with-current-buffer (car buffer-point) + (goto-char (or (cdr buffer-point) (point-min))) + (point-marker))))) + + +;;; Cross-reference + +(defclass xref--xref () + ((description :type string :initarg :description + :reader xref--xref-description) + (location :type xref-location :initarg :location + :reader xref--xref-location)) + :comment "An xref is used to display and locate constructs like +variables or functions.") + +(defun xref-make (description location) + "Create and return a new xref. +DESCRIPTION is a short string to describe the xref. +LOCATION is an `xref-location'." + (make-instance 'xref--xref :description description :location location)) + + +;;; API + +(declare-function etags-xref-find "etags" (action id)) +(declare-function tags-lazy-completion-table "etags" ()) + +;; For now, make the etags backend the default. +(defvar xref-find-function #'etags-xref-find + "Function to look for cross-references. +It can be called in several ways: + + (definitions IDENTIFIER): Find definitions of IDENTIFIER. The +result must be a list of xref objects. If no definitions can be +found, return nil. + + (references IDENTIFIER): Find references of IDENTIFIER. The +result must be a list of xref objects. If no references can be +found, return nil. + + (apropos PATTERN): Find all symbols that match PATTERN. PATTERN +is a regexp. + +IDENTIFIER can be any string returned by +`xref-identifier-at-point-function', or from the table returned +by `xref-identifier-completion-table-function'. + +To create an xref object, call `xref-make'.") + +(defvar xref-identifier-at-point-function #'xref-default-identifier-at-point + "Function to get the relevant identifier at point. + +The return value must be a string or nil. nil means no +identifier at point found. + +If it's hard to determine the identifier precisely (e.g., because +it's a method call on unknown type), the implementation can +return a simple string (such as symbol at point) marked with a +special text property which `xref-find-function' would recognize +and then delegate the work to an external process.") + +(defvar xref-identifier-completion-table-function #'tags-lazy-completion-table + "Function that returns the completion table for identifiers.") + +(defun xref-default-identifier-at-point () + (let ((thing (thing-at-point 'symbol))) + (and thing (substring-no-properties thing)))) + + +;;; misc utilities +(defun xref--alistify (list key test) + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare +keys." + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (cl-assoc k alist :test test))) + (if probe + (setcdr probe (cons e (cdr probe))) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (cl-loop for (key . value) in (reverse alist) + collect (cons key (reverse value))))) + +(defun xref--insert-propertized (props &rest strings) + "Insert STRINGS with text properties PROPS." + (let ((start (point))) + (apply #'insert strings) + (add-text-properties start (point) props))) + +(defun xref--search-property (property &optional backward) + "Search the next text range where text property PROPERTY is non-nil. +Return the value of PROPERTY. If BACKWARD is non-nil, search +backward." + (let ((next (if backward + #'previous-single-char-property-change + #'next-single-char-property-change)) + (start (point)) + (value nil)) + (while (progn + (goto-char (funcall next (point) property)) + (not (or (setq value (get-text-property (point) property)) + (eobp) + (bobp))))) + (cond (value) + (t (goto-char start) nil)))) + + +;;; Marker stack (M-. pushes, M-, pops) + +(defcustom xref-marker-ring-length 16 + "Length of the xref marker ring." + :type 'integer + :version "25.1") + +(defvar xref--marker-ring (make-ring xref-marker-ring-length) + "Ring of markers to implement the marker stack.") + +(defun xref-push-marker-stack () + "Add point to the marker stack." + (ring-insert xref--marker-ring (point-marker))) + +;;;###autoload +(defun xref-pop-marker-stack () + "Pop back to where \\[xref-find-definitions] was last invoked." + (interactive) + (let ((ring xref--marker-ring)) + (when (ring-empty-p ring) + (error "Marker stack is empty")) + (let ((marker (ring-remove ring 0))) + (switch-to-buffer (or (marker-buffer marker) + (error "The marked buffer has been deleted"))) + (goto-char (marker-position marker)) + (set-marker marker nil nil)))) + +;; etags.el needs this +(defun xref-clear-marker-stack () + "Discard all markers from the marker stack." + (let ((ring xref--marker-ring)) + (while (not (ring-empty-p ring)) + (let ((marker (ring-remove ring))) + (set-marker marker nil nil))))) + + +(defun xref--goto-location (location) + "Set buffer and point according to xref-location LOCATION." + (let ((marker (xref-location-marker location))) + (set-buffer (marker-buffer marker)) + (cond ((and (<= (point-min) marker) (<= marker (point-max)))) + (widen-automatically (widen)) + (t (error "Location is outside accessible part of buffer"))) + (goto-char marker))) + +(defun xref--pop-to-location (location &optional window) + "Goto xref-location LOCATION and display the buffer. +WINDOW controls how the buffer is displayed: + nil -- switch-to-buffer + 'window -- pop-to-buffer (other window) + 'frame -- pop-to-buffer (other frame)" + (xref--goto-location location) + (cl-ecase window + ((nil) (switch-to-buffer (current-buffer))) + (window (pop-to-buffer (current-buffer) t)) + (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t))))) + + +;;; XREF buffer (part of the UI) + +;; The xref buffer is used to display a set of xrefs. + +(defun xref--display-position (pos other-window recenter-arg) + ;; show the location, but don't hijack focus. + (with-selected-window (display-buffer (current-buffer) other-window) + (goto-char pos) + (recenter recenter-arg))) + +(defun xref--show-location (location) + (condition-case err + (progn + (xref--goto-location location) + (xref--display-position (point) t 1)) + (user-error (message (error-message-string err))))) + +(defun xref--next-line (backward) + (let ((loc (xref--search-property 'xref-location backward))) + (when loc + (save-window-excursion + (xref--show-location loc) + (sit-for most-positive-fixnum))))) + +(defun xref-next-line () + "Move to the next xref and display its source in the other window." + (interactive) + (xref--next-line nil)) + +(defun xref-prev-line () + "Move to the previous xref and display its source in the other window." + (interactive) + (xref--next-line t)) + +(defun xref--location-at-point () + (or (get-text-property (point) 'xref-location) + (error "No reference at point"))) + +(defvar-local xref--window nil) + +(defun xref-goto-xref () + "Jump to the xref at point and bury the xref buffer." + (interactive) + (let ((loc (xref--location-at-point)) + (window xref--window)) + (quit-window) + (xref--pop-to-location loc window))) + +(define-derived-mode xref--xref-buffer-mode fundamental-mode "XREF" + "Mode for displaying cross-references." + (setq buffer-read-only t)) + +(let ((map xref--xref-buffer-mode-map)) + (define-key map (kbd "q") #'quit-window) + (define-key map [remap next-line] #'xref-next-line) + (define-key map [remap previous-line] #'xref-prev-line) + (define-key map (kbd "RET") #'xref-goto-xref) + + ;; suggested by Johan Claesson "to further reduce finger movement": + (define-key map (kbd ".") #'xref-next-line) + (define-key map (kbd ",") #'xref-prev-line)) + +(defconst xref-buffer-name "*xref*" + "The name of the buffer to show xrefs.") + +(defun xref--insert-xrefs (xref-alist) + "Insert XREF-ALIST in the current-buffer. +XREF-ALIST is of the form ((GROUP . (XREF ...)) ...). Where +GROUP is a string for decoration purposes and XREF is an +`xref--xref' object." + (cl-loop for ((group . xrefs) . more1) on xref-alist do + (xref--insert-propertized '(face bold) group "\n") + (cl-loop for (xref . more2) on xrefs do + (insert " ") + (with-slots (description location) xref + (xref--insert-propertized + (list 'xref-location location + 'face 'font-lock-keyword-face) + description)) + (when (or more1 more2) + (insert "\n"))))) + +(defun xref--analyze (xrefs) + "Find common filenames in XREFS. +Return an alist of the form ((FILENAME . (XREF ...)) ...)." + (xref--alistify xrefs + (lambda (x) + (xref-location-group (xref--xref-location x))) + #'equal)) + +(defun xref--show-xref-buffer (xrefs window) + (let ((xref-alist (xref--analyze xrefs))) + (with-current-buffer (get-buffer-create xref-buffer-name) + (let ((inhibit-read-only t)) + (erase-buffer) + (xref--insert-xrefs xref-alist) + (xref--xref-buffer-mode) + (pop-to-buffer (current-buffer)) + (goto-char (point-min)) + (setq xref--window window) + (current-buffer))))) + + +;; This part of the UI seems fairly uncontroversial: it reads the +;; identifier and deals with the single definition case. +;; +;; The controversial multiple definitions case is handed off to +;; xref-show-xrefs-function. + +(defvar xref-show-xrefs-function 'xref--show-xref-buffer + "Function to display a list of xrefs.") + +(defun xref--show-xrefs (id kind xrefs window) + (cond + ((null xrefs) + (user-error "No known %s for: %s" kind id)) + ((not (cdr xrefs)) + (xref-push-marker-stack) + (xref--pop-to-location (xref--xref-location (car xrefs)) window)) + (t + (xref-push-marker-stack) + (funcall xref-show-xrefs-function xrefs window)))) + +(defun xref--read-identifier (prompt) + "Return the identifier at point or read it from the minibuffer." + (let ((id (funcall xref-identifier-at-point-function))) + (cond ((or current-prefix-arg (not id)) + (completing-read prompt + (funcall xref-identifier-completion-table-function) + nil t id)) + (t id)))) + + +;;; Commands + +(defun xref--find-definitions (id window) + (xref--show-xrefs id "definitions" + (funcall xref-find-function 'definitions id) + window)) + +;;;###autoload +(defun xref-find-definitions (identifier) + "Find the definition of the identifier at point. +With prefix argument or when there's no identifier at point, +prompt for it." + (interactive (list (xref--read-identifier "Find definitions of: "))) + (xref--find-definitions identifier nil)) + +;;;###autoload +(defun xref-find-definitions-other-window (identifier) + "Like `xref-find-definitions' but switch to the other window." + (interactive (list (xref--read-identifier "Find definitions of: "))) + (xref--find-definitions identifier 'window)) + +;;;###autoload +(defun xref-find-definitions-other-frame (identifier) + "Like `xref-find-definitions' but switch to the other frame." + (interactive (list (xref--read-identifier "Find definitions of: "))) + (xref--find-definitions identifier 'frame)) + +;;;###autoload +(defun xref-find-references (identifier) + "Find references to the identifier at point. +With prefix argument, prompt for the identifier." + (interactive (list (xref--read-identifier "Find references of: "))) + (xref--show-xrefs identifier "references" + (funcall xref-find-function 'references identifier) + nil)) + +;;;###autoload +(defun xref-find-apropos (pattern) + "Find all meaningful symbols that match PATTERN. +The argument has the same meaning as in `apropos'." + (interactive (list (read-from-minibuffer + "Search for pattern (word list or regexp): "))) + (require 'apropos) + (xref--show-xrefs pattern "apropos" + (funcall xref-find-function 'apropos + (apropos-parse-pattern + (if (string-equal (regexp-quote pattern) pattern) + ;; Split into words + (or (split-string pattern "[ \t]+" t) + (user-error "No word list given")) + pattern))) + nil)) + + +;;; Key bindings + +;;;###autoload (define-key esc-map "." #'xref-find-definitions) +;;;###autoload (define-key esc-map "," #'xref-pop-marker-stack) +;;;###autoload (define-key esc-map [?\C-.] #'xref-find-apropos) +;;;###autoload (define-key ctl-x-4-map "." #'xref-find-definitions-other-window) +;;;###autoload (define-key ctl-x-5-map "." #'xref-find-definitions-other-frame) + + +(provide 'xref) + +;;; xref.el ends here |