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 ;; If a backend decides to subclass xref-location it can provide
  69 ;; methods for some of the following functions:
  70 (cl-defgeneric xref-location-marker (location)
  71   "Return the marker for LOCATION.")
  72
  73 (cl-defgeneric xref-location-group (location)
  74   "Return a string used to group a set of locations.
  75 This is typically the filename.")
  76
  77 (cl-defgeneric xref-location-line (_location)
  78   "Return the line number corresponding to the location."
  79   nil)
  80
  81 (cl-defgeneric xref-match-bounds (_item)
  82   "Return a cons with columns of the beginning and end of the match."
  83   nil)
  84
  85 ;;;; Commonly needed location classes are defined here:
  86
  87 ;; FIXME: might be useful to have an optional "hint" i.e. a string to
  88 ;; search for in case the line number is sightly out of date.
  89 (defclass xref-file-location (xref-location)
  90   ((file :type string :initarg :file)
  91    (line :type fixnum :initarg :line :reader xref-location-line)
  92    (column :type fixnum :initarg :column :reader xref-file-location-column))
  93   :documentation "A file location is a file/line/column triple.
  94 Line numbers start from 1 and columns from 0.")
  95
  96 (defun xref-make-file-location (file line column)
  97   "Create and return a new xref-file-location."
  98   (make-instance 'xref-file-location :file file :line line :column column))
  99
 100 (cl-defmethod xref-location-marker ((l xref-file-location))
 101   (with-slots (file line column) l
 102     (with-current-buffer
 103         (or (get-file-buffer file)
 104             (let ((find-file-suppress-same-file-warnings t))
 105               (find-file-noselect file)))
 106       (save-restriction
 107         (widen)
 108         (save-excursion
 109           (goto-char (point-min))
 110           (beginning-of-line line)
 111           (move-to-column column)
 112           (point-marker))))))
 113
 114 (cl-defmethod xref-location-group ((l xref-file-location))
 115   (oref l file))
 116
 117 (defclass xref-buffer-location (xref-location)
 118   ((buffer :type buffer :initarg :buffer)
 119    (position :type fixnum :initarg :position)))
 120
 121 (defun xref-make-buffer-location (buffer position)
 122   "Create and return a new xref-buffer-location."
 123   (make-instance 'xref-buffer-location :buffer buffer :position position))
 124
 125 (cl-defmethod xref-location-marker ((l xref-buffer-location))
 126   (with-slots (buffer position) l
 127     (let ((m (make-marker)))
 128       (move-marker m position buffer))))
 129
 130 (cl-defmethod xref-location-group ((l xref-buffer-location))
 131   (with-slots (buffer) l
 132     (or (buffer-file-name buffer)
 133         (format "(buffer %s)" (buffer-name buffer)))))
 134
 135 (defclass xref-bogus-location (xref-location)
 136   ((message :type string :initarg :message
 137             :reader xref-bogus-location-message))
 138   :documentation "Bogus locations are sometimes useful to
 139 indicate errors, e.g. when we know that a function exists but the
 140 actual location is not known.")
 141
 142 (defun xref-make-bogus-location (message)
 143   "Create and return a new xref-bogus-location."
 144   (make-instance 'xref-bogus-location :message message))
 145
 146 (cl-defmethod xref-location-marker ((l xref-bogus-location))
 147   (user-error "%s" (oref l message)))
 148
 149 (cl-defmethod xref-location-group ((_ xref-bogus-location)) "(No location)")
 150
 151 \f
 152 ;;; Cross-reference
 153
 154 (defclass xref-item ()
 155   ((summary :type string :initarg :summary
 156             :reader xref-item-summary
 157             :documentation "One line which will be displayed for
 158 this item in the output buffer.")
 159    (location :initarg :location
 160              :reader xref-item-location
 161              :documentation "An object describing how to navigate
 162 to the reference's target."))
 163   :comment "An xref item describes a reference to a location
 164 somewhere.")
 165
 166 (defun xref-make (summary location)
 167   "Create and return a new xref item.
 168 SUMMARY is a short string to describe the xref.
 169 LOCATION is an `xref-location'."
 170   (make-instance 'xref-item :summary summary :location location))
 171
 172 (defclass xref-match-item ()
 173   ((summary :type string :initarg :summary
 174             :reader xref-item-summary)
 175    (location :initarg :location
 176              :type xref-file-location
 177              :reader xref-item-location)
 178    (end-column :initarg :end-column))
 179   :comment "An xref item describes a reference to a location
 180 somewhere.")
 181
 182 (cl-defmethod xref-match-bounds ((i xref-match-item))
 183   (with-slots (end-column location) i
 184     (cons (xref-file-location-column location)
 185           end-column)))
 186
 187 (defun xref-make-match (summary end-column location)
 188   "Create and return a new xref match item.
 189 SUMMARY is a short string to describe the xref.
 190 END-COLUMN is the match end column number inside SUMMARY.
 191 LOCATION is an `xref-location'."
 192   (make-instance 'xref-match-item :summary summary :location location
 193                  :end-column end-column))
 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 no definitions can be
 208 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                   (let ((bounds (xref-match-bounds xref--current-item)))
 346                     (when bounds
 347                       (cons (progn (move-to-column (car bounds))
 348                                    (point))
 349                             (progn (move-to-column (cdr bounds))
 350                                    (point)))))
 351                   (back-to-indentation)
 352                   (if (eolp)
 353                       (cons (line-beginning-position) (1+ (point)))
 354                     (cons (point) (line-end-position)))))))
 355     (pulse-momentary-highlight-region beg end 'next-error)))
 356
 357 ;; etags.el needs this
 358 (defun xref-clear-marker-stack ()
 359   "Discard all markers from the marker stack."
 360   (let ((ring xref--marker-ring))
 361     (while (not (ring-empty-p ring))
 362       (let ((marker (ring-remove ring)))
 363         (set-marker marker nil nil)))))
 364
 365 ;;;###autoload
 366 (defun xref-marker-stack-empty-p ()
 367   "Return t if the marker stack is empty; nil otherwise."
 368   (ring-empty-p xref--marker-ring))
 369
 370 \f
 371 (defun xref--goto-location (location)
 372   "Set buffer and point according to xref-location LOCATION."
 373   (let ((marker (xref-location-marker location)))
 374     (set-buffer (marker-buffer marker))
 375     (cond ((and (<= (point-min) marker) (<= marker (point-max))))
 376           (widen-automatically (widen))
 377           (t (error "Location is outside accessible part of buffer")))
 378     (goto-char marker)))
 379
 380 (defun xref--pop-to-location (item &optional window)
 381   "Go to the location of ITEM and display the buffer.
 382 WINDOW controls how the buffer is displayed:
 383   nil      -- switch-to-buffer
 384   'window  -- pop-to-buffer (other window)
 385   'frame   -- pop-to-buffer (other frame)"
 386   (xref--goto-location (xref-item-location item))
 387   (cl-ecase window
 388     ((nil)  (switch-to-buffer (current-buffer)))
 389     (window (pop-to-buffer (current-buffer) t))
 390     (frame  (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t))))
 391   (let ((xref--current-item item))
 392     (run-hooks 'xref-after-jump-hook)))
 393
 394 \f
 395 ;;; XREF buffer (part of the UI)
 396
 397 ;; The xref buffer is used to display a set of xrefs.
 398
 399 (defvar-local xref--display-history nil
 400   "List of pairs (BUFFER . WINDOW), for temporarily displayed buffers.")
 401
 402 (defvar-local xref--temporary-buffers nil
 403   "List of buffers created by xref code.")
 404
 405 (defvar-local xref--current nil
 406   "Non-nil if this buffer was once current, except while displaying xrefs.
 407 Used for temporary buffers.")
 408
 409 (defvar xref--inhibit-mark-current nil)
 410
 411 (defun xref--mark-selected ()
 412   (unless xref--inhibit-mark-current
 413     (setq xref--current t))
 414   (remove-hook 'buffer-list-update-hook #'xref--mark-selected t))
 415
 416 (defun xref--save-to-history (buf win)
 417   (let ((restore (window-parameter win 'quit-restore)))
 418     ;; Save the new entry if the window displayed another buffer
 419     ;; previously.
 420     (when (and restore (not (eq (car restore) 'same)))
 421       (push (cons buf win) xref--display-history))))
 422
 423 (defun xref--display-position (pos other-window xref-buf)
 424   ;; Show the location, but don't hijack focus.
 425   (with-selected-window (display-buffer (current-buffer) other-window)
 426     (goto-char pos)
 427     (run-hooks 'xref-after-jump-hook)
 428     (let ((buf (current-buffer))
 429           (win (selected-window)))
 430       (with-current-buffer xref-buf
 431         (setq-local other-window-scroll-buffer buf)
 432         (xref--save-to-history buf win)))))
 433
 434 (defun xref--show-location (location)
 435   (condition-case err
 436       (let ((xref-buf (current-buffer))
 437             (bl (buffer-list))
 438             (xref--inhibit-mark-current t))
 439         (xref--goto-location location)
 440         (let ((buf (current-buffer)))
 441           (unless (memq buf bl)
 442             ;; Newly created.
 443             (add-hook 'buffer-list-update-hook #'xref--mark-selected nil t)
 444             (with-current-buffer xref-buf
 445               (push buf xref--temporary-buffers))))
 446         (xref--display-position (point) t xref-buf))
 447     (user-error (message (error-message-string err)))))
 448
 449 (defun xref-show-location-at-point ()
 450   "Display the source of xref at point in the other window, if any."
 451   (interactive)
 452   (let* ((xref (xref--item-at-point))
 453          (xref--current-item xref))
 454     (when xref
 455       (xref--show-location (xref-item-location xref)))))
 456
 457 (defun xref-next-line ()
 458   "Move to the next xref and display its source in the other window."
 459   (interactive)
 460   (xref--search-property 'xref-item)
 461   (xref-show-location-at-point))
 462
 463 (defun xref-prev-line ()
 464   "Move to the previous xref and display its source in the other window."
 465   (interactive)
 466   (xref--search-property 'xref-item t)
 467   (xref-show-location-at-point))
 468
 469 (defun xref--item-at-point ()
 470   (save-excursion
 471     (back-to-indentation)
 472     (get-text-property (point) 'xref-item)))
 473
 474 (defvar-local xref--window nil
 475   "ACTION argument to call `display-buffer' with.")
 476
 477 (defun xref-goto-xref ()
 478   "Jump to the xref on the current line and bury the xref buffer."
 479   (interactive)
 480   (let ((xref (or (xref--item-at-point)
 481                  (user-error "No reference at point")))
 482         (window xref--window))
 483     (xref-quit)
 484     (xref--pop-to-location xref window)))
 485
 486 (defvar xref--xref-buffer-mode-map
 487   (let ((map (make-sparse-keymap)))
 488     (define-key map [remap quit-window] #'xref-quit)
 489     (define-key map (kbd "n") #'xref-next-line)
 490     (define-key map (kbd "p") #'xref-prev-line)
 491     (define-key map (kbd "RET") #'xref-goto-xref)
 492     (define-key map (kbd "C-o") #'xref-show-location-at-point)
 493     ;; suggested by Johan Claesson "to further reduce finger movement":
 494     (define-key map (kbd ".") #'xref-next-line)
 495     (define-key map (kbd ",") #'xref-prev-line)
 496     map))
 497
 498 (define-derived-mode xref--xref-buffer-mode special-mode "XREF"
 499   "Mode for displaying cross-references."
 500   (setq buffer-read-only t)
 501   (setq next-error-function #'xref--next-error-function)
 502   (setq next-error-last-buffer (current-buffer)))
 503
 504 (defun xref--next-error-function (n reset?)
 505   (when reset?
 506     (goto-char (point-min)))
 507   (let ((backward (< n 0))
 508         (n (abs n))
 509         (xref nil))
 510     (dotimes (_ n)
 511       (setq xref (xref--search-property 'xref-item backward)))
 512     (cond (xref
 513            (xref--pop-to-location xref))
 514           (t
 515            (error "No %s xref" (if backward "previous" "next"))))))
 516
 517 (defun xref-quit (&optional kill)
 518   "Bury temporarily displayed buffers, then quit the current window.
 519
 520 If KILL is non-nil, kill all buffers that were created in the
 521 process of showing xrefs, and also kill the current buffer.
 522
 523 The buffers that the user has otherwise interacted with in the
 524 meantime are preserved."
 525   (interactive "P")
 526   (let ((window (selected-window))
 527         (history xref--display-history))
 528     (setq xref--display-history nil)
 529     (pcase-dolist (`(,buf . ,win) history)
 530       (when (and (window-live-p win)
 531                  (eq buf (window-buffer win)))
 532         (quit-window nil win)))
 533     (when kill
 534       (let ((xref--inhibit-mark-current t)
 535             kill-buffer-query-functions)
 536         (dolist (buf xref--temporary-buffers)
 537           (unless (buffer-local-value 'xref--current buf)
 538             (kill-buffer buf)))
 539         (setq xref--temporary-buffers nil)))
 540     (quit-window kill window)))
 541
 542 (defconst xref-buffer-name "*xref*"
 543   "The name of the buffer to show xrefs.")
 544
 545 (defvar xref--button-map
 546   (let ((map (make-sparse-keymap)))
 547     (define-key map [(control ?m)] #'xref-goto-xref)
 548     (define-key map [mouse-1] #'xref-goto-xref)
 549     (define-key map [mouse-2] #'xref--mouse-2)
 550     map))
 551
 552 (defun xref--mouse-2 (event)
 553   "Move point to the button and show the xref definition."
 554   (interactive "e")
 555   (mouse-set-point event)
 556   (forward-line 0)
 557   (xref--search-property 'xref-item)
 558   (xref-show-location-at-point))
 559
 560 (defun xref--insert-xrefs (xref-alist)
 561   "Insert XREF-ALIST in the current-buffer.
 562 XREF-ALIST is of the form ((GROUP . (XREF ...)) ...).  Where
 563 GROUP is a string for decoration purposes and XREF is an
 564 `xref-item' object."
 565   (require 'compile) ; For the compilation faces.
 566   (cl-loop for ((group . xrefs) . more1) on xref-alist
 567            for max-line-width =
 568            (cl-loop for xref in xrefs
 569                     maximize (let ((line (xref-location-line
 570                                           (oref xref location))))
 571                                (length (and line (format "%d" line)))))
 572            for line-format = (and max-line-width
 573                                   (format "%%%dd: " max-line-width))
 574            do
 575            (xref--insert-propertized '(face compilation-info) group "\n")
 576            (cl-loop for (xref . more2) on xrefs do
 577                     (with-slots (summary location) xref
 578                       (let* ((line (xref-location-line location))
 579                              (prefix
 580                               (if line
 581                                   (propertize (format line-format line)
 582                                               'face 'compilation-line-number)
 583                                 "  ")))
 584                         (xref--insert-propertized
 585                          (list 'xref-item xref
 586                                ;; 'face 'font-lock-keyword-face
 587                                'mouse-face 'highlight
 588                                'keymap xref--button-map
 589                                'help-echo
 590                                (concat "mouse-2: display in another window, "
 591                                        "RET or mouse-1: follow reference"))
 592                          prefix summary)))
 593                     (insert "\n"))))
 594
 595 (defun xref--analyze (xrefs)
 596   "Find common filenames in XREFS.
 597 Return an alist of the form ((FILENAME . (XREF ...)) ...)."
 598   (xref--alistify xrefs
 599                   (lambda (x)
 600                     (xref-location-group (xref-item-location x)))
 601                   #'equal))
 602
 603 (defun xref--show-xref-buffer (xrefs alist)
 604   (let ((xref-alist (xref--analyze xrefs)))
 605     (with-current-buffer (get-buffer-create xref-buffer-name)
 606       (let ((inhibit-read-only t))
 607         (erase-buffer)
 608         (xref--insert-xrefs xref-alist)
 609         (xref--xref-buffer-mode)
 610         (pop-to-buffer (current-buffer))
 611         (goto-char (point-min))
 612         (setq xref--window (assoc-default 'window alist))
 613         (setq xref--temporary-buffers (assoc-default 'temporary-buffers alist))
 614         (dolist (buf xref--temporary-buffers)
 615           (with-current-buffer buf
 616             (add-hook 'buffer-list-update-hook #'xref--mark-selected nil t)))
 617         (current-buffer)))))
 618
 619 \f
 620 ;; This part of the UI seems fairly uncontroversial: it reads the
 621 ;; identifier and deals with the single definition case.
 622 ;;
 623 ;; The controversial multiple definitions case is handed off to
 624 ;; xref-show-xrefs-function.
 625
 626 (defvar xref-show-xrefs-function 'xref--show-xref-buffer
 627   "Function to display a list of xrefs.")
 628
 629 (defvar xref--read-identifier-history nil)
 630
 631 (defvar xref--read-pattern-history nil)
 632
 633 (defun xref--show-xrefs (input kind arg window)
 634   (let* ((bl (buffer-list))
 635          (xrefs (funcall xref-find-function kind arg))
 636          (tb (cl-set-difference (buffer-list) bl)))
 637     (cond
 638      ((null xrefs)
 639       (user-error "No %s found for: %s" (symbol-name kind) input))
 640      ((not (cdr xrefs))
 641       (xref-push-marker-stack)
 642       (xref--pop-to-location (car xrefs) window))
 643      (t
 644       (xref-push-marker-stack)
 645       (funcall xref-show-xrefs-function xrefs
 646                `((window . ,window)
 647                  (temporary-buffers . ,tb)))))))
 648
 649 (defun xref--prompt-p (command)
 650   (or (eq xref-prompt-for-identifier t)
 651       (if (eq (car xref-prompt-for-identifier) 'not)
 652           (not (memq command (cdr xref-prompt-for-identifier)))
 653         (memq command xref-prompt-for-identifier))))
 654
 655 (defun xref--read-identifier (prompt)
 656   "Return the identifier at point or read it from the minibuffer."
 657   (let ((id (funcall xref-identifier-at-point-function)))
 658     (cond ((or current-prefix-arg
 659                (not id)
 660                (xref--prompt-p this-command))
 661            (completing-read (if id
 662                                 (format "%s (default %s): "
 663                                         (substring prompt 0 (string-match
 664                                                              "[ :]+\\'" prompt))
 665                                         id)
 666                               prompt)
 667                             (funcall xref-identifier-completion-table-function)
 668                             nil nil nil
 669                             'xref--read-identifier-history id))
 670           (t id))))
 671
 672 \f
 673 ;;; Commands
 674
 675 (defun xref--find-definitions (id window)
 676   (xref--show-xrefs id 'definitions id window))
 677
 678 ;;;###autoload
 679 (defun xref-find-definitions (identifier)
 680   "Find the definition of the identifier at point.
 681 With prefix argument or when there's no identifier at point,
 682 prompt for it."
 683   (interactive (list (xref--read-identifier "Find definitions of: ")))
 684   (xref--find-definitions identifier nil))
 685
 686 ;;;###autoload
 687 (defun xref-find-definitions-other-window (identifier)
 688   "Like `xref-find-definitions' but switch to the other window."
 689   (interactive (list (xref--read-identifier "Find definitions of: ")))
 690   (xref--find-definitions identifier 'window))
 691
 692 ;;;###autoload
 693 (defun xref-find-definitions-other-frame (identifier)
 694   "Like `xref-find-definitions' but switch to the other frame."
 695   (interactive (list (xref--read-identifier "Find definitions of: ")))
 696   (xref--find-definitions identifier 'frame))
 697
 698 ;;;###autoload
 699 (defun xref-find-references (identifier)
 700   "Find references to the identifier at point.
 701 With prefix argument, prompt for the identifier."
 702   (interactive (list (xref--read-identifier "Find references of: ")))
 703   (xref--show-xrefs identifier 'references identifier nil))
 704
 705 ;;;###autoload
 706 (defun xref-find-regexp (regexp)
 707   "Find all matches for REGEXP.
 708 With \\[universal-argument] prefix, you can specify the directory
 709 to search in, and the file name pattern to search for."
 710   (interactive (list (xref--read-identifier "Find regexp: ")))
 711   (let* ((proj (project-current))
 712          (files (if current-prefix-arg
 713                     (grep-read-files regexp)
 714                   "*.*"))
 715          (dirs (if current-prefix-arg
 716                    (list (read-directory-name "Base directory: "
 717                                               nil default-directory t))
 718                  (project--prune-directories
 719                   (nconc
 720                    (project-directories proj)
 721                    (project-search-path proj)))))
 722          (xref-find-function
 723           (lambda (_kind regexp)
 724             (cl-mapcan
 725              (lambda (dir)
 726                (xref-collect-matches regexp files dir (project-ignores proj)))
 727              dirs))))
 728     (xref--show-xrefs regexp 'matches regexp nil)))
 729
 730 (declare-function apropos-parse-pattern "apropos" (pattern))
 731
 732 ;;;###autoload
 733 (defun xref-find-apropos (pattern)
 734   "Find all meaningful symbols that match PATTERN.
 735 The argument has the same meaning as in `apropos'."
 736   (interactive (list (read-string
 737                       "Search for pattern (word list or regexp): "
 738                       nil 'xref--read-pattern-history)))
 739   (require 'apropos)
 740   (xref--show-xrefs pattern 'apropos
 741                     (apropos-parse-pattern
 742                      (if (string-equal (regexp-quote pattern) pattern)
 743                          ;; Split into words
 744                          (or (split-string pattern "[ \t]+" t)
 745                              (user-error "No word list given"))
 746                        pattern))
 747                     nil))
 748
 749 \f
 750 ;;; Key bindings
 751
 752 ;;;###autoload (define-key esc-map "." #'xref-find-definitions)
 753 ;;;###autoload (define-key esc-map "," #'xref-pop-marker-stack)
 754 ;;;###autoload (define-key esc-map "?" #'xref-find-references)
 755 ;;;###autoload (define-key esc-map [?\C-.] #'xref-find-apropos)
 756 ;;;###autoload (define-key ctl-x-4-map "." #'xref-find-definitions-other-window)
 757 ;;;###autoload (define-key ctl-x-5-map "." #'xref-find-definitions-other-frame)
 758
 759 \f
 760 ;;; Helper functions
 761
 762 (defvar xref-etags-mode--saved nil)
 763
 764 (define-minor-mode xref-etags-mode
 765   "Minor mode to make xref use etags again.
 766
 767 Certain major modes install their own mechanisms for listing
 768 identifiers and navigation.  Turn this on to undo those settings
 769 and just use etags."
 770   :lighter ""
 771   (if xref-etags-mode
 772       (progn
 773         (setq xref-etags-mode--saved
 774               (cons xref-find-function
 775                     xref-identifier-completion-table-function))
 776         (kill-local-variable 'xref-find-function)
 777         (kill-local-variable 'xref-identifier-completion-table-function))
 778     (setq-local xref-find-function (car xref-etags-mode--saved))
 779     (setq-local xref-identifier-completion-table-function
 780                 (cdr xref-etags-mode--saved))))
 781
 782 (declare-function semantic-symref-find-references-by-name "semantic/symref")
 783 (declare-function semantic-symref-find-text "semantic/symref")
 784 (declare-function semantic-find-file-noselect "semantic/fw")
 785 (declare-function grep-read-files "grep")
 786 (declare-function grep-expand-template "grep")
 787
 788 (defun xref-collect-references (symbol dir)
 789   "Collect references to SYMBOL inside DIR.
 790 This function uses the Semantic Symbol Reference API, see
 791 `semantic-symref-find-references-by-name' for details on which
 792 tools are used, and when."
 793   (cl-assert (directory-name-p dir))
 794   (require 'semantic/symref)
 795   (defvar semantic-symref-tool)
 796   (let* ((default-directory dir)
 797          (semantic-symref-tool 'detect)
 798          (res (semantic-symref-find-references-by-name symbol 'subdirs))
 799          (hits (and res (oref res hit-lines)))
 800          (orig-buffers (buffer-list)))
 801     (unwind-protect
 802         (delq nil
 803               (mapcar (lambda (hit) (xref--collect-match
 804                                 hit (format "\\_<%s\\_>" (regexp-quote symbol))))
 805                       hits))
 806       (mapc #'kill-buffer
 807             (cl-set-difference (buffer-list) orig-buffers)))))
 808
 809 (defun xref-collect-matches (regexp files dir ignores)
 810   "Collect matches for REGEXP inside FILES in DIR.
 811 FILES is a string with glob patterns separated by spaces.
 812 IGNORES is a list of glob patterns."
 813   (cl-assert (directory-name-p dir))
 814   (require 'semantic/fw)
 815   (grep-compute-defaults)
 816   (defvar grep-find-template)
 817   (defvar grep-highlight-matches)
 818   (let* ((grep-find-template (replace-regexp-in-string "-e " "-E "
 819                                                        grep-find-template t t))
 820          (grep-highlight-matches nil)
 821          (command (xref--rgrep-command (xref--regexp-to-extended regexp)
 822                                        files dir ignores))
 823          (orig-buffers (buffer-list))
 824          (buf (get-buffer-create " *xref-grep*"))
 825          (grep-re (caar grep-regexp-alist))
 826          hits)
 827     (with-current-buffer buf
 828       (erase-buffer)
 829       (call-process-shell-command command nil t)
 830       (goto-char (point-min))
 831       (while (re-search-forward grep-re nil t)
 832         (push (cons (string-to-number (match-string 2))
 833                     (match-string 1))
 834               hits)))
 835     (unwind-protect
 836         (delq nil
 837               (mapcar (lambda (hit) (xref--collect-match hit regexp))
 838                       (nreverse hits)))
 839       (mapc #'kill-buffer
 840             (cl-set-difference (buffer-list) orig-buffers)))))
 841
 842 (defun xref--rgrep-command (regexp files dir ignores)
 843   (require 'find-dired)      ; for `find-name-arg'
 844   (defvar grep-find-template)
 845   (defvar find-name-arg)
 846   (grep-expand-template
 847    grep-find-template
 848    regexp
 849    (concat (shell-quote-argument "(")
 850            " " find-name-arg " "
 851            (mapconcat
 852             #'shell-quote-argument
 853             (split-string files)
 854             (concat " -o " find-name-arg " "))
 855            " "
 856            (shell-quote-argument ")"))
 857    dir
 858    (concat
 859     (shell-quote-argument "(")
 860     " -path "
 861     (mapconcat
 862      (lambda (ignore)
 863        (when (string-match "\\(\\.\\)/" ignore)
 864          (setq ignore (replace-match dir t t ignore 1)))
 865        (when (string-match-p "/\\'" ignore)
 866          (setq ignore (concat ignore "*")))
 867        (unless (string-prefix-p "*" ignore)
 868          (setq ignore (concat "*/" ignore)))
 869        (shell-quote-argument ignore))
 870      ignores
 871      " -o -path ")
 872     " "
 873     (shell-quote-argument ")")
 874     " -prune -o ")))
 875
 876 (defun xref--regexp-to-extended (str)
 877   (replace-regexp-in-string
 878    ;; FIXME: Add tests.  Move to subr.el, make a public function.
 879    ;; Maybe error on Emacs-only constructs.
 880    "\\(?:\\\\\\\\\\)*\\(?:\\\\[][]\\)?\\(?:\\[.+?\\]\\|\\(\\\\?[(){}|]\\)\\)"
 881    (lambda (str)
 882      (cond
 883       ((not (match-beginning 1))
 884        str)
 885       ((eq (length (match-string 1 str)) 2)
 886        (concat (substring str 0 (match-beginning 1))
 887                (substring (match-string 1 str) 1 2)))
 888       (t
 889        (concat (substring str 0 (match-beginning 1))
 890                "\\"
 891                (match-string 1 str)))))
 892    str t t))
 893
 894 (defun xref--collect-match (hit regexp)
 895   (pcase-let* ((`(,line . ,file) hit)
 896                (buf (or (find-buffer-visiting file)
 897                         (semantic-find-file-noselect file))))
 898     (with-current-buffer buf
 899       (save-excursion
 900         (goto-char (point-min))
 901         (forward-line (1- line))
 902         (syntax-propertize (line-end-position))
 903         (when (re-search-forward regexp (line-end-position) t)
 904           (goto-char (match-beginning 0))
 905           (let ((loc (xref-make-file-location file line
 906                                               (current-column))))
 907             (goto-char (match-end 0))
 908             (xref-make-match (buffer-substring
 909                               (line-beginning-position)
 910                               (line-end-position))
 911                              (current-column)
 912                              loc)))))))
 913
 914 (provide 'xref)
 915
 916 ;;; xref.el ends here