2 files changed, 89 insertions, 46 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index af58ef47b28..4b8389877a2 100644
--- 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 35a3ac3c09a..f1baee8dafe 100644
--- 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."