List Text Properties

[Per Abrahamsen]

A long time ago, I complained that

  Edit -> Text Properties -> List Properties

did not list overlays, which made it hard to use it as a "here is some
weird text, what is going on?" tool, and got an OK to include
overlays in the list.

Here is an implementation that list widgets, buttons, overlays and
text properties.  I called it `describe-text-at'.  I'd like to replace
the call to `list-text-properties-at' in the menu with this function.

Is it ok to install?

Eval the code, and type `M-x describe-text-at <ret>' while point is
somewhere interesting to test.

;;;; Move to wid-edit.el:

;;;###autoload
(defun widgetp (widget)
  "Return non-nil iff WIDGET is a widget."
  (if (symbolp widget)
      (get widget 'widget-type)
    (and (consp widget)
         (get (widget-type widget) 'widget-type))))

;;;; Move to facemenu.el:

;;; Describe-Text Mode.

(defun describe-text-done ()
  "Delete the current window or bury the current buffer."
  (interactive)
  (if (> (count-windows) 1)
      (delete-window)
    (bury-buffer)))

(defvar describe-text-mode-map nil
  "Keymap for `describe-text-mode'.")
  
(unless describe-text-mode-map
  (setq describe-text-mode-map (make-sparse-keymap))
  (set-keymap-parent describe-text-mode-map widget-keymap)
  (define-key describe-text-mode-map "q" 'describe-text-done))

(defcustom describe-text-mode-hook nil
  "List of hook functions ran by `describe-text-mode'."
  :type 'hook)

(defun describe-text-mode ()
  "Major mode for buffers created by `describe-text-at'.

\\{describe-text-mode-map}
Entry to this mode calls the value of `describe-text-mode-hook'
if that value is non-nil."
  (kill-all-local-variables)
  (setq major-mode 'describe-text-mode
        mode-name "Describe-Text")
  (use-local-map describe-text-mode-map)
  (widget-setup)
  (run-hooks 'describe-text-mode-hook))

;;; Describe-Text Utilities.

(define-widget 'describe-text-close 'push-button
  "Add a `close' button."
  :tag "Close"
  :action (lambda (&rest ignore) (describe-text-done)))

(defun describe-text-widget (widget)
  "Insert text to describe WIDGET in the current buffer."
  (widget-create 'link
                 :notify `(lambda (&rest ignore)
                            (widget-browse ',widget))
                 (format "%S" (if (symbolp widget) 
                                  widget
                                (car widget))))
  (widget-insert " ")
  (widget-create 'info-link :tag "widget" "(widget)Top"))

(defun describe-text-sexp (sexp)
  "Insert a short description of SEXP in the current buffer."
  (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))
        (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))))
  

(defun describe-text-properties (properties)
  "Insert a description of PROPERTIES in the current buffer.
PROPERTIES should be a list of overlay or text properties.
The `category' property is made into a widget button that call 
`describe-text-category' when pushed."
  (while properties
    (widget-insert (format "  %-20s " (car properties)))
    (let ((key (nth 0 properties))
          (value (nth 1 properties)))
      (cond ((eq key 'category)
             (widget-create 'link 
                            :notify `(lambda (&rest ignore)
                                       (describe-text-category ',value))
                            (format "%S" value)))
            ((widgetp value)
             (describe-text-widget value))
            (t
             (describe-text-sexp value))))
    (widget-insert "\n")
    (setq properties (cdr (cdr properties)))))

;;; Describe-Text Commands.

(defun describe-text-category (category)
  "Describe a text property category."
  (interactive "S")
  (when (get-buffer "*Text Category*")
    (kill-buffer "*Text Category*"))
  (save-excursion
    (with-output-to-temp-buffer "*Text Category*"
      (set-buffer "*Text Category*")
      (widget-insert "Category " (format "%S" category) ":\n\n")
      (describe-text-properties (symbol-plist category))
      (widget-insert "\n")
      (widget-create 'describe-text-close)
      (describe-text-mode)
      (goto-char (point-min)))))

;;;###autoload
(defun describe-text-at (pos)
  "Describe widgets, buttons, overlays and text properties at POS."
  (interactive "d")
  (when (eq (current-buffer) (get-buffer "*Text Description*"))
    (error "Self inspection not supported"))
  (when (get-buffer "*Text Description*")
    (kill-buffer "*Text Description*"))
  (let* ((properties (text-properties-at pos))
         (overlays (overlays-at pos))
         overlay
         (wid-field (get-char-property pos 'field))
         (wid-button (get-char-property pos 'button))
         (wid-doc (get-char-property pos 'widget-doc))
         (button (button-at pos))
         (button-type (and button (button-type button)))
         (button-label (and button (button-label button)))
         (widget (or wid-field wid-button wid-doc)))
    (save-excursion
      (with-output-to-temp-buffer "*Text Description*"
        (set-buffer "*Text Description*")
        (widget-insert "Text content at position " (format "%d" pos) ":\n\n")
        ;; Widgets
        (when (widgetp widget)
          (widget-insert (cond (wid-field "This is an editable text area")
                               (wid-button "This is an active area")
                               (wid-doc "This is documentation text")))
          (widget-insert " of a ")
          (describe-text-widget widget)
          (widget-insert ".\n\n"))
        ;; Buttons
        (when (and button (not (widgetp wid-button)))
          (widget-insert "Here is a " (format "%S" button-type) 
                         " button labeled `" 
                         (format "%S" button-label) "\n\n"))
        ;; Overlays
        (when overlays
          (if (eq (length overlays) 1)
              (widget-insert "There is an overlay here:\n")
            (widget-insert "There are " (format "%d" (length overlays))
                           " overlays here:\n"))
          (dolist (overlay overlays)
            (widget-insert " From " (format "%d" (overlay-start overlay)) 
                           " to " (format "%d" (overlay-end overlay)) "\n")
            (describe-text-properties (overlay-properties overlay)))
          (widget-insert "\n"))
        ;; Text properties
        (when properties
          (widget-insert "There are text properties here:\n")
          (describe-text-properties properties))
        (widget-insert "\n")
        (widget-create 'describe-text-close)
        (describe-text-mode)
        (goto-char (point-min))))))

;;; Code to facemenu.el ends here.