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: Thu, 20 Nov 2014 14:44:54 +0100 Message-ID: References: <20141102151524.0d9c665c@forcix> <20141117211039.37f03409@forcix> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1416491161 22271 80.91.229.3 (20 Nov 2014 13:46:01 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 20 Nov 2014 13:46:01 +0000 (UTC) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Thu Nov 20 14:45:55 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 1XrS3V-0006hC-Cj for ged-emacs-devel@m.gmane.org; Thu, 20 Nov 2014 14:45:53 +0100 Original-Received: from localhost ([::1]:35363 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XrS3T-0003iE-Ra for ged-emacs-devel@m.gmane.org; Thu, 20 Nov 2014 08:45:51 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:38302) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XrS2t-0003hE-R3 for emacs-devel@gnu.org; Thu, 20 Nov 2014 08:45:21 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XrS2n-00052O-T9 for emacs-devel@gnu.org; Thu, 20 Nov 2014 08:45:15 -0500 Original-Received: from plane.gmane.org ([80.91.229.3]:38314) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XrS2n-00051l-IR for emacs-devel@gnu.org; Thu, 20 Nov 2014 08:45:09 -0500 Original-Received: from list by plane.gmane.org with local (Exim 4.69) (envelope-from ) id 1XrS2k-0006Mn-Vx for emacs-devel@gnu.org; Thu, 20 Nov 2014 14:45:07 +0100 Original-Received: from dial-183220.pool.broadband44.net ([212.46.183.220]) by main.gmane.org with esmtp (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Thu, 20 Nov 2014 14:45:06 +0100 Original-Received: from eller.helmut by dial-183220.pool.broadband44.net with local (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Thu, 20 Nov 2014 14:45:06 +0100 X-Injected-Via-Gmane: http://gmane.org/ Original-Lines: 473 Original-X-Complaints-To: usenet@ger.gmane.org X-Gmane-NNTP-Posting-Host: dial-183220.pool.broadband44.net User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.4.50 (gnu/linux) Cancel-Lock: sha1:egW1YOaGfy6SmGnFDKSM5JYN9Jc= X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 80.91.229.3 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:177873 Archived-At: --=-=-= Content-Type: text/plain On Mon, Nov 17 2014, Jorgen Schaefer wrote: > Some initial patch attached. I'm proposing an alternative implementation. This version uses EIOIO which, I think, makes it more flexible. Proof-of-concept-quality backends for elisp and etags are included. The UI is lifted from SLIME (with some simplifications). To try it out, load xref.el and then M-x xref-minor-mode to turn it on. It's not fully polished but good enough to show the main ideas. Also available at: https://github.com/ellerh/xref/blob/master/xref.el --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=xref.el Content-Transfer-Encoding: quoted-printable ;; xref.el --- Cross referencing commands -*-lexical-binding:= t-*- (require 'cl-lib) (require 'eieio) ;;; Locations ;; A location represents a position in a file or buffer. (defclass xref-location () ()) ;; If a backend decides to subclass xref-location it can provide ;; methods for some of the following functions: (defgeneric xref-location-buffer (location)) (defgeneric xref-location-position (location)) (defgeneric xref-location=3D (location1 location2)) (defmethod xref-location=3D ((l1 xref-location) l2) (equal l1 l2)) ;;;; Commonly needed location classes are defined here: ;; A file location is file/line/colum triple. Line numbers start from 1 and ;; columns from 0 (as inconstistent as the rest of Emacs). ;; ;; 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))) (defun xref-file-location (file line column) (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) (position :type fixnum :initarg :position))) (defun xref-buffer-location (buffer position) (make-instance 'xref--buffer-location :buffer buffer :position position)) (defmethod xref-location-buffer ((l xref--buffer-location)) (with-slots (buffer) l buffer)) (defmethod xref-location-position ((l xref--buffer-location)) (with-slots (position) l position)) ;; The "bogus" location subclass is sometimes useful to indicate ;; errors, e.g. when we know that a function exists but the actual ;; location is not known. (defclass xref--bogus-location (xref-location) ((message :type string :initarg :message :reader xref-bogus-location-message))) (defun xref-bogus-location (message) (make-instance 'xref--bogus-location :message message)) ;;; cross reference ;; An xref is used to display and locate constructs like variables or ;; functions. (defclass xref--xref () ((description :type string :initarg :description :reader xref--xref-description) (location :type xref-location :initarg :location :reader xref--xref-location))) (defun xref-make (description location) (make-instance 'xref--xref :description description :location location)) ;;; Backend ;; A setting the variable `xref-backend' to a subclass of ;; xref-backend-class can be used to provde languages specific ;; behaviour, primarily `xref-find-definitions'. ;; Ugly name because defclass stores the class object in the symbol. (defclass xref-backend-class () ()) (defvar xref-backend (make-instance 'xref-backend-class)) ;;;; Backend interface functions (defgeneric xref-find-definitions (backend identifier)) ;; An identifier is backend specific. By default it's a string but it ;; can be any type. (defgeneric xref-identifier-at-point (backend)) (defgeneric xref-read-identifier-from-minibuffer (backend prompt default)) (defgeneric xref-identifier-to-string (backend identifier)) ;; default implementation for identifiers (defmethod xref-identifier-at-point (_backend) (substring-no-properties (thing-at-point 'symbol))) (defmethod xref-read-identifier-from-minibuffer (_backend prompt init) (read-from-minibuffer prompt init)) (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--singleton-p (list) "Is LIST a list with exactly one element?" (and (consp list) (null (cdr list)))) (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) ;; FIXME: for now this is just a wrapper around find-tag-marker-ring. (require 'etags) (defun xref-push-marker-stack () "Add point to find-tag-marker-ring." (ring-insert find-tag-marker-ring (point-marker))) (defun xref-pop-marker-stack () "Pop the edit-definition stack and goto the location." (interactive) (pop-tag-mark)) (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 (<=3D (point-min) pos) (<=3D 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 ;; 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)) (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"))))) (defun xref--show-xref-buffer (xref-alist) (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)))) ;; Return a string used to group a set of locations (this is typically ;; the filename). (defgeneric xref-location-group (location)) (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 (cond ((not buffer) "(dead buffer)") ((buffer-file-name buffer)) (t (format "(buffer %s)" (buffer-name buffer)))))) (defun xref--analyze (xrefs) "Find common filenames in XREFS. Return a list (SINGLE-LOCATION XREF-ALIST). SINGLE-LOCATION is true if all xrefs point to the same location. XREF-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)." (list (and xrefs (let ((loc (xref--xref-location (car xrefs)))) (and (cl-every (lambda (x) (xref-location=3D (xref--xref-location x) loc)) (cdr xrefs)) loc))) (xref--alistify xrefs (lambda (x) (xref-location-group (xref--xref-location x))) #'equal))) (defun xref--find-definition (id window) (let ((xrefs (xref-find-definitions xref-backend id))) (cl-destructuring-bind (1loc file-alist) (xref--analyze xrefs) (cond ((null xrefs) (error "No known definition for: %s" (xref-identifier-to-string xref-backend id))) (1loc (xref-push-marker-stack) (xref--pop-to-location (xref--xref-location (car xrefs)) window)) (t (xref-push-marker-stack) (xref--show-xref-buffer file-alist)))))) (defun xref--read-identifier (prompt) "Return the identifier at point or read it from the minibuffer." (let ((id (xref-identifier-at-point xref-backend))) (cond ((or current-prefix-arg (not id)) (let ((init (if id (xref-identifier-to-string xref-backend id)))) (xref-read-identifier-from-minibuffer xref-backend prompt init))) (t id)))) (defun xref-find-definition (&optional identifier) (interactive (list (xref--read-identifier "Edit Definition of: "))) (xref--find-definition identifier nil)) (defun xref-find-definition-other-window (&optional identifier) "Like `xref-find-definition' but switch to the other window." (interactive (list (xref--read-identifier "Edit Definition of: "))) (xref--find-definition identifier 'window)) (defun xref-find-definition-other-frame (&optional identifier) "Like `xref-find-definition' but switch to the other window." (interactive (list (xref--read-identifier "Edit Definition of: "))) (xref--find-definition identifier 'frame)) ;;; ELisp backend ;; For now this is just a wrapper around find-func.el in particular ;; `find-definition-noselect'. (defclass xref-elisp-backend (xref-backend-class) ()) (defun xref--elisp-find-definition (symbol type) (let ((loc (condition-case err (let ((loc (save-excursion (find-definition-noselect symbol type)))) (xref-buffer-location (car loc) (or (cdr loc) 1))) (error (xref-bogus-location (error-message-string err))))) (desc (cond ((not type) (symbol-name symbol)) (t (format "(%s %s)" type symbol))))) (xref-make desc loc))) ;; FIXME: include other stuff likes faces, compiler-macros, methods... (defmethod xref-find-definitions ((_ xref-elisp-backend) id) (let ((sym (intern-soft id))) (if (null sym) '() (let ((fdef (if (fboundp sym) (xref--elisp-find-definition sym nil))) (vdef (if (boundp sym) (xref--elisp-find-definition sym 'defvar)))) (remove nil (list fdef vdef)))))) ;;; etags backend (defclass xref-etags-backend (xref-backend-class) ()) ;; For now, make the etags backend the default. (setq-default xref-backend (make-instance 'xref-etags-backend)) (defmethod xref-find-definitions ((_ xref-etags-backend) id) ;; This emulates the behaviour of `find-tag-in-order' but instead of ;; returning on match at the time all matches are returned as list. ;; NOTE: find-tag-tag-order is typically a buffer-local variable. (let ((xrefs '()) (first-time t) (pattern id) (search-fun #'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 find-tag-tag-order) (goto-char (point-min)) (while (funcall search-fun pattern nil t) (when (funcall order-fun pattern) (beginning-of-line) (cl-destructuring-bind (hint line &rest pos) (etags-snarf-tag) (unless (eq hint t) ; hint=3D=3Dt 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-file-location (expand-file-name file) line 0))) (push (xref-make hint loc) xrefs) (puthash mark-key t marks))))))))))) (nreverse xrefs))) ;;; just for testing (define-minor-mode xref-minor-mode "xref" :keymap `((,(kbd "M-.") . xref-find-definition) (,(kbd "M-,") . xref-pop-marker-stack) (,(kbd "C-x 4 .") . xref-find-definitions-other-window) (,(kbd "C-x 5 .") . xref-find-definitions-other-frame)) :lighter " xref") ;; (define-key global-map [rmap find-tag] 'xref-find-definition) ;; (define-key global-map [rmap pop-tag-mark] 'xref-pop-marker-stack) ;; (define-key global-map (kbd "M-,") 'xref-pop-marker-stack) (defun xref-install-backends () (dolist (buffer (buffer-list)) (with-current-buffer buffer (let ((backend (cl-case major-mode (emacs-lisp-mode (make-instance 'xref-elisp-backend)) (t nil)))) (when backend (setq-local xref-backend backend)))))) (add-hook 'xref-minor-mode-hook 'xref-install-backends) ;; system-name --=-=-= Content-Type: text/plain Helmut --=-=-=--