>From ecac500ac7dee3095863df23c4cd661ba62e2187 Mon Sep 17 00:00:00 2001
From: Jorgen Schaefer
Date: Mon, 17 Nov 2014 20:43:57 +0100
Subject: [PATCH] * lisp/progmodes/find-definition.el: New file. *
test/automated/find-definition-test.el: New file.
---
lisp/ChangeLog | 4 +
lisp/progmodes/find-definition.el | 194 +++++++++++++++++++++++++++++
test/ChangeLog | 4 +
test/automated/find-definition-test.el | 208 ++++++++++++++++++++++++++++++++
4 files changed, 410 insertions(+)
create mode 100644 lisp/progmodes/find-definition.el
create mode 100644 test/automated/find-definition-test.el
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 912b69a..0334bb4 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,7 @@
+2014-11-17 Jorgen Schaefer
+
+ * progmodes/find-definition.el: New file.
+
2014-11-17 Lars Magne Ingebrigtsen
* bindings.el (search-map): Move `eww-search-words' to `M-s M-w'.
diff --git a/lisp/progmodes/find-definition.el b/lisp/progmodes/find-definition.el
new file mode 100644
index 0000000..d9846e7
--- /dev/null
+++ b/lisp/progmodes/find-definition.el
@@ -0,0 +1,194 @@
+;;; find-definition.el --- Find definition at point -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;; Author: Jorgen Schaefer
+;; Keywords: tools
+
+;; This file is part of GNU Emacs.
+
+;; This program 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.
+
+;; This program 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 this program. If not, see .
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ring)
+
+(defgroup find-definition nil "Finding definitions of things at point."
+ :group 'tools)
+
+(defcustom find-definition-marker-ring-length 16
+ "Length of marker rings `find-definition-marker-ring'."
+ :group 'find-definition
+ :type 'integer)
+
+(defvar find-definition-function nil
+ "The function `find-definition' calls to find the definition.
+
+Will be called with no arguments with point at the location of
+the thing to find the definition for. It should return a list
+with each element being a list of one to three elements. The
+first element should be the file name, the second the
+line (defaulting to 1) and the third the column (defaulting to
+0).")
+
+(defvar find-definition-identifier-function nil
+ "Find the definition of a named identifier.
+
+Will be called with the result of prompting the user for a
+completion using `find-definition-completion-table', and should
+return a list like `find-definition-function'.")
+
+(defvar find-definition-identifier-completion-table nil
+ "The completion table to complete known symbols.
+
+Will be passed as COLLECTION to `completing-read'.")
+
+(defvar find-definition-marker-ring
+ (make-ring find-definition-marker-ring-length)
+ "Ring of positions visited by `find-definition'.")
+
+(defvar find-definition-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "M-.") 'find-definition)
+ (define-key map (kbd "C-x 4 .") 'find-definition-other-window)
+ (define-key map (kbd "C-x 5 .") 'find-definition-other-frame)
+ ;; (define-key map (kbd "M-_") 'find-definition-uses)
+ (define-key map (kbd "M-,") 'find-definition-goto-last-position)
+ map)
+ "The key map for `find-definition-mode'.")
+
+;;;###autoload
+(define-minor-mode find-definition-mode
+ "Minor mode to provide some key bindings to find definitions.
+
+\\{find-definition-mode-map}"
+ :keymap 'find-definition-mode)
+
+;;;###autoload
+(defun find-definition (&optional ask)
+ "Go to the definition of the thing at point.
+
+If the definition can not be found, or with a prefix argument,
+prompt for a symbol to use."
+ (interactive "P")
+ (switch-to-buffer (find-definition--noselect ask)))
+
+;;;###autoload
+(defun find-definition-other-window (&optional ask)
+ "Display the definition of the thing at point in another window.
+
+If the definition can not be found, or with a prefix argument,
+prompt for a symbol to use."
+ (interactive "P")
+ (switch-to-buffer-other-window (find-definition--noselect ask)))
+
+;;;###autoload
+(defun find-definition-other-frame (&optional ask)
+ "Display the definition of the thing at point in another frame.
+
+If the definition can not be found, or with a prefix argument,
+prompt for a symbol to use."
+ (interactive "P")
+ (switch-to-buffer-other-frame (find-definition--noselect ask)))
+
+(defun find-definition--noselect (&optional ask)
+ "Internal function for `find-definition'.
+
+Does all the work, but returns the buffer instead of displaying
+it."
+ (let* ((locations (when (not ask)
+ (funcall find-definition-function))))
+ (cond
+ (locations
+ (find-definition--find-locations locations))
+ ((and find-definition-identifier-completion-table
+ find-definition-identifier-function)
+ (let* ((identifier (completing-read
+ "Find definition: "
+ find-definition-identifier-completion-table
+ nil t))
+ (locations (funcall find-definition-identifier-function
+ identifier)))
+ (find-definition--find-locations locations)))
+ (t
+ (error "Can't find the definition of the thing at point")))))
+
+(defun find-definition--find-locations (locations)
+ "Go to the location in LOCATIONS.
+
+If there is exactly one location, go directly there. Otherwise,
+prompt the user for a location choice."
+ (if (null (cdr locations))
+ ;; Exactly one definition
+ (let* ((location (car locations))
+ (filename (elt location 0))
+ (line (or (elt location 1)
+ 1))
+ (col (or (elt location 2)
+ 0))
+ (buf (find-file-noselect filename)))
+ (with-current-buffer buf
+ (widen)
+ (goto-char (point-min))
+ (forward-line (- line 1))
+ (forward-char col))
+ buf)
+ ;; More than one definition
+ (let ((outbuf (get-buffer-create "*Definitions*"))
+ (dir default-directory)
+ (inhibit-read-only t))
+ (with-current-buffer outbuf
+ (erase-buffer)
+ (setq default-directory dir)
+ (compilation-mode)
+ (dolist (location locations)
+ (let* ((filename (elt location 0))
+ (line (or (elt location 1)
+ 1))
+ (col (or (elt location 2)
+ 0))
+ (buffer (find-buffer-visiting filename))
+ (line-string
+ (when buffer
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-line (- line 1))
+ (buffer-substring (line-beginning-position)
+ (line-end-position))))))))
+ (insert (format "%s:%s:%s:%s\n"
+ filename line col
+ (or line-string
+ "")))))
+ (goto-char (point-min)))
+ outbuf)))
+
+;;;###autoload
+(defun find-definition-goto-last-position ()
+ "Pop back to where \\[find-definition] was last invoked."
+ (interactive)
+ (when (ring-empty-p find-definition-marker-ring)
+ (error "No previous locations for find-definition invocation"))
+ (let ((marker (ring-remove find-definition-marker-ring)))
+ (switch-to-buffer (or (marker-buffer marker)
+ (error "The marked buffer has been deleted")))
+ (goto-char (marker-position marker))
+ (set-marker marker nil nil)))
+
+(provide 'find-definition)
+;;; find-definition.el ends here
diff --git a/test/ChangeLog b/test/ChangeLog
index fb00410..217672e 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,7 @@
+2014-11-17 Jorgen Schaefer
+
+ * automated/find-definition-test.el: New file.
+
2014-11-17 Glenn Morris
* automated/occur-tests.el (occur-test-case, occur-test-create):
diff --git a/test/automated/find-definition-test.el b/test/automated/find-definition-test.el
new file mode 100644
index 0000000..920eb30
--- /dev/null
+++ b/test/automated/find-definition-test.el
@@ -0,0 +1,208 @@
+;;; find-definition-test.el --- Test suite for find-definition.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014 Jorgen Schaefer
+
+;; This program 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.
+
+;; This program 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 this program. If not, see .
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'find-definition)
+
+
+(defmacro find-definition-with-temp-file (variable &rest body)
+ "Create a temporary file, bind it to VARIABLE, and evaluated BODY.
+
+Delete the file after BODY finishes."
+ (declare (indent 1))
+ `(let ((,variable (make-temp-file "find-definition-test-")))
+ (unwind-protect
+ (progn ,@body)
+ (delete-file ,variable))))
+
+;;;;;;;;;;;;;;;;;;;
+;;; find-definition
+
+(ert-deftest find-definition ()
+ ;; It should go to the definition if there is exactly one.
+ (find-definition-with-temp-file filename
+ (with-temp-file filename
+ (insert "Hello\n"
+ "World\n"))
+ (let ((find-definition-function (lambda ()
+ (list (list filename 2 3)))))
+
+ (find-definition)
+
+ (should (equal (buffer-file-name) filename))
+ (should (looking-at "ld")))
+ (kill-buffer))
+
+ ;; If the backend function can't find a definition for the thing at
+ ;; point, find-definition should prompt the user for a symbol
+ ;; completed by a backend-provided completion table. This symbol
+ ;; then is passed to a backend function to get the location.
+ (find-definition-with-temp-file filename
+ (cl-letf* ( ;; User function definitions
+ (find-definition-function (lambda ()
+ nil))
+ (find-definition-identifier-completion-table 'test-table)
+ (fdsf-identifier nil)
+ (find-definition-identifier-function
+ (lambda (sym)
+ (setq fdsf-identifier sym)
+ (list (list filename 1 0))))
+ ;; Mocking
+ (cr-collection nil)
+ ((symbol-function 'completing-read)
+ (lambda (prompt collection &rest args)
+ (setq cr-collection collection)
+ "test-symbol")))
+
+ (find-definition)
+
+ (should (equal cr-collection 'test-table))
+ (should (equal fdsf-identifier "test-symbol"))
+ (should (equal (buffer-file-name) filename))))
+
+ ;; Do the same with a prefix argument.
+ (find-definition-with-temp-file filename
+ (cl-letf* ( ;; User function definitions
+ (find-definition-function (lambda ()
+ (error "Should not be called")))
+ (find-definition-identifier-completion-table 'test-table)
+ (find-definition-identifier-function
+ (lambda (sym)
+ (list (list filename 1 0))))
+ ;; Mocking
+ (cr-collection nil)
+ ((symbol-function 'completing-read)
+ (lambda (prompt collection &rest args)
+ (setq cr-collection collection)
+ "test-symbol")))
+
+ (find-definition '(4))
+
+ (should (equal cr-collection 'test-table))))
+
+ ;; Without a completion table and no identifier at point, the
+ ;; function should throw an error.
+ (cl-letf* ((find-definition-function (lambda ()
+ nil))
+ (find-definition-identifier-completion-table nil)
+ (find-definition-identifier-function nil))
+
+ (should-error
+ (find-definition)))
+
+ ;; Without a completion table and a prefix argument, the function
+ ;; should throw an error as well
+ (cl-letf* ((find-definition-function (lambda ()
+ (error "Should not be called")))
+ (find-definition-identifier-completion-table nil)
+ (find-definition-identifier-function nil))
+
+ (should-error
+ (find-definition '(4))))
+
+ ;; It should pop up a selection dialog if there is more than one
+ ;; definition.
+ (find-definition-with-temp-file filename
+ (with-temp-file filename
+ (insert "Hello\n"
+ "World\n"))
+ (let ((find-definition-function (lambda ()
+ (list (list filename 1)
+ (list filename 2)))))
+
+ (find-definition)
+
+ (should (equal (buffer-name) "*Definitions*"))
+ (should (eq major-mode 'compilation-mode))))
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;
+;;; find-definition-uses
+
+;; - find-definition-uses should go the use if there is exactly one.
+;; - find-definition-uses should pop up a selection dialog if there is
+;; more than one use.
+;; - find-definition-uses should prompt for name if there is no definition.
+;; - find-definition-uses should prompt for name with prefix argument.
+
+;; - Provide a new function, etags-find-definition
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; find-definition-goto-last-position
+
+(ert-deftest find-definition-goto-last-position ()
+ ;; It should move to the last position in the same buffer
+ (with-temp-buffer
+ (let* ((find-definition-marker-ring (make-ring 5))
+ (start (point))
+ (marker (make-marker)))
+ (set-marker marker start)
+ (ring-insert find-definition-marker-ring marker)
+ (insert "Bla bla\n")
+ (should (not (= (point) start)))
+ (find-definition-goto-last-position)
+ (should (= (point) start))))
+
+ ;; It should move to the last position in another buffer
+ (with-temp-buffer
+ (let* ((find-definition-marker-ring (make-ring 5))
+ (start (point))
+ (start-buffer (current-buffer))
+ (marker (make-marker)))
+ (set-marker marker start start-buffer)
+ (ring-insert find-definition-marker-ring marker)
+ (with-temp-buffer
+ (find-definition-goto-last-position)
+ (should (equal (current-buffer) start-buffer))
+ (should (= (point) start)))))
+
+ ;; It should should be interactive
+ (should (interactive-form 'find-definition-goto-last-position))
+
+ ;; It should raise an error when the marker ring is empty
+ (let ((find-definition-marker-ring (make-ring 1)))
+ (should-error (find-definition-goto-last-position)))
+
+ ;; It should raise an error if the original buffer is deleted
+ (let* ((find-definition-marker-ring (make-ring 5))
+ (marker (make-marker)))
+ (with-temp-buffer
+ (set-marker marker (point))
+ (ring-insert find-definition-marker-ring marker))
+ (should-error
+ (find-definition-goto-last-position)))
+
+ ;; It should reset the marker
+ ;;
+ ;; Why? This is copied from pop-to-mark, but why would this be
+ ;; needed?
+ (let* ((find-definition-marker-ring (make-ring 5))
+ (marker (make-marker)))
+ (with-temp-buffer
+ (set-marker marker (point))
+ (ring-insert find-definition-marker-ring marker)
+ (find-definition-goto-last-position)
+ (should (null (marker-position marker)))
+ (should (null (marker-buffer marker)))))
+ )
+
+(provide 'find-definition-test)
+;;; find-definition-test.el ends here
--
1.7.10.4