xref.el 35.6 KB
Newer Older
1 2
;; xref.el --- Cross-referencing commands              -*-lexical-binding:t-*-

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25

;; 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
26
;; dependent way and that's done by defining an xref backend.
27
;;
28 29 30
;; That consists of a constructor function, which should return a
;; backend value, and a set of implementations for the generic
;; functions:
31
;;
32 33 34 35 36 37 38 39 40
;; `xref-backend-identifier-at-point',
;; `xref-backend-identifier-completion-table',
;; `xref-backend-definitions', `xref-backend-references',
;; `xref-backend-apropos', which see.
;;
;; A major mode would normally use `add-hook' to add the backend
;; constructor to `xref-backend-functions'.
;;
;; The last three methods operate with "xref" and "location" values.
41 42 43
;;
;; One would usually call `make-xref' and `xref-make-file-location',
;; `xref-make-buffer-location' or `xref-make-bogus-location' to create
44 45 46
;; them.  More generally, a location must be an instance of an EIEIO
;; class inheriting from `xref-location' and implementing
;; `xref-location-group' and `xref-location-marker'.
47
;;
48 49 50 51 52
;; There's a special kind of xrefs we call "match xrefs", which
;; correspond to search results.  For these values,
;; `xref-match-length' must be defined, and `xref-location-marker'
;; must return the beginning of the match.
;;
53 54 55
;; 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
56
;; `xref-backend-identifier-completion-table' should still be
57 58 59
;; distinct, because the user can't see the properties when making the
;; choice.
;;
60
;; See the etags and elisp-mode implementations for full examples.
61 62 63 64 65 66

;;; Code:

(require 'cl-lib)
(require 'eieio)
(require 'ring)
67
(require 'pcase)
Dmitry Gutov's avatar
Dmitry Gutov committed
68
(require 'project)
69

70 71 72
(eval-when-compile
  (require 'semantic/symref)) ;; for hit-lines slot

73 74 75 76 77 78 79 80 81
(defgroup xref nil "Cross-referencing commands"
  :group 'tools)


;;; Locations

(defclass xref-location () ()
  :documentation "A location represents a position in a file or buffer.")

82
(cl-defgeneric xref-location-marker (location)
83 84
  "Return the marker for LOCATION.")

85
(cl-defgeneric xref-location-group (location)
86 87 88
  "Return a string used to group a set of locations.
This is typically the filename.")

89 90 91 92
(cl-defgeneric xref-location-line (_location)
  "Return the line number corresponding to the location."
  nil)

93 94
(cl-defgeneric xref-match-length (_item)
  "Return the length of the match."
Dmitry Gutov's avatar
Dmitry Gutov committed
95 96
  nil)

97 98 99 100 101 102
;;;; 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)
103
   (line :type fixnum :initarg :line :reader xref-location-line)
Dmitry Gutov's avatar
Dmitry Gutov committed
104
   (column :type fixnum :initarg :column :reader xref-file-location-column))
105 106 107 108
  :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)
109
  "Create and return a new `xref-file-location'."
110 111
  (make-instance 'xref-file-location :file file :line line :column column))

112
(cl-defmethod xref-location-marker ((l xref-file-location))
113 114 115 116 117 118 119 120 121 122
  (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)
123
          (forward-char column)
124 125
          (point-marker))))))

126
(cl-defmethod xref-location-group ((l xref-file-location))
127
  (oref l file))
128 129 130 131 132 133

(defclass xref-buffer-location (xref-location)
  ((buffer :type buffer :initarg :buffer)
   (position :type fixnum :initarg :position)))

(defun xref-make-buffer-location (buffer position)
134
  "Create and return a new `xref-buffer-location'."
135 136
  (make-instance 'xref-buffer-location :buffer buffer :position position))

137
(cl-defmethod xref-location-marker ((l xref-buffer-location))
138 139 140 141
  (with-slots (buffer position) l
    (let ((m (make-marker)))
      (move-marker m position buffer))))

142
(cl-defmethod xref-location-group ((l xref-buffer-location))
143 144 145 146 147 148 149 150 151 152 153 154
  (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)
155
  "Create and return a new `xref-bogus-location'."
156 157
  (make-instance 'xref-bogus-location :message message))

158
(cl-defmethod xref-location-marker ((l xref-bogus-location))
159
  (user-error "%s" (oref l message)))
160

161
(cl-defmethod xref-location-group ((_ xref-bogus-location)) "(No location)")
162 163 164 165


;;; Cross-reference

Dmitry Gutov's avatar
Dmitry Gutov committed
166
(defclass xref-item ()
167
  ((summary :type string :initarg :summary
Dmitry Gutov's avatar
Dmitry Gutov committed
168 169 170
            :reader xref-item-summary
            :documentation "One line which will be displayed for
this item in the output buffer.")
171
   (location :initarg :location
Dmitry Gutov's avatar
Dmitry Gutov committed
172 173 174 175 176
             :reader xref-item-location
             :documentation "An object describing how to navigate
to the reference's target."))
  :comment "An xref item describes a reference to a location
somewhere.")
177

178
(defun xref-make (summary location)
179
  "Create and return a new `xref-item'.
180
SUMMARY is a short string to describe the xref.
181
LOCATION is an `xref-location'."
Dmitry Gutov's avatar
Dmitry Gutov committed
182
  (make-instance 'xref-item :summary summary :location location))
183

Dmitry Gutov's avatar
Dmitry Gutov committed
184 185 186 187 188 189
(defclass xref-match-item ()
  ((summary :type string :initarg :summary
            :reader xref-item-summary)
   (location :initarg :location
             :type xref-file-location
             :reader xref-item-location)
190 191
   (length :initarg :length :reader xref-match-length))
  :comment "A match xref item describes a search result.")
Dmitry Gutov's avatar
Dmitry Gutov committed
192

193
(defun xref-make-match (summary location length)
194
  "Create and return a new `xref-match-item'.
Dmitry Gutov's avatar
Dmitry Gutov committed
195
SUMMARY is a short string to describe the xref.
196 197 198 199
LOCATION is an `xref-location'.
LENGTH is the match length, in characters."
  (make-instance 'xref-match-item :summary summary
                 :location location :length length))
Dmitry Gutov's avatar
Dmitry Gutov committed
200

201 202 203

;;; API

204
(defvar xref-backend-functions nil
205 206 207 208 209
  "Special hook to find the xref backend for the current context.
Each functions on this hook is called in turn with no arguments
and should return either nil to mean that it is not applicable,
or an xref backend, which is a value to be used to dispatch the
generic functions.")
210

211
;; We make the etags backend the default for now, until something
212 213 214
;; better comes along.  Use APPEND so that any `add-hook' calls made
;; before this package is loaded put new items before this one.
(add-hook 'xref-backend-functions #'etags--xref-backend t)
215

216
;;;###autoload
217 218
(defun xref-find-backend ()
  (run-hook-with-args-until-success 'xref-backend-functions))
219

220 221
(cl-defgeneric xref-backend-definitions (backend identifier)
  "Find definitions of IDENTIFIER.
222

223 224 225 226 227
The result must be a list of xref objects.  If IDENTIFIER
contains sufficient information to determine a unique definition,
return only that definition. If there are multiple possible
definitions, return all of them.  If no definitions can be found,
return nil.
228 229

IDENTIFIER can be any string returned by
230 231
`xref-backend-identifier-at-point', or from the table returned by
`xref-backend-identifier-completion-table'.
232 233 234

To create an xref object, call `xref-make'.")

235
(cl-defgeneric xref-backend-references (_backend identifier)
236 237
  "Find references of IDENTIFIER.
The result must be a list of xref objects.  If no references can
238 239
be found, return nil.

Stephen Leake's avatar
Stephen Leake committed
240 241 242
The default implementation uses `semantic-symref-tool-alist' to
find a search tool; by default, this uses \"find | grep\" in the
`project-current' roots."
243 244 245 246 247 248
  (cl-mapcan
   (lambda (dir)
     (xref-collect-references identifier dir))
   (let ((pr (project-current t)))
     (append
      (project-roots pr)
249
      (project-external-roots pr)))))
250 251 252 253 254 255 256

(cl-defgeneric xref-backend-apropos (backend pattern)
  "Find all symbols that match PATTERN.
PATTERN is a regexp")

(cl-defgeneric xref-backend-identifier-at-point (_backend)
  "Return the relevant identifier at point.
257 258 259 260

The return value must be a string or nil.  nil means no
identifier at point found.

Paul Eggert's avatar
Paul Eggert committed
261
If it's hard to determine the identifier precisely (e.g., because
262 263
it's a method call on unknown type), the implementation can
return a simple string (such as symbol at point) marked with a
264 265
special text property which e.g. `xref-backend-definitions' would
recognize and then delegate the work to an external process."
266 267 268
  (let ((thing (thing-at-point 'symbol)))
    (and thing (substring-no-properties thing))))

269 270 271
(cl-defgeneric xref-backend-identifier-completion-table (backend)
  "Returns the completion table for identifiers.")

272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316

;;; 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."
317
  :type 'integer)
318

319 320 321 322
(defcustom xref-prompt-for-identifier '(not xref-find-definitions
                                            xref-find-definitions-other-window
                                            xref-find-definitions-other-frame)
  "When t, always prompt for the identifier name.
323

324 325 326 327 328 329 330 331
When nil, prompt only when there's no value at point we can use,
or when the command has been called with the prefix argument.

Otherwise, it's a list of xref commands which will prompt
anyway (the value at point, if any, will be used as the default).

If the list starts with `not', the meaning of the rest of the
elements is negated."
332
  :type '(choice (const :tag "always" t)
333 334 335 336
                 (const :tag "auto" nil)
                 (set :menu-tag "command specific" :tag "commands"
		      :value (not)
		      (const :tag "Except" not)
337
		      (repeat :inline t (symbol :tag "command")))))
338

339 340 341 342 343 344 345 346
(defcustom xref-after-jump-hook '(recenter
                                  xref-pulse-momentarily)
  "Functions called after jumping to an xref."
  :type 'hook)

(defcustom xref-after-return-hook '(xref-pulse-momentarily)
  "Functions called after returning to a pre-jump location."
  :type 'hook)
Dmitry Gutov's avatar
Dmitry Gutov committed
347

348 349 350
(defvar xref--marker-ring (make-ring xref-marker-ring-length)
  "Ring of markers to implement the marker stack.")

351 352 353
(defun xref-push-marker-stack (&optional m)
  "Add point M (defaults to `point-marker') to the marker stack."
  (ring-insert xref--marker-ring (or m (point-marker))))
354 355 356 357 358 359 360

;;;###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)
361
      (user-error "Marker stack is empty"))
362 363
    (let ((marker (ring-remove ring 0)))
      (switch-to-buffer (or (marker-buffer marker)
364
                            (user-error "The marked buffer has been deleted")))
365
      (goto-char (marker-position marker))
Dmitry Gutov's avatar
Dmitry Gutov committed
366
      (set-marker marker nil nil)
367 368
      (run-hooks 'xref-after-return-hook))))

Dmitry Gutov's avatar
Dmitry Gutov committed
369 370
(defvar xref--current-item nil)

371
(defun xref-pulse-momentarily ()
Dmitry Gutov's avatar
Dmitry Gutov committed
372 373 374
  (pcase-let ((`(,beg . ,end)
               (save-excursion
                 (or
375 376
                  (let ((length (xref-match-length xref--current-item)))
                    (and length (cons (point) (+ (point) length))))
Dmitry Gutov's avatar
Dmitry Gutov committed
377 378 379 380
                  (back-to-indentation)
                  (if (eolp)
                      (cons (line-beginning-position) (1+ (point)))
                    (cons (point) (line-end-position)))))))
381
    (pulse-momentary-highlight-region beg end 'next-error)))
382 383 384 385 386 387 388 389 390

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

391
;;;###autoload
392 393 394 395
(defun xref-marker-stack-empty-p ()
  "Return t if the marker stack is empty; nil otherwise."
  (ring-empty-p xref--marker-ring))

396

397 398 399 400 401 402 403 404

(defun xref--goto-char (pos)
  (cond
   ((and (<= (point-min) pos) (<= pos (point-max))))
   (widen-automatically (widen))
   (t (user-error "Position is outside accessible part of buffer")))
  (goto-char pos))

405 406 407 408
(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))
409
    (xref--goto-char marker)))
410

Dmitry Gutov's avatar
Dmitry Gutov committed
411 412
(defun xref--pop-to-location (item &optional window)
  "Go to the location of ITEM and display the buffer.
413 414
WINDOW controls how the buffer is displayed:
  nil      -- switch-to-buffer
415 416
  `window' -- pop-to-buffer (other window)
  `frame'  -- pop-to-buffer (other frame)"
417 418 419 420 421 422 423 424
  (let* ((marker (save-excursion
                   (xref-location-marker (xref-item-location item))))
         (buf (marker-buffer marker)))
    (cl-ecase window
      ((nil)  (switch-to-buffer buf))
      (window (pop-to-buffer buf t))
      (frame  (let ((pop-up-frames t)) (pop-to-buffer buf t))))
    (xref--goto-char marker))
Dmitry Gutov's avatar
Dmitry Gutov committed
425 426
  (let ((xref--current-item item))
    (run-hooks 'xref-after-jump-hook)))
427 428 429 430 431 432


;;; XREF buffer (part of the UI)

;; The xref buffer is used to display a set of xrefs.

433 434
(defvar-local xref--display-history nil
  "List of pairs (BUFFER . WINDOW), for temporarily displayed buffers.")
435

436 437 438 439 440 441 442
(defun xref--save-to-history (buf win)
  (let ((restore (window-parameter win 'quit-restore)))
    ;; Save the new entry if the window displayed another buffer
    ;; previously.
    (when (and restore (not (eq (car restore) 'same)))
      (push (cons buf win) xref--display-history))))

443
(defun xref--display-position (pos other-window buf)
444
  ;; Show the location, but don't hijack focus.
445 446 447 448 449 450 451 452 453
  (let ((xref-buf (current-buffer)))
    (with-selected-window (display-buffer buf other-window)
      (xref--goto-char pos)
      (run-hooks 'xref-after-jump-hook)
      (let ((buf (current-buffer))
            (win (selected-window)))
        (with-current-buffer xref-buf
          (setq-local other-window-scroll-buffer buf)
          (xref--save-to-history buf win))))))
454 455 456

(defun xref--show-location (location)
  (condition-case err
457 458 459
      (let* ((marker (xref-location-marker location))
             (buf (marker-buffer marker)))
        (xref--display-position marker t buf))
460 461
    (user-error (message (error-message-string err)))))

462 463 464
(defun xref-show-location-at-point ()
  "Display the source of xref at point in the other window, if any."
  (interactive)
Dmitry Gutov's avatar
Dmitry Gutov committed
465 466 467 468
  (let* ((xref (xref--item-at-point))
         (xref--current-item xref))
    (when xref
      (xref--show-location (xref-item-location xref)))))
469

470 471 472
(defun xref-next-line ()
  "Move to the next xref and display its source in the other window."
  (interactive)
Dmitry Gutov's avatar
Dmitry Gutov committed
473
  (xref--search-property 'xref-item)
474
  (xref-show-location-at-point))
475 476 477 478

(defun xref-prev-line ()
  "Move to the previous xref and display its source in the other window."
  (interactive)
Dmitry Gutov's avatar
Dmitry Gutov committed
479
  (xref--search-property 'xref-item t)
480
  (xref-show-location-at-point))
481

Dmitry Gutov's avatar
Dmitry Gutov committed
482
(defun xref--item-at-point ()
483 484
  (save-excursion
    (back-to-indentation)
Dmitry Gutov's avatar
Dmitry Gutov committed
485
    (get-text-property (point) 'xref-item)))
486

487 488
(defvar-local xref--window nil
  "ACTION argument to call `display-buffer' with.")
489 490

(defun xref-goto-xref ()
491
  "Jump to the xref on the current line and bury the xref buffer."
492
  (interactive)
Dmitry Gutov's avatar
Dmitry Gutov committed
493
  (let ((xref (or (xref--item-at-point)
494
                 (user-error "No reference at point")))
495
        (window xref--window))
496
    (xref-quit)
Dmitry Gutov's avatar
Dmitry Gutov committed
497
    (xref--pop-to-location xref window)))
498

499 500 501 502 503 504 505 506 507 508 509
(defun xref-query-replace (from to)
  "Perform interactive replacement in all current matches."
  (interactive
   (list (read-regexp "Query replace regexp in matches" ".*")
         (read-regexp "Replace with: ")))
  (let (pairs item)
    (unwind-protect
        (progn
          (save-excursion
            (goto-char (point-min))
            (while (setq item (xref--search-property 'xref-item))
510
              (when (xref-match-length item)
511
                (save-excursion
512 513
                  (let* ((loc (xref-item-location item))
                         (beg (xref-location-marker loc))
514 515 516
                         (end (move-marker (make-marker)
                                           (+ beg (xref-match-length item))
                                           (marker-buffer beg))))
517 518 519 520 521 522 523 524 525 526 527
                    ;; Perform sanity check first.
                    (xref--goto-location loc)
                    ;; FIXME: The check should probably be a generic
                    ;; function, instead of the assumption that all
                    ;; matches contain the full line as summary.
                    ;; TODO: Offer to re-scan otherwise.
                    (unless (equal (buffer-substring-no-properties
                                    (line-beginning-position)
                                    (line-end-position))
                                   (xref-item-summary item))
                      (user-error "Search results out of date"))
528
                    (push (cons beg end) pairs)))))
529 530 531 532
            (setq pairs (nreverse pairs)))
          (unless pairs (user-error "No suitable matches here"))
          (xref--query-replace-1 from to pairs))
      (dolist (pair pairs)
533 534
        (move-marker (car pair) nil)
        (move-marker (cdr pair) nil)))))
535

536
;; FIXME: Write a nicer UI.
537 538
(defun xref--query-replace-1 (from to pairs)
  (let* ((query-replace-lazy-highlight nil)
539
         current-beg current-end current-buf
540 541 542 543 544
         ;; Counteract the "do the next match now" hack in
         ;; `perform-replace'.  And still, it'll report that those
         ;; matches were "filtered out" at the end.
         (isearch-filter-predicate
          (lambda (beg end)
545
            (and current-beg
546
                 (eq (current-buffer) current-buf)
547
                 (>= beg current-beg)
548
                 (<= end current-end))))
549 550
         (replace-re-search-function
          (lambda (from &optional _bound noerror)
551
            (let (found pair)
552
              (while (and (not found) pairs)
553 554
                (setq pair (pop pairs)
                      current-beg (car pair)
555
                      current-end (cdr pair)
556
                      current-buf (marker-buffer current-beg))
557
                (pop-to-buffer current-buf)
558
                (goto-char current-beg)
559
                (when (re-search-forward from current-end noerror)
560 561 562 563 564 565 566 567
                  (setq found t)))
              found))))
    ;; FIXME: Despite this being a multi-buffer replacement, `N'
    ;; doesn't work, because we're not using
    ;; `multi-query-replace-map', and it would expect the below
    ;; function to be called once per buffer.
    (perform-replace from to t t nil)))

568 569 570 571 572
(defvar xref--xref-buffer-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [remap quit-window] #'xref-quit)
    (define-key map (kbd "n") #'xref-next-line)
    (define-key map (kbd "p") #'xref-prev-line)
573
    (define-key map (kbd "r") #'xref-query-replace)
574 575 576 577 578 579 580 581
    (define-key map (kbd "RET") #'xref-goto-xref)
    (define-key map (kbd "C-o") #'xref-show-location-at-point)
    ;; suggested by Johan Claesson "to further reduce finger movement":
    (define-key map (kbd ".") #'xref-next-line)
    (define-key map (kbd ",") #'xref-prev-line)
    map))

(define-derived-mode xref--xref-buffer-mode special-mode "XREF"
Paul Eggert's avatar
Paul Eggert committed
582
  "Mode for displaying cross-references."
583 584 585 586 587 588 589 590 591
  (setq buffer-read-only t)
  (setq next-error-function #'xref--next-error-function)
  (setq next-error-last-buffer (current-buffer)))

(defun xref--next-error-function (n reset?)
  (when reset?
    (goto-char (point-min)))
  (let ((backward (< n 0))
        (n (abs n))
Dmitry Gutov's avatar
Dmitry Gutov committed
592
        (xref nil))
593
    (dotimes (_ n)
Dmitry Gutov's avatar
Dmitry Gutov committed
594
      (setq xref (xref--search-property 'xref-item backward)))
Dmitry Gutov's avatar
Dmitry Gutov committed
595 596
    (cond (xref
           (xref--pop-to-location xref))
597 598
          (t
           (error "No %s xref" (if backward "previous" "next"))))))
599

600
(defun xref-quit (&optional kill)
601 602
  "Bury temporarily displayed buffers, then quit the current window.

603
If KILL is non-nil, also kill the current buffer.
604 605 606

The buffers that the user has otherwise interacted with in the
meantime are preserved."
607
  (interactive "P")
608 609 610
  (let ((window (selected-window))
        (history xref--display-history))
    (setq xref--display-history nil)
611 612 613 614
    (pcase-dolist (`(,buf . ,win) history)
      (when (and (window-live-p win)
                 (eq buf (window-buffer win)))
        (quit-window nil win)))
615
    (quit-window kill window)))
616

617 618 619
(defconst xref-buffer-name "*xref*"
  "The name of the buffer to show xrefs.")

Dmitry Gutov's avatar
Dmitry Gutov committed
620 621 622 623 624 625 626 627 628 629 630 631
(defvar xref--button-map
  (let ((map (make-sparse-keymap)))
    (define-key map [(control ?m)] #'xref-goto-xref)
    (define-key map [mouse-1] #'xref-goto-xref)
    (define-key map [mouse-2] #'xref--mouse-2)
    map))

(defun xref--mouse-2 (event)
  "Move point to the button and show the xref definition."
  (interactive "e")
  (mouse-set-point event)
  (forward-line 0)
Dmitry Gutov's avatar
Dmitry Gutov committed
632
  (xref--search-property 'xref-item)
Dmitry Gutov's avatar
Dmitry Gutov committed
633 634
  (xref-show-location-at-point))

635 636
(defun xref--insert-xrefs (xref-alist)
  "Insert XREF-ALIST in the current-buffer.
637
XREF-ALIST is of the form ((GROUP . (XREF ...)) ...), where
638
GROUP is a string for decoration purposes and XREF is an
Dmitry Gutov's avatar
Dmitry Gutov committed
639
`xref-item' object."
Dmitry Gutov's avatar
Dmitry Gutov committed
640
  (require 'compile) ; For the compilation faces.
641 642 643 644
  (cl-loop for ((group . xrefs) . more1) on xref-alist
           for max-line-width =
           (cl-loop for xref in xrefs
                    maximize (let ((line (xref-location-line
645
                                          (oref xref location))))
646 647 648 649
                               (length (and line (format "%d" line)))))
           for line-format = (and max-line-width
                                  (format "%%%dd: " max-line-width))
           do
650
           (xref--insert-propertized '(face compilation-info) group "\n")
651
           (cl-loop for (xref . more2) on xrefs do
652
                    (with-slots (summary location) xref
653 654 655 656 657 658 659
                      (let* ((line (xref-location-line location))
                             (prefix
                              (if line
                                  (propertize (format line-format line)
                                              'face 'compilation-line-number)
                                "  ")))
                        (xref--insert-propertized
Dmitry Gutov's avatar
Dmitry Gutov committed
660
                         (list 'xref-item xref
661 662 663 664 665 666
                               ;; 'face 'font-lock-keyword-face
                               'mouse-face 'highlight
                               'keymap xref--button-map
                               'help-echo
                               (concat "mouse-2: display in another window, "
                                       "RET or mouse-1: follow reference"))
667
                         prefix summary)))
668
                    (insert "\n"))))
669 670 671 672 673 674

(defun xref--analyze (xrefs)
  "Find common filenames in XREFS.
Return an alist of the form ((FILENAME . (XREF ...)) ...)."
  (xref--alistify xrefs
                  (lambda (x)
Dmitry Gutov's avatar
Dmitry Gutov committed
675
                    (xref-location-group (xref-item-location x)))
676 677
                  #'equal))

678
(defun xref--show-xref-buffer (xrefs alist)
679 680 681 682 683 684 685 686
  (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))
687
        (setq xref--window (assoc-default 'window alist))
688 689 690 691 692
        (current-buffer)))))


;; This part of the UI seems fairly uncontroversial: it reads the
;; identifier and deals with the single definition case.
693 694
;; (FIXME: do we really want this case to be handled like that in
;; "find references" and "find regexp searches"?)
695 696 697 698 699 700 701
;;
;; 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.")

702 703 704 705
(defvar xref--read-identifier-history nil)

(defvar xref--read-pattern-history nil)

706 707 708 709 710 711 712 713 714
(defun xref--show-xrefs (xrefs window)
  (cond
   ((not (cdr xrefs))
    (xref-push-marker-stack)
    (xref--pop-to-location (car xrefs) window))
   (t
    (xref-push-marker-stack)
    (funcall xref-show-xrefs-function xrefs
             `((window . ,window))))))
715

716 717 718 719 720 721
(defun xref--prompt-p (command)
  (or (eq xref-prompt-for-identifier t)
      (if (eq (car xref-prompt-for-identifier) 'not)
          (not (memq command (cdr xref-prompt-for-identifier)))
        (memq command xref-prompt-for-identifier))))

722 723
(defun xref--read-identifier (prompt)
  "Return the identifier at point or read it from the minibuffer."
724 725
  (let* ((backend (xref-find-backend))
         (id (xref-backend-identifier-at-point backend)))
726 727 728
    (cond ((or current-prefix-arg
               (not id)
               (xref--prompt-p this-command))
729 730 731 732 733 734
           (completing-read (if id
                                (format "%s (default %s): "
                                        (substring prompt 0 (string-match
                                                             "[ :]+\\'" prompt))
                                        id)
                              prompt)
735
                            (xref-backend-identifier-completion-table backend)
Dmitry Gutov's avatar
Dmitry Gutov committed
736
                            nil nil nil
737
                            'xref--read-identifier-history id))
738 739 740 741 742
          (t id))))


;;; Commands

743
(defun xref--find-xrefs (input kind arg window)
744 745 746
  (let ((xrefs (funcall (intern (format "xref-backend-%s" kind))
                        (xref-find-backend)
                        arg)))
747 748 749 750
    (unless xrefs
      (user-error "No %s found for: %s" (symbol-name kind) input))
    (xref--show-xrefs xrefs window)))

751
(defun xref--find-definitions (id window)
752
  (xref--find-xrefs id 'definitions id window))
753 754 755 756

;;;###autoload
(defun xref-find-definitions (identifier)
  "Find the definition of the identifier at point.
757
With prefix argument or when there's no identifier at point,
758 759 760 761 762 763 764 765
prompt for it.

If the backend has sufficient information to determine a unique
definition for IDENTIFIER, it returns only that definition. If
there are multiple possible definitions, it returns all of them.

If the backend returns one definition, jump to it; otherwise,
display the list in a buffer."
766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785
  (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: ")))
786
  (xref--find-xrefs identifier 'references identifier nil))
Dmitry Gutov's avatar
Dmitry Gutov committed
787

788 789
(declare-function apropos-parse-pattern "apropos" (pattern))

790 791 792 793
;;;###autoload
(defun xref-find-apropos (pattern)
  "Find all meaningful symbols that match PATTERN.
The argument has the same meaning as in `apropos'."
794
  (interactive (list (read-string
795
                      "Search for pattern (word list or regexp): "
796
                      nil 'xref--read-pattern-history)))
797
  (require 'apropos)
798
  (xref--find-xrefs pattern 'apropos
799 800 801 802 803 804
                    (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))
805 806 807 808 809 810 811
                    nil))


;;; Key bindings

;;;###autoload (define-key esc-map "." #'xref-find-definitions)
;;;###autoload (define-key esc-map "," #'xref-pop-marker-stack)
812
;;;###autoload (define-key esc-map "?" #'xref-find-references)
813 814 815 816
;;;###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)

Dmitry Gutov's avatar
Dmitry Gutov committed
817 818 819 820 821 822 823 824 825 826 827 828 829 830

;;; Helper functions

(defvar xref-etags-mode--saved nil)

(define-minor-mode xref-etags-mode
  "Minor mode to make xref use etags again.

Certain major modes install their own mechanisms for listing
identifiers and navigation.  Turn this on to undo those settings
and just use etags."
  :lighter ""
  (if xref-etags-mode
      (progn
831 832 833
        (setq xref-etags-mode--saved xref-backend-functions)
        (kill-local-variable 'xref-backend-functions))
    (setq-local xref-backend-functions xref-etags-mode--saved)))
Dmitry Gutov's avatar
Dmitry Gutov committed
834

835 836
(declare-function semantic-symref-find-references-by-name "semantic/symref")
(declare-function semantic-find-file-noselect "semantic/fw")
837
(declare-function grep-expand-template "grep")
838

839 840 841 842 843 844
(defun xref-collect-references (symbol dir)
  "Collect references to SYMBOL inside DIR.
This function uses the Semantic Symbol Reference API, see
`semantic-symref-find-references-by-name' for details on which
tools are used, and when."
  (cl-assert (directory-name-p dir))
845 846 847 848
  (require 'semantic/symref)
  (defvar semantic-symref-tool)
  (let* ((default-directory dir)
         (semantic-symref-tool 'detect)
849
         (res (semantic-symref-find-references-by-name symbol 'subdirs))
850
         (hits (and res (oref res hit-lines)))
851
         (orig-buffers (buffer-list)))
852
    (unwind-protect
853 854 855
        (cl-mapcan (lambda (hit) (xref--collect-matches
                             hit (format "\\_<%s\\_>" (regexp-quote symbol))))
                   hits)
856 857
      ;; TODO: Implement "lightweight" buffer visiting, so that we
      ;; don't have to kill them.
858 859 860
      (mapc #'kill-buffer
            (cl-set-difference (buffer-list) orig-buffers)))))

861 862 863 864
(defun xref-collect-matches (regexp files dir ignores)
  "Collect matches for REGEXP inside FILES in DIR.
FILES is a string with glob patterns separated by spaces.
IGNORES is a list of glob patterns."
865 866 867 868
  (cl-assert (directory-name-p dir))
  (require 'semantic/fw)
  (grep-compute-defaults)
  (defvar grep-find-template)
869
  (defvar grep-highlight-matches)
870 871
  (let* ((grep-find-template (replace-regexp-in-string "-e " "-E "
                                                       grep-find-template t t))
872
         (grep-highlight-matches nil)
Dmitry Gutov's avatar
Dmitry Gutov committed
873
         (command (xref--rgrep-command (xref--regexp-to-extended regexp)
874
                                       files dir ignores))
875 876 877 878 879 880
         (orig-buffers (buffer-list))
         (buf (get-buffer-create " *xref-grep*"))
         (grep-re (caar grep-regexp-alist))
         hits)
    (with-current-buffer buf
      (erase-buffer)
881 882 883 884 885 886
      (call-process-shell-command command nil t)
      (goto-char (point-min))
      (while (re-search-forward grep-re nil t)
        (push (cons (string-to-number (match-string 2))
                    (match-string 1))
              hits)))
887
    (unwind-protect
888
        (cl-mapcan (lambda (hit) (xref--collect-matches hit regexp))
889
                   hits)
890
      ;; TODO: Same as above.
891
      (mapc #'kill-buffer
892
            (cl-set-difference (buffer-list) orig-buffers)))))
893

Dmitry Gutov's avatar
Dmitry Gutov committed
894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916
(defun xref--rgrep-command (regexp files dir ignores)
  (require 'find-dired)      ; for `find-name-arg'
  (defvar grep-find-template)
  (defvar find-name-arg)
  (grep-expand-template
   grep-find-template
   regexp
   (concat (shell-quote-argument "(")
           " " find-name-arg " "
           (mapconcat
            #'shell-quote-argument
            (split-string files)
            (concat " -o " find-name-arg " "))
           " "
           (shell-quote-argument ")"))
   dir
   (concat
    (shell-quote-argument "(")
    " -path "
    (mapconcat
     (lambda (ignore)
       (when (string-match-p "/\\'" ignore)
         (setq ignore (concat ignore "*")))
917 918 919 920
       (if (string-match "\\`\\./" ignore)
           (setq ignore (replace-match dir t t ignore))
         (unless (string-prefix-p "*" ignore)
           (setq ignore (concat "*/" ignore))))
Dmitry Gutov's avatar
Dmitry Gutov committed
921 922 923 924 925 926 927
       (shell-quote-argument ignore))
     ignores
     " -o -path ")
    " "
    (shell-quote-argument ")")
    " -prune -o ")))

Dmitry Gutov's avatar
Dmitry Gutov committed
928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945
(defun xref--regexp-to-extended (str)
  (replace-regexp-in-string
   ;; FIXME: Add tests.  Move to subr.el, make a public function.
   ;; Maybe error on Emacs-only constructs.
   "\\(?:\\\\\\\\\\)*\\(?:\\\\[][]\\)?\\(?:\\[.+?\\]\\|\\(\\\\?[(){}|]\\)\\)"
   (lambda (str)
     (cond
      ((not (match-beginning 1))
       str)
      ((eq (length (match-string 1 str)) 2)
       (concat (substring str 0 (match-beginning 1))
               (substring (match-string 1 str) 1 2)))
      (t
       (concat (substring str 0 (match-beginning 1))
               "\\"
               (match-string 1 str)))))
   str t t))

946
(defun xref--collect-matches (hit regexp)
947 948
  (pcase-let* ((`(,line . ,file) hit)
               (buf (or (find-buffer-visiting file)
949
                        (semantic-find-file-noselect file))))
950 951 952 953
    (with-current-buffer buf
      (save-excursion
        (goto-char (point-min))
        (forward-line (1- line))
954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969
        (let ((line-end (line-end-position))
              (line-beg (line-beginning-position))
              matches)
          (syntax-propertize line-end)
          ;; FIXME: This results in several lines with the same
          ;; summary. Solve with composite pattern?
          (while (re-search-forward regexp line-end t)
            (let* ((beg-column (- (match-beginning 0) line-beg))
                   (end-column (- (match-end 0) line-beg))
                   (loc (xref-make-file-location file line beg-column))
                   (summary (buffer-substring line-beg line-end)))
              (add-face-text-property beg-column end-column 'highlight
                                      t summary)
              (push (xref-make-match summary loc (- end-column beg-column))
                    matches)))
          (nreverse matches))))))
970

971 972 973
(provide 'xref)

;;; xref.el ends here