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

[Mauro Aranda <maurooaranda@gmail.com>]

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

Here's the file

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

[-- Attachment #2: widget-describe-actions.el --]
[-- Type: text/x-emacs-lisp, Size: 2537 bytes --]

;;; widget-describe-actions.el --- Example of describing widget actions -*- lexical-binding:t -*-

(require 'wid-edit)
(require 'wid-browse)

(defun widget-describe-actions (&optional widget-or-pos)
  "Describe the actions associated to the widget at point.
Displays a buffer with a description about the 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")
  (let ((widget (if (widgetp widget-or-pos)
		    widget-or-pos
		  (widget-at (or widget-or-pos (point)))))
	(inhibit-read-only t) ; For erasing the contents of the buffer.
	(map (make-sparse-keymap)) ; We will change the binding of `q'.
	action mouse-down-action)
    (when widget
      (setq action (widget-resolve-parent-action widget)
	    mouse-down-action (widget-get widget :mouse-down-action))
      (pop-to-buffer "*Widget Actions*" nil t)
      (erase-buffer)
      (widget-browse-mode)
      ;; In order to be more like a *Help* buffer, use quit-window instead
      ;; of bury-buffer.
      (set-keymap-parent map widget-browse-mode-map)
      (define-key map "q" 'quit-window)
      (use-local-map map)
      (widget-insert "This widget type is ")
      (widget-create 'widget-browse :format "%[%v%]\n%d"
		     :doc (get (car widget) 'widget-documentation)
		     widget)
      (widget-insert "\n")
      (when (symbolp action)
	(widget-insert (propertize "Action" 'face 'bold))
	(widget-insert "\nThe action of this widget is ")
	(widget-create 'function-link :value action)
	(widget-insert "\n\n"))
      (when (symbolp mouse-down-action)
	(widget-insert (propertize "Mouse-down-action" 'face 'bold))
	(widget-insert "\nThe mouse-down-action of this widget is ")
	(widget-create 'function-link :value mouse-down-action)
	(widget-insert "\n"))
      (widget-setup)
      (goto-char (point-min)))))

(defun widget-resolve-parent-action (widget)
  "If action of WIDGET is `widget-parent-action', find out what would that be."
  (let ((action (widget-get widget :action))
	(parent (widget-get widget :parent)))
    (while (and (eq action 'widget-parent-action)
		(setq parent (widget-get parent :parent)))
      (setq action (widget-get parent :action)))
    action))
      
(provide 'widget-describe-actions)