bug#139: describe-key vs. widget red tape

[Mauro Aranda <maurooaranda@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 540 bytes --]

I finally found some time to keep working on this.

I reworked the patch with the useful suggestion from Basil.  I think I
addressed all the points raised, and that the patch looks much better
now.  I went with `describe-widget' for the name of the command, but
have no preference over the name, so if someone suggests something
better, I'm OK with it.

If the approach of putting the variable in a preloaded library, like
Lars suggested, is better, feel free to either adapt the code
or tell me and I'll do it.

WDYT?

Best regards,
Mauro

[-- Attachment #1.2: Type: text/html, Size: 647 bytes --]

[-- Attachment #2: 0001-New-command-describe-widget-Bug-139.patch --]
[-- Type: text/x-patch, Size: 8388 bytes --]

From eb7f8a6172761826ff3e89314927ee1a931c1efa Mon Sep 17 00:00:00 2001
From: Mauro Aranda <maurooaranda@gmail.com>
Date: Fri, 11 Oct 2019 10:00:01 -0300
Subject: [PATCH] New command describe-widget (Bug#139)

Thanks to Basil Contovounesios for providing enhancements.

* lisp/help-fns.el (describe-widget-functions): New variable, used by
describe-widget.
(describe-widget): New command, to display information about a widget.
* lisp/button.el (button-describe): New command, for describing a button.
(button--describe): Helper function for button-describe.
* lisp/wid-edit.el (widget-describe): New command, for describing a
widget.
(widget--resolve-parent-action): Helper function, to allow
widget-describe to display more useful information.
---
 lisp/button.el   | 45 ++++++++++++++++++++++++++++++++++++++++++++
 lisp/help-fns.el | 44 +++++++++++++++++++++++++++++++++++++++++++
 lisp/wid-edit.el | 57 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 146 insertions(+)

diff --git a/lisp/button.el b/lisp/button.el
index 04e77ca..bc212e5 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -538,6 +538,51 @@ backward-button
   (interactive "p\nd\nd")
   (forward-button (- n) wrap display-message no-error))
 
+(defun button--describe (properties)
+  "Describe a button's PROPERTIES (an alist) in a *Help* buffer.
+This is a helper function for `button-describe', in order to be possible to
+use `help-setup-xref'.
+
+Each element of PROPERTIES should be of the form (PROPERTY . VALUE)."
+  (help-setup-xref (list #'button--describe properties)
+                   (called-interactively-p 'interactive))
+  (with-help-window (help-buffer)
+    (with-current-buffer (help-buffer)
+      (insert (format-message "This button's type is `%s'."
+                              (alist-get 'type properties)))
+      (dolist (prop '(action mouse-action))
+        (let ((name (symbol-name prop))
+              (val (alist-get prop properties)))
+          (when (functionp val)
+            (insert "\n\n"
+                    (propertize (capitalize name) 'face 'bold)
+                    "\nThe " name " of this button is")
+            (if (symbolp val)
+                (progn
+                  (insert (format-message " `%s',\nwhich is " val))
+                  (describe-function-1 val))
+              (insert "\n")
+              (princ val))))))))
+
+(defun button-describe (&optional button-or-pos)
+  "Display a buffer with information about the button at point.
+
+When called from Lisp, pass BUTTON-OR-POS as the button to describe, or a
+buffer position where a button is present.  If BUTTON-OR-POS is nil, the
+button at point is the button to describe."
+  (interactive "d")
+  (let* ((button (cond ((integer-or-marker-p button-or-pos)
+                        (button-at button-or-pos))
+                       ((null button-or-pos) (button-at (point)))
+                       ((overlayp button-or-pos) button-or-pos)))
+         (props (and button
+                     (mapcar (lambda (prop)
+                               (cons prop (button-get button prop)))
+                             '(type action mouse-action)))))
+    (when props
+      (button--describe props)
+      t)))
+
 (provide 'button)
 
 ;;; button.el ends here
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 06b15a3..997b076 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -1533,6 +1533,50 @@ describe-categories
 	  (describe-vector table 'help-describe-category-set))))))
 
 \f
+;; Widgets.
+
+(defvar describe-widget-functions
+  '(button-describe widget-describe)
+  "A list of functions for `describe-widget' to call.
+Each function should take one argument, a buffer position, and return
+non-nil if it described a widget at that position.")
+
+;;;###autoload
+(defun describe-widget (&optional pos)
+  "Display a buffer with information about a widget.
+You can use this command to describe buttons (e.g., the links in a *Help*
+buffer), editable fields of the customization buffers, etc.
+
+Interactively, click on a widget to describe it, or hit RET to describe the
+widget at point.
+
+When called from Lisp, POS may be a buffer position or a mouse position list.
+
+Calls each function of the list `describe-widget-functions' in turn, until
+one of them returns non-nil."
+  (interactive
+   (list
+    (let ((key
+           (read-key
+            "Click on a widget, or hit RET to describe the widget at point")))
+      (cond ((eq key ?\C-m) (point))
+            ((and (mouse-event-p key)
+                  (eq (event-basic-type key) 'mouse-1)
+                  (equal (event-modifiers key) '(click)))
+             (event-end key))
+            ((eq key ?\C-g) (signal 'quit nil))
+            (t (user-error "You didn't specify a widget"))))))
+  (let (buf)
+    ;; Allow describing a widget in a different window.
+    (when (posnp pos)
+      (setq buf (window-buffer (posn-window pos))
+            pos (posn-point pos)))
+    (with-current-buffer (or buf (current-buffer))
+      (unless (cl-some (lambda (fun) (when (fboundp fun) (funcall fun pos)))
+                       describe-widget-functions)
+        (message "No widget found at that position")))))
+\f
+
 ;;; Replacements for old lib-src/ programs.  Don't seem especially useful.
 
 ;; Replaces lib-src/digest-doc.c.
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 4d1a609..5e904cb 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -590,6 +590,63 @@ widget-map-buttons
       (if (and widget (funcall function widget maparg))
 	  (setq overlays nil)))))
 
+(defun widget-describe (&optional widget-or-pos)
+  "Describe the widget at point.
+Displays a buffer with information about the widget (e.g., its actions) as well
+as a link to browse all the properties of the widget.
+
+This command resolves the indirection of widgets running the action of its
+parents, so the real action executed can be known.
+
+When called from Lisp, pass WIDGET-OR-POS as the widget to describe,
+or a buffer position where a widget is present.  If WIDGET-OR-POS is nil,
+the widget at point is the widget to describe."
+  (interactive "d")
+  (require 'wid-browse) ; The widget-browse widget.
+  (let ((widget (if (widgetp widget-or-pos)
+                    widget-or-pos
+                  (widget-at widget-or-pos)))
+        props)
+    (when widget
+      (help-setup-xref (list #'widget-describe widget)
+                       (called-interactively-p 'interactive))
+      (setq props (list (cons 'action (widget--resolve-parent-action widget))
+                        (cons 'mouse-down-action
+                              (widget-get widget :mouse-down-action))))
+      (with-help-window (help-buffer)
+        (with-current-buffer (help-buffer)
+          (widget-insert "This widget's type is ")
+          (widget-create 'widget-browse :format "%[%v%]\n%d"
+                         :doc (get (car widget) 'widget-documentation)
+                         :help-echo "Browse this widget's properties"
+                         widget)
+          (dolist (action '(action mouse-down-action))
+            (let ((name (symbol-name action))
+                  (val (alist-get action props)))
+              (when (functionp val)
+                (widget-insert "\n\n" (propertize (capitalize name) 'face 'bold)
+                               "'\nThe " name " of this widget is")
+                (if (symbolp val)
+                    (progn (widget-insert " ")
+                           (widget-create 'function-link :value val
+                                          :button-prefix "" :button-suffix ""
+                                          :help-echo "Describe this function"))
+                  (widget-insert "\n")
+                  (princ val)))))))
+      (widget-setup)
+      t)))
+
+(defun widget--resolve-parent-action (widget)
+  "Resolve the real action of WIDGET up its inheritance chain.
+Follow the WIDGET's parents, until its :action is no longer
+`widget-parent-action', and return its value."
+  (let ((action (widget-get widget :action))
+        (parent (widget-get widget :parent)))
+    (while (eq action 'widget-parent-action)
+      (setq parent (widget-get parent :parent)
+            action (widget-get parent :action)))
+    action))
+
 ;;; Images.
 
 (defcustom widget-image-directory (file-name-as-directory
-- 
2.7.4