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