master b2c4470: Support tags-apropos-additional-actions in etags Xref backend

[Dmitry Gutov]

branch: master
commit b2c44706b69fff4b80cfd78a5cd94a3da1c87fa7
Author: Dmitry Gutov <dgutov@yandex.ru>
Commit: Dmitry Gutov <dgutov@yandex.ru>

    Support tags-apropos-additional-actions in etags Xref backend
    
    * lisp/progmodes/etags.el (xref-etags-apropos-location):
    New class.
    (xref-location-marker): New method definition.
    (xref-make-etags-apropos-location): New function.
    (etags--xref-apropos-additional): New function.
    (xref-backend-apropos): Use it here.
---
 etc/NEWS                |  3 +++
 lisp/progmodes/etags.el | 50 ++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 52 insertions(+), 1 deletion(-)

diff --git a/etc/NEWS b/etc/NEWS
index 416a51b..8f20db7 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2382,6 +2382,9 @@ binding in 'xref--xref-buffer-mode-map'.
 When non-nil, matches for identifiers in the file visited by the
 current buffer will be shown first in the "*xref*" buffer.
 
+*** The etags Xref backend now honors 'tags-apropos-additional-actions'.
+You can customize it to augment the output of 'xref-find-apropos'.
+
 ** Battery
 
 ---
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index a1f806a..7efa885 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -2096,7 +2096,10 @@ file name, add `tag-partial-file-name-match-p' to the 
list value.")
     definitions))
 
 (cl-defmethod xref-backend-apropos ((_backend (eql 'etags)) pattern)
-  (etags--xref-find-definitions (xref-apropos-regexp pattern) t))
+  (let ((regexp (xref-apropos-regexp pattern)))
+    (nconc
+     (etags--xref-find-definitions regexp t)
+     (etags--xref-apropos-additional regexp))))
 
 (defun etags--xref-find-definitions (pattern &optional regexp?)
   ;; This emulates the behavior of `find-tag-in-order' but instead of
@@ -2131,6 +2134,32 @@ file name, add `tag-partial-file-name-match-p' to the 
list value.")
                       (puthash mark-key t marks))))))))))
     (nreverse xrefs)))
 
+(defun etags--xref-apropos-additional (regexp)
+  (cl-mapcan
+   (lambda (oba)
+     (pcase-let* ((`(,group ,goto-fun ,symbs) oba)
+                  (res nil)
+                  (add-xref (lambda (sym)
+                              (let ((sn (symbol-name sym)))
+                                (when (string-match-p regexp sn)
+                                  (push
+                                   (xref-make
+                                    sn
+                                    (xref-make-etags-apropos-location
+                                     sym goto-fun group))
+                                   res))))))
+       (when (symbolp symbs)
+         (if (boundp symbs)
+             (setq symbs (symbol-value symbs))
+           (warn "symbol `%s' has no value" symbs)
+           (setq symbs nil))
+         (if (vectorp symbs)
+             (mapatoms add-xref symbs)
+           (dolist (sy symbs)
+             (funcall add-xref (car sy))))
+         (nreverse res))))
+   tags-apropos-additional-actions))
+
 (defclass xref-etags-location (xref-location)
   ((tag-info :type list   :initarg :tag-info)
    (file     :type string :initarg :file
@@ -2155,6 +2184,25 @@ file name, add `tag-partial-file-name-match-p' to the 
list value.")
   (with-slots (tag-info) l
     (nth 1 tag-info)))
 
+(defclass xref-etags-apropos-location (xref-location)
+  ((symbol :type symbol :initarg :symbol)
+   (goto-fun :type function :initarg :goto-fun)
+   (group :type string :initarg :group
+          :reader xref-location-group))
+  :documentation "Location of an additional apropos etags symbol.")
+
+(defun xref-make-etags-apropos-location (symbol goto-fun group)
+  (make-instance 'xref-etags-apropos-location
+                 :symbol symbol
+                 :goto-fun goto-fun
+                 :group group))
+
+(cl-defmethod xref-location-marker ((l xref-etags-apropos-location))
+  (save-window-excursion
+    (with-slots (goto-fun symbol) l
+      (funcall goto-fun symbol)
+      (point-marker))))
+
 
 (provide 'etags)