3 files changed, 146 insertions, 0 deletions

diff --git a/lisp/button.el b/lisp/button.el
index d9c36a0375c..941b9fe720a 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -555,6 +555,51 @@ Returns the button found."
   (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 b9536470631..5a99103f6af 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -1769,6 +1769,50 @@ documentation for the major and minor modes of that buffer."
   ;; For the sake of IELM and maybe others
   nil)
 
+;; 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")))))
+
+
 ;;; 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 284fd1d6cbd..ea7e266e0d0 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -577,6 +577,63 @@ respectively."
       (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