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.  More generally, a location must be an instance of an EIEIO
  38 ;; class inheriting from `xref-location' and implementing
  39 ;; `xref-location-group' and `xref-location-marker'.
  40 ;;
  41 ;; There's a special kind of xrefs we call "match xrefs", which
  42 ;; correspond to search results.  For these values,
  43 ;; `xref-match-length' must be defined, and `xref-location-marker'
  44 ;; must return the beginning of the match.
  45 ;;
  46 ;; Each identifier must be represented as a string.  Implementers can
  47 ;; use string properties to store additional information about the
  48 ;; identifier, but they should keep in mind that values returned from
  49 ;; `xref-identifier-completion-table-function' should still be
  50 ;; distinct, because the user can't see the properties when making the
  51 ;; choice.
  52 ;;
  53 ;; See the functions `etags-xref-find' and `elisp-xref-find' for full
  54 ;; examples.
  55
  56 ;;; Code:
  57
  58 (require 'cl-lib)
  59 (require 'eieio)
  60 (require 'ring)
  61 (require 'pcase)
  62 (require 'project)
  63
  64 (eval-when-compile
  65   (require 'semantic/symref)) ;; for hit-lines slot
  66
  67 (defgroup xref nil "Cross-referencing commands"
  68   :group 'tools)
  69
  70 \f
  71 ;;; Locations
  72
  73 (defclass xref-location () ()
  74   :documentation "A location represents a position in a file or buffer.")
  75
  76 (cl-defgeneric xref-location-marker (location)
  77   "Return the marker for LOCATION.")
  78
  79 (cl-defgeneric xref-location-group (location)
  80   "Return a string used to group a set of locations.
  81 This is typically the filename.")
  82
  83 (cl-defgeneric xref-location-line (_location)
  84   "Return the line number corresponding to the location."
  85   nil)
  86
  87 (cl-defgeneric xref-match-length (_item)
  88   "Return the length of the match."
  89   nil)
  90
  91 ;;;; Commonly needed location classes are defined here:
  92
  93 ;; FIXME: might be useful to have an optional "hint" i.e. a string to
  94 ;; search for in case the line number is sightly out of date.
  95 (defclass xref-file-location (xref-location)
  96   ((file :type string :initarg :file)
  97    (line :type fixnum :initarg :line :reader xref-location-line)
  98    (column :type fixnum :initarg :column :reader xref-file-location-column))
  99   :documentation "A file location is a file/line/column triple.
 100 Line numbers start from 1 and columns from 0.")
 101
 102 (defun xref-make-file-location (file line column)
 103   "Create and return a new `xref-file-location'."
 104   (make-instance 'xref-file-location :file file :line line :column column))
 105
 106 (cl-defmethod xref-location-marker ((l xref-file-location))
 107   (with-slots (file line column) l
 108     (with-current-buffer
 109         (or (get-file-buffer file)
 110             (let ((find-file-suppress-same-file-warnings t))
 111               (find-file-noselect file)))
 112       (save-restriction
 113         (widen)
 114         (save-excursion
 115           (goto-char (point-min))
 116           (beginning-of-line line)
 117           (forward-char column)
 118           (point-marker))))))
 119
 120 (cl-defmethod xref-location-group ((l xref-file-location))
 121   (oref l file))
 122
 123 (defclass xref-buffer-location (xref-location)
 124   ((buffer :type buffer :initarg :buffer)
 125    (position :type fixnum :initarg :position)))
 126
 127 (defun xref-make-buffer-location (buffer position)
 128   "Create and return a new `xref-buffer-location'."
 129   (make-instance 'xref-buffer-location :buffer buffer :position position))
 130
 131 (cl-defmethod xref-location-marker ((l xref-buffer-location))
 132   (with-slots (buffer position) l
 133     (let ((m (make-marker)))
 134       (move-marker m position buffer))))
 135
 136 (cl-defmethod xref-location-group ((l xref-buffer-location))
 137   (with-slots (buffer) l
 138     (or (buffer-file-name buffer)
 139         (format "(buffer %s)" (buffer-name buffer)))))
 140
 141 (defclass xref-bogus-location (xref-location)
 142   ((message :type string :initarg :message
 143             :reader xref-bogus-location-message))
 144   :documentation "Bogus locations are sometimes useful to
 145 indicate errors, e.g. when we know that a function exists but the
 146 actual location is not known.")
 147
 148 (defun xref-make-bogus-location (message)
 149   "Create and return a new `xref-bogus-location'."
 150   (make-instance 'xref-bogus-location :message message))
 151
 152 (cl-defmethod xref-location-marker ((l xref-bogus-location))
 153   (user-error "%s" (oref l message)))
 154
 155 (cl-defmethod xref-location-group ((_ xref-bogus-location)) "(No location)")
 156
 157 \f
 158 ;;; Cross-reference
 159
 160 (defclass xref-item ()
 161   ((summary :type string :initarg :summary
 162             :reader xref-item-summary
 163             :documentation "One line which will be displayed for
 164 this item in the output buffer.")
 165    (location :initarg :location
 166              :reader xref-item-location
 167              :documentation "An object describing how to navigate
 168 to the reference's target."))
 169   :comment "An xref item describes a reference to a location
 170 somewhere.")
 171
 172 (defun xref-make (summary location)
 173   "Create and return a new `xref-item'.
 174 SUMMARY is a short string to describe the xref.
 175 LOCATION is an `xref-location'."
 176   (make-instance 'xref-item :summary summary :location location))
 177
 178 (defclass xref-match-item ()
 179   ((summary :type string :initarg :summary
 180             :reader xref-item-summary)
 181    (location :initarg :location
 182              :type xref-file-location
 183              :reader xref-item-location)
 184    (length :initarg :length :reader xref-match-length))
 185   :comment "A match xref item describes a search result.")
 186
 187 (defun xref-make-match (summary location length)
 188   "Create and return a new `xref-match-item'.
 189 SUMMARY is a short string to describe the xref.
 190 LOCATION is an `xref-location'.
 191 LENGTH is the match length, in characters."
 192   (make-instance 'xref-match-item :summary summary
 193                  :location location :length length))
 194
 195 \f
 196 ;;; API
 197
 198 (declare-function etags-xref-find "etags" (action id))
 199 (declare-function tags-lazy-completion-table "etags" ())
 200
 201 ;; For now, make the etags backend the default.
 202 (defvar xref-find-function #'etags-xref-find
 203   "Function to look for cross-references.
 204 It can be called in several ways:
 205
 206  (definitions IDENTIFIER): Find definitions of IDENTIFIER.  The
 207 result must be a list of xref objects.  If IDENTIFIER contains
 208 sufficient information to determine a unique definition, returns
 209 only that definition. If there are multiple possible definitions,
 210 return all of them.  If no definitions can be found, return nil.
 211
 212  (references IDENTIFIER): Find references of IDENTIFIER.  The
 213 result must be a list of xref objects.  If no references can be
 214 found, return nil.
 215
 216  (apropos PATTERN): Find all symbols that match PATTERN.  PATTERN
 217 is a regexp.
 218
 219 IDENTIFIER can be any string returned by
 220 `xref-identifier-at-point-function', or from the table returned
 221 by `xref-identifier-completion-table-function'.
 222
 223 To create an xref object, call `xref-make'.")
 224
 225 (defvar xref-identifier-at-point-function #'xref-default-identifier-at-point
 226   "Function to get the relevant identifier at point.
 227
 228 The return value must be a string or nil.  nil means no
 229 identifier at point found.
 230
 231 If it's hard to determine the identifier precisely (e.g., because
 232 it's a method call on unknown type), the implementation can
 233 return a simple string (such as symbol at point) marked with a
 234 special text property which `xref-find-function' would recognize
 235 and then delegate the work to an external process.")
 236
 237 (defvar xref-identifier-completion-table-function #'tags-lazy-completion-table
 238   "Function that returns the completion table for identifiers.")
 239
 240 (defun xref-default-identifier-at-point ()
 241   (let ((thing (thing-at-point 'symbol)))
 242     (and thing (substring-no-properties thing))))
 243
 244 \f
 245 ;;; misc utilities
 246 (defun xref--alistify (list key test)
 247   "Partition the elements of LIST into an alist.
 248 KEY extracts the key from an element and TEST is used to compare
 249 keys."
 250   (let ((alist '()))
 251     (dolist (e list)
 252       (let* ((k (funcall key e))
 253              (probe (cl-assoc k alist :test test)))
 254         (if probe
 255             (setcdr probe (cons e (cdr probe)))
 256           (push (cons k (list e)) alist))))
 257     ;; Put them back in order.
 258     (cl-loop for (key . value) in (reverse alist)
 259              collect (cons key (reverse value)))))
 260
 261 (defun xref--insert-propertized (props &rest strings)
 262   "Insert STRINGS with text properties PROPS."
 263   (let ((start (point)))
 264     (apply #'insert strings)
 265     (add-text-properties start (point) props)))
 266
 267 (defun xref--search-property (property &optional backward)
 268     "Search the next text range where text property PROPERTY is non-nil.
 269 Return the value of PROPERTY.  If BACKWARD is non-nil, search
 270 backward."
 271   (let ((next (if backward
 272                   #'previous-single-char-property-change
 273                 #'next-single-char-property-change))
 274         (start (point))
 275         (value nil))
 276     (while (progn
 277              (goto-char (funcall next (point) property))
 278              (not (or (setq value (get-text-property (point) property))
 279                       (eobp)
 280                       (bobp)))))
 281     (cond (value)
 282           (t (goto-char start) nil))))
 283
 284 \f
 285 ;;; Marker stack  (M-. pushes, M-, pops)
 286
 287 (defcustom xref-marker-ring-length 16
 288   "Length of the xref marker ring."
 289   :type 'integer)
 290
 291 (defcustom xref-prompt-for-identifier '(not xref-find-definitions
 292                                             xref-find-definitions-other-window
 293                                             xref-find-definitions-other-frame)
 294   "When t, always prompt for the identifier name.
 295
 296 When nil, prompt only when there's no value at point we can use,
 297 or when the command has been called with the prefix argument.
 298
 299 Otherwise, it's a list of xref commands which will prompt
 300 anyway (the value at point, if any, will be used as the default).
 301
 302 If the list starts with `not', the meaning of the rest of the
 303 elements is negated."
 304   :type '(choice (const :tag "always" t)
 305                  (const :tag "auto" nil)
 306                  (set :menu-tag "command specific" :tag "commands"
 307                       :value (not)
 308                       (const :tag "Except" not)
 309                       (repeat :inline t (symbol :tag "command")))))
 310
 311 (defcustom xref-after-jump-hook '(recenter
 312                                   xref-pulse-momentarily)
 313   "Functions called after jumping to an xref."
 314   :type 'hook)
 315
 316 (defcustom xref-after-return-hook '(xref-pulse-momentarily)
 317   "Functions called after returning to a pre-jump location."
 318   :type 'hook)
 319
 320 (defvar xref--marker-ring (make-ring xref-marker-ring-length)
 321   "Ring of markers to implement the marker stack.")
 322
 323 (defun xref-push-marker-stack (&optional m)
 324   "Add point M (defaults to `point-marker') to the marker stack."
 325   (ring-insert xref--marker-ring (or m (point-marker))))
 326
 327 ;;;###autoload
 328 (defun xref-pop-marker-stack ()
 329   "Pop back to where \\[xref-find-definitions] was last invoked."
 330   (interactive)
 331   (let ((ring xref--marker-ring))
 332     (when (ring-empty-p ring)
 333       (error "Marker stack is empty"))
 334     (let ((marker (ring-remove ring 0)))
 335       (switch-to-buffer (or (marker-buffer marker)
 336                             (error "The marked buffer has been deleted")))
 337       (goto-char (marker-position marker))
 338       (set-marker marker nil nil)
 339       (run-hooks 'xref-after-return-hook))))
 340
 341 (defvar xref--current-item nil)
 342
 343 (defun xref-pulse-momentarily ()
 344   (pcase-let ((`(,beg . ,end)
 345                (save-excursion
 346                  (or
 347                   (let ((length (xref-match-length xref--current-item)))
 348                     (and length (cons (point) (+ (point) length))))
 349                   (back-to-indentation)
 350                   (if (eolp)
 351                       (cons (line-beginning-position) (1+ (point)))
 352                     (cons (point) (line-end-position)))))))
 353     (pulse-momentary-highlight-region beg end 'next-error)))
 354
 355 ;; etags.el needs this
 356 (defun xref-clear-marker-stack ()
 357   "Discard all markers from the marker stack."
 358   (let ((ring xref--marker-ring))
 359     (while (not (ring-empty-p ring))
 360       (let ((marker (ring-remove ring)))
 361         (set-marker marker nil nil)))))
 362
 363 ;;;###autoload
 364 (defun xref-marker-stack-empty-p ()
 365   "Return t if the marker stack is empty; nil otherwise."
 366   (ring-empty-p xref--marker-ring))
 367
 368 \f
 369
 370 (defun xref--goto-char (pos)
 371   (cond
 372    ((and (<= (point-min) pos) (<= pos (point-max))))
 373    (widen-automatically (widen))
 374    (t (user-error "Position is outside accessible part of buffer")))
 375   (goto-char pos))
 376
 377 (defun xref--goto-location (location)
 378   "Set buffer and point according to xref-location LOCATION."
 379   (let ((marker (xref-location-marker location)))
 380     (set-buffer (marker-buffer marker))
 381     (xref--goto-char marker)))
 382
 383 (defun xref--pop-to-location (item &optional window)
 384   "Go to the location of ITEM and display the buffer.
 385 WINDOW controls how the buffer is displayed:
 386   nil      -- switch-to-buffer
 387   `window' -- pop-to-buffer (other window)
 388   `frame'  -- pop-to-buffer (other frame)"
 389   (let* ((marker (save-excursion
 390                    (xref-location-marker (xref-item-location item))))
 391          (buf (marker-buffer marker)))
 392     (cl-ecase window
 393       ((nil)  (switch-to-buffer buf))
 394       (window (pop-to-buffer buf t))
 395       (frame  (let ((pop-up-frames t)) (pop-to-buffer buf t))))
 396     (xref--goto-char marker))
 397   (let ((xref--current-item item))
 398     (run-hooks 'xref-after-jump-hook)))
 399
 400 \f
 401 ;;; XREF buffer (part of the UI)
 402
 403 ;; The xref buffer is used to display a set of xrefs.
 404
 405 (defvar-local xref--display-history nil
 406   "List of pairs (BUFFER . WINDOW), for temporarily displayed buffers.")
 407
 408 (defun xref--save-to-history (buf win)
 409   (let ((restore (window-parameter win 'quit-restore)))
 410     ;; Save the new entry if the window displayed another buffer
 411     ;; previously.
 412     (when (and restore (not (eq (car restore) 'same)))
 413       (push (cons buf win) xref--display-history))))
 414
 415 (defun xref--display-position (pos other-window buf)
 416   ;; Show the location, but don't hijack focus.
 417   (let ((xref-buf (current-buffer)))
 418     (with-selected-window (display-buffer buf other-window)
 419       (xref--goto-char pos)
 420       (run-hooks 'xref-after-jump-hook)
 421       (let ((buf (current-buffer))
 422             (win (selected-window)))
 423         (with-current-buffer xref-buf
 424           (setq-local other-window-scroll-buffer buf)
 425           (xref--save-to-history buf win))))))
 426
 427 (defun xref--show-location (location)
 428   (condition-case err
 429       (let* ((marker (xref-location-marker location))
 430              (buf (marker-buffer marker)))
 431         (xref--display-position marker t buf))
 432     (user-error (message (error-message-string err)))))
 433
 434 (defun xref-show-location-at-point ()
 435   "Display the source of xref at point in the other window, if any."
 436   (interactive)
 437   (let* ((xref (xref--item-at-point))
 438          (xref--current-item xref))
 439     (when xref
 440       (xref--show-location (xref-item-location xref)))))
 441
 442 (defun xref-next-line ()
 443   "Move to the next xref and display its source in the other window."
 444   (interactive)
 445   (xref--search-property 'xref-item)
 446   (xref-show-location-at-point))
 447
 448 (defun xref-prev-line ()
 449   "Move to the previous xref and display its source in the other window."
 450   (interactive)
 451   (xref--search-property 'xref-item t)
 452   (xref-show-location-at-point))
 453
 454 (defun xref--item-at-point ()
 455   (save-excursion
 456     (back-to-indentation)
 457     (get-text-property (point) 'xref-item)))
 458
 459 (defvar-local xref--window nil
 460   "ACTION argument to call `display-buffer' with.")
 461
 462 (defun xref-goto-xref ()
 463   "Jump to the xref on the current line and bury the xref buffer."
 464   (interactive)
 465   (let ((xref (or (xref--item-at-point)
 466                  (user-error "No reference at point")))
 467         (window xref--window))
 468     (xref-quit)
 469     (xref--pop-to-location xref window)))
 470
 471 (defun xref-query-replace (from to)
 472   "Perform interactive replacement in all current matches."
 473   (interactive
 474    (list (read-regexp "Query replace regexp in matches" ".*")
 475          (read-regexp "Replace with: ")))
 476   (let (pairs item)
 477     (unwind-protect
 478         (progn
 479           (save-excursion
 480             (goto-char (point-min))
 481             (while (setq item (xref--search-property 'xref-item))
 482               (when (xref-match-length item)
 483                 (save-excursion
 484                   (let* ((loc (xref-item-location item))
 485                          (beg (xref-location-marker loc))
 486                          (len (xref-match-length item)))
 487                     ;; Perform sanity check first.
 488                     (xref--goto-location loc)
 489                     ;; FIXME: The check should probably be a generic
 490                     ;; function, instead of the assumption that all
 491                     ;; matches contain the full line as summary.
 492                     ;; TODO: Offer to re-scan otherwise.
 493                     (unless (equal (buffer-substring-no-properties
 494                                     (line-beginning-position)
 495                                     (line-end-position))
 496                                    (xref-item-summary item))
 497                       (user-error "Search results out of date"))
 498                     (push (cons beg len) pairs)))))
 499             (setq pairs (nreverse pairs)))
 500           (unless pairs (user-error "No suitable matches here"))
 501           (xref--query-replace-1 from to pairs))
 502       (dolist (pair pairs)
 503         (move-marker (car pair) nil)))))
 504
 505 ;; FIXME: Write a nicer UI.
 506 (defun xref--query-replace-1 (from to pairs)
 507   (let* ((query-replace-lazy-highlight nil)
 508          current-beg current-len current-buf
 509          ;; Counteract the "do the next match now" hack in
 510          ;; `perform-replace'.  And still, it'll report that those
 511          ;; matches were "filtered out" at the end.
 512          (isearch-filter-predicate
 513           (lambda (beg end)
 514             (and current-beg
 515                  (eq (current-buffer) current-buf)
 516                  (>= beg current-beg)
 517                  (<= end (+ current-beg current-len)))))
 518          (replace-re-search-function
 519           (lambda (from &optional _bound noerror)
 520             (let (found pair)
 521               (while (and (not found) pairs)
 522                 (setq pair (pop pairs)
 523                       current-beg (car pair)
 524                       current-len (cdr pair)
 525                       current-buf (marker-buffer current-beg))
 526                 (pop-to-buffer current-buf)
 527                 (goto-char current-beg)
 528                 (when (re-search-forward from (+ current-beg current-len) noerror)
 529                   (setq found t)))
 530               found))))
 531     ;; FIXME: Despite this being a multi-buffer replacement, `N'
 532     ;; doesn't work, because we're not using
 533     ;; `multi-query-replace-map', and it would expect the below
 534     ;; function to be called once per buffer.
 535     (perform-replace from to t t nil)))
 536
 537 (defvar xref--xref-buffer-mode-map
 538   (let ((map (make-sparse-keymap)))
 539     (define-key map [remap quit-window] #'xref-quit)
 540     (define-key map (kbd "n") #'xref-next-line)
 541     (define-key map (kbd "p") #'xref-prev-line)
 542     (define-key map (kbd "r") #'xref-query-replace)
 543     (define-key map (kbd "RET") #'xref-goto-xref)
 544     (define-key map (kbd "C-o") #'xref-show-location-at-point)
 545     ;; suggested by Johan Claesson "to further reduce finger movement":
 546     (define-key map (kbd ".") #'xref-next-line)
 547     (define-key map (kbd ",") #'xref-prev-line)
 548     map))
 549
 550 (define-derived-mode xref--xref-buffer-mode special-mode "XREF"
 551   "Mode for displaying cross-references."
 552   (setq buffer-read-only t)
 553   (setq next-error-function #'xref--next-error-function)
 554   (setq next-error-last-buffer (current-buffer)))
 555
 556 (defun xref--next-error-function (n reset?)
 557   (when reset?
 558     (goto-char (point-min)))
 559   (let ((backward (< n 0))
 560         (n (abs n))
 561         (xref nil))
 562     (dotimes (_ n)
 563       (setq xref (xref--search-property 'xref-item backward)))
 564     (cond (xref
 565            (xref--pop-to-location xref))
 566           (t
 567            (error "No %s xref" (if backward "previous" "next"))))))
 568
 569 (defun xref-quit (&optional kill)
 570   "Bury temporarily displayed buffers, then quit the current window.
 571
 572 If KILL is non-nil, also kill the current buffer.
 573
 574 The buffers that the user has otherwise interacted with in the
 575 meantime are preserved."
 576   (interactive "P")
 577   (let ((window (selected-window))
 578         (history xref--display-history))
 579     (setq xref--display-history nil)
 580     (pcase-dolist (`(,buf . ,win) history)
 581       (when (and (window-live-p win)
 582                  (eq buf (window-buffer win)))
 583         (quit-window nil win)))
 584     (quit-window kill window)))
 585
 586 (defconst xref-buffer-name "*xref*"
 587   "The name of the buffer to show xrefs.")
 588
 589 (defvar xref--button-map
 590   (let ((map (make-sparse-keymap)))
 591     (define-key map [(control ?m)] #'xref-goto-xref)
 592     (define-key map [mouse-1] #'xref-goto-xref)
 593     (define-key map [mouse-2] #'xref--mouse-2)
 594     map))
 595
 596 (defun xref--mouse-2 (event)
 597   "Move point to the button and show the xref definition."
 598   (interactive "e")
 599   (mouse-set-point event)
 600   (forward-line 0)
 601   (xref--search-property 'xref-item)
 602   (xref-show-location-at-point))
 603
 604 (defun xref--insert-xrefs (xref-alist)
 605   "Insert XREF-ALIST in the current-buffer.
 606 XREF-ALIST is of the form ((GROUP . (XREF ...)) ...), where
 607 GROUP is a string for decoration purposes and XREF is an
 608 `xref-item' object."
 609   (require 'compile) ; For the compilation faces.
 610   (cl-loop for ((group . xrefs) . more1) on xref-alist
 611            for max-line-width =
 612            (cl-loop for xref in xrefs
 613                     maximize (let ((line (xref-location-line
 614                                           (oref xref location))))
 615                                (length (and line (format "%d" line)))))
 616            for line-format = (and max-line-width
 617                                   (format "%%%dd: " max-line-width))
 618            do
 619            (xref--insert-propertized '(face compilation-info) group "\n")
 620            (cl-loop for (xref . more2) on xrefs do
 621                     (with-slots (summary location) xref
 622                       (let* ((line (xref-location-line location))
 623                              (prefix
 624                               (if line
 625                                   (propertize (format line-format line)
 626                                               'face 'compilation-line-number)
 627                                 "  ")))
 628                         (xref--insert-propertized
 629                          (list 'xref-item xref
 630                                ;; 'face 'font-lock-keyword-face
 631                                'mouse-face 'highlight
 632                                'keymap xref--button-map
 633                                'help-echo
 634                                (concat "mouse-2: display in another window, "
 635                                        "RET or mouse-1: follow reference"))
 636                          prefix summary)))
 637                     (insert "\n"))))
 638
 639 (defun xref--analyze (xrefs)
 640   "Find common filenames in XREFS.
 641 Return an alist of the form ((FILENAME . (XREF ...)) ...)."
 642   (xref--alistify xrefs
 643                   (lambda (x)
 644                     (xref-location-group (xref-item-location x)))
 645                   #'equal))
 646
 647 (defun xref--show-xref-buffer (xrefs alist)
 648   (let ((xref-alist (xref--analyze xrefs)))
 649     (with-current-buffer (get-buffer-create xref-buffer-name)
 650       (let ((inhibit-read-only t))
 651         (erase-buffer)
 652         (xref--insert-xrefs xref-alist)
 653         (xref--xref-buffer-mode)
 654         (pop-to-buffer (current-buffer))
 655         (goto-char (point-min))
 656         (setq xref--window (assoc-default 'window alist))
 657         (current-buffer)))))
 658
 659 \f
 660 ;; This part of the UI seems fairly uncontroversial: it reads the
 661 ;; identifier and deals with the single definition case.
 662 ;; (FIXME: do we really want this case to be handled like that in
 663 ;; "find references" and "find regexp searches"?)
 664 ;;
 665 ;; The controversial multiple definitions case is handed off to
 666 ;; xref-show-xrefs-function.
 667
 668 (defvar xref-show-xrefs-function 'xref--show-xref-buffer
 669   "Function to display a list of xrefs.")
 670
 671 (defvar xref--read-identifier-history nil)
 672
 673 (defvar xref--read-pattern-history nil)
 674
 675 (defun xref--show-xrefs (xrefs window)
 676   (cond
 677    ((not (cdr xrefs))
 678     (xref-push-marker-stack)
 679     (xref--pop-to-location (car xrefs) window))
 680    (t
 681     (xref-push-marker-stack)
 682     (funcall xref-show-xrefs-function xrefs
 683              `((window . ,window))))))
 684
 685 (defun xref--prompt-p (command)
 686   (or (eq xref-prompt-for-identifier t)
 687       (if (eq (car xref-prompt-for-identifier) 'not)
 688           (not (memq command (cdr xref-prompt-for-identifier)))
 689         (memq command xref-prompt-for-identifier))))
 690
 691 (defun xref--read-identifier (prompt)
 692   "Return the identifier at point or read it from the minibuffer."
 693   (let ((id (funcall xref-identifier-at-point-function)))
 694     (cond ((or current-prefix-arg
 695                (not id)
 696                (xref--prompt-p this-command))
 697            (completing-read (if id
 698                                 (format "%s (default %s): "
 699                                         (substring prompt 0 (string-match
 700                                                              "[ :]+\\'" prompt))
 701                                         id)
 702                               prompt)
 703                             (funcall xref-identifier-completion-table-function)
 704                             nil nil nil
 705                             'xref--read-identifier-history id))
 706           (t id))))
 707
 708 \f
 709 ;;; Commands
 710
 711 (defun xref--find-xrefs (input kind arg window)
 712   (let ((xrefs (funcall xref-find-function kind arg)))
 713     (unless xrefs
 714       (user-error "No %s found for: %s" (symbol-name kind) input))
 715     (xref--show-xrefs xrefs window)))
 716
 717 (defun xref--find-definitions (id window)
 718   (xref--find-xrefs id 'definitions id window))
 719
 720 ;;;###autoload
 721 (defun xref-find-definitions (identifier)
 722   "Find the definition of the identifier at point.
 723 With prefix argument or when there's no identifier at point,
 724 prompt for it.
 725
 726 If the backend has sufficient information to determine a unique
 727 definition for IDENTIFIER, it returns only that definition. If
 728 there are multiple possible definitions, it returns all of them.
 729
 730 If the backend returns one definition, jump to it; otherwise,
 731 display the list in a buffer."
 732   (interactive (list (xref--read-identifier "Find definitions of: ")))
 733   (xref--find-definitions identifier nil))
 734
 735 ;;;###autoload
 736 (defun xref-find-definitions-other-window (identifier)
 737   "Like `xref-find-definitions' but switch to the other window."
 738   (interactive (list (xref--read-identifier "Find definitions of: ")))
 739   (xref--find-definitions identifier 'window))
 740
 741 ;;;###autoload
 742 (defun xref-find-definitions-other-frame (identifier)
 743   "Like `xref-find-definitions' but switch to the other frame."
 744   (interactive (list (xref--read-identifier "Find definitions of: ")))
 745   (xref--find-definitions identifier 'frame))
 746
 747 ;;;###autoload
 748 (defun xref-find-references (identifier)
 749   "Find references to the identifier at point.
 750 With prefix argument, prompt for the identifier."
 751   (interactive (list (xref--read-identifier "Find references of: ")))
 752   (xref--find-xrefs identifier 'references identifier nil))
 753
 754 (declare-function apropos-parse-pattern "apropos" (pattern))
 755
 756 ;;;###autoload
 757 (defun xref-find-apropos (pattern)
 758   "Find all meaningful symbols that match PATTERN.
 759 The argument has the same meaning as in `apropos'."
 760   (interactive (list (read-string
 761                       "Search for pattern (word list or regexp): "
 762                       nil 'xref--read-pattern-history)))
 763   (require 'apropos)
 764   (xref--find-xrefs pattern 'apropos
 765                     (apropos-parse-pattern
 766                      (if (string-equal (regexp-quote pattern) pattern)
 767                          ;; Split into words
 768                          (or (split-string pattern "[ \t]+" t)
 769                              (user-error "No word list given"))
 770                        pattern))
 771                     nil))
 772
 773 \f
 774 ;;; Key bindings
 775
 776 ;;;###autoload (define-key esc-map "." #'xref-find-definitions)
 777 ;;;###autoload (define-key esc-map "," #'xref-pop-marker-stack)
 778 ;;;###autoload (define-key esc-map "?" #'xref-find-references)
 779 ;;;###autoload (define-key esc-map [?\C-.] #'xref-find-apropos)
 780 ;;;###autoload (define-key ctl-x-4-map "." #'xref-find-definitions-other-window)
 781 ;;;###autoload (define-key ctl-x-5-map "." #'xref-find-definitions-other-frame)
 782
 783 \f
 784 ;;; Helper functions
 785
 786 (defvar xref-etags-mode--saved nil)
 787
 788 (define-minor-mode xref-etags-mode
 789   "Minor mode to make xref use etags again.
 790
 791 Certain major modes install their own mechanisms for listing
 792 identifiers and navigation.  Turn this on to undo those settings
 793 and just use etags."
 794   :lighter ""
 795   (if xref-etags-mode
 796       (progn
 797         (setq xref-etags-mode--saved
 798               (cons xref-find-function
 799                     xref-identifier-completion-table-function))
 800         (kill-local-variable 'xref-find-function)
 801         (kill-local-variable 'xref-identifier-completion-table-function))
 802     (setq-local xref-find-function (car xref-etags-mode--saved))
 803     (setq-local xref-identifier-completion-table-function
 804                 (cdr xref-etags-mode--saved))))
 805
 806 (declare-function semantic-symref-find-references-by-name "semantic/symref")
 807 (declare-function semantic-find-file-noselect "semantic/fw")
 808 (declare-function grep-expand-template "grep")
 809
 810 (defun xref-collect-references (symbol dir)
 811   "Collect references to SYMBOL inside DIR.
 812 This function uses the Semantic Symbol Reference API, see
 813 `semantic-symref-find-references-by-name' for details on which
 814 tools are used, and when."
 815   (cl-assert (directory-name-p dir))
 816   (require 'semantic/symref)
 817   (defvar semantic-symref-tool)
 818   (let* ((default-directory dir)
 819          (semantic-symref-tool 'detect)
 820          (res (semantic-symref-find-references-by-name symbol 'subdirs))
 821          (hits (and res (oref res hit-lines)))
 822          (orig-buffers (buffer-list)))
 823     (unwind-protect
 824         (cl-mapcan (lambda (hit) (xref--collect-matches
 825                              hit (format "\\_<%s\\_>" (regexp-quote symbol))))
 826                    hits)
 827       (mapc #'kill-buffer
 828             (cl-set-difference (buffer-list) orig-buffers)))))
 829
 830 (defun xref-collect-matches (regexp files dir ignores)
 831   "Collect matches for REGEXP inside FILES in DIR.
 832 FILES is a string with glob patterns separated by spaces.
 833 IGNORES is a list of glob patterns."
 834   (cl-assert (directory-name-p dir))
 835   (require 'semantic/fw)
 836   (grep-compute-defaults)
 837   (defvar grep-find-template)
 838   (defvar grep-highlight-matches)
 839   (let* ((grep-find-template (replace-regexp-in-string "-e " "-E "
 840                                                        grep-find-template t t))
 841          (grep-highlight-matches nil)
 842          (command (xref--rgrep-command (xref--regexp-to-extended regexp)
 843                                        files dir ignores))
 844          (orig-buffers (buffer-list))
 845          (buf (get-buffer-create " *xref-grep*"))
 846          (grep-re (caar grep-regexp-alist))
 847          hits)
 848     (with-current-buffer buf
 849       (erase-buffer)
 850       (call-process-shell-command command nil t)
 851       (goto-char (point-min))
 852       (while (re-search-forward grep-re nil t)
 853         (push (cons (string-to-number (match-string 2))
 854                     (match-string 1))
 855               hits)))
 856     (unwind-protect
 857         (cl-mapcan (lambda (hit) (xref--collect-matches hit regexp))
 858                    (nreverse hits))
 859       (mapc #'kill-buffer
 860             (cl-set-difference (buffer-list) orig-buffers)))))
 861
 862 (defun xref--rgrep-command (regexp files dir ignores)
 863   (require 'find-dired)      ; for `find-name-arg'
 864   (defvar grep-find-template)
 865   (defvar find-name-arg)
 866   (grep-expand-template
 867    grep-find-template
 868    regexp
 869    (concat (shell-quote-argument "(")
 870            " " find-name-arg " "
 871            (mapconcat
 872             #'shell-quote-argument
 873             (split-string files)
 874             (concat " -o " find-name-arg " "))
 875            " "
 876            (shell-quote-argument ")"))
 877    dir
 878    (concat
 879     (shell-quote-argument "(")
 880     " -path "
 881     (mapconcat
 882      (lambda (ignore)
 883        (when (string-match-p "/\\'" ignore)
 884          (setq ignore (concat ignore "*")))
 885        (if (string-match "\\`\\./" ignore)
 886            (setq ignore (replace-match dir t t ignore))
 887          (unless (string-prefix-p "*" ignore)
 888            (setq ignore (concat "*/" ignore))))
 889        (shell-quote-argument ignore))
 890      ignores
 891      " -o -path ")
 892     " "
 893     (shell-quote-argument ")")
 894     " -prune -o ")))
 895
 896 (defun xref--regexp-to-extended (str)
 897   (replace-regexp-in-string
 898    ;; FIXME: Add tests.  Move to subr.el, make a public function.
 899    ;; Maybe error on Emacs-only constructs.
 900    "\\(?:\\\\\\\\\\)*\\(?:\\\\[][]\\)?\\(?:\\[.+?\\]\\|\\(\\\\?[(){}|]\\)\\)"
 901    (lambda (str)
 902      (cond
 903       ((not (match-beginning 1))
 904        str)
 905       ((eq (length (match-string 1 str)) 2)
 906        (concat (substring str 0 (match-beginning 1))
 907                (substring (match-string 1 str) 1 2)))
 908       (t
 909        (concat (substring str 0 (match-beginning 1))
 910                "\\"
 911                (match-string 1 str)))))
 912    str t t))
 913
 914 (defun xref--collect-matches (hit regexp)
 915   (pcase-let* ((`(,line . ,file) hit)
 916                (buf (or (find-buffer-visiting file)
 917                         (semantic-find-file-noselect file))))
 918     (with-current-buffer buf
 919       (save-excursion
 920         (goto-char (point-min))
 921         (forward-line (1- line))
 922         (let ((line-end (line-end-position))
 923               (line-beg (line-beginning-position))
 924               matches)
 925           (syntax-propertize line-end)
 926           ;; FIXME: This results in several lines with the same
 927           ;; summary. Solve with composite pattern?
 928           (while (re-search-forward regexp line-end t)
 929             (let* ((beg-column (- (match-beginning 0) line-beg))
 930                    (end-column (- (match-end 0) line-beg))
 931                    (loc (xref-make-file-location file line beg-column))
 932                    (summary (buffer-substring line-beg line-end)))
 933               (add-face-text-property beg-column end-column 'highlight
 934                                       t summary)
 935               (push (xref-make-match summary loc (- end-column beg-column))
 936                     matches)))
 937           (nreverse matches))))))
 938
 939 (provide 'xref)
 940
 941 ;;; xref.el ends here