path: root/emacs.d/nxhtml/util/whelp.el

;; This is a test file for some enhancement to the possibilities to
;; find out about widgets or buttons at point in a buffer.
;;
;; To use this just load the file. Then put point on a widget or
;; button and do
;;
;;    M-x describe-field
;;
;; You find a lot of widgets in a Custom buffer. You can find buttons
;; in for example a help buffer. (Please tell me more places so I can
;; test!)
;;
;; TODO: Add backtrace collecting to some more functions!

;; For widget-get-backtrace-info
;;(require 'debug)
(eval-when-compile (require 'cl))  ;; gensym
(require 'help-mode)

;; Last wins!
(require 'wid-browse)

(intern ":created-in-function")

(define-widget 'widget-browse-link 'item
  "Button for creating a link style button.
The :value of the widget shuld be the widget to be browsed."
  :format "%[%v%]"
  ;;:value-create 'widget-browse-value-create
  ;;:action 'widget-browse-action
  )

(defun define-button-type (name &rest properties)
  "Define a `button type' called NAME.
The remaining arguments form a sequence of PROPERTY VALUE pairs,
specifying properties to use as defaults for buttons with this type
\(a button's type may be set by giving it a `type' property when
creating the button, using the :type keyword argument).

In addition, the keyword argument :supertype may be used to specify a
button-type from which NAME inherits its default property values
\(however, the inheritance happens only when NAME is defined; subsequent
changes to a supertype are not reflected in its subtypes)."
  (let ((catsym (make-symbol (concat (symbol-name name) "-button")))
	(super-catsym
	 (button-category-symbol
	  (or (plist-get properties 'supertype)
	      (plist-get properties :supertype)
	      'button))))
    ;; Provide a link so that it's easy to find the real symbol.
    (put name 'button-category-symbol catsym)
    ;; Initialize NAME's properties using the global defaults.
    (let ((default-props (symbol-plist super-catsym))
          (where-fun (widget-get-backtrace-info 8)))
      (setq default-props
            (cons :created-in-function
                  (cons where-fun
                        default-props)))
      (while default-props
	(put catsym (pop default-props) (pop default-props))))
    ;; Add NAME as the `type' property, which will then be returned as
    ;; the type property of individual buttons.
    (put catsym 'type name)
    ;; Add the properties in PROPERTIES to the real symbol.
    (while properties
      (let ((prop (pop properties)))
	(when (eq prop :supertype)
	  (setq prop 'supertype))
	(put catsym prop (pop properties))))
    ;; Make sure there's a `supertype' property
    (unless (get catsym 'supertype)
      (put catsym 'supertype 'button))
    name))

(defun define-widget (name class doc &rest args)
  "Define a new widget type named NAME from CLASS.

NAME and CLASS should both be symbols, CLASS should be one of the
existing widget types, or nil to create the widget from scratch.

After the new widget has been defined, the following two calls will
create identical widgets:

* (widget-create NAME)

* (apply 'widget-create CLASS ARGS)

The third argument DOC is a documentation string for the widget."
  (put name 'widget-type (cons class args))
  (put name 'widget-documentation doc)
  (put name :created-in-function (widget-get-backtrace-info  8))
  name)

(defvar describe-temp-help-buffer nil)
(defun describe-get-temp-help-buffer ()
  (setq describe-temp-help-buffer (get-buffer-create "*Copy of *Help* Buffer for Description*")))

(defun describe-field (pos)
  "Describe field at marker POS."
  (interactive (list (point)))
  (unless (markerp pos) (setq pos (copy-marker pos)))
  (when (eq (marker-buffer pos) (get-buffer (help-buffer)))
    (with-current-buffer (describe-get-temp-help-buffer)
      (erase-buffer)
      (insert (with-current-buffer (help-buffer)
                (buffer-string)))
      (goto-char (marker-position pos))
      (setq pos (point-marker))))
  (let (field wbutton doc button widget)
    (with-current-buffer (marker-buffer pos)
      (setq field (get-char-property pos 'field))
      (setq wbutton (get-char-property pos 'button))
      (setq doc (get-char-property pos 'widget-doc))
      (setq button (button-at pos))
      (setq widget (or field wbutton doc)))
    (cond ((and widget
                (if (symbolp widget)
                    (get widget 'widget-type)
                  (and (consp widget)
                       (get (widget-type widget) 'widget-type))))
           (describe-widget pos))
          (button
           (describe-button pos))
          ((and (eq major-mode 'Info-mode)
                (memq (get-text-property pos 'font-lock-face)
                      '(info-xref info-xref-visited)))
           (message "info link"))
          (t
           (message "No widget or button at point")))))

(defun describe-insert-header (pos)
  (widget-insert
   (add-string-property
    (concat
     (format "Description of the field at position %d in "
             (marker-position pos))
     (format "\"%s\"" (marker-buffer pos))
     ":\n\n")
    'face '(italic))))

(defun describe-widget (pos)
  ;;(interactive (list (point-marker)))
  (unless (markerp pos) (setq pos (copy-marker pos)))
  (with-output-to-temp-buffer (help-buffer)
    (help-setup-xref (list #'describe-widget pos) (interactive-p))
    (with-current-buffer (help-buffer)
      (let ((inhibit-read-only t))
        (describe-insert-header pos)
        (insert-text-button "This field"
                            'action (lambda (button)
                                      (let* ((m (button-get button 'field-location))
                                             (p (marker-position m))
                                             (b (marker-buffer m)))
                                        (if (not (buffer-live-p b))
                                            (message "Sorry the markers buffer is gone")
                                          (switch-to-buffer b)
                                          (goto-char p))))
                            'field-location pos)
        (princ " is of type ")
        (insert-text-button "widget"
                            'action (lambda (button)
                                      (info "(widget)")))
        (princ ". You can ")
        (insert-text-button "browse the widget's properties"
                            'action (lambda (button)
                                      (widget-browse-at
                                       (button-get button 'field-location)))
                            'field-location pos))
      (princ " to find out more about it.")
      (fill-region (point-min) (point-max))
      )
    (with-no-warnings (print-help-return-message))))

(defun describe-button (pos)
  (let ((button (button-at pos)))
    (with-output-to-temp-buffer (help-buffer)
      (help-setup-xref (list #'describe-button pos) (interactive-p))
      (with-current-buffer (help-buffer)
        (let ((inhibit-read-only t)
              ;;(button-marker (gensym))
              )
          (describe-insert-header pos)
          (insert-text-button "This field"
                              'action (lambda (button)
                                        (let* ((m (button-get button 'field-location))
                                               (p (marker-position m))
                                               (b (marker-buffer m)))
                                          (switch-to-buffer b)
                                          (goto-char p)))
                              'field-location pos)
          (princ " is of type ")
          (insert-text-button "button"
                              'action (lambda (button)
                                        (info "(elisp) Buttons")))
          (princ ". You can ")
          ;;(set button-marker pos)
          (insert-text-button "browse the button's properties"
                              'action `(lambda (button)
                                         ;;(button-browse-at (symbol-value ',button-marker)))))
                                         (button-browse-at ,pos))))
        (princ " to find out more about it.")
        (fill-region (point-min) (point-max))
        )
      (with-no-warnings (print-help-return-message)))))

;; Obsolete
;; (defun whelp-describe-symbol (sym)
;;   (interactive "SSymbol: ")
;;   (with-output-to-temp-buffer (help-buffer)
;;     (help-setup-xref (list #'describe-symbol sym) (interactive-p))
;;     (with-current-buffer (help-buffer)
;;       (let ((inhibit-read-only t))
;;         (if (not (symbolp sym))
;;             (progn
;;               (princ "Argument does not look like it is a ")
;;               (insert-text-button "symbol"
;;                                   'action (lambda (button)
;;                                             (info "(elisp) Symbols")))
;;               (princ "."))
;;           (let ((n 0))
;;             (when (fboundp sym)        (setq n (1+ n)))
;;             (when (boundp sym)         (setq n (1+ n)))
;;             (when (facep sym)          (setq n (1+ n)))
;;             (when (custom-group-p sym) (setq n (1+ n)))
;;             (if (= n 0)
;;                 (progn
;;                   (princ "Can't determine usage for the ")
;;                   (insert-text-button "symbol"
;;                                       'action (lambda (button)
;;                                                 (info "(elisp) Symbols")))
;;                   (princ " '")
;;                   (princ (symbol-name sym))
;;                   (princ "."))
;;               (princ "The ")
;;               (insert-text-button "symbol"
;;                                   'action (lambda (button)
;;                                             (info "(elisp) Symbols")))
;;               (princ " '")
;;               (princ (symbol-name sym))
;;               (if (= n 1)
;;                   (progn
;;                     (princ " is a ")
;;                     (cond ((fboundp sym)
;;                            (princ "function (")
;;                            (insert-text-button
;;                             "describe it"
;;                             'action (lambda (button)
;;                                       (let ((value (button-get button 'value)))
;;                                         (describe-function value)))
;;                             'value sym)
;;                            (insert ")"))
;;                           ((boundp sym)
;;                            (insert "variable (")
;;                            (insert-text-button
;;                             "describe it"
;;                             'action (lambda (button)
;;                                       (let ((value (button-get button 'value)))
;;                                         (describe-variable value)))
;;                             'value sym)
;;                            (insert ")"))
;;                           ((facep sym)
;;                            (insert "face (")
;;                            (insert-text-button
;;                             "describe it"
;;                             'action (lambda (button)
;;                                       (let ((value (button-get button 'value)))
;;                                         (describe-face value)))
;;                             'value sym)
;;                            (insert ")"))
;;                           ((custom-group-p sym)
;;                            (insert "customize group (")
;;                            (insert-text-button
;;                             "customize it"
;;                             'action (lambda (button)
;;                                       (let ((value (button-get button 'value)))
;;                                         (customize-group value)))
;;                             'value sym)
;;                            (insert ")")))
;;                     (princ "."))
;;                 (princ " has several usages currently.")
;;                 (princ " It can be:\n\n")
;;                 (when (fboundp sym)
;;                   (princ "  - A function (")
;;                   (insert-text-button "describe it"
;;                                       'action (lambda (button)
;;                                                 (let ((value (button-get button 'value)))
;;                                                   (describe-function value)))
;;                                       'value sym)
;;                   (princ ")\n"))
;;                 (when (boundp sym)
;;                   (princ "  - A variable (")
;;                   (insert-text-button "describe it"
;;                                       'action (lambda (button)
;;                                                     (let ((value (button-get button 'value)))
;;                                                       (describe-variable value)))
;;                                       'value sym)
;;                   (princ ")\n"))
;;                 (when (facep sym)
;;                   (princ "  - A face (")
;;                   (insert-text-button "describe it"
;;                                       'action (lambda (button)
;;                                                 (let ((value (button-get button 'value)))
;;                                                   (describe-face value)))
;;                                       'value sym)
;;                   (princ ")\n"))
;;                 (when (custom-group-p sym)
;;                   (princ "  - A customization group (")
;;                   (insert-text-button "customize it"
;;                                       'action (lambda (button)
;;                                                 (let ((value (button-get button 'value)))
;;                                                   (customize-group value)))
;;                                       'value sym)
;;                   (princ ")\n"))
;;                 )))
;;           (princ "\n\nSymbol's property list:\n\n")
;;           (let ((pl (symbol-plist sym))
;;                 key
;;                 val)
;;             (princ (format "  %25s   %s\n" "Key" "Value"))
;;             (princ (format "  %25s   %s\n" "---" "-----"))
;;             (while pl
;;               (setq key (car pl))
;;               (setq pl (cdr pl))
;;                 (setq val (car pl))
;;                 (setq pl (cdr pl))
;;                 (let ((first (point-marker))
;;                       last)
;;                   (princ (format "  %25s - %s" key val))
;;                   (setq last (point-marker))
;;                   (let ((adaptive-fill-function
;;                          (lambda ()
;;                            (format "  %25s - " key))))
;;                     (fill-region first last)
;;                     ))
;;                 (princ "\n")
;;                 )))
;;         (with-no-warnings (print-help-return-message))))))



(defun widget-browse-sexp (widget key value)
  "Insert description of WIDGET's KEY VALUE.
Nothing is assumed about value."
  (let ((pp (condition-case signal
		(pp-to-string value)
	      (error (prin1-to-string signal)))))
    (when (string-match "\n\\'" pp)
      (setq pp (substring pp 0 (1- (length pp)))))
    (if (cond ((string-match "\n" pp)
	       nil)
	      ((> (length pp) (- (window-width) (current-column)))
	       nil)
	      (t t))
        (cond
         (  (and value
                 (symbolp value)
                 (or (fboundp value)
                     (boundp value)
                     (facep value)))
            (widget-create 'push-button
                           :tag pp
                           :value value
                           :action '(lambda (widget &optional event)
                                      (let ((value (widget-get widget :value))
                                            (n 0))
                                        (when (fboundp value) (setq n (1+ n)))
                                        (when (boundp value) (setq n (1+ n)))
                                        (when (facep value) (setq n (1+ n)))
                                        (if (= n 1)
                                            (cond ((fboundp value)
                                                   (describe-function value))
                                                  ((boundp value)
                                                   (describe-variable value))
                                                  ((facep value)
                                                   (describe-face value)))
                                          (describe-symbol value))))))
         (  (markerp value)
            (widget-create 'push-button
                           :tag pp
                           :value (list (marker-position value) (marker-buffer value))
                           :action '(lambda (widget &optional event)
                                      (let ((value (widget-get widget :value)))
                                        (let ((pos (car value))
                                              (buf (cadr value)))
                                          (switch-to-buffer-other-window buf)
                                          (goto-char pos))))))
         (  (overlayp value)
            (widget-create 'push-button
                           :tag pp
                           :value (list (overlay-start value) (overlay-buffer value))
                           :action '(lambda (widget &optional event)
                                      (let ((value (widget-get widget :value)))
                                        (let ((pos (car value))
                                              (buf (cadr value)))
                                          (switch-to-buffer-other-window buf)
                                          (goto-char pos))))))
         (  t
            (widget-insert pp)))

      (widget-create 'push-button
		     :tag "show"
		     :action (lambda (widget &optional event)
			       (with-output-to-temp-buffer
				   "*Pp Eval Output*"
				 (princ (widget-get widget :value))))
		     pp))))


(defvar widget-get-backtrace-active t
  "Whether to collect backtrace info for widgets and buttons.
Turn this on only for debugging purposes.

Note: This must be t when Emacs is loading to collect the needed
information.")

(defun widget-get-backtrace-info (n)
  (if widget-get-backtrace-active
      (let ((frame-n t)
            fun)
        (while (and frame-n
                    (not fun))
          (setq frame-n (backtrace-frame n))
          (when frame-n
            ;;(message "**BT %s:  %s" n (cadr frame-n))
            (when (car frame-n)
              (setq fun (cadr frame-n))
              (when (or (listp fun)
                        (member fun
                                '(
                                  backtrace-frame
                                  widget-get-backtrace-info

                                  eval
                                  eval-expression
                                  call-interactively
                                  apply
                                  funcall
                                  ;;lambda

                                  if
                                  when
                                  cond
                                  condition
                                  mapc
                                  mapcar
                                  while

                                  let
                                  let*
                                  set
                                  setq
                                  set-variable
                                  set-default

                                  widget-create
                                  widget-create-child-and-convert
                                  widget-create-child
                                  widget-create-child-value
                                  define-button-type
                                  define-widget
                                  make-text-button
                                  insert-text-button
                                  make-button
                                  insert-button
                                  )))
                (setq fun)))
            (setq n (1+ n))))
        ;;(message "---------- fun=%s" fun)
        fun)
    "Set widget-get-backtrace-info to show this"))

(defun widget-create (type &rest args)
  "Create widget of TYPE.
The optional ARGS are additional keyword arguments."
  (unless (keywordp :created-in-function) (error ":wcw not interned"))
  (let ((where-fun (widget-get-backtrace-info 8))
        yargs)
    (setq args
          (cons :created-in-function
                (cons where-fun
                      args)))
    (let ((widget (apply 'widget-convert type args)))
      (widget-apply widget :create)
      widget)))


(defun widget-create-child-and-convert (parent type &rest args)
  "As part of the widget PARENT, create a child widget TYPE.
The child is converted, using the keyword arguments ARGS."
  (let ((widget (apply 'widget-convert type args)))
    (widget-put widget :parent parent)
    (widget-put widget :created-in-function (widget-get-backtrace-info  15))
    (unless (widget-get widget :indent)
      (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
				    (or (widget-get widget :extra-offset) 0)
				    (widget-get parent :offset))))
    (widget-apply widget :create)
    widget))

(defun widget-create-child (parent type)
  "Create widget of TYPE."
  (let ((widget (widget-copy type)))
    (widget-put widget :parent parent)
    (widget-put widget :created-in-function (widget-get-backtrace-info  15))
    (unless (widget-get widget :indent)
      (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
				    (or (widget-get widget :extra-offset) 0)
				    (widget-get parent :offset))))
    (widget-apply widget :create)
    widget))

(defun widget-create-child-value (parent type value)
  "Create widget of TYPE with value VALUE."
  (let ((widget (widget-copy type)))
    (widget-put widget :value (widget-apply widget :value-to-internal value))
    (widget-put widget :parent parent)
    (widget-put widget :created-in-function (widget-get-backtrace-info  15))
    (unless (widget-get widget :indent)
      (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
				    (or (widget-get widget :extra-offset) 0)
				    (widget-get parent :offset))))
    (widget-apply widget :create)
    widget))

(defvar widget-browse-fb-history nil
  "Forward/backward history.")
(setq widget-browse-fb-history nil)

(defun widget-fb-button-action (widget &ignore)
  (let* ((num (widget-get widget :history-number))
         (rec (nth num widget-browse-fb-history))
         (fun (nth 0 rec))
         (val (nth 1 rec))
         (loc (nth 2 rec)))
    ;;(message "fun=%s, val=%s, loc=%s" fun val loc)(sit-for 4)
    (funcall fun num)))

(defun widget-insert-fb-buttons (current-number)
  ;;(message "current-number=%s" current-number)(sit-for 2)
  (if (<= 0 (1- current-number))
      (widget-create 'push-button
                     :action 'widget-fb-button-action
                     :history-number (1- current-number)
                     :format "%[%v%]"
                     "back")
    (widget-insert (add-string-property "[back]"
                                        'face 'shadow)))
  (widget-insert " ")
  (if (< (1+ current-number) (length widget-browse-fb-history))
      (widget-create 'push-button
                     :action 'widget-fb-button-action
                     :history-number (1+ current-number)
                     :format "%[%v%]"
                     "forward")
    (widget-insert (add-string-property "[forward]"
                                        'face 'shadow)))
  (widget-insert "\n"))

(defun widget-add-fb-history (elt)
  (let ((last (car widget-browse-fb-history)))
    (unless (equal elt last)
      (setq widget-browse-fb-history
            (reverse (cons elt
                           (reverse widget-browse-fb-history)))))))

(defun widget-browse (widget &optional location)
  "Create a widget browser for WIDGET."
  (interactive (list (completing-read "Widget: "
				      obarray
				      (lambda (symbol)
					(get symbol 'widget-type))
				      t nil 'widget-browse-history)))
  (let (history-number)
    (if (integerp widget)
        (progn
          ;;(message "was integer=%s" widget)(sit-for 2)
          (setq history-number widget)
          (setq widget (nth 1 (nth widget widget-browse-fb-history))))
      ;;(message "was NOT integer=%s" widget)(sit-for 2)
      (widget-add-fb-history (list 'widget-browse widget location))
      (setq history-number (1- (length widget-browse-fb-history))))
    ;;(message "history-number=%s" history-number)(sit-for 2)

    (if (stringp widget)
        (setq widget (intern widget)))
    (unless (if (symbolp widget)
                (get widget 'widget-type)
              (and (consp widget)
                   (get (widget-type widget) 'widget-type)))
      (error "Not a widget"))

    ;; Create the buffer.
    (if (symbolp widget)
        (let ((buffer (format "*Browse %s Widget*" widget)))
          (kill-buffer (get-buffer-create buffer))
          (switch-to-buffer (get-buffer-create buffer)))
      (kill-buffer (get-buffer-create "*Browse Widget*"))
      (switch-to-buffer (get-buffer-create "*Browse Widget*")))
    (widget-browse-mode)

    (make-local-variable 'widget-button-face)
    (setq widget-button-face 'link)
    (set (make-local-variable 'widget-push-button-prefix) "")
    (set (make-local-variable 'widget-push-button-suffix) "")
    (set (make-local-variable 'widget-link-prefix) "")
    (set (make-local-variable 'widget-link-suffix) "")

    ;; Top text indicating whether it is a class or object browser.
    (widget-insert-fb-buttons history-number)
    (widget-insert "----------------\n")
    (if (listp widget)
        (progn
          (widget-insert (add-string-property
                          "Widget object browser"
                          'face 'widget-browse-h1))
          (widget-insert "\n\n")
          (when location
            (let ((b (marker-buffer location))
                  (p (marker-position location)))
              (widget-insert (add-string-property "Location: "
                                                  'face 'italic))
              (widget-create 'push-button
                             :tag (format "position %s in buffer %s" p b)
                             :value (list p b)
                             :action '(lambda (widget &optional event)
                                        (let ((value (widget-get widget :value)))
                                          (let ((pos (car value))
                                                (buf (cadr value)))
                                            (switch-to-buffer-other-window buf)
                                            (goto-char pos)))))
              (widget-insert "\n\n")))
          (widget-insert (add-string-property "Class: "
                                              'face 'italic)))
      (widget-insert (add-string-property "Widget class browser"
                                          'face 'widget-browse-h1))
      (widget-insert ".\n\n")
      (widget-insert (add-string-property "Class: " 'face 'italic))
      (widget-insert (add-string-property (format "%s\n" widget)
                                          'face '(bold)))
      (widget-insert (format "%s" (get widget 'widget-documentation)))
      (unless (eq (preceding-char) ?\n) (widget-insert "\n"))
      (widget-insert (add-string-property "\nSuper: " 'face 'italic))
      (setq widget (get widget 'widget-type))
      )

    ;(widget-insert (format "%s\n" widget))

    ;; Now show the attributes.
    (let ((name (car widget))
          (items (cdr widget))
          key value printer)
      (if (not name)
          (widget-insert "none\n")
        (let ((ancestors (list name))
              a
              (i1 7)
              i
              )
          (setq i i1)
          (while name
            (setq a (intern-soft name))
            (if a
                (progn
                  (setq a (get a 'widget-type))
                  (setq name (car a))
                  (when (intern-soft name)
                    (push name ancestors)))
              (setq name)))
          ;;(widget-insert (format "ancestors=%s\n" ancestors))
          (mapc (lambda (w)
                  (widget-insert (make-string (if (= i i1) 0 i) ? ))
                  (widget-create 'widget-browse
                                 :format "%[%v%]"
                                 w)
                  (widget-insert "\n")
                  (setq i (+ i 2)))
                ancestors)))
      (while items
        (setq key (nth 0 items)
              value (nth 1 items)
              printer (or (get key 'widget-keyword-printer)
                          'widget-browse-sexp)
              items (cdr (cdr items)))
        (widget-insert "\n"
                       (add-string-property (symbol-name key)
                                            'face 'italic))
        (when (widget-browse-explained key)
          (widget-insert " (")
          (widget-create
           ;;'push-button
           ;;:tag "explain"
           ;;:format "%[%v%]"
           ;;:button-prefix ""
           ;;:button-suffix ""
           'widget-browse-link
           :value key
           :tag "explain"
           :format "%[%t%]"
           :action '(lambda (widget &optional event)
                      (widget-browse-explain
                       ;;(widget-get widget :value)
                       (widget-value widget)
                       ))
           )
          (widget-insert ")"))
        (widget-insert "\n\t")
        (funcall printer widget key value)
        (widget-insert "\n")))

    (widget-insert "\n-----------\n")
    (widget-insert-fb-buttons history-number)

    (widget-setup)
    (goto-char (point-min))
;;     (when wid-to-history
;;       (setq widget-browse-fb-history
;;             (reverse (cons (list 'widget-browse wid-to-history location)
;;                            (reverse widget-browse-fb-history)))))
    ))

(defun widget-browse-at (pos)
  "Browse the widget under point."
  (interactive "d")
  (let ((mp pos)
        (b (if (markerp pos) (marker-buffer pos)
             (current-buffer))))
    (if (not (buffer-live-p b))
        (message "Sorry the markers buffer is gone")
      (with-current-buffer b
        (when (markerp pos)
          (setq pos (marker-position pos)))
        (let* ((field (get-char-property pos 'field))
               (button (get-char-property pos 'button))
               (doc (get-char-property pos 'widget-doc))
               (text (cond (field "This is an editable text area.")
                           (button "This is an active area.")
                           (doc "This is documentation text.")
                           (t "This is unidentified text.")))
               (widget (or field button doc)))
          (when widget
            (widget-browse widget mp))
          (message text))))))

(defun button-at (pos)
  "Return the button at marker or position POS, or nil.
If not a marker use the current buffer."
  (with-current-buffer (if (markerp pos) (marker-buffer pos)
                         (current-buffer))
    (when (markerp pos)
      (setq pos (marker-position pos)))
    (let ((button (get-char-property pos 'button)))
      (if (or (overlayp button) (null button))
          button
        ;; Must be a text-property button; return a marker pointing to it.
        (copy-marker pos t)))))

(defun button-browse-at (pos)
  (interactive "d")
  (let ((b (if (markerp pos) (marker-buffer pos)
             (current-buffer))))
    (if (not (buffer-live-p b))
        (message "Sorry the button's buffer is gone")
      (button-browse (button-at pos)))))

(defun button-browse (button)
  "Create a widget browser for WIDGET."
  (interactive (list (completing-read "Button: "
				      obarray
				      (lambda (symbol)
                                        (or (get symbol 'button-category-symbol)
                                            (get symbol 'supertype)))
				      t nil 'button-browse-history)))
  (let (history-number)
    (if (integerp button)
        (progn
          (setq history-number button)
          (setq button (nth 1 (nth button widget-browse-fb-history))))
      (widget-add-fb-history (list 'button-browse button))
      (setq history-number (1- (length widget-browse-fb-history))))

    (when (stringp button)
      (setq button (intern-soft button)))
    (when (symbolp button)
      (unless (and button
                   (or (eq button 'default-button)
                       (get button 'supertype)
                       (get button 'button-category-symbol)
                       (save-match-data
                         (string-match "-button$" (symbol-name button)))))
        (error "Not a button")))
    ;; Create the buffer.
    (kill-buffer (get-buffer-create "*Browse Button*"))
    (switch-to-buffer (get-buffer-create "*Browse Button*"))
    (widget-browse-mode)

    (make-local-variable 'widget-button-face)
    (setq widget-button-face 'link)

    (widget-insert-fb-buttons history-number)
    (widget-insert "----------------\n")

    ;; Top text indicating whether it is a class or object browser.
    (if (or (overlayp button)
            (markerp button))
        (progn
          (widget-insert (add-string-property "Button object browser"
                                              'face 'widget-browse-h1))
          (widget-insert "\n\n")
          (let ((b (if (markerp button)
                       (marker-buffer button)
                     (overlay-buffer button)))
                (p (if (markerp button)
                       (marker-position button)
                     (overlay-start button))))
            (widget-insert (add-string-property "Location: "
                                                'face 'italic))
            (widget-create 'push-button
                           :tag (format "position %s in buffer %s" p b)
                           :value (list p b)
                           :action '(lambda (widget &optional event)
                                      (let ((value (widget-get widget :value)))
                                        (let ((pos (car value))
                                              (buf (cadr value)))
                                          (switch-to-buffer-other-window buf)
                                          (goto-char pos)))))
            (widget-insert "\n\n")))
      (widget-insert (add-string-property "Button class browser"
                                          'face 'widget-browse-h1))
      (widget-insert "\n\n")
      (widget-insert (add-string-property "Type: "
                                          'face 'italic))
      (widget-insert (add-string-property (symbol-name button)
                                          'face 'bold))
      (widget-insert "\n"))

    ;; Now show the attributes.
    (let (
          (items
           (if (symbolp button)
               (if (get button 'button-category-symbol)
                   (symbol-plist (get button 'button-category-symbol))
                 (symbol-plist button))
             (if (markerp button)
                 (let ((pos (marker-position button))
                       (buf (marker-buffer button)))
                   (text-properties-at pos buf))
               (overlay-properties button))))
          rest-items
          name
          key value printer)
      ;;(insert (format "\n%s\n\n" items))
      (let ((copied-items (copy-seq items)))
        (while copied-items
          (setq key   (nth 0 copied-items)
                value (nth 1 copied-items)
                copied-items (cdr (cdr copied-items)))
          (if (eq key 'category)
              (setq name value)
            (if (eq key 'supertype)
                (setq name (make-symbol (concat (symbol-name value) "-button")))
              (push value rest-items)
              (push key   rest-items)))))
      ;;(insert "\nname=" (symbol-name value) "\n\n")
      (when name
        (widget-insert (add-string-property
                        (if (symbolp button)
                            (if (get button 'supertype)
                                "Supertype: "
                              "")
                          "Category:  ")
                        'face 'italic))
        (let* (a
               (ancestors
                (list name))
               (i1 11)
               (i i1))
          (while name
            (setq a (or (get name 'supertype)
                        (get name :supertype)))
            ;;(message "name=%s, a=%s\n    name plist=%s" name a (symbol-plist name));(sit-for 4)
            (if (or (not a)
                    (eq a 'default-button))
                (setq name)
              (setq name (make-symbol (concat (symbol-name a) "-button")))
              (setq ancestors (cons name ancestors))))
          ;;(message "ancestors=%s" ancestors)(sit-for 2)
          (mapc (lambda (w)
                  (widget-insert (make-string (if (= i i1) 0 i) ? ))
                  (widget-create 'button-browse
                                 :format "%[%v%]"
                                 w)
                  (widget-insert "\n")
                  (setq i (+ i 2)))
                ancestors)))
      (while rest-items
        (setq key   (nth 0 rest-items)
              value (nth 1 rest-items)
              printer (or (get key 'widget-keyword-printer)
                          'widget-browse-sexp)
              rest-items (cdr (cdr rest-items)))
        (widget-insert "\n"
                       (add-string-property (symbol-name key)
                                            'face 'italic))
        (when (widget-browse-explained key)
          (widget-insert " (")
          (widget-create 'push-button
                         :tag "explain"
                         :value key
                         :action '(lambda (widget &optional event)
                                    (widget-browse-explain
                                     (widget-get widget :value))))
          (widget-insert ")"))
        (widget-insert "\n\t")
        (funcall printer button key value)
        (widget-insert "\n")))
    (widget-setup)
    (goto-char (point-min))

;;     (when button-to-history
;;       (setq widget-browse-fb-history
;;             (reverse (cons (list 'button-browse button-to-history)
;;                            (reverse widget-browse-fb-history)))))
    ))


;;;###autoload
(defgroup whelp nil
  "Customization group for whelp."
  :group 'emacs)

(defface widget-browse-h1
  '((t (:weight bold :height 1.5)))
  "Face for top header in widget/button browse buffers."
  :group 'whelp)

(defun add-string-property (str prop val)
  (let ((s (copy-seq str)))
    (put-text-property 0 (length s)
                       prop val
                       s)
    s))

;;; The `button-browse' Widget.

(define-widget 'button-browse 'push-button
  "Widget button for creating a button browser.
The :value of the widget shuld be the button to be browsed."
  :format "%[[%v]%]"
  :value-create 'widget-browse-button-value-create
  :action 'widget-browse-button-action)

(defun widget-browse-button-action (widget &optional event)
  ;; Create widget browser for WIDGET's :value.
  (button-browse (widget-get widget :value)))

(defun widget-browse-button-value-create (widget)
  ;; Insert type name.
  (let ((value (widget-get widget :value)))
    (cond ((symbolp value)
	   (insert (symbol-name value)))
	  ((consp value)
	   (insert (symbol-name (widget-type value))))
	  (t
	   (insert "strange")))))


(defun widget-browse-explained (property)
  (memq property
        '(
          :created-in-function
        )))

(defun widget-browse-explain (property)
  (with-output-to-temp-buffer (help-buffer)
    (help-setup-xref (list #'widget-browse-explain property) (interactive-p))
    (with-current-buffer (help-buffer)
      (let ((inhibit-read-only t))
        (cond
         ( (eq property :created-in-function)
           (princ "Property :created-in-function tells where a field object or class is created.")
           )
         ( t
           (princ (format "No explanation found for %s" property))
           )
         )
        (with-no-warnings (print-help-return-message))))))

(provide 'whelp)