Mercurial > emacs

--- a/lisp/ChangeLog	Thu Feb 14 01:55:43 2002 +0000
+++ b/lisp/ChangeLog	Thu Feb 14 16:47:11 2002 +0000
@@ -1,3 +1,26 @@
+2002-02-14  Per Abrahamsen  <abraham@dina.kvl.dk>
+
+	* facemenu.el (describe-text-done): New function.
+	(describe-text-mode-map): New variable.
+	(describe-text-mode-hook): New option.
+	(describe-text-mode): New function.
+	(describe-text-widget): New function.
+	(describe-text-sexp): New function.
+	(describe-text-properties): New function.
+	(describe-text-category): New command.
+	(describe-text-at): New command.
+	(facemenu-menu): Replace `list-text-properties-at' with
+	`describe-text-at' in the menu.
+        (button): Require.
+
+	* wid-edit.el (widgetp): New function.
+	* wid-edit.el (widget-keymap, widget-insert, widget-setup):
+	Autoloaded.
+
+	* emacs-lisp/pp.el (pp-to-string): Autoloaded.
+
+	* wid-browse.el: Removed version and x-url keywords.
+
 2002-02-13  Kim F. Storm  <storm@cua.dk>

 	* cus-start.el (mode-line-in-non-selected-windows):
--- a/lisp/emacs-lisp/pp.el	Thu Feb 14 01:55:43 2002 +0000
+++ b/lisp/emacs-lisp/pp.el	Thu Feb 14 16:47:11 2002 +0000
@@ -36,6 +36,7 @@
   :type 'boolean
   :group 'pp)

+;;;###autoload
 (defun pp-to-string (object)
   "Return a string containing the pretty-printed representation of OBJECT.
 OBJECT can be any Lisp object.  Quoting characters are used as needed
--- a/lisp/facemenu.el	Thu Feb 14 01:55:43 2002 +0000
+++ b/lisp/facemenu.el	Thu Feb 14 16:47:11 2002 +0000
@@ -1,6 +1,6 @@
 ;;; facemenu.el --- create a face menu for interactively adding fonts to text

-;; Copyright (c) 1994, 1995, 1996, 2001 Free Software Foundation, Inc.
+;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc.

 ;; Author: Boris Goldowsky <boris@gnu.org>
 ;; Keywords: faces
@@ -94,6 +94,10 @@

 (provide 'facemenu)

+(eval-when-compile
+  (require 'help)
+  (require 'button))
+
 ;;; Provide some binding for startup:
 ;;;###autoload (define-key global-map "\M-g" 'facemenu-keymap)
 ;;;###autoload (autoload 'facemenu-keymap "facemenu" "Keymap for face-changing commands." t 'keymap)
@@ -240,8 +244,8 @@
 (let ((map facemenu-menu))
   (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
   (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
-  (define-key map [dp] (cons (purecopy "List Properties")
-			     'list-text-properties-at))
+  (define-key map [dp] (cons (purecopy "Describe Text")
+			     'describe-text-at))
   (define-key map [ra] (cons (purecopy "Remove Text Properties")
 			     'facemenu-remove-all))
   (define-key map [rm] (cons (purecopy "Remove Face Properties")
@@ -463,6 +467,177 @@
     (remove-text-properties
      start end '(invisible nil intangible nil read-only nil))))

+;;; 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
+  (let ((map (make-sparse-keymap)))
+    (if (boundp 'widget-keymap)
+	(set-keymap-parent map widget-keymap)
+      ;; Copy from wid-edit.el if widget-keymap isn't in loaddefs.el
+      ;; Needed for bootstrap purposes, can hopefully be removed when
+      ;; loaddefs.el is updated.
+      ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2002-02-14.
+      (define-key map "\t" 'widget-forward)
+      (define-key map [(shift tab)] 'widget-backward)
+      (define-key map [backtab] 'widget-backward)
+      (define-key map [down-mouse-2] 'widget-button-click)
+      (define-key map "\C-m" 'widget-button-press))
+    (define-key map "q" 'describe-text-done)
+    map)
+  "Keymap for `describe-text-mode'.")
+
+(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.
+
+(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 sexp)
+	      (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))
+      (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 "Can't do self inspection"))
+  (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))
+	 ;; If button.el is not loaded, we have no buttons in the text.
+	 (button (and (fboundp 'button-at) (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)))
+    (if (not (or properties overlays))
+	(message "This is plain text.")
+      (when (get-buffer "*Text Description*")
+	(kill-buffer "*Text Description*"))
+      (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 `" 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))
+	  (describe-text-mode)
+	  (goto-char (point-min)))))))
+
+;;; List Text Properties
+
 ;;;###autoload
 (defun list-text-properties-at (p)
   "Pop up a buffer listing text-properties at LOCATION."
--- a/lisp/wid-browse.el	Thu Feb 14 01:55:43 2002 +0000
+++ b/lisp/wid-browse.el	Thu Feb 14 16:47:11 2002 +0000
@@ -4,8 +4,6 @@
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.9914
-;; X-URL: http://www.dina.kvl.dk/~abraham/custom/

 ;; This file is part of GNU Emacs.
--- a/lisp/wid-edit.el	Thu Feb 14 01:55:43 2002 +0000
+++ b/lisp/wid-edit.el	Thu Feb 14 16:47:11 2002 +0000
@@ -1,6 +1,6 @@
 ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*-
 ;;
-;; Copyright (C) 1996, 1997, 1999, 2000, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Maintainer: FSF
@@ -468,6 +468,14 @@
   "Return the type of WIDGET, a symbol."
   (car widget))

+;;;###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))))
+
 (defun widget-get-indirect (widget property)
   "In WIDGET, get the value of PROPERTY.
 If the value is a symbol, return its binding.
@@ -747,6 +755,7 @@
     ;; Return the newly create widget.
     widget))

+;;;###autoload
 (defun widget-insert (&rest args)
   "Call `insert' with ARGS even if surrounding text is read only."
   (let ((inhibit-read-only t)
@@ -801,6 +810,7 @@

 ;;; Keymap and Commands.

+;;;###autoload
 (defvar widget-keymap
   (let ((map (make-sparse-keymap)))
     (define-key map "\t" 'widget-forward)
@@ -1083,6 +1093,7 @@
   (or (get-char-property (or pos (point)) 'button)
       (widget-field-at pos)))

+;;;###autoload
 (defun widget-setup ()
   "Setup current buffer so editing string widgets works."
   (let ((inhibit-read-only t)