comparison lisp/descr-text.el @ 67752:dd459879f1e7

Add FSF as maintainer. (describe-text-mode, describe-text-mode-map) (describe-text-mode-hook, describe-text-done): Delete. Use normal help-mode. (describe-text-widget, describe-text-sexp) (describe-property-list, describe-text-category) (describe-text-properties, describe-text-properties-1) (describe-char): Use help buttons instead of widgets. (describe-char-unicodedata-file): Make URL link in doc string.

67751:5b235259a476

;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
;;   2005 Free Software Foundation, Inc.

;; Author: Boris Goldowsky <[e-mail]>
;; Keywords: faces, i18n, Unicode, multilingual

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;;; Code:

(eval-when-compile (require 'button) (require 'quail))

(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)))
    (set-keymap-parent map widget-keymap)
    map)
  "Keymap for `describe-text-mode'.")

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

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

\\{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)
  (add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
  (run-mode-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)

    (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-property-list (properties)
  "Insert a description of PROPERTIES in the current buffer.
PROPERTIES should be a list of overlay or text properties.
The `category', `face' and `font-lock-face' properties are made
into widget buttons that call `describe-text-category' or
`describe-face' when pushed."
  ;; Sort the properties by the size of their value.
  (dolist (elt (sort (let (ret)
		       (while properties
			 (push (list (pop properties) (pop properties)) ret))
		       ret)
		     (lambda (a b) (string< (prin1-to-string (nth 0 a) t)
					    (prin1-to-string (nth 0 b) t)))))
    (let ((key (nth 0 elt))
	  (value (nth 1 elt)))
      (widget-insert (propertize (format "  %-20s " key)
				 'font-lock-face 'italic))
      (cond ((eq key 'category)
	     (widget-create 'link
			    :notify `(lambda (&rest ignore)
				       (describe-text-category ',value))
			    (format "%S" value)))
            ((memq key '(face font-lock-face mouse-face))
	     (widget-create 'link
			    :notify `(lambda (&rest ignore)
				       (describe-face ',value))
			    (format "%S" value)))
            ((widgetp value)
	     (describe-text-widget value))
	    (t
	     (describe-text-sexp value))))
    (widget-insert "\n")))

;;; Describe-Text Commands.

(defun describe-text-category (category)
  "Describe a text property category."
  (interactive "S")
  (save-excursion
    (with-output-to-temp-buffer "*Help*"
      (set-buffer standard-output)
      (widget-insert "Category " (format "%S" category) ":\n\n")
      (describe-property-list (symbol-plist category))
      (describe-text-mode)
      (goto-char (point-min)))))

;;;###autoload
(defun describe-text-properties (pos &optional output-buffer)
  "Describe widgets, buttons, overlays and text properties at POS.

	  (setq target-buffer "*Help*<2>"))
	(save-excursion
	  (with-output-to-temp-buffer target-buffer
	    (set-buffer standard-output)
	    (setq output-buffer (current-buffer))
	    (widget-insert "Text content at position " (format "%d" pos) ":\n\n")
	    (with-current-buffer buffer
	      (describe-text-properties-1 pos output-buffer))
	    (describe-text-mode)
	    (goto-char (point-min))))))))

(defun describe-text-properties-1 (pos output-buffer)
  (let* ((properties (text-properties-at pos))
	 (overlays (overlays-at pos))

	 (widget (or wid-field wid-button wid-doc)))
    (with-current-buffer output-buffer
      ;; Widgets
      (when (widgetp widget)
	(newline)
	(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)))
	(newline)
	(widget-insert "Here is a " (format "%S" button-type)
		       " button labeled `" button-label "'.\n\n"))
      ;; Overlays
      (when overlays
	(newline)
	(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-property-list (overlay-properties overlay)))
	(widget-insert "\n"))
      ;; Text properties
      (when properties
	(newline)
	(widget-insert "There are text properties here:\n")
	(describe-property-list properties)))))

(defcustom describe-char-unicodedata-file nil
  "Location of Unicode data file.
This is the UnicodeData.txt file from the Unicode consortium, used for
diagnostics.  If it is non-nil `describe-char' will print data
looked up from it.  This facility is mostly of use to people doing
multilingual development.

This is a fairly large file, not typically present on GNU systems.  At
the time of writing it is at
<URL:http://www.unicode.org/Public/UNIDATA/UnicodeData.txt>."
  :group 'mule
  :version "22.1"
  :type '(choice (const :tag "None" nil)
		 file))

		     char char char
		     (if unicode
			 (format ", U+%04X" unicode)
		       "")))
	    ("charset"
	     ,`(widget-create 'link
			      :notify (lambda (&rest ignore)
					(describe-character-set ',charset))
			      ,(symbol-name charset))
	     ,(format "(%s)" (charset-description charset)))
	    ("code point"
	     ,(let ((split (split-char char)))
		`(widget-create
		  'link
		  :notify (lambda (&rest ignore)
			    (list-charset-chars ',charset)
			    (with-selected-window
				(get-buffer-window "*Character List*" 0)
			      (goto-char (point-min))
                              (forward-line 2) ;Skip the header.
                              (let ((case-fold-search nil))
                                (search-forward ,(char-to-string char)
                                                nil t))))
		  ,(if (= (charset-dimension charset) 1)
		       (format "%d" (nth 1 split))
		     (format "%d %d" (nth 1 split) (nth 2 split))))))
	    ("syntax"
	     ,(let ((syntax (syntax-after pos)))
		(with-temp-buffer
		  (internal-describe-syntax-value syntax)
		  (buffer-string))))

		 (if (consp key-list)
		     (list "type"
			   (mapconcat #'(lambda (x) (concat "\"" x "\""))
				      key-list " or ")
			   "with"
			   `(widget-create
			     'link
			     :notify (lambda (&rest ignore)
				       (describe-input-method
					',current-input-method))
			     ,(format "%s" current-input-method))))))
	    ("buffer code"
	     ,(encoded-string-description
	       (string-as-unibyte (char-to-string char)) nil))
	    ("file code"
	     ,@(let* ((coding buffer-file-coding-system)

			  ((and nobreak-char-display unicode (eq unicode '#xad))
			   'escape-glyph)
			  ((and (< char 32) (not (memq char '(9 10))))
			   'escape-glyph)))))
		(if face (list (list "hardcoded face"
				     `(widget-create
				       'link
				       :notify (lambda (&rest ignore)
						 (describe-face ',face))
				       ,(format "%s" face))))))
	    ,@(let ((unicodedata (and unicode
				      (describe-char-unicode-data unicode))))
		(if unicodedata
		    (cons (list "Unicode data" " ") unicodedata)))))
    (setq max-width (apply #'max (mapcar #'(lambda (x)
					     (if (cadr x) (length (car x)) 0))
					 item-list)))
    (with-output-to-temp-buffer "*Help*"
      (with-current-buffer standard-output
	(let ((help-xref-following t))
	  (help-setup-xref nil nil))
	(set-buffer-multibyte multibyte-p)
	(let ((formatter (format "%%%ds:" max-width)))
	  (dolist (elt item-list)
	    (when (cadr elt)
	      (insert (format formatter (car elt)))
	      (dolist (clm (cdr elt))
		(if (eq (car-safe clm) 'widget-create)
		    (progn (insert " ") (eval clm))
		  (when (>= (+ (current-column)
			       (or (string-match "\n" clm)
				   (string-width clm))
			       1)

				      (cddr (aref disp-vector i)))
			    "-- no font --")
			  "\n")
		  (when (> (car (aref disp-vector i)) #x7ffff)
		    (let* ((face-id (lsh (car (aref disp-vector i)) -19))
			   (face (car (delq nil (mapcar (lambda (face)
							  (and (eq (face-id face)
								   face-id) face))
							(face-list))))))
		      (when face
			(insert (propertize " " 'display '(space :align-to 5))
				"face: ")
			(widget-create 'link
				       :notify `(lambda (&rest ignore)
						  (describe-face ',face))
				       (format "%S" face))
			(insert "\n"))))))
	    (insert "these terminal codes:\n")
	    (dotimes (i (length disp-vector))
	      (insert (car (aref disp-vector i))
		      (propertize " " 'display '(space :align-to 5))

		      (or (cdr elt) "-- not encodable --"))))
	  (insert "\nSee the variable `reference-point-alist' for "
		  "the meaning of the rule.\n"))

        (if text-props-desc (insert text-props-desc))
	(describe-text-mode)
	(toggle-read-only 1)
	(help-make-xrefs (current-buffer))
	(print-help-return-message)))))

(defalias 'describe-char-after 'describe-char)
(make-obsolete 'describe-char-after 'describe-char "22.1")

67752:dd459879f1e7

;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
;;   2005 Free Software Foundation, Inc.

;; Author: Boris Goldowsky <[e-mail]>
;; Maintainer: FSF
;; Keywords: faces, i18n, Unicode, multilingual

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;;; Code:

(eval-when-compile (require 'button) (require 'quail))

;;; Describe-Text Utilities.

(defun describe-text-widget (widget)
  "Insert text to describe WIDGET in the current buffer."
  (insert-text-button
   (symbol-name (if (symbolp widget) widget (car widget)))
   'action `(lambda (&rest ignore)
	      (widget-browse ',widget)))
  (insert " ")
  (insert-text-button "(widget)Top"
		      'action (lambda (&rest ignore) (info "(widget)Top"))
		      'help-echo "mouse-2, RET: read this Info node"))

(defun describe-text-sexp (sexp)
  "Insert a short description of SEXP in the current buffer."
  (let ((pp (condition-case signal
		(pp-to-string sexp)

    (if (cond ((string-match "\n" pp)
	       nil)
	      ((> (length pp) (- (window-width) (current-column)))
	       nil)
	      (t t))
	(insert pp)
      (insert-text-button
       "show" 'action `(lambda (&rest ignore)
			(with-output-to-temp-buffer
			    "*Pp Eval Output*"
			  (princ ',pp)))
       'help-echo "mouse-2, RET: pretty print value in another buffer"))))

(defun describe-property-list (properties)
  "Insert a description of PROPERTIES in the current buffer.
PROPERTIES should be a list of overlay or text properties.
The `category', `face' and `font-lock-face' properties are made
into help buttons that call `describe-text-category' or
`describe-face' when pushed."
  ;; Sort the properties by the size of their value.
  (dolist (elt (sort (let (ret)
		       (while properties
			 (push (list (pop properties) (pop properties)) ret))
		       ret)
		     (lambda (a b) (string< (prin1-to-string (nth 0 a) t)
					    (prin1-to-string (nth 0 b) t)))))
    (let ((key (nth 0 elt))
	  (value (nth 1 elt)))
      (insert (propertize (format "  %-20s " key)
			  'face 'italic))
      (cond ((eq key 'category)
	     (insert-text-button (symbol-name value)
				 'action `(lambda (&rest ignore)
					    (describe-text-category ',value))
				 'help-echo
				 "mouse-2, RET: describe this category"))
            ((memq key '(face font-lock-face mouse-face))
	     (insert (concat "`" (format "%S" value) "'")))
            ((widgetp value)
	     (describe-text-widget value))
	    (t
	     (describe-text-sexp value))))
    (insert "\n")))

;;; Describe-Text Commands.

(defun describe-text-category (category)
  "Describe a text property category."
  (interactive "S")
  (save-excursion
    (with-output-to-temp-buffer "*Help*"
      (set-buffer standard-output)
      (insert "Category " (format "%S" category) ":\n\n")
      (describe-property-list (symbol-plist category))
      (goto-char (point-min)))))

;;;###autoload
(defun describe-text-properties (pos &optional output-buffer)
  "Describe widgets, buttons, overlays and text properties at POS.

	  (setq target-buffer "*Help*<2>"))
	(save-excursion
	  (with-output-to-temp-buffer target-buffer
	    (set-buffer standard-output)
	    (setq output-buffer (current-buffer))
	    (insert "Text content at position " (format "%d" pos) ":\n\n")
	    (with-current-buffer buffer
	      (describe-text-properties-1 pos output-buffer))
	    (goto-char (point-min))))))))

(defun describe-text-properties-1 (pos output-buffer)
  (let* ((properties (text-properties-at pos))
	 (overlays (overlays-at pos))

	 (widget (or wid-field wid-button wid-doc)))
    (with-current-buffer output-buffer
      ;; Widgets
      (when (widgetp widget)
	(newline)
	(insert (cond (wid-field "This is an editable text area")
		      (wid-button "This is an active area")
		      (wid-doc "This is documentation text")))
	(insert " of a ")
	(describe-text-widget widget)
	(insert ".\n\n"))
      ;; Buttons
      (when (and button (not (widgetp wid-button)))
	(newline)
	(insert "Here is a " (format "%S" button-type)
		" button labeled `" button-label "'.\n\n"))
      ;; Overlays
      (when overlays
	(newline)
	(if (eq (length overlays) 1)
	    (insert "There is an overlay here:\n")
	  (insert "There are " (format "%d" (length overlays))
			 " overlays here:\n"))
	(dolist (overlay overlays)
	  (insert " From " (format "%d" (overlay-start overlay))
			 " to " (format "%d" (overlay-end overlay)) "\n")
	  (describe-property-list (overlay-properties overlay)))
	(insert "\n"))
      ;; Text properties
      (when properties
	(newline)
	(insert "There are text properties here:\n")
	(describe-property-list properties)))))

(defcustom describe-char-unicodedata-file nil
  "Location of Unicode data file.
This is the UnicodeData.txt file from the Unicode consortium, used for
diagnostics.  If it is non-nil `describe-char' will print data
looked up from it.  This facility is mostly of use to people doing
multilingual development.

This is a fairly large file, not typically present on GNU systems.  At
the time of writing it is at the URL
`http://www.unicode.org/Public/UNIDATA/UnicodeData.txt'."
  :group 'mule
  :version "22.1"
  :type '(choice (const :tag "None" nil)
		 file))

		     char char char
		     (if unicode
			 (format ", U+%04X" unicode)
		       "")))
	    ("charset"
	     ,`(insert-text-button
		(symbol-name charset)
		'action `(lambda (&rest ignore)
			   (describe-character-set ',charset))
		'help-echo
		"mouse-2, RET: describe this character set")
	     ,(format "(%s)" (charset-description charset)))
	    ("code point"
	     ,(let ((split (split-char char)))
		`(insert-text-button ,(if (= (charset-dimension charset) 1)
					  (format "%d" (nth 1 split))
					(format "%d %d" (nth 1 split)
						(nth 2 split)))
		 'action (lambda (&rest ignore)
			   (list-charset-chars ',charset)
			   (with-selected-window
			       (get-buffer-window "*Character List*" 0)
			     (goto-char (point-min))
                              (forward-line 2) ;Skip the header.
                              (let ((case-fold-search nil))
                                (search-forward ,(char-to-string char)
                                                nil t)))))))
	    ("syntax"
	     ,(let ((syntax (syntax-after pos)))
		(with-temp-buffer
		  (internal-describe-syntax-value syntax)
		  (buffer-string))))

		 (if (consp key-list)
		     (list "type"
			   (mapconcat #'(lambda (x) (concat "\"" x "\""))
				      key-list " or ")
			   "with"
			   `(insert-text-button
			     (symbol-name current-input-method)
			     'action (lambda (&rest ignore)
				       (describe-input-method
					',current-input-method)))))))
	    ("buffer code"
	     ,(encoded-string-description
	       (string-as-unibyte (char-to-string char)) nil))
	    ("file code"
	     ,@(let* ((coding buffer-file-coding-system)

			  ((and nobreak-char-display unicode (eq unicode '#xad))
			   'escape-glyph)
			  ((and (< char 32) (not (memq char '(9 10))))
			   'escape-glyph)))))
		(if face (list (list "hardcoded face"
				     '(insert
				       (concat "`" (symbol-name face) "'"))))))
	    ,@(let ((unicodedata (and unicode
				      (describe-char-unicode-data unicode))))
		(if unicodedata
		    (cons (list "Unicode data" " ") unicodedata)))))
    (setq max-width (apply #'max (mapcar #'(lambda (x)
					     (if (cadr x) (length (car x)) 0))
					 item-list)))
    (help-setup-xref nil (interactive-p))
    (with-output-to-temp-buffer (help-buffer)
      (with-current-buffer standard-output
	(set-buffer-multibyte multibyte-p)
	(let ((formatter (format "%%%ds:" max-width)))
	  (dolist (elt item-list)
	    (when (cadr elt)
	      (insert (format formatter (car elt)))
	      (dolist (clm (cdr elt))
		(if (eq (car-safe clm) 'insert-text-button)
		    (progn (insert " ") (eval clm))
		  (when (>= (+ (current-column)
			       (or (string-match "\n" clm)
				   (string-width clm))
			       1)

				      (cddr (aref disp-vector i)))
			    "-- no font --")
			  "\n")
		  (when (> (car (aref disp-vector i)) #x7ffff)
		    (let* ((face-id (lsh (car (aref disp-vector i)) -19))
			   (face (car (delq nil (mapcar
						 (lambda (face)
						   (and (eq (face-id face)
							    face-id) face))
						 (face-list))))))
		      (when face
			(insert (propertize " " 'display '(space :align-to 5))
				"face: ")
			(insert (concat "`" (symbol-name face) "'"))
			(insert "\n"))))))
	    (insert "these terminal codes:\n")
	    (dotimes (i (length disp-vector))
	      (insert (car (aref disp-vector i))
		      (propertize " " 'display '(space :align-to 5))

		      (or (cdr elt) "-- not encodable --"))))
	  (insert "\nSee the variable `reference-point-alist' for "
		  "the meaning of the rule.\n"))

        (if text-props-desc (insert text-props-desc))
	(toggle-read-only 1)
	(print-help-return-message)))))

(defalias 'describe-char-after 'describe-char)
(make-obsolete 'describe-char-after 'describe-char "22.1")