diff options
Diffstat (limited to 'lisp/help.el')
| -rw-r--r-- | lisp/help.el | 438 |
1 files changed, 275 insertions, 163 deletions
diff --git a/lisp/help.el b/lisp/help.el index 941d4cfab12..5114ddefba1 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -50,6 +50,11 @@ (defvar help-window-old-frame nil "Frame selected at the time `with-help-window' is invoked.") +(defvar help-buffer-under-preparation nil + "Whether a *Help* buffer is being prepared. +This variable is bound to t during the preparation of a *Help* +buffer.") + (defvar help-map (let ((map (make-sparse-keymap))) (define-key map (char-to-string help-char) 'help-for-help) @@ -524,30 +529,31 @@ See `lossage-size' to update the number of recorded keystrokes. To record all your input, use `open-dribble-file'." (interactive) - (help-setup-xref (list #'view-lossage) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (princ " ") - (princ (mapconcat (lambda (key) - (cond - ((and (consp key) (null (car key))) - (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) - "anonymous-command"))) - ((or (integerp key) (symbolp key) (listp key)) - (single-key-description key)) - (t - (prin1-to-string key nil)))) - (recent-keys 'include-cmds) - " ")) - (with-current-buffer standard-output - (goto-char (point-min)) - (let ((comment-start ";; ") - (comment-column 24)) - (while (not (eobp)) - (comment-indent) - (forward-line 1))) - ;; Show point near the end of "lossage", as we did in Emacs 24. - (set-marker help-window-point-marker (point))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'view-lossage) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (princ " ") + (princ (mapconcat (lambda (key) + (cond + ((and (consp key) (null (car key))) + (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) + "anonymous-command"))) + ((or (integerp key) (symbolp key) (listp key)) + (single-key-description key)) + (t + (prin1-to-string key nil)))) + (recent-keys 'include-cmds) + " ")) + (with-current-buffer standard-output + (goto-char (point-min)) + (let ((comment-start ";; ") + (comment-column 24)) + (while (not (eobp)) + (comment-indent) + (forward-line 1))) + ;; Show point near the end of "lossage", as we did in Emacs 24. + (set-marker help-window-point-marker (point)))))) ;; Key bindings @@ -561,11 +567,13 @@ To record all your input, use `open-dribble-file'." 'font-lock-face 'help-key-binding 'face 'help-key-binding)) -(defcustom describe-bindings-outline nil +(defcustom describe-bindings-outline t "Non-nil enables outlines in the output buffer of `describe-bindings'." :type 'boolean :group 'help - :version "28.1") + :version "29.1") + +(declare-function outline-hide-subtree "outline") (defun describe-bindings (&optional prefix buffer) "Display a buffer showing a list of all defined keys, and their definitions. @@ -577,33 +585,32 @@ The optional argument BUFFER specifies which buffer's bindings to display (default, the current buffer). BUFFER can be a buffer or a buffer name." (interactive) - (or buffer (setq buffer (current-buffer))) - (help-setup-xref (list #'describe-bindings prefix buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - ;; Be aware that `describe-buffer-bindings' puts its output into - ;; the current buffer. - (with-current-buffer (help-buffer) - (describe-buffer-bindings buffer prefix) - - (when describe-bindings-outline - (setq-local outline-regexp ".*:$") - (setq-local outline-heading-end-regexp ":\n") - (setq-local outline-level (lambda () 1)) - (setq-local outline-minor-mode-cycle t - outline-minor-mode-highlight t) - (outline-minor-mode 1) - (save-excursion - (let ((inhibit-read-only t)) + (let ((help-buffer-under-preparation t)) + (or buffer (setq buffer (current-buffer))) + (help-setup-xref (list #'describe-bindings prefix buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (describe-buffer-bindings buffer prefix) + + (when describe-bindings-outline + (setq-local outline-regexp ".*:$") + (setq-local outline-heading-end-regexp ":\n") + (setq-local outline-level (lambda () 1)) + (setq-local outline-minor-mode-cycle t + outline-minor-mode-highlight t) + (setq-local outline-minor-mode-use-buttons t) + (outline-minor-mode 1) + (save-excursion (goto-char (point-min)) - (insert (substitute-command-keys - (concat "\\<outline-minor-mode-cycle-map>Type " - "\\[outline-cycle] or \\[outline-cycle-buffer] " - "on headings to cycle their visibility.\n\n"))) - ;; Hide the longest body - (when (and (re-search-forward "Key translations" nil t) - (fboundp 'outline-cycle)) - (outline-cycle)))))))) + (let ((inhibit-read-only t)) + ;; Hide the longest body. + (when (re-search-forward "Key translations" nil t) + (outline-hide-subtree)) + ;; Hide ^Ls. + (while (search-forward "\n\f\n" nil t) + (put-text-property (1+ (match-beginning 0)) (1- (match-end 0)) + 'invisible t))))))))) (defun where-is (definition &optional insert) "Print message listing key sequences that invoke the command DEFINITION. @@ -903,7 +910,8 @@ current buffer." (let ((raw (if (numberp buffer) (this-single-command-raw-keys) buffer))) (setf (cdar (last key-list)) raw))) (setq buffer nil)) - (let* ((buf (or buffer (current-buffer))) + (let* ((help-buffer-under-preparation t) + (buf (or buffer (current-buffer))) (on-link (mapcar (lambda (kr) (let ((raw (cdr kr))) @@ -1060,6 +1068,14 @@ is currently activated with completion." result)) +(defcustom help-link-key-to-documentation t + "Non-nil means link keys to their command in *Help* buffers. +This affects \\\\=\\[command] substitutions in documentation +strings done by `substitute-command-keys'." + :type 'boolean + :version "29.1" + :group 'help) + (defun substitute-command-keys (string &optional no-face) "Substitute key descriptions for command names in STRING. Each substring of the form \\\\=[COMMAND] is replaced by either a @@ -1067,6 +1083,9 @@ keystroke sequence that invokes COMMAND, or \"M-x COMMAND\" if COMMAND is not on any keys. Keybindings will use the face `help-key-binding', unless the optional argument NO-FACE is non-nil. +Each substring of the form \\\\=`KEYBINDING' will be replaced by +KEYBINDING and use the `help-key-binding' face. + Each substring of the form \\\\={MAPVAR} is replaced by a summary of the value of MAPVAR as a keymap. This summary is similar to the one produced by ‘describe-bindings’. The summary ends in two newlines @@ -1119,6 +1138,23 @@ Otherwise, return a new string." (delete-char 2) (ignore-errors (forward-char 1))) + ((and (= (following-char) ?`) + (save-excursion + (prog1 (search-forward "'" nil t) + (setq end-point (- (point) 2))))) + (goto-char orig-point) + (delete-char 2) + (goto-char (1- end-point)) + (delete-char 1) + ;; (backward-char 1) + (let ((k (buffer-substring-no-properties orig-point (point)))) + (cond ((= (length k) 0) + (error "Empty key sequence in substitution")) + ((not (key-valid-p k)) + (error "Invalid key sequence in substitution: `%s'" k)))) + (add-text-properties orig-point (point) + '( face help-key-binding + font-lock-face help-key-binding))) ;; 1C. \[foo] is replaced with the keybinding. ((and (= (following-char) ?\[) (save-excursion @@ -1150,9 +1186,19 @@ Otherwise, return a new string." (delete-char 1)) ;; Function is on a key. (delete-char (- end-point (point))) - (insert (if no-face - (key-description key) - (help--key-description-fontified key)))))) + + (insert + (if no-face + (key-description key) + (let ((key (help--key-description-fontified key))) + (if (and help-link-key-to-documentation + help-buffer-under-preparation + (functionp fun)) + ;; The `fboundp' fixes bootstrap. + (if (fboundp 'help-mode--add-function-link) + (help-mode--add-function-link key fun) + key) + key))))))) ;; 1D. \{foo} is replaced with a summary of the keymap ;; (symbol-value foo). ;; \<foo> just sets the keymap used for \[cmd]. @@ -1212,8 +1258,8 @@ Otherwise, return a new string." (buffer-string))))) (defvar help--keymaps-seen nil) -(defun describe-map-tree (startmap partial shadow prefix title no-menu - transl always-title mention-shadow) +(defun describe-map-tree (startmap &optional partial shadow prefix title + no-menu transl always-title mention-shadow) "Insert a description of the key bindings in STARTMAP. This is followed by the key bindings of all maps reachable through STARTMAP. @@ -1239,10 +1285,7 @@ maps to look through. If MENTION-SHADOW is non-nil, then when something is shadowed by SHADOW, don't omit it; instead, mention it but say it is -shadowed. - -Any inserted text ends in two newlines (used by -`help-make-xrefs')." +shadowed." (let* ((amaps (accessible-keymaps startmap prefix)) (orig-maps (if no-menu (progn @@ -1259,17 +1302,8 @@ Any inserted text ends in two newlines (used by result)) amaps)) (maps orig-maps) - (print-title (or maps always-title))) - ;; Print title. - (when print-title - (insert (concat (if title - (concat title - (if prefix - (concat " Starting With " - (help--key-description-fontified prefix))) - ":\n")) - "key binding\n" - "--- -------\n"))) + (print-title (or maps always-title)) + (start-point (point))) ;; Describe key bindings. (setq help--keymaps-seen nil) (while (consp maps) @@ -1294,8 +1328,24 @@ Any inserted text ends in two newlines (used by (describe-map (cdr elt) elt-prefix transl partial sub-shadows no-menu mention-shadow))) (setq maps (cdr maps))) - (when print-title - (insert "\n")))) + ;; Print title... + (when (and print-title + ;; ... unless the keymap was empty. + (/= (point) start-point)) + (save-excursion + (goto-char start-point) + (when (eolp) + (delete-region (point) (1+ (point)))) + (insert + (concat + (if title + (concat title + (if prefix + (concat " Starting With " + (help--key-description-fontified prefix))) + ":\n")) + "\nKey Binding\n" + (make-separator-line))))))) (defun help--shadow-lookup (keymap key accept-default remap) "Like `lookup-key', but with command remapping. @@ -1308,48 +1358,37 @@ Return nil if the key sequence is too long." value)) (t value)))) -(defvar help--previous-description-column 0) -(defun help--describe-command (definition) - ;; Converted from describe_command in keymap.c. - ;; If column 16 is no good, go to col 32; - ;; but don't push beyond that--go to next line instead. - (let* ((column (current-column)) - (description-column (cond ((> column 30) - (insert "\n") - 32) - ((or (> column 14) - (and (> column 10) - (= help--previous-description-column 32))) - 32) - (t 16)))) - ;; Avoid using the `help-keymap' face. - (let ((op (point))) - (indent-to description-column 1) - (set-text-properties op (point) '( face nil - font-lock-face nil))) - (setq help--previous-description-column description-column) - (cond ((symbolp definition) - (insert (symbol-name definition) "\n")) - ((or (stringp definition) (vectorp definition)) - (insert "Keyboard Macro\n")) - ((keymapp definition) - (insert "Prefix Command\n")) - (t (insert "??\n"))))) - -(defun help--describe-translation (definition) - ;; Converted from describe_translation in keymap.c. - ;; Avoid using the `help-keymap' face. - (let ((op (point))) - (indent-to 16 1) - (set-text-properties op (point) '( face nil - font-lock-face nil))) +(defun help--describe-command (definition &optional translation) (cond ((symbolp definition) - (insert (symbol-name definition) "\n")) + (if (and (fboundp definition) + help-buffer-under-preparation) + (insert-text-button (symbol-name definition) + 'type 'help-function + 'help-args (list definition)) + (insert (symbol-name definition))) + (insert "\n")) ((or (stringp definition) (vectorp definition)) - (insert (key-description definition nil) "\n")) + (if translation + (insert (key-description definition nil) "\n") + (insert "Keyboard Macro\n"))) ((keymapp definition) (insert "Prefix Command\n")) - (t (insert "??\n")))) + ((byte-code-function-p definition) + (insert "[%s]\n" (buttonize "byte-code" #'disassemble definition))) + ((and (consp definition) + (memq (car definition) '(closure lambda))) + (insert (format "[%s]\n" + (buttonize + (symbol-name (car definition)) + (lambda (_) + (pp-display-expression + definition "*Help Source*" t)) + nil "View definition")))) + (t + (insert "??\n")))) + +(define-obsolete-function-alias 'help--describe-translation + #'help--describe-command "29.1") (defun help--describe-map-compare (a b) (let ((a (car a)) @@ -1363,7 +1402,8 @@ Return nil if the key sequence is too long." (string-version-lessp (symbol-name a) (symbol-name b))) (t nil)))) -(defun describe-map (map prefix transl partial shadow nomenu mention-shadow) +(defun describe-map (map &optional prefix transl partial shadow + nomenu mention-shadow) "Describe the contents of keymap MAP. Assume that this keymap itself is reached by the sequence of prefix keys PREFIX (a string or vector). @@ -1375,14 +1415,22 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (map (keymap-canonicalize map)) (tail map) (first t) - (describer (if transl - #'help--describe-translation - #'help--describe-command)) done vect) (while (and (consp tail) (not done)) (cond ((or (vectorp (car tail)) (char-table-p (car tail))) - (help--describe-vector (car tail) prefix describer partial - shadow map mention-shadow)) + (let ((columns ())) + (help--describe-vector + (car tail) prefix + (lambda (def) + (let ((start-line (line-beginning-position)) + (end-key (point)) + (column (current-column))) + (help--describe-command def transl) + (push (list column start-line end-key (1- (point))) + columns))) + partial shadow map mention-shadow) + (when columns + (describe-map--align-section columns)))) ((consp (car tail)) (let ((event (caar tail)) definition this-shadowed) @@ -1425,7 +1473,9 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (push (cons tail prefix) help--keymaps-seen))))) (setq tail (cdr tail))) ;; If we found some sparse map events, sort them. - (let ((vect (sort vect 'help--describe-map-compare))) + (let ((vect (sort vect 'help--describe-map-compare)) + (columns ()) + line-start key-end column) ;; Now output them in sorted order. (while vect (let* ((elem (car vect)) @@ -1433,10 +1483,6 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (definition (cadr elem)) (shadowed (caddr elem)) (end start)) - (when first - (setq help--previous-description-column 0) - (insert "\n") - (setq first nil)) ;; Find consecutive chars that are identically defined. (when (fixnump start) (while (and (cdr vect) @@ -1451,26 +1497,80 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (eq this-shadowed next-shadowed)))) (setq vect (cdr vect)) (setq end (caar vect)))) - ;; Now START .. END is the range to describe next. - ;; Insert the string to describe the event START. - (insert (help--key-description-fontified (vector start) prefix)) - (when (not (eq start end)) - (insert " .. " (help--key-description-fontified (vector end) prefix))) - ;; Print a description of the definition of this character. - ;; Called function will take care of spacing out far enough - ;; for alignment purposes. - (if transl - (help--describe-translation definition) - (help--describe-command definition)) - ;; Print a description of the definition of this character. - ;; elt_describer will take care of spacing out far enough for - ;; alignment purposes. - (when shadowed - (goto-char (max (1- (point)) (point-min))) - (insert "\n (this binding is currently shadowed)") - (goto-char (min (1+ (point)) (point-max))))) + (when (or (not (eq start end)) + ;; Don't output keymap prefixes. + (not (keymapp definition))) + (when first + (insert "\n") + (setq first nil)) + ;; Now START .. END is the range to describe next. + ;; Insert the string to describe the event START. + (setq line-start (point)) + (insert (help--key-description-fontified (vector start) prefix)) + (when (not (eq start end)) + (insert " .. " (help--key-description-fontified (vector end) + prefix))) + (setq key-end (point) + column (current-column)) + ;; Print a description of the definition of this character. + ;; Called function will take care of spacing out far enough + ;; for alignment purposes. + (help--describe-command definition transl) + (push (list column line-start key-end (1- (point))) columns) + ;; Print a description of the definition of this character. + ;; elt_describer will take care of spacing out far enough for + ;; alignment purposes. + (when shadowed + (goto-char (max (1- (point)) (point-min))) + (insert "\n (this binding is currently shadowed)") + (goto-char (min (1+ (point)) (point-max)))))) ;; Next item in list. - (setq vect (cdr vect)))))) + (setq vect (cdr vect))) + (when columns + (describe-map--align-section columns))))) + +(defun describe-map--align-section (columns) + (save-excursion + (let ((max-key (apply #'max (mapcar #'car columns)))) + (cond + ;; It's fine to use the minimum, so just do it, but quantize to + ;; two different widths, because having each block align slightly + ;; differently looks untidy. + ((< max-key 16) + (describe-map--fill-columns columns 16)) + ((< max-key 24) + (describe-map--fill-columns columns 24)) + ((< max-key 32) + (describe-map--fill-columns columns 32)) + ;; We have some really wide ones in this block. + (t + (let ((window-width (window-width)) + (max-def (apply #'max (mapcar + (lambda (elem) + (- (nth 3 elem) (nth 2 elem))) + columns)))) + (if (< (+ max-def (max 16 max-key)) window-width) + ;; Can we do the block without continuation lines? Then do that. + (describe-map--fill-columns columns (1+ (max 16 max-key))) + ;; No, do continuation lines for some definitions. + (dolist (elem columns) + (goto-char (caddr elem)) + (if (< (+ (car elem) (- (nth 3 elem) (nth 2 elem))) window-width) + ;; Indent. + (insert-char ?\s (- (1+ max-key) (car elem))) + ;; Continuation. + (insert "\n") + (insert-char ?\t 2)))))))))) + +(defun describe-map--fill-columns (columns width) + (dolist (elem columns) + (goto-char (caddr elem)) + (let ((tabs (- (/ width tab-width) + (/ (car elem) tab-width)))) + (insert-char ?\t tabs) + (insert-char ?\s (if (zerop tabs) + (- width (car elem)) + (mod width tab-width)))))) ;;;; This Lisp version is 100 times slower than its C equivalent: ;; @@ -1606,10 +1706,16 @@ and some others." (add-hook 'temp-buffer-show-hook 'resize-temp-buffer-window 'append) (remove-hook 'temp-buffer-show-hook 'resize-temp-buffer-window))) +(defvar resize-temp-buffer-window-inhibit nil + "Non-nil means `resize-temp-buffer-window' should not resize.") + (defun resize-temp-buffer-window (&optional window) "Resize WINDOW to fit its contents. WINDOW must be a live window and defaults to the selected one. -Do not resize if WINDOW was not created by `display-buffer'. +Do not resize if WINDOW was not created by `display-buffer'. Do +not resize either if a `window-height', `window-width' or +`window-size' entry in `display-buffer-alist' prescribes some +alternative resizing for WINDOW's buffer. If WINDOW is part of a vertical combination, restrain its new size by `temp-buffer-max-height' and do not resize if its minimum @@ -1624,27 +1730,33 @@ provided `fit-frame-to-buffer' is non-nil. This function may call `preserve-window-size' to preserve the size of WINDOW." (setq window (window-normalize-window window t)) - (let ((height (if (functionp temp-buffer-max-height) + (let* ((buffer (window-buffer window)) + (height (if (functionp temp-buffer-max-height) + (with-selected-window window + (funcall temp-buffer-max-height buffer)) + temp-buffer-max-height)) + (width (if (functionp temp-buffer-max-width) (with-selected-window window - (funcall temp-buffer-max-height (window-buffer))) - temp-buffer-max-height)) - (width (if (functionp temp-buffer-max-width) - (with-selected-window window - (funcall temp-buffer-max-width (window-buffer))) - temp-buffer-max-width)) - (quit-cadr (cadr (window-parameter window 'quit-restore)))) - ;; Resize WINDOW iff it was made by `display-buffer'. + (funcall temp-buffer-max-width buffer)) + temp-buffer-max-width)) + (quit-cadr (cadr (window-parameter window 'quit-restore)))) + ;; Resize WINDOW only if it was made by `display-buffer'. (when (or (and (eq quit-cadr 'window) (or (and (window-combined-p window) (not (eq fit-window-to-buffer-horizontally 'only)) - (pos-visible-in-window-p (point-min) window)) + (pos-visible-in-window-p + (with-current-buffer buffer (point-min)) + window) + (not resize-temp-buffer-window-inhibit)) (and (window-combined-p window t) - fit-window-to-buffer-horizontally))) + fit-window-to-buffer-horizontally + (not resize-temp-buffer-window-inhibit)))) (and (eq quit-cadr 'frame) fit-frame-to-buffer - (eq window (frame-root-window window)))) - (fit-window-to-buffer window height nil width nil t)))) + (eq window (frame-root-window window)) + (not resize-temp-buffer-window-inhibit))) + (fit-window-to-buffer window height nil width nil t)))) ;;; Help windows. (defcustom help-window-select nil @@ -1754,13 +1866,13 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" to delete help window") + "Type \\<help-map>\\[help-quit] to delete help window") ((eq help-setup 'frame) ;; ... on a new frame, ... - "Type \"q\" to quit the help frame") + "Type \\<help-map>\\[help-quit] to quit the help frame") ((eq help-setup 'other) ;; ... or displayed some other buffer before. - "Type \"q\" to restore previous buffer")) + "Type \\<help-map>\\[help-quit] to restore previous buffer")) window t)) ((and (eq (window-frame window) help-window-old-frame) (= (length (window-list nil 'no-mini)) 2)) @@ -1771,7 +1883,7 @@ Return VALUE." ((eq help-setup 'window) "Type \\[delete-other-windows] to delete the help window") ((eq help-setup 'other) - "Type \"q\" in help window to restore its previous buffer")) + "Type \\<help-map>\\[help-quit] in help window to restore its previous buffer")) window 'other)) (t ;; The help window is not selected ... @@ -1779,10 +1891,10 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" in help window to delete it") + "Type \\<help-map>\\[help-quit] in help window to delete it") ((eq help-setup 'other) ;; ... or displayed some other buffer before. - "Type \"q\" in help window to restore previous buffer")) + "Type \\<help-map>\\[help-quit] in help window to restore previous buffer")) window)))) ;; Return VALUE. value)) |