feature/xref-find-extra 26121b4c49a 1/7: Xref: add xref-find-extra command

[Dmitry Gutov]

branch: feature/xref-find-extra
commit 26121b4c49a3cc65f309a1cef87e38e35acefa0d
Author: Dmitry Gutov <dgutov@yandex.ru>
Commit: Dmitry Gutov <dmitry@gutov.dev>

    Xref: add xref-find-extra command
    
    * lisp/progmodes/elisp-mode.el (xref-backend-extra-kinds):
    Implement for elisp backend.
    
    * lisp/progmodes/xref.el (xref-backend-extra-kinds)
    (xref-backend-extra-defs): New generic functions.
    (xref-prompt-for-identifier): Tweak.
    (xref--create-fetcher): Rework.
    (xref-find-extra): New command.
---
 lisp/progmodes/elisp-mode.el | 60 ++++++++++++++++++++++++++++++++++++++++++++
 lisp/progmodes/xref.el       | 50 +++++++++++++++++++++++++++++++++---
 2 files changed, 106 insertions(+), 4 deletions(-)

diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 63198a660be..e4e21bc565a 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -1212,6 +1212,66 @@ namespace but with lower confidence."
 
     xrefs))
 
+(cl-defmethod xref-backend-extra-kinds ((_backend (eql 'elisp)) identifier)
+  ;; The file name is not known when `symbol' is defined via interactive eval.
+  (let ((symbol (intern-soft identifier))
+        kinds)
+    ;; alphabetical by result type symbol
+
+    ;; FIXME: advised function; list of advice functions
+    ;; FIXME: aliased variable
+
+    ;; Coding system symbols do not appear in ‘load-history’,
+    ;; so we can’t get a location for them.
+    (when (and (symbolp symbol)
+               (symbol-function symbol)
+               (symbolp (symbol-function symbol)))
+      (push "defalias" kinds))
+
+    (when (facep symbol)
+      (push "face" kinds))
+
+    (when (fboundp symbol)
+      (let ((file (find-lisp-object-file-name symbol (symbol-function symbol)))
+            doc)
+        (when file
+          (cond
+           ((eq file 'C-source)
+            (push "function" kinds))
+           ((and (setq doc (documentation symbol t))
+                 ;; This doc string is defined in cl-macs.el cl-defstruct
+                 (string-match "Constructor for objects of type `\\(.*\\)'" 
doc))
+            (push "constructor" kinds))
+           ((cl--generic symbol)
+            (push "generic" kinds))
+           (t
+            (push "function" kinds))))))
+    (when (boundp symbol)
+      (push "variable" kinds))
+    (when (featurep symbol)
+      (push "feature" kinds))
+    (nreverse kinds)))
+
+(cl-defmethod xref-backend-extra-defs ((_backend (eql 'elisp)) identifier kind)
+  (require 'find-func)
+  (let ((sym (intern-soft identifier)))
+    (when sym
+      (let* ((defs (elisp--xref-find-definitions sym))
+             (expected-kind
+              (assoc-default kind
+                             '(("defalias" . defalias)
+                               ("face" . defface)
+                               ("function" . nil)
+                               ("variable" . defvar)
+                               ("constructor" . define-type)
+                               ("generic" . generic)))))
+        (cl-loop for d in defs
+                 for def-kind = (xref-elisp-location-type (xref-item-location 
d))
+                 when (if (eq expected-kind 'generic)
+                          (memq def-kind '(cl-defgeneric cl-defmethod))
+                        (eq def-kind expected-kind))
+                 collect d)))))
+
 (declare-function xref-apropos-regexp "xref" (pattern))
 
 (cl-defmethod xref-backend-apropos ((_backend (eql 'elisp)) pattern)
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 81618428bf3..e1e3862256c 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -314,6 +314,17 @@ recognize and then delegate the work to an external 
process."
   "Return t if case is not significant in identifier completion."
   completion-ignore-case)
 
+(cl-defgeneric xref-backend-extra-kinds (_backend _identifier)
+  "Return the other definition types BACKEND could show for IDENTIFIER."
+  (user-error "Extra definitions not supported by the backend"))
+
+(cl-defgeneric xref-backend-extra-defs (_backend _identifier _kind)
+  "Find definitions of extra KIND for IDENTIFIER.
+
+The result must be a list of xref objects.  Refer to
+`xref-backend-definitions' for other details."
+  nil)
+
 
 ;;; misc utilities
 (defun xref--alistify (list key)
@@ -364,7 +375,8 @@ otherwise unused.")
 
 (defcustom xref-prompt-for-identifier '(not xref-find-definitions
                                             xref-find-definitions-other-window
-                                            xref-find-definitions-other-frame)
+                                            xref-find-definitions-other-frame
+                                            xref-find-extra)
   "If non-nil, prompt for the identifier to find.
 
 When t, always prompt for the identifier name.
@@ -1569,11 +1581,11 @@ The meanings of both arguments are the same as 
documented in
    (xref--create-fetcher id 'definitions id)
    display-action))
 
-(defun xref--create-fetcher (input kind arg)
+(defun xref--create-fetcher (input kind &rest args)
   "Return an xref list fetcher function.
 
 It revisits the saved position and delegates the finding logic to
-the xref backend method indicated by KIND and passes ARG to it."
+the xref backend method indicated by KIND and passes ARGS to it."
   (let* ((orig-buffer (current-buffer))
          (orig-position (point))
          (backend (xref-find-backend))
@@ -1589,7 +1601,7 @@ the xref backend method indicated by KIND and passes ARG 
to it."
         (when (buffer-live-p orig-buffer)
           (set-buffer orig-buffer)
           (ignore-errors (goto-char orig-position)))
-        (let ((xrefs (funcall method backend arg)))
+        (let ((xrefs (apply method backend args)))
           (unless xrefs
             (xref--not-found-error kind input))
           xrefs)))))
@@ -1624,6 +1636,35 @@ Use \\[xref-go-back] to return back to where you invoked 
this command."
   (interactive (list (xref--read-identifier "Find definitions of: ")))
   (xref--find-definitions identifier 'frame))
 
+;;;###autoload
+(defun xref-find-extra (identifier)
+  "Find some specific kind of definition of the identifier at point.
+With prefix argument or when there's no identifier at point,
+prompt for the identifier.
+
+If only one location is found, display it in the selected window.
+Otherwise, display the list of the possible definitions in a
+buffer where the user can select from the list.
+
+Use \\[xref-go-back] to return back to where you invoked this command."
+  (interactive (list
+                ;; XXX: Choose kind of "extra" first? That would fail
+                ;; to take advantage of the symbol-at-point, though.
+                (xref--read-identifier "Find definitions of: ")))
+  (let* ((kinds (xref-backend-extra-kinds (xref-find-backend) identifier))
+         ;; FIXME: We should probably skip asking when there's just
+         ;; one available kind, but let's keep completing-read while
+         ;; collecting the initial feedback about the interface.
+         (kind ;; (if (cdr kinds)
+          (completing-read "Definition kind: " kinds nil t nil nil (car kinds))
+          ;; (car kinds)
+          ;; )
+          ))
+    (unless kind (user-error "No supported kinds"))
+    (xref--show-defs
+     (xref--create-fetcher identifier 'extra-defs identifier kind)
+     nil)))
+
 ;;;###autoload
 (defun xref-find-references (identifier)
   "Find references to the identifier at point.
@@ -1724,6 +1765,7 @@ output of this command when the backend is etags."
 ;;;###autoload (define-key esc-map [?\C-,] #'xref-go-forward)
 ;;;###autoload (define-key esc-map "?" #'xref-find-references)
 ;;;###autoload (define-key esc-map [?\C-.] #'xref-find-apropos)
+;;;###autoload (define-key esc-map "'" #'xref-find-extra)
 ;;;###autoload (define-key ctl-x-4-map "." 
#'xref-find-definitions-other-window)
 ;;;###autoload (define-key ctl-x-5-map "." #'xref-find-definitions-other-frame)