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