From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Helmut Eller Newsgroups: gmane.emacs.devel Subject: Re: Generalizing find-definition Date: Tue, 09 Dec 2014 09:40:16 +0100 Message-ID: References: <20141102151524.0d9c665c@forcix> <20141117211039.37f03409@forcix> <877fymghgb.fsf@bredband.net> <85ppc0qf9a.fsf@stephe-leake.org> <85zjb3o09d.fsf@stephe-leake.org> <85tx1amnyg.fsf@stephe-leake.org> <85egsem1u2.fsf@stephe-leake.org> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1418114460 16023 80.91.229.3 (9 Dec 2014 08:41:00 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 9 Dec 2014 08:41:00 +0000 (UTC) Cc: emacs-devel@gnu.org To: Stefan Monnier Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Tue Dec 09 09:40:54 2014 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1XyGLl-00076F-4g for ged-emacs-devel@m.gmane.org; Tue, 09 Dec 2014 09:40:54 +0100 Original-Received: from localhost ([::1]:38437 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XyGLk-0004xv-MF for ged-emacs-devel@m.gmane.org; Tue, 09 Dec 2014 03:40:52 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:47899) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XyGLO-0004xi-R0 for emacs-devel@gnu.org; Tue, 09 Dec 2014 03:40:36 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XyGLI-0000eD-7R for emacs-devel@gnu.org; Tue, 09 Dec 2014 03:40:30 -0500 Original-Received: from mail-wg0-x22a.google.com ([2a00:1450:400c:c00::22a]:38692) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XyGLE-0000cn-HE for emacs-devel@gnu.org; Tue, 09 Dec 2014 03:40:24 -0500 Original-Received: by mail-wg0-f42.google.com with SMTP id z12so173603wgg.1 for ; Tue, 09 Dec 2014 00:40:19 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version:content-type; bh=QdmGmYRNEqlxQ1RjPlCTK8yUGKbsV69arGCASKEb+S0=; b=dbZPfUOd9qLU04w+5rlWdNEYtdL04MaVZQOUzDf1mr0MyavwVgJnA/pbkjvJd9o+Ek APRbjXAycOYar6eE46rBsWs/am2BGQrYIXlzS2I0b42/SqXDi+JpXOvelUHAAz5CxNlt 2aHANJWT2KFTq0ax8TCl5AMnU76jsWvbQZBLb4cRS2HDDvjr35zPRnReqUrx9gqFJj9S htmqkuimQqqarANzQStmmmmRBn1c9nXyGXJ6GwPm2pgzBsgDTUwmLU/abvDvtVGSx/lQ nwi4Z2tHG8lMfMfyWBgy1dcHsn0+aVLgv+klNPW+qwybk6iqyfyJ5wrkDgZLEVgBK+hQ ggOw== X-Received: by 10.194.193.2 with SMTP id hk2mr2837420wjc.40.1418114419842; Tue, 09 Dec 2014 00:40:19 -0800 (PST) Original-Received: from ix ([212.46.172.140]) by mx.google.com with ESMTPSA id j1sm778599wjw.25.2014.12.09.00.40.17 for (version=TLSv1.2 cipher=RC4-SHA bits=128/128); Tue, 09 Dec 2014 00:40:18 -0800 (PST) Original-Received: from helmut by ix with local (Exim 4.80) (envelope-from ) id 1XyGLA-0001hH-Hp; Tue, 09 Dec 2014 09:40:16 +0100 In-Reply-To: (Stefan Monnier's message of "Mon, 08 Dec 2014 21:34:07 -0500") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.0.50 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: Error: Malformed IPv6 address (bad octet value). X-Received-From: 2a00:1450:400c:c00::22a X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:179537 Archived-At: --=-=-= Content-Type: text/plain On Mon, Dec 08 2014, Stefan Monnier wrote: > Alright, let's go ahead with this. Can you send a "latest and greatest" > version of your code so I can install it into master? Here we go: --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Generalized-infrastructure-for-find-definition.patch >From daa6a31e4903a5dd2d1450d4118fa0703ab88006 Mon Sep 17 00:00:00 2001 From: Helmut Eller Date: Tue, 9 Dec 2014 09:37:34 +0100 Subject: [PATCH] Generalized infrastructure for find-definition * progmodes/xref.el: New file. * progmodes/etags.el (find-tag-marker-ring, pop-tag-mark): Move to xref but keep aliases for backward compatibility. (tags-reset-tags-tables): Use xref marker stack instead of find-tag-marker-ring. (etags--xref-backend, etags--xref-backend-var) (etags-xref-backend-function): New xref backend. (esc-map, ctl-x-4-map, ctl-x-5-map): Move key bindings for M-., M-,, C-x 4 M-., and C-x 5 M-. to xref.el * emacs-lisp/find-func.el (find-function--xref-backend) (find-function--xref-backend-var) (find-function-xref-backend-function, find-function--find-xref): New xref backend. * progmodes/elisp-mode.el (emacs-lisp-mode): Initialize xref-backend-function. --- lisp/emacs-lisp/find-func.el | 38 ++++ lisp/progmodes/elisp-mode.el | 1 + lisp/progmodes/etags.el | 88 ++++++-- lisp/progmodes/xref.el | 487 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 591 insertions(+), 23 deletions(-) create mode 100644 lisp/progmodes/xref.el diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index c372117..405135f 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -43,6 +43,8 @@ ;;; Code: +(require 'xref) + ;;; User variables: (defgroup find-function nil @@ -578,6 +580,42 @@ Set mark before moving, if the buffer already existed." (define-key ctl-x-4-map "V" 'find-variable-other-window) (define-key ctl-x-5-map "V" 'find-variable-other-frame)) + +;;; Xref backend + +(defclass find-function--xref-backend (xref-backend-class) ()) + +(defvar find-function--xref-backend-var + (make-instance 'find-function--xref-backend)) + +;;;###autoload +(defun find-function-xref-backend-function () find-function--xref-backend-var) + +(defun find-function--find-xref (symbol type) + (let ((loc (condition-case err + (let ((loc (save-excursion + (find-definition-noselect symbol type)))) + (xref-make-buffer-location (car loc) (or (cdr loc) 1))) + (error + (xref-make-bogus-location (error-message-string err))))) + (desc (format "(%s %s)" (or type 'defun) symbol))) + (xref-make desc loc))) + +;; FIXME: include other stuff likes faces, compiler-macros, methods... +(defmethod xref-lookup-definitions ((_ find-function--xref-backend) id) + (let ((sym (intern-soft id))) + (if (null sym) + '() + (let ((fun (if (fboundp sym) (find-function--find-xref sym nil))) + (var (if (boundp sym) (find-function--find-xref sym 'defvar)))) + (remove nil (list fun var)))))) + +(defmethod xref-read-identifier-from-minibuffer + ((b find-function--xref-backend) prompt id) + (completing-read prompt obarray nil nil + (if id (xref-identifier-to-string b id)))) + + (provide 'find-func) ;;; find-func.el ends here diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index ba70f90..fa97890 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -231,6 +231,7 @@ Blank lines separate paragraphs. Semicolons start comments. (setq imenu-case-fold-search nil) (setq-local eldoc-documentation-function #'elisp-eldoc-documentation-function) + (setq-local xref-backend-function #'find-function-xref-backend-function) (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil 'local)) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index b89b4cf..8696d8c 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -28,6 +28,7 @@ (require 'ring) (require 'button) +(require 'xref) ;;;###autoload (defvar tags-file-name nil @@ -182,8 +183,8 @@ Example value: (sexp :tag "Tags to search"))) :version "21.1") -(defvar find-tag-marker-ring (make-ring find-tag-marker-ring-length) - "Ring of markers which are locations from which \\[find-tag] was invoked.") +(define-obsolete-variable-alias 'find-tag-marker-ring 'xref--marker-ring + "25.1") (defvar default-tags-table-function nil "If non-nil, a function to choose a default tags file for a buffer. @@ -716,12 +717,10 @@ Returns t if it visits a tags table, or nil if there are no more in the list." (while (< i find-tag-marker-ring-length) (if (aref (cddr tags-location-ring) i) (set-marker (aref (cddr tags-location-ring) i) nil)) - (if (aref (cddr find-tag-marker-ring) i) - (set-marker (aref (cddr find-tag-marker-ring) i) nil)) (setq i (1+ i)))) + (xref-clear-marker-stack) (setq tags-file-name nil tags-location-ring (make-ring find-tag-marker-ring-length) - find-tag-marker-ring (make-ring find-tag-marker-ring-length) tags-table-list nil tags-table-computed-list nil tags-table-computed-list-for nil @@ -898,7 +897,7 @@ See documentation of variable `tags-file-name'." ;; Run the user's hook. Do we really want to do this for pop? (run-hooks 'local-find-tag-hook)))) ;; Record whence we came. - (ring-insert find-tag-marker-ring (point-marker)) + (xref-push-marker-stack) (if (and next-p last-tag) ;; Find the same table we last used. (visit-tags-table-buffer 'same) @@ -954,7 +953,6 @@ See documentation of variable `tags-file-name'." (switch-to-buffer buf) (error (pop-to-buffer buf))) (goto-char pos))) -;;;###autoload (define-key esc-map "." 'find-tag) ;;;###autoload (defun find-tag-other-window (tagname &optional next-p regexp-p) @@ -995,7 +993,6 @@ See documentation of variable `tags-file-name'." ;; the window's point from the buffer. (set-window-point (selected-window) tagpoint)) window-point))) -;;;###autoload (define-key ctl-x-4-map "." 'find-tag-other-window) ;;;###autoload (defun find-tag-other-frame (tagname &optional next-p) @@ -1020,7 +1017,6 @@ See documentation of variable `tags-file-name'." (interactive (find-tag-interactive "Find tag other frame: ")) (let ((pop-up-frames t)) (find-tag-other-window tagname next-p))) -;;;###autoload (define-key ctl-x-5-map "." 'find-tag-other-frame) ;;;###autoload (defun find-tag-regexp (regexp &optional next-p other-window) @@ -1049,20 +1045,8 @@ See documentation of variable `tags-file-name'." ;;;###autoload (define-key esc-map "*" 'pop-tag-mark) ;;;###autoload -(defun pop-tag-mark () - "Pop back to where \\[find-tag] was last invoked. +(defalias 'pop-tag-mark 'xref-pop-marker-stack) -This is distinct from invoking \\[find-tag] with a negative argument -since that pops a stack of markers at which tags were found, not from -where they were found." - (interactive) - (if (ring-empty-p find-tag-marker-ring) - (error "No previous locations for find-tag invocation")) - (let ((marker (ring-remove find-tag-marker-ring 0))) - (switch-to-buffer (or (marker-buffer marker) - (error "The marked buffer has been deleted"))) - (goto-char (marker-position marker)) - (set-marker marker nil nil))) (defvar tag-lines-already-matched nil "Matches remembered between calls.") ; Doc string: calls to what? @@ -1859,7 +1843,6 @@ nil, we exit; otherwise we scan the next file." (and messaged (null tags-loop-operate) (message "Scanning file %s...found" buffer-file-name)))) -;;;###autoload (define-key esc-map "," 'tags-loop-continue) ;;;###autoload (defun tags-search (regexp &optional file-list-form) @@ -2077,6 +2060,65 @@ for \\[find-tag] (which see)." (completion-in-region (car comp-data) (cadr comp-data) (nth 2 comp-data) (plist-get (nthcdr 3 comp-data) :predicate))))) + + +;;; Xref backed + +(defclass etags--xref-backend (xref-backend-class) ()) + +(defvar etags--xref-backend-var (make-instance 'etags--xref-backend)) + +;;;###autoload +(defun etags-xref-backend-function () etags--xref-backend-var) + +;; Stop searching if we find more than xref-limit matches, as the xref +;; infrastracture is not designed to handle very long lists. +;; Switching to some kind of lazy list might be better, but hopefully +;; we hit the limit rarely. +(defconst etags--xref-limit 1000) + +(defmethod xref-lookup-definitions ((_ etags--xref-backend) id) + ;; This emulates the behaviour of `find-tag-in-order' but instead of + ;; returning one match at a time all matches are returned as list. + ;; NOTE: find-tag-tag-order is typically a buffer-local variable. + (let* ((xrefs '()) + (first-time t) + (regexp? (consp id)) + (pattern (if regexp? (cadr id) id)) + (search-fun (if regexp? #'re-search-forward #'search-forward)) + (marks (make-hash-table :test 'equal))) + (save-excursion + (while (visit-tags-table-buffer (not first-time)) + (setq first-time nil) + (dolist (order-fun (cond (regexp? find-tag-regexp-tag-order) + (t find-tag-tag-order))) + (goto-char (point-min)) + (while (and (funcall search-fun pattern nil t) + (< (hash-table-count marks) etags--xref-limit)) + (when (funcall order-fun pattern) + (beginning-of-line) + (cl-destructuring-bind (hint line &rest pos) (etags-snarf-tag) + (unless (eq hint t) ; hint==t if we are in a filename line + (let* ((file (file-of-tag)) + (mark-key (cons file line))) + (unless (gethash mark-key marks) + (let ((loc (xref-make-file-location + (expand-file-name file) line 0))) + (push (xref-make hint loc) xrefs) + (puthash mark-key t marks))))))))))) + (nreverse xrefs))) + +;; If the text in the minibuffer starts with " it's interpreted as a +;; regexp. This is an example for a non-trivial identifier type. +(defmethod xref-read-identifier-from-minibuffer ((b etags--xref-backend) + prompt id) + (let ((string (completing-read prompt (tags-lazy-completion-table) nil nil + (if id (xref-identifier-to-string b id))))) + (cond ((string-match "^\"" string) + `(rx ,(read string))) + (t + string)))) + (provide 'etags) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el new file mode 100644 index 0000000..fd8d87b --- /dev/null +++ b/lisp/progmodes/xref.el @@ -0,0 +1,487 @@ +;; xref.el --- Cross referencing commands -*-lexical-binding:t-*- + +;; Copyright (C) 2014 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file provides a somewhat generic infrastructure for cross +;; referencing commands, in particular "find-definition". Some part of +;; the functionality must be implemented in a language dependent way +;; and that's done by defining a "backend". The generic code finds +;; the backend by calling the function stored in the variable +;; `xref-backend-function'. A language specific mode usually makes +;; `xref-backend-function' buffer local before storing into it. +;; +;; A backend is an instance of the EIEIO class `xref-backend-class'. +;; Various generic functions (in the EIEIO sense of the word) are +;; defined on xref-backend-class. A language specific mode usually +;; creates a subclasses of xref-backend-class and provides specialized +;; methods for the generic functions. See the `etags--xref-backend' +;; and `find-function--xref-backend' classes for examples. + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'ring) + + +;;; Locations + +(defclass xref-location () () + :documentation "A location represents a position in a file or buffer.") + +;; If a backend decides to subclass xref-location it can provide +;; methods for some of the following functions: +(defgeneric xref-location-buffer (location) + "Return the buffer for LOCATION.") + +(defgeneric xref-location-position (location) + "Return the position in LOCATIONs buffer.") + +(defgeneric xref-location= (location1 location2) + "Return t if two locations are equal.") + +(defmethod xref-location= ((l1 xref-location) l2) + (equal l1 l2)) + +;;;; Commonly needed location classes are defined here: + +;; FIXME: might be useful to have an optional "hint" i.e. a string to +;; search for in case the line number is sightly out of date. +(defclass xref-file-location (xref-location) + ((file :type string :initarg :file) + (line :type fixnum :initarg :line) + (column :type fixnum :initarg :column)) + :documentation "A file location is a file/line/column triple. +Line numbers start from 1 and columns from 0.") + +(defun xref-make-file-location (file line column) + "Create and return a new xref-file-location." + (make-instance 'xref-file-location :file file :line line :column column)) + +(defmethod xref-location-buffer ((l xref-file-location)) + (with-slots (file) l + (or (get-file-buffer file) + (let ((find-file-suppress-same-file-warnings t)) + (find-file-noselect file))))) + +(defmethod xref-location-position ((l xref-file-location)) + (with-slots (line column) l + (with-current-buffer (xref-location-buffer l) + (save-restriction + (widen) + (save-excursion + (goto-char (point-min)) + (beginning-of-line line) + (move-to-column column) + (point)))))) + +(defclass xref-buffer-location (xref-location) + ((buffer :type buffer :initarg :buffer :reader xref-location-buffer) + (position :type fixnum :initarg :position :reader xref-location-position))) + +(defun xref-make-buffer-location (buffer position) + "Create and return a new xref-buffer-location." + (make-instance 'xref-buffer-location :buffer buffer :position position)) + +(defclass xref-bogus-location (xref-location) + ((message :type string :initarg :message + :reader xref-bogus-location-message)) + :documentation "Bogus locations are sometimes useful to +indicate errors, e.g. when we know that a function exists but the +actual location is not known.") + +(defun xref-make-bogus-location (message) + "Create and return a new xref-bogus-location." + (make-instance 'xref-bogus-location :message message)) + +(defmethod xref-location-buffer ((l xref-bogus-location)) + (with-slots (message) l + (error "%s" message))) + +(defmethod xref-location-position ((l xref-bogus-location)) + (with-slots (message) l + (error "%s" message))) + + +;;; cross reference + +(defclass xref--xref () + ((description :type string :initarg :description + :reader xref--xref-description) + (location :type xref-location :initarg :location + :reader xref--xref-location)) + :comment "An xref is used to display and locate constructs like +variables or functions.") + +(defun xref-make (description location) + "Create and return an new xref. +DESCRIPTION is a short string to describe the xref. +LOCATION is an `xref-location'." + (make-instance 'xref--xref :description description :location location)) + + +;;; Backend + +;; Ugly name because defclass stores the class object in the symbol. +(defclass xref-backend-class () () + :documentation "Abstract superclass for backends.") + +;; For now, make the etags backend the default. +(defvar xref-backend-function #'etags-xref-backend-function + "Function called to find the current xref-backend. +The function is called with no arguments and should return +a subclass of `xref-backend-class'.") + +(defun xref--backend () + (funcall xref-backend-function)) + +;;;; Backend interface functions + +(defgeneric xref-lookup-definitions (backend identifier) + "Find definitions of IDENTIFIER. +The result is a list of `xref--xref' objects. +If no definition can be found, return nil.") + +(defgeneric xref-lookup-references (backend identifier) + "Find references of IDENTIFIER. +The result is a list of `xref--xref' objects. +If no reference can be found, return nil.") + +;; An identifier is backend specific. By default it's a string but it +;; can be any type, expect nil. +(defgeneric xref-identifier-at-point (backend) + "Search and return the identfier near point. +If no identifier can be found, return nil.") + +(defgeneric xref-read-identifier-from-minibuffer (backend prompt init) + "Read an identifier from the minibuffer. +PROMPT is a string used for prompting. +INIT is either an identifier or nil.") + +(defgeneric xref-identifier-to-string (backend identifier) + "Return a string representing IDENTIFIER.") + +;; default implementation for identifiers +(defmethod xref-identifier-at-point (_backend) + (let ((thing (thing-at-point 'symbol))) + (and thing (substring-no-properties thing)))) + +(defmethod xref-read-identifier-from-minibuffer (backend prompt id) + (read-from-minibuffer prompt + (if id (xref-identifier-to-string backend id)))) + +(defmethod xref-identifier-to-string (_backend identifier) + (with-output-to-string (princ identifier))) + + +;;; misc utilities +(defun xref--alistify (list key test) + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare +keys." + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (cl-assoc k alist :test test))) + (if probe + (setcdr probe (cons e (cdr probe))) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (cl-loop for (key . value) in (reverse alist) + collect (cons key (reverse value))))) + +(defun xref--insert-propertized (props &rest strings) + "Insert STRINGS with text properties PROPS." + (let ((start (point))) + (apply #'insert strings) + (add-text-properties start (point) props))) + +(defun xref--search-property (property &optional backward) + "Search the next text range where text property PROPERTY is non-nil. +Return the value of PROPERTY. If BACKWARD is non-nil, search +backward." + (let ((next (if backward + #'previous-single-char-property-change + #'next-single-char-property-change)) + (start (point)) + (value nil)) + (while (progn + (goto-char (funcall next (point) property)) + (not (or (setq value (get-text-property (point) property)) + (eobp) + (bobp))))) + (cond (value) + (t (goto-char start) nil)))) + + +;;; Marker stack (M-. pushes, M-, pops) + +(defconst xref--marker-ring-length 16) + +(defvar xref--marker-ring (make-ring xref--marker-ring-length) + "Ring of markers to implement the marker stack.") + +(defun xref-push-marker-stack () + "Add point to the marker stack." + (ring-insert xref--marker-ring (point-marker))) + +;;;###autoload +(defun xref-pop-marker-stack () + "Pop back to where \\[xref-find-definitions] was last invoked." + (interactive) + (let ((ring xref--marker-ring)) + (when (ring-empty-p ring) + (error "Marker stack is empty")) + (let ((marker (ring-remove ring 0))) + (switch-to-buffer (or (marker-buffer marker) + (error "The marked buffer has been deleted"))) + (goto-char (marker-position marker)) + (set-marker marker nil nil)))) + +;; etags.el needs this +(defun xref-clear-marker-stack () + "Discard all markers from the marker stack." + (let ((ring xref--marker-ring)) + (while (not (ring-empty-p ring)) + (let ((marker (ring-remove ring))) + (set-marker marker nil nil))))) + + +(defun xref--goto-location (location) + "Set buffer and point according to xref-location LOCATION." + (set-buffer (xref-location-buffer location)) + (let ((pos (xref-location-position location))) + (cond ((and (<= (point-min) pos) (<= pos (point-max)))) + (widen-automatically (widen)) + (t (error "Location is outside accessible part of buffer"))) + (goto-char pos))) + +(defun xref--pop-to-location (location &optional window) + "Goto xref-location LOCATION and display the buffer. +WINDOW controls how the buffer is displayed: + nil -- switch-to-buffer + 'window -- pop-to-buffer (other window) + 'frame -- pop-to-buffer (other frame)" + (xref--goto-location location) + (cl-ecase window + ((nil) (switch-to-buffer (current-buffer))) + (window (pop-to-buffer (current-buffer) t)) + (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t))))) + + +;;; XREF buffer (part of the UI) + +;; The xref buffer is used to display a set of xrefs. + +(defun xref--display-position (pos other-window recenter-arg) + ;; show the location, but don't hijack focus. + (with-selected-window (display-buffer (current-buffer) other-window) + (goto-char pos) + (recenter recenter-arg))) + +(defgeneric xref--show-location (location)) +(defmethod xref--show-location ((l xref-bogus-location)) + (with-slots (message) l + (message "%s" message))) + +(defmethod xref--show-location (location) + (xref--goto-location location) + (xref--display-position (point) t 1)) + +(defun xref--next-line (backward) + (let ((loc (xref--search-property 'xref-location backward))) + (when loc + (xref--show-location loc)))) + +(defun xref-next-line () + "Move to the next xref and display its source in the other window." + (interactive) + (xref--next-line nil)) + +(defun xref-prev-line () + "Move to the previous xref and display its source in the other window." + (interactive) + (xref--next-line t)) + +(defun xref--location-at-point () + (or (get-text-property (point) 'xref-location) + (error "No reference at point"))) + +(defun xref-goto-xref () + "Jump to the xref at point and close the xref buffer." + (interactive) + (xref--show-location (xref--location-at-point)) + (quit-window)) + +(define-derived-mode xref--xref-buffer-mode fundamental-mode "XREF" + "Mode for displaying cross refenences." + (setq buffer-read-only t)) + +(let ((map xref--xref-buffer-mode-map)) + (define-key map (kbd "q") #'quit-window) + (define-key map [remap next-line] #'xref-next-line) + (define-key map [remap previous-line] #'xref-prev-line) + (define-key map (kbd "RET") #'xref-goto-xref) + + ;; suggested by Johan Claesson "to further reduce finger movement": + (define-key map (kbd ".") #'xref-next-line) + (define-key map (kbd ",") #'xref-prev-line)) + +(defun xref--buffer-name () "*xref*") + +(defun xref--insert-xrefs (xref-alist) + "Insert XREF-ALIST in the current-buffer. +XREF-ALIST is of the form ((GROUP . (XREF ...)) ...). Where +GROUP is a string for decoration purposes and XREF is an +`xref--xref' object." + (cl-loop for ((group . xrefs) . more1) on xref-alist do + (xref--insert-propertized '(face bold) group "\n") + (cl-loop for (xref . more2) on xrefs do + (insert " ") + (with-slots (description location) xref + (xref--insert-propertized + (list 'xref-location location + 'face 'font-lock-keyword-face) + description)) + (when (or more1 more2) + (insert "\n"))))) + +(defgeneric xref-location-group (location) + "Return a string used to group a set of locations. +This is typically the filename.") + +(defmethod xref-location-group ((_ xref-bogus-location)) "(No location)") +(defmethod xref-location-group ((l xref-file-location)) + (with-slots (file) l + file)) +(defmethod xref-location-group ((l xref-buffer-location)) + (with-slots (buffer) l + (or (buffer-file-name buffer) + (format "(buffer %s)" (buffer-name buffer))))) + +(defun xref--analyze (xrefs) + "Find common filenames in XREFS. +Return an alist of the form ((FILENAME . (XREF ...)) ...)." + (xref--alistify xrefs + (lambda (x) + (xref-location-group (xref--xref-location x))) + #'equal)) + +(defun xref--show-xref-buffer (xrefs) + (let ((xref-alist (xref--analyze xrefs))) + (with-current-buffer (get-buffer-create (xref--buffer-name)) + (let ((inhibit-read-only t)) + (erase-buffer) + (xref--insert-xrefs xref-alist) + (xref--xref-buffer-mode) + (pop-to-buffer (current-buffer)) + (goto-char (point-min)) + (current-buffer))))) + + +;; This part of the UI seems fairly uncontroversial: it reads the +;; identifier and deals with the single definition case. +;; +;; The controversial multiple definitions case is handed of to +;; xref-show-xrefs-function. + +(defun xref--unique-location (xrefs) + "If it exists, return the single location in the list XREFS. +If there are multiple or no locations in XREFS return nil." + (and xrefs + (let ((loc (xref--xref-location (car xrefs)))) + (and (cl-every (lambda (x) + (xref-location= (xref--xref-location x) loc)) + (cdr xrefs)) + loc)))) + +(defvar xref-show-xrefs-function 'xref--show-xref-buffer + "Function to display a list of xrefs.") + +(defun xref--show-xrefs (id kind xrefs window) + (let ((1loc (xref--unique-location xrefs))) + (cond ((null xrefs) + (error "No known %s for: %s" + kind (xref-identifier-to-string (xref--backend) id))) + (1loc + (xref-push-marker-stack) + (xref--pop-to-location 1loc window)) + (t + (xref-push-marker-stack) + (funcall xref-show-xrefs-function xrefs))))) + +(defun xref--read-identifier (prompt) + "Return the identifier at point or read it from the minibuffer." + (let* ((backend (xref--backend)) + (id (xref-identifier-at-point backend))) + (cond ((or current-prefix-arg (not id)) + (xref-read-identifier-from-minibuffer backend prompt id)) + (t id)))) + + +;;; Commands + +(defun xref--find-definitions (id window) + (xref--show-xrefs id "definitions" + (xref-lookup-definitions (xref--backend) id) + window)) + +;;;###autoload +(defun xref-find-definitions (identifier) + "Find the definition of the identifier at point. +With prefix argument, prompt for the identifier." + (interactive (list (xref--read-identifier "Find definitions of: "))) + (xref--find-definitions identifier nil)) + +;;;###autoload +(defun xref-find-definitions-other-window (identifier) + "Like `xref-find-definitions' but switch to the other window." + (interactive (list (xref--read-identifier "Find definitions of: "))) + (xref--find-definitions identifier 'window)) + +;;;###autoload +(defun xref-find-definitions-other-frame (identifier) + "Like `xref-find-definitions' but switch to the other window." + (interactive (list (xref--read-identifier "Find definitions of: "))) + (xref--find-definitions identifier 'frame)) + +;;;###autoload +(defun xref-find-references (identifier) + "Find references for the identifier at point. +With prefix argument, prompt for the identifier." + (interactive (list (xref--read-identifier "Find references of: "))) + (xref--show-xrefs identifier "references" + (xref-lookup-references (xref--backend) identifier) + nil)) + + +;;; Key bindings + +;;;###autoload +(progn + (define-key esc-map "." #'xref-find-definitions) + (define-key esc-map "," #'xref-pop-marker-stack) + (define-key ctl-x-4-map "." #'xref-find-definitions-other-window) + (define-key ctl-x-5-map "." #'xref-find-definitions-other-frame)) + + +(provide 'xref) + +;;; xref.el ends here -- 1.7.10.4 --=-=-=--