X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/233ba4d924933cb56129bd7511e6137b7c0b8e3e..c5cde04220c3961df41d290dfe3ddbcba821fa26:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index 70ce860e1d..d3d66f2a07 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) @@ -371,8 +389,8 @@ Value is a list of offsets of the words into the string." "Return apropos score for documentation string DOC." (let ((l (length doc))) (if (> l 0) - (let ((score 0) i) - (when (setq i (string-match apropos-pattern-quoted doc)) + (let ((score 0)) + (when (string-match apropos-pattern-quoted doc) (setq score 10000)) (dolist (s (apropos-calc-scores doc apropos-all-words) score) (setq score (+ score 50 (/ (* (- l s) 50) l))))) @@ -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))) @@ -972,17 +990,13 @@ If non-nil TEXT is a string that will be printed as a heading." (with-output-to-temp-buffer "*Apropos*" (let ((p apropos-accumulator) (old-buffer (current-buffer)) + (inhibit-read-only t) symbol item) (set-buffer standard-output) - (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")) + (apropos-mode) + (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))) @@ -1064,8 +1078,7 @@ If non-nil TEXT is a string that will be printed as a heading." (apropos-print-doc 5 'apropos-widget t) (apropos-print-doc 4 'apropos-plist nil)) (set (make-local-variable 'truncate-partial-width-windows) t) - (set (make-local-variable 'truncate-lines) t) - (apropos-mode)))) + (set (make-local-variable 'truncate-lines) t)))) (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc @@ -1081,30 +1094,51 @@ 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 (if (integerp emacs-lisp-docstring-fill-column) + emacs-lisp-docstring-fill-column + 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."