comparison lisp/descr-text.el @ 67814:cc79e7966f97

2005-12-27 Nick Roberts <[e-mail]> * descr-text.el (describe-char): Add optional argument for buffer. Set buffer appropriately. Call help-setup-xref. Suggested by Stefan Monnier. 2005-12-27 Juri Linkov <[e-mail]> * descr-text.el (help-fns): Require. Don't require button for byte compilation. (describe-text-widget): Add help echo for first button. Use 'help-info for second. (describe-property-list): Use 'help-argument-name instead of 'italic. (describe-text-category): Prompt in minibuffer. Call help-setup-xref. (describe-char): Use 'help-character-set. Add help echo. Use 'help-input-method. Remove superfluous insert.

67813:7ead07735f77

;;; Describe-Text Mode.

;;; 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)

		     (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 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))

      (if encoded
	  (encoded-string-description encoded coding)))))


;;;###autoload
(defun describe-char (pos)
  "Describe the character after POS (interactively, the character after point).
The information includes character code, charset and code points in it,
syntax, category, how the character is encoded in a file,
character composition information (if relevant),
as well as widgets, buttons, overlays, and text properties."
  (interactive "d")
  (if (>= pos (point-max))
      (error "No character follows specified position"))
  (let* ((char (char-after pos))
	 (charset (char-charset char))
	 (composition (find-composition pos nil nil t))

			       (single-key-description char)
			     (if (< char 128)
				 (single-key-description char)
			       (string-to-multibyte
				(char-to-string char)))))
         (text-props-desc
          (let ((tmp-buf (generate-new-buffer " *text-props*")))
            (unwind-protect
                (progn
                  (describe-text-properties pos tmp-buf)
                  (with-current-buffer tmp-buf (buffer-string)))
              (kill-buffer tmp-buf))))
	 item-list max-width unicode)

    (if (or (< char 256)
	    (memq 'mule-utf-8 (find-coding-systems-region pos (1+ pos)))
	    (get-char-property pos 'untranslated-utf-8))
	(setq unicode (or (get-char-property pos 'untranslated-utf-8)
			  (encode-char char 'ucs))))
    (setq item-list
	  `(("character"
	    ,(format "%s (%d, #o%o, #x%x%s)"
		     (apply 'propertize char-description
			    (text-properties-at pos))
		     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))))

		     (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 "\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")

(provide 'descr-text)

67814:cc79e7966f97

;;; Describe-Text Mode.

;;; Code:

(eval-when-compile (require 'quail))
(require 'help-fns)

;;; 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))
   'help-echo "mouse-2, RET: browse this widget")
  (insert " ")
  (insert-text-button
   "(widget)Top" 'type 'help-info 'help-args '("(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)

		     (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 'help-argument-name))
      (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 Commands.

(defun describe-text-category (category)
  "Describe a text property category."
  (interactive "SCategory: ")
  (help-setup-xref (list #'describe-text-category category) (interactive-p))
  (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))

      (if encoded
	  (encoded-string-description encoded coding)))))


;;;###autoload
(defun describe-char (pos &optional buf)
  "Describe the character after POS (interactively, the character after point).
The information includes character code, charset and code points in it,
syntax, category, how the character is encoded in a file,
character composition information (if relevant),
as well as widgets, buttons, overlays, and text properties."
  (interactive "d")
  (let ((help-buffer (help-buffer)))
  (with-current-buffer  (if buf buf (current-buffer))
  (if (>= pos (point-max))
      (error "No character follows specified position"))
  (let* ((char (char-after pos))
	 (charset (char-charset char))
	 (composition (find-composition pos nil nil t))

			       (single-key-description char)
			     (if (< char 128)
				 (single-key-description char)
			       (string-to-multibyte
				(char-to-string char)))))
	 (text-props-desc
	  (let ((tmp-buf (generate-new-buffer " *text-props*")))
	    (unwind-protect
		(progn
		  (describe-text-properties pos tmp-buf)
		  (with-current-buffer tmp-buf (buffer-string)))
	      (kill-buffer tmp-buf))))
	 item-list max-width unicode)

    (if (or (< char 256)
	    (memq 'mule-utf-8 (find-coding-systems-region pos (1+ pos)))
	    (get-char-property pos 'untranslated-utf-8))
	(setq unicode (or (get-char-property pos 'untranslated-utf-8)
			  (encode-char char 'ucs))))
    (setq item-list
	  `(("character"
	     ,(format "%s (%d, #o%o, #x%x%s)"
		      (apply 'propertize char-description
			     (text-properties-at pos))
		      char char char
		      (if unicode
			  (format ", U+%04X" unicode)
			"")))
	    ("charset"
	     ,`(insert-text-button
		,(symbol-name charset)
		'type 'help-character-set 'help-args '(,charset))
	     ,(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))))
		  'help-echo
		  "mouse-2, RET: show this character in its character set")))
	    ("syntax"
	     ,(let ((syntax (syntax-after pos)))
		(with-temp-buffer
		  (internal-describe-syntax-value syntax)
		  (buffer-string))))

		     (list "type"
			   (mapconcat #'(lambda (x) (concat "\"" x "\""))
				      key-list " or ")
			   "with"
			   `(insert-text-button
			     ,(symbol-name current-input-method)
			     'type 'help-input-method
			     'help-args '(,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"
				     (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
     (list #'describe-char pos (if buf buf (current-buffer)))
     (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 "\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")

(provide 'descr-text)