lisp/progmodes/xref.el

   1 ;; xref.el --- Cross-referencing commands              -*-lexical-binding:t-*-
   2
   3 ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; This file provides a somewhat generic infrastructure for cross
  23 ;; referencing commands, in particular "find-definition".
  24 ;;
  25 ;; Some part of the functionality must be implemented in a language
  26 ;; dependent way and that's done by defining `xref-find-function',
  27 ;; `xref-identifier-at-point-function' and
  28 ;; `xref-identifier-completion-table-function', which see.
  29 ;;
  30 ;; A major mode should make these variables buffer-local first.
  31 ;;
  32 ;; `xref-find-function' can be called in several ways, see its
  33 ;; description.  It has to operate with "xref" and "location" values.
  34 ;;
  35 ;; One would usually call `make-xref' and `xref-make-file-location',
  36 ;; `xref-make-buffer-location' or `xref-make-bogus-location' to create
  37 ;; them.
  38 ;;
  39 ;; Each identifier must be represented as a string.  Implementers can
  40 ;; use string properties to store additional information about the
  41 ;; identifier, but they should keep in mind that values returned from
  42 ;; `xref-identifier-completion-table-function' should still be
  43 ;; distinct, because the user can't see the properties when making the
  44 ;; choice.
  45 ;;
  46 ;; See the functions `etags-xref-find' and `elisp-xref-find' for full
  47 ;; examples.
  48
  49 ;;; Code:
  50
  51 (require 'cl-lib)
  52 (require 'eieio)
  53 (require 'ring)
  54
  55 (defgroup xref nil "Cross-referencing commands"
  56   :group 'tools)
  57
  58 \f
  59 ;;; Locations
  60
  61 (defclass xref-location () ()
  62   :documentation "A location represents a position in a file or buffer.")
  63
  64 ;; If a backend decides to subclass xref-location it can provide
  65 ;; methods for some of the following functions:
  66 (defgeneric xref-location-marker (location)
  67   "Return the marker for LOCATION.")
  68
  69 (defgeneric xref-location-group (location)
  70   "Return a string used to group a set of locations.
  71 This is typically the filename.")
  72
  73 ;;;; Commonly needed location classes are defined here:
  74
  75 ;; FIXME: might be useful to have an optional "hint" i.e. a string to
  76 ;; search for in case the line number is sightly out of date.
  77 (defclass xref-file-location (xref-location)
  78   ((file :type string :initarg :file)
  79    (line :type fixnum :initarg :line)
  80    (column :type fixnum :initarg :column))
  81   :documentation "A file location is a file/line/column triple.
  82 Line numbers start from 1 and columns from 0.")
  83
  84 (defun xref-make-file-location (file line column)
  85   "Create and return a new xref-file-location."
  86   (make-instance 'xref-file-location :file file :line line :column column))
  87
  88 (defmethod xref-location-marker ((l xref-file-location))
  89   (with-slots (file line column) l
  90     (with-current-buffer
  91         (or (get-file-buffer file)
  92             (let ((find-file-suppress-same-file-warnings t))
  93               (find-file-noselect file)))
  94       (save-restriction
  95         (widen)
  96         (save-excursion
  97           (goto-char (point-min))
  98           (beginning-of-line line)
  99           (move-to-column column)
 100           (point-marker))))))
 101
 102 (defmethod xref-location-group ((l xref-file-location))
 103   (oref l :file))
 104
 105 (defclass xref-buffer-location (xref-location)
 106   ((buffer :type buffer :initarg :buffer)
 107    (position :type fixnum :initarg :position)))
 108
 109 (defun xref-make-buffer-location (buffer position)
 110   "Create and return a new xref-buffer-location."
 111   (make-instance 'xref-buffer-location :buffer buffer :position position))
 112
 113 (defmethod xref-location-marker ((l xref-buffer-location))
 114   (with-slots (buffer position) l
 115     (let ((m (make-marker)))
 116       (move-marker m position buffer))))
 117
 118 (defmethod xref-location-group ((l xref-buffer-location))
 119   (with-slots (buffer) l
 120     (or (buffer-file-name buffer)
 121         (format "(buffer %s)" (buffer-name buffer)))))
 122
 123 (defclass xref-bogus-location (xref-location)
 124   ((message :type string :initarg :message
 125             :reader xref-bogus-location-message))
 126   :documentation "Bogus locations are sometimes useful to
 127 indicate errors, e.g. when we know that a function exists but the
 128 actual location is not known.")
 129
 130 (defun xref-make-bogus-location (message)
 131   "Create and return a new xref-bogus-location."
 132   (make-instance 'xref-bogus-location :message message))
 133
 134 (defmethod xref-location-marker ((l xref-bogus-location))
 135   (user-error "%s" (oref l :message)))
 136
 137 (defmethod xref-location-group ((_ xref-bogus-location)) "(No location)")
 138
 139 ;; This should be in elisp-mode.el, but it's preloaded, and we can't
 140 ;; preload defclass and defmethod (at least, not yet).
 141 (defclass xref-elisp-location (xref-location)
 142   ((symbol :type symbol :initarg :symbol)
 143    (type   :type symbol :initarg :type)
 144    (file   :type string :initarg :file
 145            :reader xref-location-group))
 146   :documentation "Location of an Emacs Lisp symbol definition.")
 147
 148 (defun xref-make-elisp-location (symbol type file)
 149   (make-instance 'xref-elisp-location :symbol symbol :type type :file file))
 150
 151 (defmethod xref-location-marker ((l xref-elisp-location))
 152   (with-slots (symbol type file) l
 153     (let ((buffer-point
 154            (pcase type
 155              (`defun (find-function-search-for-symbol symbol nil file))
 156              ((or `defvar `defface)
 157               (find-function-search-for-symbol symbol type file))
 158              (`feature
 159               (cons (find-file-noselect file) 1)))))
 160       (with-current-buffer (car buffer-point)
 161         (goto-char (or (cdr buffer-point) (point-min)))
 162         (point-marker)))))
 163
 164 \f
 165 ;;; Cross-reference
 166
 167 (defclass xref--xref ()
 168   ((description :type string :initarg :description
 169                 :reader xref--xref-description)
 170    (location :type xref-location :initarg :location
 171              :reader xref--xref-location))
 172   :comment "An xref is used to display and locate constructs like
 173 variables or functions.")
 174
 175 (defun xref-make (description location)
 176   "Create and return a new xref.
 177 DESCRIPTION is a short string to describe the xref.
 178 LOCATION is an `xref-location'."
 179   (make-instance 'xref--xref :description description :location location))
 180
 181 \f
 182 ;;; API
 183
 184 (declare-function etags-xref-find "etags" (action id))
 185 (declare-function tags-lazy-completion-table "etags" ())
 186
 187 ;; For now, make the etags backend the default.
 188 (defvar xref-find-function #'etags-xref-find
 189   "Function to look for cross-references.
 190 It can be called in several ways:
 191
 192  (definitions IDENTIFIER): Find definitions of IDENTIFIER.  The
 193 result must be a list of xref objects.  If no definitions can be
 194 found, return nil.
 195
 196  (references IDENTIFIER): Find references of IDENTIFIER.  The
 197 result must be a list of xref objects.  If no references can be
 198 found, return nil.
 199
 200  (apropos PATTERN): Find all symbols that match PATTERN.  PATTERN
 201 is a regexp.
 202
 203 IDENTIFIER can be any string returned by
 204 `xref-identifier-at-point-function', or from the table returned
 205 by `xref-identifier-completion-table-function'.
 206
 207 To create an xref object, call `xref-make'.")
 208
 209 (defvar xref-identifier-at-point-function #'xref-default-identifier-at-point
 210   "Function to get the relevant identifier at point.
 211
 212 The return value must be a string or nil.  nil means no
 213 identifier at point found.
 214
 215 If it's hard to determine the identifier precisely (e.g., because
 216 it's a method call on unknown type), the implementation can
 217 return a simple string (such as symbol at point) marked with a
 218 special text property which `xref-find-function' would recognize
 219 and then delegate the work to an external process.")
 220
 221 (defvar xref-identifier-completion-table-function #'tags-lazy-completion-table
 222   "Function that returns the completion table for identifiers.")
 223
 224 (defun xref-default-identifier-at-point ()
 225   (let ((thing (thing-at-point 'symbol)))
 226     (and thing (substring-no-properties thing))))
 227
 228 \f
 229 ;;; misc utilities
 230 (defun xref--alistify (list key test)
 231   "Partition the elements of LIST into an alist.
 232 KEY extracts the key from an element and TEST is used to compare
 233 keys."
 234   (let ((alist '()))
 235     (dolist (e list)
 236       (let* ((k (funcall key e))
 237              (probe (cl-assoc k alist :test test)))
 238         (if probe
 239             (setcdr probe (cons e (cdr probe)))
 240           (push (cons k (list e)) alist))))
 241     ;; Put them back in order.
 242     (cl-loop for (key . value) in (reverse alist)
 243              collect (cons key (reverse value)))))
 244
 245 (defun xref--insert-propertized (props &rest strings)
 246   "Insert STRINGS with text properties PROPS."
 247   (let ((start (point)))
 248     (apply #'insert strings)
 249     (add-text-properties start (point) props)))
 250
 251 (defun xref--search-property (property &optional backward)
 252     "Search the next text range where text property PROPERTY is non-nil.
 253 Return the value of PROPERTY.  If BACKWARD is non-nil, search
 254 backward."
 255   (let ((next (if backward
 256                   #'previous-single-char-property-change
 257                 #'next-single-char-property-change))
 258         (start (point))
 259         (value nil))
 260     (while (progn
 261              (goto-char (funcall next (point) property))
 262              (not (or (setq value (get-text-property (point) property))
 263                       (eobp)
 264                       (bobp)))))
 265     (cond (value)
 266           (t (goto-char start) nil))))
 267
 268 \f
 269 ;;; Marker stack  (M-. pushes, M-, pops)
 270
 271 (defcustom xref-marker-ring-length 16
 272   "Length of the xref marker ring."
 273   :type 'integer
 274   :version "25.1")
 275
 276 (defvar xref--marker-ring (make-ring xref-marker-ring-length)
 277   "Ring of markers to implement the marker stack.")
 278
 279 (defun xref-push-marker-stack ()
 280   "Add point to the marker stack."
 281   (ring-insert xref--marker-ring (point-marker)))
 282
 283 ;;;###autoload
 284 (defun xref-pop-marker-stack ()
 285   "Pop back to where \\[xref-find-definitions] was last invoked."
 286   (interactive)
 287   (let ((ring xref--marker-ring))
 288     (when (ring-empty-p ring)
 289       (error "Marker stack is empty"))
 290     (let ((marker (ring-remove ring 0)))
 291       (switch-to-buffer (or (marker-buffer marker)
 292                             (error "The marked buffer has been deleted")))
 293       (goto-char (marker-position marker))
 294       (set-marker marker nil nil))))
 295
 296 ;; etags.el needs this
 297 (defun xref-clear-marker-stack ()
 298   "Discard all markers from the marker stack."
 299   (let ((ring xref--marker-ring))
 300     (while (not (ring-empty-p ring))
 301       (let ((marker (ring-remove ring)))
 302         (set-marker marker nil nil)))))
 303
 304 \f
 305 (defun xref--goto-location (location)
 306   "Set buffer and point according to xref-location LOCATION."
 307   (let ((marker (xref-location-marker location)))
 308     (set-buffer (marker-buffer marker))
 309     (cond ((and (<= (point-min) marker) (<= marker (point-max))))
 310           (widen-automatically (widen))
 311           (t (error "Location is outside accessible part of buffer")))
 312     (goto-char marker)))
 313
 314 (defun xref--pop-to-location (location &optional window)
 315   "Goto xref-location LOCATION and display the buffer.
 316 WINDOW controls how the buffer is displayed:
 317   nil      -- switch-to-buffer
 318   'window  -- pop-to-buffer (other window)
 319   'frame   -- pop-to-buffer (other frame)"
 320   (xref--goto-location location)
 321   (cl-ecase window
 322     ((nil)  (switch-to-buffer (current-buffer)))
 323     (window (pop-to-buffer (current-buffer) t))
 324     (frame  (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))))
 325
 326 \f
 327 ;;; XREF buffer (part of the UI)
 328
 329 ;; The xref buffer is used to display a set of xrefs.
 330
 331 (defun xref--display-position (pos other-window recenter-arg)
 332   ;; show the location, but don't hijack focus.
 333   (with-selected-window (display-buffer (current-buffer) other-window)
 334     (goto-char pos)
 335     (recenter recenter-arg)))
 336
 337 (defun xref--show-location (location)
 338   (condition-case err
 339       (progn
 340         (xref--goto-location location)
 341         (xref--display-position (point) t 1))
 342     (user-error (message (error-message-string err)))))
 343
 344 (defun xref--next-line (backward)
 345   (let ((loc (xref--search-property 'xref-location backward)))
 346     (when loc
 347       (save-window-excursion
 348         (xref--show-location loc)
 349         (sit-for most-positive-fixnum)))))
 350
 351 (defun xref-next-line ()
 352   "Move to the next xref and display its source in the other window."
 353   (interactive)
 354   (xref--next-line nil))
 355
 356 (defun xref-prev-line ()
 357   "Move to the previous xref and display its source in the other window."
 358   (interactive)
 359   (xref--next-line t))
 360
 361 (defun xref--location-at-point ()
 362   (or (get-text-property (point) 'xref-location)
 363       (error "No reference at point")))
 364
 365 (defvar-local xref--window nil)
 366
 367 (defun xref-goto-xref ()
 368   "Jump to the xref at point and bury the xref buffer."
 369   (interactive)
 370   (let ((loc (xref--location-at-point))
 371         (window xref--window))
 372     (quit-window)
 373     (xref--pop-to-location loc window)))
 374
 375 (define-derived-mode xref--xref-buffer-mode fundamental-mode "XREF"
 376   "Mode for displaying cross-references."
 377   (setq buffer-read-only t))
 378
 379 (let ((map xref--xref-buffer-mode-map))
 380   (define-key map (kbd "q") #'quit-window)
 381   (define-key map [remap next-line] #'xref-next-line)
 382   (define-key map [remap previous-line] #'xref-prev-line)
 383   (define-key map (kbd "RET") #'xref-goto-xref)
 384
 385   ;; suggested by Johan Claesson "to further reduce finger movement":
 386   (define-key map (kbd ".") #'xref-next-line)
 387   (define-key map (kbd ",") #'xref-prev-line))
 388
 389 (defconst xref-buffer-name "*xref*"
 390   "The name of the buffer to show xrefs.")
 391
 392 (defun xref--insert-xrefs (xref-alist)
 393   "Insert XREF-ALIST in the current-buffer.
 394 XREF-ALIST is of the form ((GROUP . (XREF ...)) ...).  Where
 395 GROUP is a string for decoration purposes and XREF is an
 396 `xref--xref' object."
 397   (cl-loop for ((group . xrefs) . more1) on xref-alist do
 398            (xref--insert-propertized '(face bold) group "\n")
 399            (cl-loop for (xref . more2) on xrefs do
 400                     (insert "  ")
 401                     (with-slots (description location) xref
 402                       (xref--insert-propertized
 403                        (list 'xref-location location
 404                              'face 'font-lock-keyword-face)
 405                        description))
 406                     (when (or more1 more2)
 407                       (insert "\n")))))
 408
 409 (defun xref--analyze (xrefs)
 410   "Find common filenames in XREFS.
 411 Return an alist of the form ((FILENAME . (XREF ...)) ...)."
 412   (xref--alistify xrefs
 413                   (lambda (x)
 414                     (xref-location-group (xref--xref-location x)))
 415                   #'equal))
 416
 417 (defun xref--show-xref-buffer (xrefs window)
 418   (let ((xref-alist (xref--analyze xrefs)))
 419     (with-current-buffer (get-buffer-create xref-buffer-name)
 420       (let ((inhibit-read-only t))
 421         (erase-buffer)
 422         (xref--insert-xrefs xref-alist)
 423         (xref--xref-buffer-mode)
 424         (pop-to-buffer (current-buffer))
 425         (goto-char (point-min))
 426         (setq xref--window window)
 427         (current-buffer)))))
 428
 429 \f
 430 ;; This part of the UI seems fairly uncontroversial: it reads the
 431 ;; identifier and deals with the single definition case.
 432 ;;
 433 ;; The controversial multiple definitions case is handed off to
 434 ;; xref-show-xrefs-function.
 435
 436 (defvar xref-show-xrefs-function 'xref--show-xref-buffer
 437   "Function to display a list of xrefs.")
 438
 439 (defun xref--show-xrefs (id kind xrefs window)
 440   (cond
 441    ((null xrefs)
 442     (user-error "No known %s for: %s" kind id))
 443    ((not (cdr xrefs))
 444     (xref-push-marker-stack)
 445     (xref--pop-to-location (xref--xref-location (car xrefs)) window))
 446    (t
 447     (xref-push-marker-stack)
 448     (funcall xref-show-xrefs-function xrefs window))))
 449
 450 (defun xref--read-identifier (prompt)
 451   "Return the identifier at point or read it from the minibuffer."
 452   (let ((id (funcall xref-identifier-at-point-function)))
 453     (cond ((or current-prefix-arg (not id))
 454            (completing-read prompt
 455                             (funcall xref-identifier-completion-table-function)
 456                             nil t id))
 457           (t id))))
 458
 459 \f
 460 ;;; Commands
 461
 462 (defun xref--find-definitions (id window)
 463   (xref--show-xrefs id "definitions"
 464                     (funcall xref-find-function 'definitions id)
 465                     window))
 466
 467 ;;;###autoload
 468 (defun xref-find-definitions (identifier)
 469   "Find the definition of the identifier at point.
 470 With prefix argument or when there's no identifier at point,
 471 prompt for it."
 472   (interactive (list (xref--read-identifier "Find definitions of: ")))
 473   (xref--find-definitions identifier nil))
 474
 475 ;;;###autoload
 476 (defun xref-find-definitions-other-window (identifier)
 477   "Like `xref-find-definitions' but switch to the other window."
 478   (interactive (list (xref--read-identifier "Find definitions of: ")))
 479   (xref--find-definitions identifier 'window))
 480
 481 ;;;###autoload
 482 (defun xref-find-definitions-other-frame (identifier)
 483   "Like `xref-find-definitions' but switch to the other frame."
 484   (interactive (list (xref--read-identifier "Find definitions of: ")))
 485   (xref--find-definitions identifier 'frame))
 486
 487 ;;;###autoload
 488 (defun xref-find-references (identifier)
 489   "Find references to the identifier at point.
 490 With prefix argument, prompt for the identifier."
 491   (interactive (list (xref--read-identifier "Find references of: ")))
 492   (xref--show-xrefs identifier "references"
 493                     (funcall xref-find-function 'references identifier)
 494                     nil))
 495
 496 ;;;###autoload
 497 (defun xref-find-apropos (pattern)
 498   "Find all meaningful symbols that match PATTERN.
 499 The argument has the same meaning as in `apropos'."
 500   (interactive (list (read-from-minibuffer
 501                       "Search for pattern (word list or regexp): ")))
 502   (require 'apropos)
 503   (xref--show-xrefs pattern "apropos"
 504                     (funcall xref-find-function 'apropos
 505                              (apropos-parse-pattern
 506                               (if (string-equal (regexp-quote pattern) pattern)
 507                                   ;; Split into words
 508                                   (or (split-string pattern "[ \t]+" t)
 509                                       (user-error "No word list given"))
 510                                 pattern)))
 511                     nil))
 512
 513 \f
 514 ;;; Key bindings
 515
 516 ;;;###autoload (define-key esc-map "." #'xref-find-definitions)
 517 ;;;###autoload (define-key esc-map "," #'xref-pop-marker-stack)
 518 ;;;###autoload (define-key esc-map [?\C-.] #'xref-find-apropos)
 519 ;;;###autoload (define-key ctl-x-4-map "." #'xref-find-definitions-other-window)
 520 ;;;###autoload (define-key ctl-x-5-map "." #'xref-find-definitions-other-frame)
 521
 522 \f
 523 (provide 'xref)
 524
 525 ;;; xref.el ends here