Improve apropos buffer highlighting.

* lisp/apropos.el (apropos-label-face): Avoid variable-pitch face.
(apropos-accumulator): Doc fix.
(apropos-function, apropos-macro, apropos-command)
(apropos-variable, apropos-face, apropos-group, apropos-widget)
(apropos-plist): Add face property.
(apropos-symbols-internal): Fix indentation.
(apropos-print): Simplify help, and recognize apropos-multi-type.
(apropos-print-doc): Use button-type-get to extract the button's
face property.  Fill docstring (Bug#8352).

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index af58ef47b281ef12bd404635c434e62716b7c345..4b8389877a2bcfc98d3cc385ed92d1abe318af67 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,15 @@
+2011-04-24  Chong Yidong  <cyd@stupidchicken.com>
+
+       * apropos.el (apropos-label-face): Avoid variable-pitch face.
+       (apropos-accumulator): Doc fix.
+       (apropos-function, apropos-macro, apropos-command)
+       (apropos-variable, apropos-face, apropos-group, apropos-widget)
+       (apropos-plist): Add face property.
+       (apropos-symbols-internal): Fix indentation.
+       (apropos-print): Simplify help, and recognize apropos-multi-type.
+       (apropos-print-doc): Use button-type-get to extract the button's
+       face property.  Fill docstring (Bug#8352).
+
 2011-04-23  Juanma Barranquero  <lekktu@gmail.com>
 
        * buff-menu.el (Buffer-menu--buffers): Fix typo in docstring (bug#8535).

diff --git a/lisp/apropos.el b/lisp/apropos.el
index 35a3ac3c09ad434b860b7c4d57589c22e6a9d298..f1baee8dafe4712c2b956bf8acf31c73e2cd2a24 100644 (file)
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -83,7 +83,7 @@ Slows them down more or less.  Set this non-nil if you have a fast machine."
   :group 'apropos
   :type 'face)
 
-(defcustom apropos-label-face '(italic variable-pitch)
+(defcustom apropos-label-face '(italic)
   "Face for label (`Command', `Variable' ...) in Apropos output.
 A value of nil means don't use any special font for them, and also
 turns off mouse highlighting."
@@ -155,7 +155,17 @@ If value is `verbose', the computed score is shown for each match."
   "List of elc files already scanned in current run of `apropos-documentation'.")
 
 (defvar apropos-accumulator ()
-  "Alist of symbols already found in current apropos run.")
+  "Alist of symbols already found in current apropos run.
+Each element has the form
+
+  (SYMBOL SCORE FUN-DOC VAR-DOC PLIST WIDGET-DOC FACE-DOC CUS-GROUP-DOC)
+
+where SYMBOL is the symbol name, SCORE is its relevance score (a
+number), FUN-DOC is the function docstring, VAR-DOC is the
+variable docstring, PLIST is the list of the symbols names in the
+property list, WIDGET-DOC is the widget docstring, FACE-DOC is
+the face docstring, and CUS-GROUP-DOC is the custom group
+docstring.  Each docstring is either nil or a string.")
 
 (defvar apropos-item ()
   "Current item in or for `apropos-accumulator'.")
@@ -187,6 +197,7 @@ term, and the rest of the words are alternative terms.")
 (define-button-type 'apropos-function
   'apropos-label "Function"
   'apropos-short-label "f"
+  'face '(font-lock-function-name-face button)
   'help-echo "mouse-2, RET: Display more help on this function"
   'follow-link t
   'action (lambda (button)
@@ -195,6 +206,7 @@ term, and the rest of the words are alternative terms.")
 (define-button-type 'apropos-macro
   'apropos-label "Macro"
   'apropos-short-label "m"
+  'face '(font-lock-function-name-face button)
   'help-echo "mouse-2, RET: Display more help on this macro"
   'follow-link t
   'action (lambda (button)
@@ -203,6 +215,7 @@ term, and the rest of the words are alternative terms.")
 (define-button-type 'apropos-command
   'apropos-label "Command"
   'apropos-short-label "c"
+  'face '(font-lock-function-name-face button)
   'help-echo "mouse-2, RET: Display more help on this command"
   'follow-link t
   'action (lambda (button)
@@ -216,6 +229,7 @@ term, and the rest of the words are alternative terms.")
 (define-button-type 'apropos-variable
   'apropos-label "Variable"
   'apropos-short-label "v"
+  'face '(font-lock-variable-name-face button)
   'help-echo "mouse-2, RET: Display more help on this variable"
   'follow-link t
   'action (lambda (button)
@@ -224,6 +238,7 @@ term, and the rest of the words are alternative terms.")
 (define-button-type 'apropos-face
   'apropos-label "Face"
   'apropos-short-label "F"
+  'face '(font-lock-variable-name-face button)
   'help-echo "mouse-2, RET: Display more help on this face"
   'follow-link t
   'action (lambda (button)
@@ -232,6 +247,7 @@ term, and the rest of the words are alternative terms.")
 (define-button-type 'apropos-group
   'apropos-label "Group"
   'apropos-short-label "g"
+  'face '(font-lock-builtin-face button)
   'help-echo "mouse-2, RET: Display more help on this group"
   'follow-link t
   'action (lambda (button)
@@ -241,14 +257,16 @@ term, and the rest of the words are alternative terms.")
 (define-button-type 'apropos-widget
   'apropos-label "Widget"
   'apropos-short-label "w"
+  'face '(font-lock-builtin-face button)
   'help-echo "mouse-2, RET: Display more help on this widget"
   'follow-link t
   'action (lambda (button)
            (widget-browse-other-window (button-get button 'apropos-symbol))))
 
 (define-button-type 'apropos-plist
-  'apropos-label "Plist"
+  'apropos-label "Properties"
   'apropos-short-label "p"
+  'face '(font-lock-keyword-face button)
   'help-echo "mouse-2, RET: Display more help on this plist"
   'follow-link t
   'action (lambda (button)
@@ -636,15 +654,15 @@ thus be found in `load-history'."
                   "(not documented)"))
               (when (boundp symbol)
                 (apropos-documentation-property
-                   symbol 'variable-documentation t))
-                (when (setq properties (symbol-plist symbol))
-                  (setq doc (list (car properties)))
-                  (while (setq properties (cdr (cdr properties)))
-                    (setq doc (cons (car properties) doc)))
-                  (mapconcat #'symbol-name (nreverse doc) " "))
-                (when (get symbol 'widget-type)
-                  (apropos-documentation-property
-                   symbol 'widget-documentation t))
+                 symbol 'variable-documentation t))
+              (when (setq properties (symbol-plist symbol))
+                (setq doc (list (car properties)))
+                (while (setq properties (cdr (cdr properties)))
+                  (setq doc (cons (car properties) doc)))
+                (mapconcat #'symbol-name (nreverse doc) " "))
+              (when (get symbol 'widget-type)
+                (apropos-documentation-property
+                 symbol 'widget-documentation t))
               (when (facep symbol)
                 (let ((alias (get symbol 'face-alias)))
                   (if alias
@@ -660,8 +678,8 @@ thus be found in `load-history'."
                     (apropos-documentation-property
                      symbol 'face-documentation t))))
               (when (get symbol 'custom-group)
-                  (apropos-documentation-property
-                   symbol 'group-documentation t)))))
+                (apropos-documentation-property
+                 symbol 'group-documentation t)))))
          symbols)))
     (apropos-print keys nil text)))
 
@@ -976,15 +994,9 @@ If non-nil TEXT is a string that will be printed as a heading."
            symbol item)
        (set-buffer standard-output)
        (apropos-mode)
-       (if (display-mouse-p)
-           (insert
-            "If moving the mouse over text changes the text's color, "
-            "you can click\n"
-            "or press return on that text to get more information.\n"))
-       (insert "In this buffer, go to the name of the command, or function,"
-               " or variable,\n"
-               (substitute-command-keys
-                "and type \\[apropos-follow] to get full documentation.\n\n"))
+       (insert (substitute-command-keys "Type \\[apropos-follow] on ")
+               (if apropos-multi-type "a type label" "an entry")
+               " to view its full documentation.\n\n")
        (if text (insert text "\n\n"))
        (dolist (apropos-item p)
          (when (and spacing (not (bobp)))
@@ -1082,30 +1094,49 @@ If non-nil TEXT is a string that will be printed as a heading."
 
 
 (defun apropos-print-doc (i type do-keys)
-  (when (stringp (setq i (nth i apropos-item)))
-    (if apropos-compact-layout
-        (insert (propertize "\t" 'display '(space :align-to 32)) " ")
-      (insert "  "))
-    (if (null apropos-multi-type)
-       ;; If the query is only for a single type, there's no point
-       ;; writing it over and over again.  Insert a blank button, and
-       ;; put the 'apropos-label property there (needed by
-       ;; apropos-symbol-button-display-help).
-       (insert-text-button
+  (let ((doc (nth i apropos-item)))
+    (when (stringp doc)
+      (if apropos-compact-layout
+         (insert (propertize "\t" 'display '(space :align-to 32)) " ")
+       (insert "  "))
+      (if apropos-multi-type
+         (let ((button-face (button-type-get type 'face)))
+           (unless (consp button-face)
+             (setq button-face (list button-face)))
+           (insert-text-button
+            (if apropos-compact-layout
+                (format "<%s>" (button-type-get type 'apropos-short-label))
+              (button-type-get type 'apropos-label))
+            'type type
+            ;; Can't use the default button face, since user may have changed the
+            ;; variable!  Just say `no' to variables containing faces!
+            'face (append button-face apropos-label-face)
+            'apropos-symbol (car apropos-item))
+           (insert (if apropos-compact-layout " " ": ")))
+
+       ;; If the query is only for a single type, there's no point
+       ;; writing it over and over again.  Insert a blank button, and
+       ;; put the 'apropos-label property there (needed by
+       ;; apropos-symbol-button-display-help).
+       (insert-text-button
         " " 'type type 'skip t
-        'face 'default 'apropos-symbol (car apropos-item))
-      (insert-text-button
-       (if apropos-compact-layout
-           (format "<%s>" (button-type-get type 'apropos-short-label))
-         (button-type-get type 'apropos-label))
-       'type type
-       ;; Can't use the default button face, since user may have changed the
-       ;; variable!  Just say `no' to variables containing faces!
-       'face apropos-label-face
-       'apropos-symbol (car apropos-item))
-      (insert (if apropos-compact-layout " " ": ")))
-    (insert (if do-keys (substitute-command-keys i) i))
-    (or (bolp) (terpri))))
+        'face 'default 'apropos-symbol (car apropos-item)))
+
+      (let ((opoint (point))
+           (ocol (current-column)))
+       (cond ((equal doc "")
+              (setq doc "(not documented)"))
+             (do-keys
+              (setq doc (substitute-command-keys doc))))
+       (insert doc)
+       (if (equal doc "(not documented)")
+           (put-text-property opoint (point) 'font-lock-face 'shadow))
+       ;; The labeling buttons might make the line too long, so fill it if
+       ;; necessary.
+       (let ((fill-column (+ 5 emacs-lisp-docstring-fill-column))
+             (fill-prefix (make-string ocol ?\s)))
+         (fill-region opoint (point) nil t)))
+      (or (bolp) (terpri)))))
 
 (defun apropos-follow ()
   "Invokes any button at point, otherwise invokes the nearest label button."