Re: Generalizing find-definition

[Jorgen Schaefer <forcer@forcix.cx>]

[-- Attachment #1: Type: text/plain, Size: 1498 bytes --]

On Sun, 02 Nov 2014 10:34:28 -0500
Stefan Monnier <monnier@iro.umontreal.ca> wrote:

> > M-. is bound to a new command `find-definition', which primarily
> > calls the value of a new variable `find-definition-function' (by
> > default a wrapper around `find-tag' to keep the current
> > functionality intact). `find-definition' also keeps track of the
> > tag ring, so this would move `find-tag-marker-ring' and related
> > functionality out of etags.el, too.
> 
> Yes, this sounds great.
>
> [...]
>
> > Comments?
> 
> I'm all for it,

Some initial patch attached. Is this what you had in mind when you said
the above? Anything I should change to make it fit into Emacs better? I
do not know much about Emacs coding conventions.

Currently missing:

- find-definition does not store locations in the tag ring yet
  (ran out of time and wanted to post the initial patch for feedback)
- The whole "find uses" interface
- etags.el integration
- emacs-lisp-mode integration

This also does define a minor mode instead of changing the global key
bindings. I think in the final version it should replace the key
binding definitions done in etags.el. Is this correct? Do I need to
hook it up elsewhere in the build process?

Public git repo for those who find that easier to read / clone (nothing
there that isn't in the attached patch):

https://github.com/jorgenschaefer/emacs/tree/find-definition
https://github.com/jorgenschaefer/emacs/commit/ecac500ac7dee3095863df23c4cd661ba62e2187

Regards,
Jorgen

[-- Attachment #2: 0001-lisp-progmodes-find-definition.el-New-file.patch --]
[-- Type: text/x-patch, Size: 16839 bytes --]

From ecac500ac7dee3095863df23c4cd661ba62e2187 Mon Sep 17 00:00:00 2001
From: Jorgen Schaefer <contact@jorgenschaefer.de>
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 <contact@jorgenschaefer.de>
+
+	* progmodes/find-definition.el: New file.
+
 2014-11-17  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
 	* 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 <contact@jorgenschaefer.de>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 <contact@jorgenschaefer.de>
+
+	* automated/find-definition-test.el: New file.
+
 2014-11-17  Glenn Morris  <rgm@gnu.org>
 
 	* 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 <contact@jorgenschaefer.de>
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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