commit 60c9702972f3cef9e6dbbce5eaad8cc90ea7f8e8 (HEAD, refs/remotes/origin/master) Author: Stefan Monnier Date: Thu Mar 21 21:43:38 2024 -0400 * lisp/help.el (help--analyze-key): Use `help-fns-function-name` diff --git a/lisp/help.el b/lisp/help.el index 4171d0c57c7..bafe6032942 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -926,7 +926,9 @@ in the selected window." (let ((key-desc (help-key-description key untranslated))) (if (help--binding-undefined-p defn) (format "%s%s is undefined" key-desc mouse-msg) - (format "%s%s runs the command %S" key-desc mouse-msg defn))) + (format "%s%s runs the command %s" key-desc mouse-msg + (if (symbolp defn) (prin1-to-string defn) + (help-fns-function-name defn))))) defn event mouse-msg))) (defun help--filter-info-list (info-list i) commit a1f8702e8345254e6898d35e554bdc06ab09c3ca Author: Stefan Monnier Date: Thu Mar 21 19:40:20 2024 -0400 (help-fns-function-name): New function Consolidate code used in profiler and help--describe-command, and improve it while we're at it. Also use #' to quote a few function names along the way. * lisp/help-fns.el (help-fns--function-numbers, help-fns--function-names): New vars. (help-fns--display-function): New aux function. (help-fns-function-name): New function, inspired from `help--describe-command`. * lisp/help.el (help--describe-command): Use `help-fns-function-name`. (help--for-help-make-sections): Remove redundant "" arg to `mapconcat`. * lisp/profiler.el (profiler-format-entry, profiler-fixup-entry): Delete functions. (profiler-report-make-entry-part): Use `help-fns-function-name` instead. (profiler-report-find-entry): Use `push-button`. * lisp/transient.el (transient--debug): Use `help-fns-function-name` when available. diff --git a/etc/NEWS b/etc/NEWS index ba0e4c80fa0..eda84d588a8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1647,6 +1647,12 @@ values. * Lisp Changes in Emacs 30.1 +** New function 'help-fns-function-name'. +For named functions, it just returns the name and otherwise +it returns a short "unique" string that identifies the function. +In either case, the string is propertized so clicking on it gives +further details. + ** New function 'cl-type-of'. This function is like 'type-of' except that it sometimes returns a more precise type. For example, for nil and t it returns 'null' diff --git a/lisp/bind-key.el b/lisp/bind-key.el index 1e59c75566a..780314fecbd 100644 --- a/lisp/bind-key.el +++ b/lisp/bind-key.el @@ -468,6 +468,7 @@ other modes. See `override-global-mode'." ((and bind-key-describe-special-forms (functionp elem) (stringp (setq doc (documentation elem)))) doc) ;;FIXME: Keep only the first line? + ;; FIXME: Use `help-fns-function-name'? ((consp elem) (if (symbolp (car elem)) (format "#<%s>" (car elem)) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 15d87f9925c..422f6e9dddf 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -2448,6 +2448,74 @@ one of them returns non-nil." (setq buffer-undo-list nil) (texinfo-mode))) +(defconst help-fns--function-numbers + (make-hash-table :test 'equal :weakness 'value)) +(defconst help-fns--function-names (make-hash-table :weakness 'key)) + +(defun help-fns--display-function (function) + (cond + ((subr-primitive-p function) + (describe-function function)) + ((and (compiled-function-p function) + (not (and (fboundp 'kmacro-p) (kmacro-p function)))) + (disassemble function)) + (t + ;; FIXME: Use cl-print! + (pp-display-expression function "*Help Source*" (consp function))))) + +;;;###autoload +(defun help-fns-function-name (function) + "Return a short string representing FUNCTION." + ;; FIXME: For kmacros, should we print the key-sequence? + (cond + ((symbolp function) + (let ((name (if (eq (intern-soft (symbol-name function)) function) + (symbol-name function) + (concat "#:" (symbol-name function))))) + (if (not (fboundp function)) + name + (make-text-button name nil + 'type 'help-function + 'help-args (list function))))) + ((gethash function help-fns--function-names)) + ((subrp function) + (let ((name (subr-name function))) + ;; FIXME: For native-elisp-functions, should we use `help-function' + ;; or `disassemble'? + (format "#<%s %s>" + (cl-type-of function) + (make-text-button name nil + 'type 'help-function + ;; Let's hope the subr hasn't been redefined! + 'help-args (list (intern name)))))) + (t + (let ((type (or (oclosure-type function) + (if (consp function) + (car function) (cl-type-of function)))) + (hash (sxhash-eq function)) + ;; Use 3 digits minimum. + (mask #xfff) + name) + (while + (let* ((hex (format (concat "%0" + (number-to-string (1+ (/ (logb mask) 4))) + "X") + (logand mask hash))) + ;; FIXME: For kmacros, we don't want to `disassemble'! + (button (buttonize + hex #'help-fns--display-function function + ;; FIXME: Shouldn't `buttonize' add + ;; the "mouse-2, RET:" prefix? + "mouse-2, RET: Display the function's body"))) + (setq name (format "#<%s %s>" type button)) + (and (< mask (abs hash)) ; We can add more digits. + (gethash name help-fns--function-numbers))) + ;; Add a digit. + (setq mask (+ (ash mask 4) #x0f))) + (puthash name function help-fns--function-numbers) + (puthash function name help-fns--function-names) + name)))) + (provide 'help-fns) ;;; help-fns.el ends here diff --git a/lisp/help.el b/lisp/help.el index c6a1e3c6bd9..4171d0c57c7 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -301,6 +301,8 @@ Do not call this in the scope of `with-help-window'." (let ((first-message (cond ((or pop-up-frames + ;; FIXME: `special-display-p' is obsolete since + ;; the vars on which it depends are obsolete! (special-display-p (buffer-name standard-output))) (setq help-return-method (cons (selected-window) t)) ;; If the help output buffer is a special display buffer, @@ -382,9 +384,9 @@ Do not call this in the scope of `with-help-window'." (propertize title 'face 'help-for-help-header) "\n\n" (help--for-help-make-commands commands)))) - sections "")) + sections)) -(defalias 'help 'help-for-help) +(defalias 'help #'help-for-help) (make-help-screen help-for-help (purecopy "Type a help option: [abcCdefFgiIkKlLmnprstvw.] C-[cdefmnoptw] or ?") (concat @@ -876,7 +878,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (format "%s (translated from %s)" string otherstring)))))) (defun help--binding-undefined-p (defn) - (or (null defn) (integerp defn) (equal defn 'undefined))) + (or (null defn) (integerp defn) (equal defn #'undefined))) (defun help--analyze-key (key untranslated &optional buffer) "Get information about KEY its corresponding UNTRANSLATED events. @@ -1221,7 +1223,7 @@ appeared on the mode-line." (defun describe-minor-mode-completion-table-for-symbol () ;; In order to list up all minor modes, minor-mode-list ;; is used here instead of minor-mode-alist. - (delq nil (mapcar 'symbol-name minor-mode-list))) + (delq nil (mapcar #'symbol-name minor-mode-list))) (defun describe-minor-mode-from-symbol (symbol) "Display documentation of a minor mode given as a symbol, SYMBOL." @@ -1644,34 +1646,14 @@ Return nil if the key sequence is too long." (t value)))) (defun help--describe-command (definition &optional translation) - (cond ((symbolp definition) - (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)) + (cond ((or (stringp definition) (vectorp definition)) (if translation (insert (key-description definition nil) "\n") + ;; These should be rare nowadays, replaced by `kmacro's. (insert "Keyboard Macro\n"))) ((keymapp definition) (insert "Prefix Command\n")) - ((byte-code-function-p definition) - (insert (format "[%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")))) + (t (insert (help-fns-function-name definition) "\n")))) (define-obsolete-function-alias 'help--describe-translation #'help--describe-command "29.1") @@ -2011,8 +1993,8 @@ and some others." (if temp-buffer-resize-mode ;; `help-make-xrefs' may add a `back' button and thus increase the ;; text size, so `resize-temp-buffer-window' must be run *after* it. - (add-hook 'temp-buffer-show-hook 'resize-temp-buffer-window 'append) - (remove-hook 'temp-buffer-show-hook 'resize-temp-buffer-window))) + (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.") @@ -2256,7 +2238,7 @@ The `temp-buffer-window-setup-hook' hook is called." ;; Don't print to *Help*; that would clobber Help history. (defun help-form-show () "Display the output of a non-nil `help-form'." - (let ((msg (eval help-form))) + (let ((msg (eval help-form t))) (if (stringp msg) (with-output-to-temp-buffer " *Char Help*" (princ msg))))) @@ -2421,7 +2403,7 @@ the same names as used in the original source code, when possible." (t arg))) arglist))) -(define-obsolete-function-alias 'help-make-usage 'help--make-usage "25.1") +(define-obsolete-function-alias 'help-make-usage #'help--make-usage "25.1") (defun help--make-usage-docstring (fn arglist) (let ((print-escape-newlines t)) diff --git a/lisp/profiler.el b/lisp/profiler.el index 80f84037a63..4e02cd1d890 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el @@ -38,8 +38,7 @@ (defcustom profiler-sampling-interval 1000000 "Default sampling interval in nanoseconds." - :type 'natnum - :group 'profiler) + :type 'natnum) ;;; Utilities @@ -68,7 +67,7 @@ collect c into s do (cl-decf i) finally return - (apply 'string (if (eq (car s) ?,) (cdr s) s))) + (apply #'string (if (eq (car s) ?,) (cdr s) s))) (profiler-ensure-string number))) (defun profiler-format (fmt &rest args) @@ -76,7 +75,7 @@ for arg in args for str = (cond ((consp subfmt) - (apply 'profiler-format subfmt arg)) + (apply #'profiler-format subfmt arg)) ((stringp subfmt) (format subfmt arg)) ((and (symbolp subfmt) @@ -91,7 +90,8 @@ if (< width len) collect (progn (put-text-property (max 0 (- width 2)) len 'invisible 'profiler str) - str) into frags + str) + into frags else collect (let ((padding (make-string (max 0 (- width len)) ?\s))) @@ -100,32 +100,11 @@ (right (concat padding str)))) into frags finally return (apply #'concat frags))) - - -;;; Entries - -(defun profiler-format-entry (entry) - "Format ENTRY in human readable string. -ENTRY would be a function name of a function itself." - (cond ((memq (car-safe entry) '(closure lambda)) - (format "#" (sxhash entry))) - ((byte-code-function-p entry) - (format "#" (sxhash entry))) - ((or (subrp entry) (symbolp entry) (stringp entry)) - (format "%s" entry)) - (t - (format "#" (sxhash entry))))) - -(defun profiler-fixup-entry (entry) - (if (symbolp entry) - entry - (profiler-format-entry entry))) - ;;; Backtraces (defun profiler-fixup-backtrace (backtrace) - (apply 'vector (mapcar 'profiler-fixup-entry backtrace))) + (apply #'vector (mapcar #'help-fns-function-name backtrace))) ;;; Logs @@ -434,18 +413,15 @@ Optional argument MODE means only check for the specified mode (cpu or mem)." (defcustom profiler-report-closed-mark "+" "An indicator of closed calltrees." - :type 'string - :group 'profiler) + :type 'string) (defcustom profiler-report-open-mark "-" "An indicator of open calltrees." - :type 'string - :group 'profiler) + :type 'string) (defcustom profiler-report-leaf-mark " " "An indicator of calltree leaves." - :type 'string - :group 'profiler) + :type 'string) (defvar profiler-report-cpu-line-format '((17 right ((12 right) @@ -474,17 +450,18 @@ Do not touch this variable directly.") (let ((string (cond ((eq entry t) "Others") - ((and (symbolp entry) - (fboundp entry)) - (propertize (symbol-name entry) - 'face 'link - 'follow-link "\r" - 'mouse-face 'highlight - 'help-echo "\ + (t (propertize (help-fns-function-name entry) + ;; Override the `button-map' which + ;; otherwise adds RET, mouse-1, and TAB + ;; bindings we don't want. :-( + 'keymap '(make-sparse-keymap) + 'follow-link "\r" + ;; FIXME: The help-echo code gets confused + ;; by the `follow-link' property and rewrites + ;; `mouse-2' to `mouse-1' :-( + 'help-echo "\ mouse-2: jump to definition\n\ -RET: expand or collapse")) - (t - (profiler-format-entry entry))))) +RET: expand or collapse"))))) (propertize string 'profiler-entry entry))) (defun profiler-report-make-name-part (tree) @@ -719,10 +696,13 @@ point." (current-buffer)) (and event (setq event (event-end event)) (posn-set-point event)) - (let ((tree (profiler-report-calltree-at-point))) - (when tree - (let ((entry (profiler-calltree-entry tree))) - (find-function entry)))))) + (save-excursion + (forward-line 0) + (let ((eol (pos-eol))) + (forward-button 1) + (if (> (point) eol) + (error "No entry found") + (push-button)))))) (defun profiler-report-describe-entry () "Describe entry at point." diff --git a/lisp/transient.el b/lisp/transient.el index 2d8566a3ac4..c3b9448e2c4 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -1249,7 +1249,7 @@ symbol property.") (when (and (boundp 'read-extended-command-predicate) ; since Emacs 28.1 (not read-extended-command-predicate)) (setq read-extended-command-predicate - 'transient-command-completion-not-suffix-only-p)) + #'transient-command-completion-not-suffix-only-p)) (defun transient-parse-suffix (prefix suffix) "Parse SUFFIX, to be added to PREFIX. @@ -1258,7 +1258,7 @@ SUFFIX is a suffix command or a group specification (of the same forms as expected by `transient-define-prefix'). Intended for use in a group's `:setup-children' function." (cl-assert (and prefix (symbolp prefix))) - (eval (car (transient--parse-child prefix suffix)))) + (eval (car (transient--parse-child prefix suffix)) t)) (defun transient-parse-suffixes (prefix suffixes) "Parse SUFFIXES, to be added to PREFIX. @@ -1278,7 +1278,7 @@ Intended for use in a group's `:setup-children' function." (string suffix))) (mem (transient--layout-member loc prefix)) (elt (car mem))) - (setq suf (eval suf)) + (setq suf (eval suf t)) (cond ((not mem) (message "Cannot insert %S into %s; %s not found" @@ -1736,7 +1736,8 @@ to `transient-predicate-map'. Also see `transient-base-map'." "Hide common commands" "Show common permanently"))) (list "C-x l" "Show/hide suffixes" #'transient-set-level) - (list "C-x a" #'transient-toggle-level-limit)))))))) + (list "C-x a" #'transient-toggle-level-limit))))) + t))) (defvar-keymap transient-popup-navigation-map :doc "One of the keymaps used when popup navigation is enabled. @@ -2574,10 +2575,11 @@ value. Otherwise return CHILDREN as is." (if (symbolp arg) (message "-- %-22s (cmd: %s, event: %S, exit: %s%s)" arg - (or (and (symbolp this-command) this-command) - (if (byte-code-function-p this-command) - "#[...]" - this-command)) + (if (fboundp 'help-fns-function-name) + (help-fns-function-name this-command) + (if (byte-code-function-p this-command) + "#[...]" + this-command)) (key-description (this-command-keys-vector)) transient--exitp (cond ((keywordp (car args)) @@ -2982,7 +2984,7 @@ transient is active." (interactive) (transient-set-value (transient-prefix-object))) -(defalias 'transient-set-and-exit 'transient-set +(defalias 'transient-set-and-exit #'transient-set "Set active transient's value for this Emacs session and exit.") (defun transient-save () @@ -2990,7 +2992,7 @@ transient is active." (interactive) (transient-save-value (transient-prefix-object))) -(defalias 'transient-save-and-exit 'transient-save +(defalias 'transient-save-and-exit #'transient-save "Save active transient's value for this and future Emacs sessions and exit.") (defun transient-reset () commit 946280365d40104dffd5329eebefc02329f72041 Author: Stefan Monnier Date: Thu Mar 21 19:26:33 2024 -0400 (make-help-screen): Move most of the code out to a function This avoids problems like variable-name capture and lets compiler messages point to the actual source code. * lisp/help-macro.el (help--help-screen): New function, extracted from `make-help-screen`. (make-help-screen): Use it. diff --git a/lisp/help-macro.el b/lisp/help-macro.el index cea8b379ec0..8a16e85a329 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -92,141 +92,146 @@ and then returns." `(defun ,fname () "Help command." (interactive) - (let ((line-prompt - (substitute-command-keys ,help-line)) - (help-buffer-under-preparation t)) - (when three-step-help - (message "%s" line-prompt)) - (let* ((help-screen ,help-text) - ;; We bind overriding-local-map for very small - ;; sections, *excluding* where we switch buffers - ;; and where we execute the chosen help command. - (local-map (make-sparse-keymap)) - (new-minor-mode-map-alist minor-mode-map-alist) - (prev-frame (selected-frame)) - config new-frame key char) - (when (string-match "%THIS-KEY%" help-screen) - (setq help-screen - (replace-match (help--key-description-fontified - (substring (this-command-keys) 0 -1)) - t t help-screen))) - (unwind-protect - (let ((minor-mode-map-alist nil)) - (setcdr local-map ,helped-map) - (define-key local-map [t] 'undefined) - ;; Make the scroll bar keep working normally. - (define-key local-map [vertical-scroll-bar] - (lookup-key global-map [vertical-scroll-bar])) - (if three-step-help - (progn - (setq key (let ((overriding-local-map local-map)) - (read-key-sequence nil))) - ;; Make the HELP key translate to C-h. - (if (lookup-key function-key-map key) - (setq key (lookup-key function-key-map key))) - (setq char (aref key 0))) - (setq char ??)) - (when (or (eq char ??) (eq char help-char) - (memq char help-event-list)) - (setq config (current-window-configuration)) - (pop-to-buffer (or ,buffer-name " *Metahelp*") nil t) - (and (fboundp 'make-frame) - (not (eq (window-frame) - prev-frame)) - (setq new-frame (window-frame) - config nil)) - (setq buffer-read-only nil) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert (substitute-command-keys help-screen))) - (let ((minor-mode-map-alist new-minor-mode-map-alist)) - (help-mode) - (variable-pitch-mode) - (setq new-minor-mode-map-alist minor-mode-map-alist)) - (goto-char (point-min)) - (while (or (memq char (append help-event-list - (cons help-char '( ?? ?\C-v ?\s ?\177 ?\M-v ?\S-\s - deletechar backspace vertical-scroll-bar - home end next prior up down)))) - (eq (car-safe char) 'switch-frame) - (equal key "\M-v")) - (condition-case nil - (cond - ((eq (car-safe char) 'switch-frame) - (handle-switch-frame char)) - ((memq char '(?\C-v ?\s next end)) - (scroll-up)) - ((or (memq char '(?\177 ?\M-v ?\S-\s deletechar backspace prior home)) - (equal key "\M-v")) - (scroll-down)) - ((memq char '(down)) - (scroll-up 1)) - ((memq char '(up)) - (scroll-down 1))) - (error nil)) - (let ((cursor-in-echo-area t) - (overriding-local-map local-map)) - (frame-toggle-on-screen-keyboard (selected-frame) nil) - (setq key (read-key-sequence - (format "Type one of listed options%s: " - (if (pos-visible-in-window-p - (point-max)) - "" - (concat ", or " - (help--key-description-fontified (kbd "")) - "/" - (help--key-description-fontified (kbd "")) - "/" - (help--key-description-fontified (kbd "SPC")) - "/" - (help--key-description-fontified (kbd "DEL")) - " to scroll"))) - nil nil nil nil - ;; Disable ``text conversion''. OS - ;; input methods might otherwise chose - ;; to insert user input directly into - ;; a buffer. - t) - char (aref key 0))) - - ;; If this is a scroll bar command, just run it. - (when (eq char 'vertical-scroll-bar) - (command-execute (lookup-key local-map key) nil key)))) - ;; We don't need the prompt any more. - (message "") - ;; Mouse clicks are not part of the help feature, - ;; so reexecute them in the standard environment. - (if (listp char) - (setq unread-command-events - (cons char unread-command-events) - config nil) - (let ((defn (lookup-key local-map key))) - (if defn - (progn - (when config - (set-window-configuration config) - (setq config nil)) - ;; Temporarily rebind `minor-mode-map-alist' - ;; to `new-minor-mode-map-alist' (Bug#10454). - (let ((minor-mode-map-alist new-minor-mode-map-alist)) - ;; `defn' must make sure that its frame is - ;; selected, so we won't iconify it below. - (call-interactively defn)) - (when new-frame - ;; Do not iconify the selected frame. - (unless (eq new-frame (selected-frame)) - (iconify-frame new-frame)) - (setq new-frame nil))) - (unless (equal (key-description key) "C-g") - (message (substitute-command-keys - (format "No help command is bound to `\\`%s''" - (key-description key)))) - (ding)))))) - (when config - (set-window-configuration config)) - (when new-frame - (iconify-frame new-frame)) - (setq minor-mode-map-alist new-minor-mode-map-alist)))))) + (help--help-screen ,help-line ,help-text ,helped-map ,buffer-name))) + + +;;;###autoload +(defun help--help-screen (help-line help-text helped-map buffer-name) + (let ((line-prompt + (substitute-command-keys help-line)) + (help-buffer-under-preparation t)) + (when three-step-help + (message "%s" line-prompt)) + (let* ((help-screen help-text) + ;; We bind overriding-local-map for very small + ;; sections, *excluding* where we switch buffers + ;; and where we execute the chosen help command. + (local-map (make-sparse-keymap)) + (new-minor-mode-map-alist minor-mode-map-alist) + (prev-frame (selected-frame)) + config new-frame key char) + (when (string-match "%THIS-KEY%" help-screen) + (setq help-screen + (replace-match (help--key-description-fontified + (substring (this-command-keys) 0 -1)) + t t help-screen))) + (unwind-protect + (let ((minor-mode-map-alist nil)) + (setcdr local-map helped-map) + (define-key local-map [t] #'undefined) + ;; Make the scroll bar keep working normally. + (define-key local-map [vertical-scroll-bar] + (lookup-key global-map [vertical-scroll-bar])) + (if three-step-help + (progn + (setq key (let ((overriding-local-map local-map)) + (read-key-sequence nil))) + ;; Make the HELP key translate to C-h. + (if (lookup-key function-key-map key) + (setq key (lookup-key function-key-map key))) + (setq char (aref key 0))) + (setq char ??)) + (when (or (eq char ??) (eq char help-char) + (memq char help-event-list)) + (setq config (current-window-configuration)) + (pop-to-buffer (or buffer-name " *Metahelp*") nil t) + (and (fboundp 'make-frame) + (not (eq (window-frame) + prev-frame)) + (setq new-frame (window-frame) + config nil)) + (setq buffer-read-only nil) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (substitute-command-keys help-screen))) + (let ((minor-mode-map-alist new-minor-mode-map-alist)) + (help-mode) + (variable-pitch-mode) + (setq new-minor-mode-map-alist minor-mode-map-alist)) + (goto-char (point-min)) + (while (or (memq char (append help-event-list + (cons help-char '( ?? ?\C-v ?\s ?\177 ?\M-v ?\S-\s + deletechar backspace vertical-scroll-bar + home end next prior up down)))) + (eq (car-safe char) 'switch-frame) + (equal key "\M-v")) + (condition-case nil + (cond + ((eq (car-safe char) 'switch-frame) + (handle-switch-frame char)) + ((memq char '(?\C-v ?\s next end)) + (scroll-up)) + ((or (memq char '(?\177 ?\M-v ?\S-\s deletechar backspace prior home)) + (equal key "\M-v")) + (scroll-down)) + ((memq char '(down)) + (scroll-up 1)) + ((memq char '(up)) + (scroll-down 1))) + (error nil)) + (let ((cursor-in-echo-area t) + (overriding-local-map local-map)) + (frame-toggle-on-screen-keyboard (selected-frame) nil) + (setq key (read-key-sequence + (format "Type one of listed options%s: " + (if (pos-visible-in-window-p + (point-max)) + "" + (concat ", or " + (help--key-description-fontified (kbd "")) + "/" + (help--key-description-fontified (kbd "")) + "/" + (help--key-description-fontified (kbd "SPC")) + "/" + (help--key-description-fontified (kbd "DEL")) + " to scroll"))) + nil nil nil nil + ;; Disable ``text conversion''. OS + ;; input methods might otherwise chose + ;; to insert user input directly into + ;; a buffer. + t) + char (aref key 0))) + + ;; If this is a scroll bar command, just run it. + (when (eq char 'vertical-scroll-bar) + (command-execute (lookup-key local-map key) nil key)))) + ;; We don't need the prompt any more. + (message "") + ;; Mouse clicks are not part of the help feature, + ;; so reexecute them in the standard environment. + (if (listp char) + (setq unread-command-events + (cons char unread-command-events) + config nil) + (let ((defn (lookup-key local-map key))) + (if defn + (progn + (when config + (set-window-configuration config) + (setq config nil)) + ;; Temporarily rebind `minor-mode-map-alist' + ;; to `new-minor-mode-map-alist' (Bug#10454). + (let ((minor-mode-map-alist new-minor-mode-map-alist)) + ;; `defn' must make sure that its frame is + ;; selected, so we won't iconify it below. + (call-interactively defn)) + (when new-frame + ;; Do not iconify the selected frame. + (unless (eq new-frame (selected-frame)) + (iconify-frame new-frame)) + (setq new-frame nil))) + (unless (equal (key-description key) "C-g") + (message (substitute-command-keys + (format "No help command is bound to `\\`%s''" + (key-description key)))) + (ding)))))) + (when config + (set-window-configuration config)) + (when new-frame + (iconify-frame new-frame)) + (setq minor-mode-map-alist new-minor-mode-map-alist))))) (provide 'help-macro) commit c214fc9626c8b37e4d155a6d3caebe2e09fd0ab2 Author: Jonas Bernoulli Date: Thu Mar 21 23:55:38 2024 +0100 Update to Transient v0.6.0-1-gcaef3347 diff --git a/doc/misc/transient.texi b/doc/misc/transient.texi index f76edc6b1e4..3a6486903bf 100644 --- a/doc/misc/transient.texi +++ b/doc/misc/transient.texi @@ -31,7 +31,7 @@ General Public License for more details. @finalout @titlepage @title Transient User and Developer Manual -@subtitle for version 0.5.2 +@subtitle for version 0.6.0 @author Jonas Bernoulli @page @vskip 0pt plus 1filll @@ -53,7 +53,7 @@ resource to get over that hurdle is Psionic K's interactive tutorial, available at @uref{https://github.com/positron-solutions/transient-showcase}. @noindent -This manual is for Transient version 0.5.2. +This manual is for Transient version 0.6.0. @insertcopying @end ifnottex @@ -554,7 +554,7 @@ state, you have to make sure that that state is currently active. @item @kbd{C-x a} (@code{transient-toggle-level-limit}) @kindex C-x a @findex transient-toggle-level-limit -This command toggle whether suffixes that are on levels lower than +This command toggle whether suffixes that are on levels higher than the level specified by @code{transient-default-level} are temporarily available anyway. @end table @@ -1206,9 +1206,19 @@ The returned children must have the same form as stored in the prefix's @code{transient--layout} property, but it is often more convenient to use the same form as understood by @code{transient-define-prefix}, described below. If you use the latter approach, you can use the -@code{transient-parse-child} and @code{transient-parse-children} functions to +@code{transient-parse-suffixes} and @code{transient-parse-suffix} functions to transform them from the convenient to the expected form. +If you explicitly specify children and then transform them using +@code{:setup-chilren}, then the class of the group is determined as usual, +based on explicitly specified children. + +If you do not explicitly specify children and thus rely solely on +@code{:setup-children}, then you must specify the class using @code{:class}. +For backward compatibility, if you fail to do so, @code{transient-column} +is used and a warning is displayed. This warning will eventually +be replaced with an error. + @item The boolean @code{:pad-keys} argument controls whether keys of all suffixes contained in a group are right padded, effectively aligning the @@ -1220,11 +1230,11 @@ The @var{ELEMENT}s are either all subgroups, or all suffixes and strings. subgroups with commands at the same level, though in principle there is nothing that prevents that.) -If the @var{ELEMENT}s are not subgroups, then they can be a mixture of lists -that specify commands and strings. Strings are inserted verbatim into -the buffer. The empty string can be used to insert gaps between -suffixes, which is particularly useful if the suffixes are outlined as -a table. +If the @var{ELEMENT}s are not subgroups, then they can be a mixture of +lists, which specify commands, and strings. Strings are inserted +verbatim into the buffer. The empty string can be used to insert gaps +between suffixes, which is particularly useful if the suffixes are +outlined as a table. Inside group specifications, including inside contained suffix specifications, nothing has to be quoted and quoting anyway is diff --git a/lisp/transient.el b/lisp/transient.el index bb35746e186..2d8566a3ac4 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -5,7 +5,7 @@ ;; Author: Jonas Bernoulli ;; URL: https://github.com/magit/transient ;; Keywords: extensions -;; Version: 0.5.2 +;; Version: 0.6.0 ;; SPDX-License-Identifier: GPL-3.0-or-later @@ -93,17 +93,20 @@ enclosed in a `progn' form. ELSE-FORMS may be empty." then-form (cons 'progn else-forms))) -(defmacro transient--with-emergency-exit (&rest body) +(defmacro transient--with-emergency-exit (id &rest body) (declare (indent defun)) + (unless (keywordp id) + (setq body (cons id body)) + (setq id nil)) `(condition-case err (let ((debugger #'transient--exit-and-debug)) ,(macroexp-progn body)) ((debug error) - (transient--emergency-exit) + (transient--emergency-exit ,id) (signal (car err) (cdr err))))) (defun transient--exit-and-debug (&rest args) - (transient--emergency-exit) + (transient--emergency-exit :debugger) (apply #'debug args)) ;;; Options @@ -668,6 +671,7 @@ If `transient-save-history' is nil, then do nothing." (incompatible :initarg :incompatible :initform nil) (suffix-description :initarg :suffix-description) (variable-pitch :initarg :variable-pitch :initform nil) + (column-widths :initarg :column-widths :initform nil) (unwind-suffix :documentation "Internal use." :initform nil)) "Transient prefix command. @@ -725,7 +729,8 @@ slot is non-nil." :abstract t) (defclass transient-suffix (transient-child) - ((key :initarg :key) + ((definition :allocation :class :initform nil) + (key :initarg :key) (command :initarg :command) (transient :initarg :transient) (format :initarg :format :initform " %k %d") @@ -946,7 +951,10 @@ ARGLIST. The infix arguments are usually accessed by using (pcase-let ((`(,class ,slots ,_ ,docstr ,body) (transient--expand-define-args args arglist))) `(progn - (defalias ',name (lambda ,arglist ,@body)) + (defalias ',name + ,(if (and (not body) class (oref-default class definition)) + `(oref-default ',class definition) + `(lambda ,arglist ,@body))) (put ',name 'interactive-only t) (put ',name 'function-documentation ,docstr) (put ',name 'transient--suffix @@ -997,7 +1005,7 @@ keyword. `(progn (defalias ',name #'transient--default-infix-command) (put ',name 'interactive-only t) - (put ',name 'command-modes (list 'not-a-mode)) + (put ',name 'completion-predicate #'transient--suffix-only) (put ',name 'function-documentation ,docstr) (put ',name 'transient--suffix (,(or class 'transient-switch) :command ',name ,@slots))))) @@ -1013,21 +1021,39 @@ example, sets a variable, use `transient-define-infix' instead. (defun transient--default-infix-command () ;; Most infix commands are but an alias for this command. - "Cannot show any documentation for this anonymous infix command. + "Cannot show any documentation for this transient infix command. + +When you request help for an infix command using `transient-help', that +usually shows the respective man-page and tries to jump to the location +where the respective argument is being described. -This infix command was defined anonymously, i.e., it was define -inside a call to `transient-define-prefix'. +If no man-page is specified for the containing transient menu, then the +docstring is displayed instead, if any. -When you request help for such an infix command, then we usually -show the respective man-page and jump to the location where the -respective argument is being described. This isn't possible in -this case, because the `man-page' slot was not set in this case." +If the infix command doesn't have a docstring, as is the case here, then +this docstring is displayed instead, because technically infix commands +are aliases for `transient--default-infix-command'. + +`describe-function' also shows the docstring of the infix command, +falling back to that of the same aliased command." (interactive) (let ((obj (transient-suffix-object))) (transient-infix-set obj (transient-infix-read obj))) (transient--show)) (put 'transient--default-infix-command 'interactive-only t) -(put 'transient--default-infix-command 'command-modes (list 'not-a-mode)) +(put 'transient--default-infix-command 'completion-predicate + #'transient--suffix-only) + +(defun transient--find-function-advised-original (fn func) + "Return nil instead of `transient--default-infix-command'. +When using `find-function' to jump to the definition of a transient +infix command/argument, then we want to actually jump to that, not to +the definition of `transient--default-infix-command', which all infix +commands are aliases for." + (let ((val (funcall fn func))) + (and val (not (eq val 'transient--default-infix-command)) val))) +(advice-add 'find-function-advised-original :around + #'transient--find-function-advised-original) (eval-and-compile (defun transient--expand-define-args (args &optional arglist) @@ -1056,7 +1082,8 @@ this case, because the `man-page' slot was not set in this case." args)))) (defun transient--parse-child (prefix spec) - (cl-etypecase spec + (cl-typecase spec + (null (error "Invalid transient--parse-child spec: %s" spec)) (symbol (let ((value (symbol-value spec))) (if (and (listp value) (or (listp (car value)) @@ -1065,7 +1092,8 @@ this case, because the `man-page' slot was not set in this case." (transient--parse-child prefix value)))) (vector (and-let* ((c (transient--parse-group prefix spec))) (list c))) (list (and-let* ((c (transient--parse-suffix prefix spec))) (list c))) - (string (list spec)))) + (string (list spec)) + (t (error "Invalid transient--parse-child spec: %s" spec)))) (defun transient--parse-group (prefix spec) (setq spec (append spec nil)) @@ -1086,12 +1114,16 @@ this case, because the `man-page' slot was not set in this case." (and (listp val) (not (eq (car val) 'lambda)))) (setq args (plist-put args key (macroexp-quote val)))) ((setq args (plist-put args key val)))))) + (unless (or spec class (not (plist-get args :setup-children))) + (message "WARNING: %s: When %s is used, %s must also be specified" + 'transient-define-prefix :setup-children :class)) (list 'vector (or level transient--default-child-level) - (or class - (if (vectorp car) - (quote 'transient-columns) - (quote 'transient-column))) + (cond (class) + ((or (vectorp car) + (and car (symbolp car))) + (quote 'transient-columns)) + ((quote 'transient-column))) (and args (cons 'list args)) (cons 'list (cl-mapcan (lambda (s) (transient--parse-child prefix s)) @@ -1130,14 +1162,15 @@ this case, because the `man-page' slot was not set in this case." (format "transient:%s:%s" prefix (let ((desc (plist-get args :description))) - (if (and desc (or (stringp desc) (symbolp desc))) + (if (and (stringp desc) + (length< desc 16)) desc (plist-get args :key))))))) (setq args (plist-put args :command `(prog1 ',sym (put ',sym 'interactive-only t) - (put ',sym 'command-modes (list 'not-a-mode)) + (put ',sym 'completion-predicate #'transient--suffix-only) (defalias ',sym ,(if (eq (car-safe cmd) 'lambda) cmd @@ -1160,7 +1193,7 @@ this case, because the `man-page' slot was not set in this case." args :command `(prog1 ',sym (put ',sym 'interactive-only t) - (put ',sym 'command-modes (list 'not-a-mode)) + (put ',sym 'completion-predicate #'transient--suffix-only) (defalias ',sym #'transient--default-infix-command)))) (cond ((and car (not (keywordp car))) (setq class 'transient-option) @@ -1198,12 +1231,33 @@ this case, because the `man-page' slot was not set in this case." (and (string-match "\\`\\(-[a-zA-Z]\\)\\(\\'\\|=\\)" arg) (match-string 1 arg)))) +(defun transient-command-completion-not-suffix-only-p (symbol _buffer) + "Say whether SYMBOL should be offered as a completion. +If the value of SYMBOL's `completion-predicate' property is +`transient--suffix-only', then return nil, otherwise return t. +This is the case when a command should only ever be used as a +suffix of a transient prefix command (as opposed to bindings +in regular keymaps or by using `execute-extended-command')." + (not (eq (get symbol 'completion-predicate) 'transient--suffix-only))) + +(defalias 'transient--suffix-only #'ignore + "Ignore ARGUMENTS, do nothing, and return nil. +Also see `transient-command-completion-not-suffix-only-p'. +Only use this alias as the value of the `completion-predicate' +symbol property.") + +(when (and (boundp 'read-extended-command-predicate) ; since Emacs 28.1 + (not read-extended-command-predicate)) + (setq read-extended-command-predicate + 'transient-command-completion-not-suffix-only-p)) + (defun transient-parse-suffix (prefix suffix) "Parse SUFFIX, to be added to PREFIX. PREFIX is a prefix command, a symbol. SUFFIX is a suffix command or a group specification (of the same forms as expected by `transient-define-prefix'). Intended for use in a group's `:setup-children' function." + (cl-assert (and prefix (symbolp prefix))) (eval (car (transient--parse-child prefix suffix)))) (defun transient-parse-suffixes (prefix suffixes) @@ -1212,6 +1266,7 @@ PREFIX is a prefix command, a symbol. SUFFIXES is a list of suffix command or a group specification (of the same forms as expected by `transient-define-prefix'). Intended for use in a group's `:setup-children' function." + (cl-assert (and prefix (symbolp prefix))) (mapcar (apply-partially #'transient-parse-suffix prefix) suffixes)) ;;; Edit @@ -1472,7 +1527,8 @@ drawing in the transient buffer.") (defvar transient--pending-suffix nil "The suffix that is currently being processed. -This is bound while the suffix predicate is being evaluated.") +This is bound while the suffix predicate is being evaluated, +and while functions that return faces are being evaluated.") (defvar transient--pending-group nil "The group that is currently being processed. @@ -1555,33 +1611,35 @@ probably use this instead: (get COMMAND \\='transient--suffix)" (when command (cl-check-type command command)) - (if (or transient--prefix - transient-current-prefix) - (let ((suffixes - (cl-remove-if-not - (lambda (obj) - (eq (oref obj command) - (or command - (if (eq this-command 'transient-set-level) - ;; This is how it can look up for which - ;; command it is setting the level. - this-original-command - this-command)))) - (or transient--suffixes - transient-current-suffixes)))) - (or (and (cdr suffixes) - (cl-find-if - (lambda (obj) - (equal (listify-key-sequence (transient--kbd (oref obj key))) - (listify-key-sequence (this-command-keys)))) - suffixes)) - (car suffixes))) - (and-let* ((obj (transient--suffix-prototype (or command this-command))) + (cond + (transient--pending-suffix) + ((or transient--prefix + transient-current-prefix) + (let ((suffixes + (cl-remove-if-not + (lambda (obj) + (eq (oref obj command) + (or command + (if (eq this-command 'transient-set-level) + ;; This is how it can look up for which + ;; command it is setting the level. + this-original-command + this-command)))) + (or transient--suffixes + transient-current-suffixes)))) + (or (and (cdr suffixes) + (cl-find-if + (lambda (obj) + (equal (listify-key-sequence (transient--kbd (oref obj key))) + (listify-key-sequence (this-command-keys)))) + suffixes)) + (car suffixes)))) + ((and-let* ((obj (transient--suffix-prototype (or command this-command))) (obj (clone obj))) (progn ; work around debbugs#31840 (transient-init-scope obj) (transient-init-value obj) - obj)))) + obj))))) (defun transient--suffix-prototype (command) (or (get command 'transient--suffix) @@ -1762,7 +1820,10 @@ of the corresponding object." ;; an unbound key, then Emacs calls the `undefined' command ;; but does not set `this-command', `this-original-command' ;; or `real-this-command' accordingly. Instead they are nil. - "" #'transient--do-warn) + "" #'transient--do-warn + ;; Bound to the `mouse-movement' event, this command is similar + ;; to `ignore'. + "" #'transient--do-noop) (defvar transient--transient-map nil) (defvar transient--predicate-map nil) @@ -1821,7 +1882,7 @@ of the corresponding object." (defun transient--make-predicate-map () (let* ((default (transient--resolve-pre-command (oref transient--prefix transient-suffix))) - (return (and transient-current-prefix (eq default t))) + (return (and transient--stack (eq default t))) (map (make-sparse-keymap))) (set-keymap-parent map transient-predicate-map) (when (or (and (slot-boundp transient--prefix 'transient-switch-frame) @@ -1912,7 +1973,7 @@ the \"scope\" of the transient (see `transient-define-prefix'). This function is also called internally in which case LAYOUT and EDIT may be non-nil." (transient--debug 'setup) - (transient--with-emergency-exit + (transient--with-emergency-exit :setup (cond ((not name) ;; Switching between regular and edit mode. @@ -2166,7 +2227,7 @@ value. Otherwise return CHILDREN as is." (defun transient--pre-command () (transient--debug 'pre-command) - (transient--with-emergency-exit + (transient--with-emergency-exit :pre-command ;; The use of `overriding-terminal-local-map' does not prevent the ;; lookup of command remappings in the overridden maps, which can ;; lead to a suffix being remapped to a non-suffix. We have to undo @@ -2228,14 +2289,14 @@ value. Otherwise return CHILDREN as is." (when (window-live-p transient--window) (let ((remain-in-minibuffer-window (and (minibuffer-selected-window) - (selected-window))) - (buf (window-buffer transient--window))) + (selected-window)))) ;; Only delete the window if it has never shown another buffer. (unless (eq (car (window-parameter transient--window 'quit-restore)) 'other) (with-demoted-errors "Error while exiting transient: %S" (delete-window transient--window))) - (kill-buffer buf) + (when-let ((buffer (get-buffer transient--buffer-name))) + (kill-buffer buffer)) (when remain-in-minibuffer-window (select-window remain-in-minibuffer-window))))) @@ -2253,7 +2314,10 @@ value. Otherwise return CHILDREN as is." ((and transient--prefix transient--redisplay-key) (setq transient--redisplay-key nil) (when transient--showp - (transient--show)))) + (if-let ((win (minibuffer-selected-window))) + (with-selected-window win + (transient--show)) + (transient--show))))) (transient--pop-keymap 'transient--transient-map) (transient--pop-keymap 'transient--redisplay-map) (remove-hook 'pre-command-hook #'transient--pre-command) @@ -2308,7 +2372,7 @@ value. Otherwise return CHILDREN as is." (remove-hook 'minibuffer-exit-hook ,exit))) ,@body))) -(static-if (>= emacs-major-version 30) +(static-if (>= emacs-major-version 30) ;transient--wrap-command (defun transient--wrap-command () (cl-assert (>= emacs-major-version 30) nil @@ -2316,27 +2380,31 @@ value. Otherwise return CHILDREN as is." (letrec ((prefix transient--prefix) (suffix this-command) - (advice (lambda (fn &rest args) - (interactive - (lambda (spec) - (let ((abort t)) - (unwind-protect - (prog1 (advice-eval-interactive-spec spec) - (setq abort nil)) - (when abort - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-interactive) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil)))))) - (unwind-protect - (apply fn args) + (advice + (lambda (fn &rest args) + (interactive + (lambda (spec) + (let ((abort t)) + (unwind-protect + (prog1 (let ((debugger #'transient--exit-and-debug)) + (advice-eval-interactive-spec spec)) + (setq abort nil)) + (when abort (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-command) + (transient--debug 'unwind-interactive) (funcall unwind suffix)) (advice-remove suffix advice) - (oset prefix unwind-suffix nil))))) - (advice-add suffix :around advice '((depth . -99))))) + (oset prefix unwind-suffix nil)))))) + (unwind-protect + (let ((debugger #'transient--exit-and-debug)) + (apply fn args)) + (when-let ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-command) + (funcall unwind suffix)) + (advice-remove suffix advice) + (oset prefix unwind-suffix nil))))) + (when (symbolp this-command) + (advice-add suffix :around advice '((depth . -99)))))) (defun transient--wrap-command () (let* ((prefix transient--prefix) @@ -2346,7 +2414,8 @@ value. Otherwise return CHILDREN as is." (lambda (spec) (let ((abort t)) (unwind-protect - (prog1 (advice-eval-interactive-spec spec) + (prog1 (let ((debugger #'transient--exit-and-debug)) + (advice-eval-interactive-spec spec)) (setq abort nil)) (when abort (when-let ((unwind (oref prefix unwind-suffix))) @@ -2357,7 +2426,8 @@ value. Otherwise return CHILDREN as is." (advice-body (lambda (fn &rest args) (unwind-protect - (apply fn args) + (let ((debugger #'transient--exit-and-debug)) + (apply fn args)) (when-let ((unwind (oref prefix unwind-suffix))) (transient--debug 'unwind-command) (funcall unwind suffix)) @@ -2366,7 +2436,8 @@ value. Otherwise return CHILDREN as is." (setq advice `(lambda (fn &rest args) (interactive ,advice-interactive) (apply ',advice-body fn args))) - (advice-add suffix :around advice '((depth . -99)))))) + (when (symbolp this-command) + (advice-add suffix :around advice '((depth . -99))))))) (defun transient--premature-post-command () (and (equal (this-command-keys-vector) []) @@ -2385,7 +2456,7 @@ value. Otherwise return CHILDREN as is." (defun transient--post-command () (unless (transient--premature-post-command) (transient--debug 'post-command) - (transient--with-emergency-exit + (transient--with-emergency-exit :post-command (cond (transient--exitp (transient--post-exit)) ;; If `this-command' is the current transient prefix, then we ;; have already taken care of updating the transient buffer... @@ -2509,18 +2580,22 @@ value. Otherwise return CHILDREN as is." this-command)) (key-description (this-command-keys-vector)) transient--exitp - (cond ((stringp (car args)) + (cond ((keywordp (car args)) + (format ", from: %s" + (substring (symbol-name (car args)) 1))) + ((stringp (car args)) (concat ", " (apply #'format args))) - (args + ((functionp (car args)) (concat ", " (apply (car args) (cdr args)))) (""))) (apply #'message arg args))))) -(defun transient--emergency-exit () +(defun transient--emergency-exit (&optional id) "Exit the current transient command after an error occurred. When no transient is active (i.e., when `transient--prefix' is -nil) then do nothing." - (transient--debug 'emergency-exit) +nil) then do nothing. Optional ID is a keyword identifying the +exit." + (transient--debug 'emergency-exit id) (when transient--prefix (setq transient--stack nil) (setq transient--exitp t) @@ -2544,6 +2619,7 @@ nil) then do nothing." (defun transient--get-pre-command (&optional cmd enforce-type) (or (and (not (eq enforce-type 'non-suffix)) + (symbolp cmd) (lookup-key transient--predicate-map (vector cmd))) (and (not (eq enforce-type 'suffix)) (transient--resolve-pre-command @@ -3087,14 +3163,14 @@ infix command determines what the new value should be, based on the previous value.") (cl-defmethod transient-infix-read :around ((obj transient-infix)) - "Refresh the transient buffer buffer calling the next method. + "Refresh the transient buffer and call the next method. Also wrap `cl-call-next-method' with two macros: - `transient--with-suspended-override' allows use of minibuffer. - `transient--with-emergency-exit' arranges for the transient to be exited in case of an error." (transient--show) - (transient--with-emergency-exit + (transient--with-emergency-exit :infix-read (transient--with-suspended-override (cl-call-next-method obj)))) @@ -3176,8 +3252,10 @@ The last value is \"don't use any of these switches\"." "Elsewhere use the reader of the infix command COMMAND. Use this if you want to share an infix's history with a regular stand-alone command." - (cl-letf (((symbol-function #'transient--show) #'ignore)) - (transient-infix-read (transient--suffix-prototype command)))) + (if-let ((obj (transient--suffix-prototype command))) + (cl-letf (((symbol-function #'transient--show) #'ignore)) + (transient-infix-read obj)) + (error "Not a suffix command: `%s'" command))) ;;;; Readers @@ -3354,7 +3432,7 @@ the set, saved or default value for PREFIX." (transient--init-suffixes prefix))))) (defun transient-get-value () - (transient--with-emergency-exit + (transient--with-emergency-exit :get-value (cl-mapcan (lambda (obj) (and (or (not (slot-exists-p obj 'unsavable)) (not (oref obj unsavable))) @@ -3565,7 +3643,7 @@ have a history of their own.") (propertize "\n" 'face face 'line-height t)))) (defmacro transient-with-shadowed-buffer (&rest body) - "While in the transient buffer, temporarily make the shadowed buffer current." + "While in the transient buffer, temporarly make the shadowed buffer current." (declare (indent 0) (debug t)) `(with-current-buffer (or transient--shadowed-buffer (current-buffer)) ,@body)) @@ -3620,7 +3698,8 @@ have a history of their own.") (lambda (column) (transient--maybe-pad-keys column group) (transient-with-shadowed-buffer - (let ((rows (mapcar #'transient-format (oref column suffixes)))) + (let* ((transient--pending-group column) + (rows (mapcar #'transient-format (oref column suffixes)))) (when-let ((desc (transient-format-description column))) (push desc rows)) (flatten-tree rows)))) @@ -3629,10 +3708,15 @@ have a history of their own.") transient-align-variable-pitch)) (rs (apply #'max (mapcar #'length columns))) (cs (length columns)) - (cw (mapcar (lambda (col) - (apply #'max - (mapcar (if vp #'transient--pixel-width #'length) - col))) + (cw (mapcar (let ((widths (oref transient--prefix column-widths))) + (lambda (col) + (apply + #'max + (if-let ((min (pop widths))) + (if vp (* min (transient--pixel-width " ")) min) + 0) + (mapcar (if vp #'transient--pixel-width #'length) + col)))) columns)) (cc (transient--seq-reductions-from (apply-partially #'+ (* 3 (if vp (transient--pixel-width " ") 1))) @@ -3908,7 +3992,10 @@ If the OBJ's `key' is currently unreachable, then apply the face (face (slot-value obj slot))) (if (and (not (facep face)) (functionp face)) - (funcall face) + (let ((transient--pending-suffix obj)) + (if (= (car (func-arity face)) 1) + (funcall face obj) + (funcall face))) face))) (defun transient--key-face (&optional cmd enforce-type) commit 2000d6e0f27f9f34f343016f4aa93e09c29c8695 Author: Stefan Monnier Date: Thu Mar 21 18:27:03 2024 -0400 (describe-symbol-backends): Fix addition of the "type" backend That backend was added from `cl-extra.el` with no autoload, so (describe-symbol `advice) failed to show the info about the `advice` type unless `cl-extra.el` had been loaded beforehand. `C-h o RET advice RET` worked by accident because the completion table uses `cl-some` which is autoloaded from `cl-extra.el`. * lisp/help-mode.el (describe-symbol-backends): Add the "type" backend. * lisp/emacs-lisp/cl-extra.el (describe-symbol-backends): Don't add the "type" backend here. diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index c8eaca9a77c..d43c21d3eb9 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -711,13 +711,6 @@ PROPLIST is a list of the sort returned by `symbol-plist'. (eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class. (require 'help-mode) -;; FIXME: We could go crazy and add another entry so describe-symbol can be -;; used with the slot names of CL structs (and/or EIEIO objects). -(add-to-list 'describe-symbol-backends - `(nil ,#'cl-find-class ,#'cl-describe-type) - ;; Document the `cons` function before the `cons` type. - t) - (defconst cl--typedef-regexp (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct" "cl-deftype" "deftype")) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index f9ec8a5cc2b..dd78342ace7 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -545,6 +545,9 @@ it does not already exist." (or (and (boundp symbol) (not (keywordp symbol))) (get symbol 'variable-documentation))) ,#'describe-variable) + ;; FIXME: We could go crazy and add another entry so describe-symbol can be + ;; used with the slot names of CL structs (and/or EIEIO objects). + ("type" ,#'cl-find-class ,#'cl-describe-type) ("face" ,#'facep ,(lambda (s _b _f) (describe-face s)))) "List of providers of information about symbols. Each element has the form (NAME TESTFUN DESCFUN) where: commit 05b8de54e30fdfccda78c5cfc2481828b897614b Author: Stefan Monnier Date: Thu Mar 21 18:16:41 2024 -0400 byte-opt.el: Remove test that's not applicable any more * lisp/emacs-lisp/byte-opt.el: Remove left-over test for ancient byte-compiled representation. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index f75be3f71ad..f6df40a2d9b 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -3116,7 +3116,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; (eval-when-compile (or (compiled-function-p (symbol-function 'byte-optimize-form)) - (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) (mapc (lambda (x) commit e819413e24d81875abaf81c281115e695ad5cc28 Author: Stefan Monnier Date: Thu Mar 21 12:28:54 2024 -0400 Speed up `describe-char` when a property has a large value Doing `C-u C-x =` on a buffer position where the overlay/text properties hold large values (e.g. inside the profiler report) can be surprisingly slow because it pretty prints all those properties. Change the code to do the pretty printing more lazily. While at it, share that duplicated code between `descr-text.el` and `wid-browse.el`. * lisp/emacs-lisp/pp.el (pp-insert-short-sexp): New function. * lisp/descr-text.el (describe-text-sexp): Delete function. (describe-property-list): Use `pp-insert-short-sexp` instead. * lisp/wid-browse.el (widget-browse-sexp): Use `pp-insert-short-sexp` and `widget--allow-insertion`. diff --git a/lisp/descr-text.el b/lisp/descr-text.el index eeab995c37d..524a6474cd4 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -42,26 +42,6 @@ (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) - (error (prin1-to-string signal))))) - (when (string-match-p "\n\\'" pp) - (setq pp (substring pp 0 (1- (length pp))))) - - (if (and (not (string-search "\n" pp)) - (<= (length pp) (- (window-width) (current-column)))) - (insert pp) - (insert-text-button - "[Show]" - 'follow-link t - 'action (lambda (&rest _ignore) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ pp))) - 'help-echo "mouse-2, RET: pretty print value in another buffer")))) - (defun describe-property-list (properties) "Insert a description of PROPERTIES in the current buffer. PROPERTIES should be a list of overlay or text properties. @@ -92,7 +72,9 @@ into help buttons that call `describe-text-category' or (format "%S" value) 'type 'help-face 'help-args (list value))) (t - (describe-text-sexp value)))) + (require 'pp) + (declare-function pp-insert-short-sexp "pp" (sexp &optional width)) + (pp-insert-short-sexp value)))) (insert "\n"))) ;;; Describe-Text Commands. @@ -522,24 +504,24 @@ The character information includes: (setcar composition (concat " with the surrounding characters \"" - (mapconcat 'describe-char-padded-string - (buffer-substring from pos) "") + (mapconcat #'describe-char-padded-string + (buffer-substring from pos)) "\" and \"" - (mapconcat 'describe-char-padded-string - (buffer-substring (1+ pos) to) "") + (mapconcat #'describe-char-padded-string + (buffer-substring (1+ pos) to)) "\"")) (setcar composition (concat " with the preceding character(s) \"" - (mapconcat 'describe-char-padded-string - (buffer-substring from pos) "") + (mapconcat #'describe-char-padded-string + (buffer-substring from pos)) "\""))) (if (< (1+ pos) to) (setcar composition (concat " with the following character(s) \"" - (mapconcat 'describe-char-padded-string - (buffer-substring (1+ pos) to) "") + (mapconcat #'describe-char-padded-string + (buffer-substring (1+ pos) to)) "\"")) (setcar composition nil))) (setcar (cdr composition) @@ -568,7 +550,7 @@ The character information includes: ("character" ,(format "%s (displayed as %s) (codepoint %d, #o%o, #x%x)" char-description - (apply 'propertize char-description + (apply #'propertize char-description (text-properties-at pos)) char char char)) ("charset" @@ -620,7 +602,7 @@ The character information includes: (if (consp key-list) (list "type" (concat "\"" - (mapconcat 'identity + (mapconcat #'identity key-list "\" or \"") "\"") "with" @@ -721,7 +703,7 @@ The character information includes: (let ((unicodedata (describe-char-unicode-data char))) (if unicodedata (cons (list "Unicode data" "") unicodedata)))))) - (setq max-width (apply 'max (mapcar (lambda (x) + (setq max-width (apply #'max (mapcar (lambda (x) (if (cadr x) (length (car x)) 0)) item-list))) (set-buffer src-buf) @@ -736,7 +718,7 @@ The character information includes: (dolist (clm (cdr elt)) (cond ((eq (car-safe clm) 'insert-text-button) (insert " ") - (eval clm)) + (eval clm t)) ((not (zerop (length clm))) (insert " " clm)))) (insert "\n")))) @@ -855,7 +837,7 @@ The character information includes: (insert "\n") (dolist (elt (cond ((eq describe-char-unidata-list t) - (nreverse (mapcar 'car char-code-property-alist))) + (nreverse (mapcar #'car char-code-property-alist))) ((< char 32) ;; Temporary fix (2016-05-22): The ;; decomposition item for \n corrupts the @@ -898,7 +880,7 @@ characters." (setq width (- width (length (car last)) 1))) (let ((ellipsis (and (cdr last) "..."))) (setcdr last nil) - (concat (mapconcat 'identity words " ") ellipsis))) + (concat (mapconcat #'identity words " ") ellipsis))) ""))) (defun describe-char-eldoc--format (ch &optional width) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 569f70ca604..de7468b3e38 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -346,6 +346,23 @@ after OUT-BUFFER-NAME." (setq buffer-read-only nil) (setq-local font-lock-verbose nil))))) +(defun pp-insert-short-sexp (sexp &optional width) + "Insert a short description of SEXP in the current buffer. +WIDTH is the maximum width to use for it and it defaults to the +space available between point and the window margin." + (let ((printed (format "%S" sexp))) + (if (and (not (string-search "\n" printed)) + (<= (string-width printed) + (or width (- (window-width) (current-column))))) + (insert printed) + (insert-text-button + "[Show]" + 'follow-link t + 'action (lambda (&rest _ignore) + ;; FIXME: Why "eval output"? + (pp-display-expression sexp "*Pp Eval Output*")) + 'help-echo "mouse-2, RET: pretty print value in another buffer")))) + ;;;###autoload (defun pp-eval-expression (expression) "Evaluate EXPRESSION and pretty-print its value. diff --git a/lisp/wid-browse.el b/lisp/wid-browse.el index bb56f3f62fb..d4000187bd1 100644 --- a/lisp/wid-browse.el +++ b/lisp/wid-browse.el @@ -141,7 +141,7 @@ The following commands are available: (setq key (nth 0 items) value (nth 1 items) printer (or (get key 'widget-keyword-printer) - 'widget-browse-sexp) + #'widget-browse-sexp) items (cdr (cdr items))) (widget-insert "\n" (symbol-name key) "\n\t") (funcall printer widget key value) @@ -204,24 +204,10 @@ VALUE is assumed to be a list of widgets." (defun widget-browse-sexp (_widget _key value) "Insert description of WIDGET's KEY VALUE. Nothing is assumed about value." - (let ((pp (condition-case signal - (pp-to-string value) - (error (prin1-to-string signal))))) - (when (string-match "\n\\'" pp) - (setq pp (substring pp 0 (1- (length pp))))) - (if (cond ((string-search "\n" pp) - nil) - ((> (length pp) (- (window-width) (current-column))) - nil) - (t t)) - (widget-insert pp) - (widget-create 'push-button - :tag "show" - :action (lambda (widget &optional _event) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ (widget-get widget :value)))) - pp)))) + (require 'pp) + (declare-function pp-insert-short-sexp "pp" (sexp &optional width)) + (widget--allow-insertion + (pp-insert-short-sexp value))) (defun widget-browse-sexps (widget key value) "Insert description of WIDGET's KEY VALUE. @@ -235,11 +221,11 @@ VALUE is assumed to be a list of widgets." ;;; Keyword Printers. -(put :parent 'widget-keyword-printer 'widget-browse-widget) -(put :children 'widget-keyword-printer 'widget-browse-widgets) -(put :buttons 'widget-keyword-printer 'widget-browse-widgets) -(put :button 'widget-keyword-printer 'widget-browse-widget) -(put :args 'widget-keyword-printer 'widget-browse-sexps) +(put :parent 'widget-keyword-printer #'widget-browse-widget) +(put :children 'widget-keyword-printer #'widget-browse-widgets) +(put :buttons 'widget-keyword-printer #'widget-browse-widgets) +(put :button 'widget-keyword-printer #'widget-browse-widget) +(put :args 'widget-keyword-printer #'widget-browse-sexps) ;;; Widget Minor Mode. commit 129bc91a2c9b7a6e314b4a5a4c60c266ca1cac0f Author: Stefan Monnier Date: Thu Mar 21 12:08:02 2024 -0400 wid-edit.el: Cosmetic changes * lisp/wid-edit.el: Use #' to quote function names. (widget--simplify-menu, widget-echo-help): Explicitly specify the lexenv to `eval`. (widget-choose, widget-get-sibling, widget-setup, widget-field-find) (widget-choice-action, widget-checklist-value-get) (widget-radio-value-create, widget-radio-value-set) (widget-radio-action, widget-editable-list-delete-at) (widget-group-value-create, widget-choice-prompt-value): Use `dolist`. (widget-convert): Hoist `(setq current` out of the ifs. (widget-convert): Hoist `(setq keys` out of the if. (widget-after-change): Hoist `(setq begin` out of the if. (widget-default-completions): Use `cond`. (widget-default-value-set): Hoist `goto-char` out of the if. (widget-choice-action): Hoist `nth` out of the if. (widget-checkbox-action): Hoist `widget-apply` out of the if. (widget-editable-list-value-create): Hoist `car` out of the if. (widget-editable-list-entry-create): Hoist `(setq child ...` out of the if. (widget-documentation-link-action): Fold `if` into `cond`. (widget-key-sequence-value-to-external): Use `key-parse`. (widget-plist-convert-option, widget-alist-convert-option): Hoist `(setq key-type` out of the if. diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 0645871f16d..f69a3d3b05f 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,4 +1,4 @@ -;;; wid-edit.el --- Functions for creating and using widgets -*- lexical-binding:t -*- +;; wid-edit.el --- Functions for creating and using widgets -*- lexical-binding:t -*- ;; ;; Copyright (C) 1996-1997, 1999-2024 Free Software Foundation, Inc. ;; @@ -247,10 +247,10 @@ to evaluate to nil for the menu item to be meaningful." (eq (car value) :radio)) (setq selected (cdr value)))) (setq plist (cddr plist))) - (when (and (eval visible) - (eval enable) + (when (and (eval visible t) + (eval enable t) (or (not selected) - (not (eval selected)))) + (not (eval selected t)))) (push (cons (nth 1 def) ev) simplified))))) extended) (reverse simplified))) @@ -317,7 +317,7 @@ in the key vector, as in the argument of `define-key'." (when (keymapp items) (setq items (widget--simplify-menu items))) ;; Read the choice of name from the minibuffer. - (setq items (cl-remove-if 'stringp items)) + (setq items (cl-remove-if #'stringp items)) (let ((val (completing-read (concat title ": ") items nil t))) (if (stringp val) (let ((try (try-completion val items))) @@ -330,12 +330,11 @@ in the key vector, as in the argument of `define-key'." ;; Construct a menu of the choices ;; and then use it for prompting for a single character. (let ((next-digit ?0) - alist choice some-choice-enabled value) + alist some-choice-enabled value) (with-current-buffer (get-buffer-create " widget-choose") (erase-buffer) (insert "Available choices:\n\n") - (while items - (setq choice (pop items)) + (dolist (choice items) (when (consp choice) (insert (format "%c = %s\n" next-digit (car choice))) (push (cons next-digit (cdr choice)) alist) @@ -665,12 +664,9 @@ The current value is assumed to be VALUE, unless UNBOUND is non-nil." (defun widget-get-sibling (widget) "Get the item WIDGET is assumed to toggle. This is only meaningful for radio buttons or checkboxes in a list." - (let* ((children (widget-get (widget-get widget :parent) :children)) - child) + (let* ((children (widget-get (widget-get widget :parent) :children))) (catch 'child - (while children - (setq child (car children) - children (cdr children)) + (dolist (child children) (when (eq (widget-get child :button) widget) (throw 'child child))) nil))) @@ -850,14 +846,14 @@ button is pressed or inactive, respectively. These are currently ignored." (defun widget-create (type &rest args) "Create widget of TYPE. The optional ARGS are additional keyword arguments." - (let ((widget (apply 'widget-convert type args))) + (let ((widget (apply #'widget-convert type args))) (widget-apply widget :create) widget)) (defun widget-create-child-and-convert (parent type &rest args) "As part of the widget PARENT, create a child widget TYPE. The child is converted, using the keyword arguments ARGS." - (let ((widget (apply 'widget-convert type args))) + (let ((widget (apply #'widget-convert type args))) (widget-put widget :parent parent) (unless (widget-get widget :indent) (widget-put widget :indent (+ (or (widget-get parent :indent) 0) @@ -911,18 +907,19 @@ The optional ARGS are additional keyword arguments." (keys args)) ;; First set the :args keyword. (while (cdr current) ;Look in the type. - (if (and (keywordp (cadr current)) - ;; If the last element is a keyword, - ;; it is still the :args element, - ;; even though it is a keyword. - (cddr current)) - (if (eq (cadr current) :args) - ;; If :args is explicitly specified, obey it. - (setq current nil) - ;; Some other irrelevant keyword. - (setq current (cdr (cdr current)))) - (setcdr current (list :args (cdr current))) - (setq current nil))) + (setq current + (if (and (keywordp (cadr current)) + ;; If the last element is a keyword, + ;; it is still the :args element, + ;; even though it is a keyword. + (cddr current)) + (if (eq (cadr current) :args) + ;; If :args is explicitly specified, obey it. + nil + ;; Some other irrelevant keyword. + (cdr (cdr current))) + (setcdr current (list :args (cdr current))) + nil))) (while (and args (not done)) ;Look in ARGS. (cond ((eq (car args) :args) ;; Handle explicit specification of :args. @@ -943,11 +940,9 @@ The optional ARGS are additional keyword arguments." ;; Finally set the keyword args. (while keys (let ((next (nth 0 keys))) - (if (keywordp next) - (progn - (widget-put widget next (nth 1 keys)) - (setq keys (nthcdr 2 keys))) - (setq keys nil)))) + (setq keys (when (keywordp next) + (widget-put widget next (nth 1 keys)) + (nthcdr 2 keys))))) ;; Convert the :value to internal format. (if (widget-member widget :value) (widget-put widget @@ -972,7 +967,7 @@ and TO will be used as the widgets end points. If optional arguments BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets button end points. Optional ARGS are extra keyword arguments for TYPE." - (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args)) + (let ((widget (apply #'widget-convert type :delete 'widget-leave-text args)) (from (copy-marker from)) (to (copy-marker to))) (set-marker-insertion-type from t) @@ -989,7 +984,7 @@ Optional ARGS are extra keyword arguments for TYPE. No text will be inserted to the buffer, instead the text between FROM and TO will be used as the widgets end points, as well as the widgets button end points." - (apply 'widget-convert-text type from to from to args)) + (apply #'widget-convert-text type from to from to args)) (defun widget-leave-text (widget) "Remove markers and overlays from WIDGET and its children." @@ -1007,7 +1002,7 @@ button end points." (delete-overlay doc)) (when field (delete-overlay field)) - (mapc 'widget-leave-text (widget-get widget :children)))) + (mapc #'widget-leave-text (widget-get widget :children)))) (defun widget-text (widget) "Get the text representation of the widget." @@ -1022,7 +1017,7 @@ button end points." ;; Custom-mode) which key-binding of widget-keymap one wants to refer to. ;; https://lists.gnu.org/r/emacs-devel/2008-11/msg00480.html (define-obsolete-function-alias 'advertised-widget-backward - 'widget-backward "23.2") + #'widget-backward "23.2") ;;;###autoload (defvar widget-keymap @@ -1048,13 +1043,13 @@ Note that such modes will need to require wid-edit.") (defvar widget-field-keymap (let ((map (copy-keymap widget-keymap))) - (define-key map "\C-k" 'widget-kill-line) - (define-key map "\M-\t" 'widget-complete) - (define-key map "\C-m" 'widget-field-activate) + (define-key map "\C-k" #'widget-kill-line) + (define-key map "\M-\t" #'widget-complete) + (define-key map "\C-m" #'widget-field-activate) ;; Since the widget code uses a `field' property to identify fields, ;; ordinary beginning-of-line does the right thing. - ;; (define-key map "\C-a" 'widget-beginning-of-line) - (define-key map "\C-e" 'widget-end-of-line) + ;; (define-key map "\C-a" #'widget-beginning-of-line) + (define-key map "\C-e" #'widget-end-of-line) map) "Keymap used inside an editable field.") @@ -1062,8 +1057,8 @@ Note that such modes will need to require wid-edit.") (let ((map (copy-keymap widget-keymap))) ;; Since the widget code uses a `field' property to identify fields, ;; ordinary beginning-of-line does the right thing. - ;; (define-key map "\C-a" 'widget-beginning-of-line) - (define-key map "\C-e" 'widget-end-of-line) + ;; (define-key map "\C-a" #'widget-beginning-of-line) + (define-key map "\C-e" #'widget-end-of-line) map) "Keymap used inside a text field.") @@ -1304,7 +1299,7 @@ With optional ARG, move across that many fields." ;; Since the widget code uses a `field' property to identify fields, ;; ordinary beginning-of-line does the right thing. -(defalias 'widget-beginning-of-line 'beginning-of-line) +(defalias 'widget-beginning-of-line #'beginning-of-line) (defun widget-end-of-line () "Go to end of field or end of line, whichever is first. @@ -1382,17 +1377,14 @@ When not inside a field, signal an error." (defun widget-setup () "Setup current buffer so editing string widgets works." (widget--allow-insertion - (let (field) - (while widget-field-new - (setq field (car widget-field-new) - widget-field-new (cdr widget-field-new) - widget-field-list (cons field widget-field-list)) - (let ((from (car (widget-get field :field-overlay))) - (to (cdr (widget-get field :field-overlay)))) - (widget-specify-field field - (marker-position from) (marker-position to)) - (set-marker from nil) - (set-marker to nil))))) + (dolist (field widget-field-new) + (push field widget-field-list) + (let ((from (car (widget-get field :field-overlay))) + (to (cdr (widget-get field :field-overlay)))) + (widget-specify-field field + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil)))) (widget-clear-undo) (widget-add-change)) @@ -1467,11 +1459,8 @@ When not inside a field, signal an error." (defun widget-field-find (pos) "Return the field at POS. Unlike (get-char-property POS \\='field), this works with empty fields too." - (let ((fields widget-field-list) - field found) - (while fields - (setq field (car fields) - fields (cdr fields)) + (let (found) + (dolist (field widget-field-list) (when (and (<= (widget-field-start field) pos) (<= pos (widget-field-end field))) (when found @@ -1486,11 +1475,11 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (let ((from-field (widget-field-find from)) (to-field (widget-field-find to))) (cond ((not (eq from-field to-field)) - (add-hook 'post-command-hook 'widget-add-change nil t) + (add-hook 'post-command-hook #'widget-add-change nil t) (signal 'text-read-only '("Change should be restricted to a single field"))) ((null from-field) - (add-hook 'post-command-hook 'widget-add-change nil t) + (add-hook 'post-command-hook #'widget-add-change nil t) (signal 'text-read-only '("Attempt to change text outside editable field"))) (widget-field-use-before-change @@ -1498,9 +1487,9 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." from-field (list 'before-change from to))))))) (defun widget-add-change () - (remove-hook 'post-command-hook 'widget-add-change t) - (add-hook 'before-change-functions 'widget-before-change nil t) - (add-hook 'after-change-functions 'widget-after-change nil t)) + (remove-hook 'post-command-hook #'widget-add-change t) + (add-hook 'before-change-functions #'widget-before-change nil t) + (add-hook 'after-change-functions #'widget-after-change nil t)) (defun widget-after-change (from to _old) "Adjust field size and text properties." @@ -1520,12 +1509,12 @@ Unlike (get-char-property POS \\='field), this works with empty fields too." (insert-char ?\s (- (+ begin size) end)))) ((> (- end begin) size) ;; Field too large and - (if (or (< (point) (+ begin size)) - (> (point) end)) - ;; Point is outside extra space. - (setq begin (+ begin size)) - ;; Point is within the extra space. - (setq begin (point))) + (setq begin (if (or (< (point) (+ begin size)) + (> (point) end)) + ;; Point is outside extra space. + (+ begin size) + ;; Point is within the extra space. + (point))) (save-excursion (goto-char end) (while (and (eq (preceding-char) ?\s) @@ -1545,9 +1534,9 @@ Optional EVENT is the event that triggered the action." (defun widget-children-value-delete (widget) "Delete all :children and :buttons in WIDGET." - (mapc 'widget-delete (widget-get widget :children)) + (mapc #'widget-delete (widget-get widget :children)) (widget-put widget :children nil) - (mapc 'widget-delete (widget-get widget :buttons)) + (mapc #'widget-delete (widget-get widget :buttons)) (widget-put widget :buttons nil)) (defun widget-children-validate (widget) @@ -1598,13 +1587,13 @@ The value of the :type attribute should be an unconverted widget type." (defun widget-types-copy (widget) "Copy :args as widget types in WIDGET." - (widget-put widget :args (mapcar 'widget-copy (widget-get widget :args))) + (widget-put widget :args (mapcar #'widget-copy (widget-get widget :args))) widget) ;; Made defsubst to speed up face editor creation. (defsubst widget-types-convert-widget (widget) "Convert :args as widget types in WIDGET." - (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) + (widget-put widget :args (mapcar #'widget-convert (widget-get widget :args))) widget) (defun widget-value-convert-widget (widget) @@ -1659,17 +1648,18 @@ The value of the :type attribute should be an unconverted widget type." (defun widget-default-completions (widget) "Return completion data, like `completion-at-point-functions' would." (let ((completions (widget-get widget :completions))) - (if completions - (list (widget-field-start widget) - (max (point) (widget-field-text-end widget)) - completions) - (if (widget-get widget :complete) - (lambda () (widget-apply widget :complete)) - (if (widget-get widget :complete-function) - (lambda () - (let ((widget--completing-widget widget)) - (call-interactively - (widget-get widget :complete-function))))))))) + (cond + (completions + (list (widget-field-start widget) + (max (point) (widget-field-text-end widget)) + completions)) + ((widget-get widget :complete) + (lambda () (widget-apply widget :complete))) + ((widget-get widget :complete-function) + (lambda () + (let ((widget--completing-widget widget)) + (call-interactively + (widget-get widget :complete-function)))))))) (defun widget-default-create (widget) "Create WIDGET at point in the current buffer." @@ -1814,9 +1804,9 @@ The value of the :type attribute should be an unconverted widget type." (widget-put widget :value value) (widget-apply widget :create)) (if offset - (if (< offset 0) - (goto-char (+ (widget-get widget :to) offset 1)) - (goto-char (min (+ from offset) (1- (widget-get widget :to)))))))) + (goto-char (if (< offset 0) + (+ (widget-get widget :to) offset 1) + (min (+ from offset) (1- (widget-get widget :to)))))))) (defun widget-default-value-inline (widget) "Wrap value in a list unless it is inline." @@ -1979,8 +1969,8 @@ as the argument to `documentation-property'." ;; Only bind mouse-2, since mouse-1 will be translated accordingly to ;; the customization of `mouse-1-click-follows-link'. (define-key map [down-mouse-1] (lookup-key widget-global-map [down-mouse-1])) - (define-key map [down-mouse-2] 'widget-button-click) - (define-key map [mouse-2] 'widget-button-click) + (define-key map [down-mouse-2] #'widget-button-click) + (define-key map [mouse-2] #'widget-button-click) map) "Keymap used inside a link widget.") @@ -2328,13 +2318,10 @@ when he invoked the menu." ((and widget-choice-toggle (= (length args) 2) (memq old args)) - (if (eq old (nth 0 args)) - (nth 1 args) - (nth 0 args))) + (nth (if (eq old (nth 0 args)) 1 0) + args)) (t - (while args - (setq current (car args) - args (cdr args)) + (dolist (current args) (setq choices (cons (cons (widget-apply current :menu-tag-get) current) @@ -2427,9 +2414,8 @@ when he invoked the menu." (widget-toggle-action widget event) (let ((sibling (widget-get-sibling widget))) (when sibling - (if (widget-value widget) - (widget-apply sibling :activate) - (widget-apply sibling :deactivate)) + (widget-apply sibling + (if (widget-value widget) :activate :deactivate)) (widget-clear-undo)))) ;;; The `checklist' Widget. @@ -2478,7 +2464,7 @@ If the item is checked, CHOSEN is a cons whose cdr is the value." (cond ((eq escape ?%) (insert ?%)) ((eq escape ?b) - (setq button (apply 'widget-create-child-and-convert + (setq button (apply #'widget-create-child-and-convert widget 'checkbox :value (not (null chosen)) button-args))) @@ -2558,11 +2544,8 @@ Return an alist of (TYPE MATCH)." (defun widget-checklist-value-get (widget) ;; The values of all selected items. - (let ((children (widget-get widget :children)) - child result) - (while children - (setq child (car children) - children (cdr children)) + (let (result) + (dolist (child (widget-get widget :children)) (if (widget-value (widget-get child :button)) (setq result (append result (widget-apply child :value-inline))))) result)) @@ -2630,12 +2613,8 @@ Return an alist of (TYPE MATCH)." (defun widget-radio-value-create (widget) ;; Insert all values - (let ((args (widget-get widget :args)) - arg) - (while args - (setq arg (car args) - args (cdr args)) - (widget-radio-add-item widget arg)))) + (dolist (arg (widget-get widget :args)) + (widget-radio-add-item widget arg))) (defun widget-radio-add-item (widget type) "Add to radio widget WIDGET a new radio button item of type TYPE." @@ -2662,7 +2641,7 @@ Return an alist of (TYPE MATCH)." (cond ((eq escape ?%) (insert ?%)) ((eq escape ?b) - (setq button (apply 'widget-create-child-and-convert + (setq button (apply #'widget-create-child-and-convert widget 'radio-button :value (not (null chosen)) button-args))) @@ -2718,11 +2697,8 @@ Return an alist of (TYPE MATCH)." ;; We can't just delete and recreate a radio widget, since children ;; can be added after the original creation and won't be recreated ;; by `:create'. - (let ((children (widget-get widget :children)) - current found) - (while children - (setq current (car children) - children (cdr children)) + (let (found) + (dolist (current (widget-get widget :children)) (let* ((button (widget-get current :button)) (match (and (not found) (widget-apply current :match value)))) @@ -2749,13 +2725,9 @@ Return an alist of (TYPE MATCH)." (defun widget-radio-action (widget child event) ;; Check if a radio button was pressed. - (let ((children (widget-get widget :children)) - (buttons (widget-get widget :buttons)) - current) + (let ((buttons (widget-get widget :buttons))) (when (memq child buttons) - (while children - (setq current (car children) - children (cdr children)) + (dolist (current (widget-get widget :children)) (let* ((button (widget-get current :button))) (cond ((eq child button) (widget-value-set button t) @@ -2825,7 +2797,7 @@ Return an alist of (TYPE MATCH)." (and (widget--should-indent-p) (widget-get widget :indent) (insert-char ?\s (widget-get widget :indent))) - (apply 'widget-create-child-and-convert + (apply #'widget-create-child-and-convert widget 'insert-button (widget-get widget :append-button-args))) (t @@ -2845,9 +2817,9 @@ Return an alist of (TYPE MATCH)." (if answer (setq children (cons (widget-editable-list-entry-create widget - (if (widget-inline-p type t) - (car answer) - (car (car answer))) + (car (if (widget-inline-p type t) + answer + (car answer))) t) children) value (cdr answer)) @@ -2856,8 +2828,8 @@ Return an alist of (TYPE MATCH)." (defun widget-editable-list-value-get (widget) ;; Get value of the child widget. - (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) - (widget-get widget :children)))) + (apply #'append (mapcar (lambda (child) (widget-apply child :value-inline)) + (widget-get widget :children)))) (defun widget-editable-list-match (widget value) ;; Value must be a list and all the members must match the type. @@ -2923,16 +2895,12 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (widget-put widget :last-deleted lst)) ;; Delete child from list of children. (save-excursion - (let ((buttons (copy-sequence (widget-get widget :buttons))) - button) - (widget--allow-insertion - (while buttons - (setq button (car buttons) - buttons (cdr buttons)) - (when (eq (widget-get button :widget) child) - (widget-put widget - :buttons (delq button (widget-get widget :buttons))) - (widget-delete button))))) + (widget--allow-insertion + (dolist (button (copy-sequence (widget-get widget :buttons))) + (when (eq (widget-get button :widget) child) + (widget-put widget + :buttons (delq button (widget-get widget :buttons))) + (widget-delete button)))) (let ((entry-from (widget-get child :entry-from)) (entry-to (widget-get child :entry-to))) (widget--allow-insertion @@ -2962,19 +2930,17 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (cond ((eq escape ?%) (insert ?%)) ((eq escape ?i) - (setq insert (apply 'widget-create-child-and-convert + (setq insert (apply #'widget-create-child-and-convert widget 'insert-button (widget-get widget :insert-button-args)))) ((eq escape ?d) - (setq delete (apply 'widget-create-child-and-convert + (setq delete (apply #'widget-create-child-and-convert widget 'delete-button (widget-get widget :delete-button-args)))) ((eq escape ?v) - (if conv - (setq child (widget-create-child-value - widget type value)) - (setq child (widget-create-child-value - widget type (widget-default-get type))))) + (setq child (widget-create-child-value + widget type + (if conv value (widget-default-get type))))) (t (error "Unknown escape `%c'" escape))))) (let ((buttons (widget-get widget :buttons))) @@ -3014,13 +2980,10 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (defun widget-group-value-create (widget) ;; Create each component. - (let ((args (widget-get widget :args)) - (value (widget-get widget :value)) - arg answer children) - (while args - (setq arg (car args) - args (cdr args) - answer (widget-match-inline arg value) + (let ((value (widget-get widget :value)) + answer children) + (dolist (arg (widget-get widget :args)) + (setq answer (widget-match-inline arg value) value (cdr answer)) (and (widget--should-indent-p) (widget-get widget :indent) @@ -3036,7 +2999,7 @@ Save CHILD into the :last-deleted list, so it can be inserted later." (defun widget-group-default-get (widget) ;; Get the default of the components. - (mapcar 'widget-default-get (widget-get widget :args))) + (mapcar #'widget-default-get (widget-get widget :args))) (defun widget-group-match (widget vals) ;; Match if the components match. @@ -3094,20 +3057,20 @@ The following properties have special meanings for this widget: "Display documentation for WIDGET's value. Ignore optional argument EVENT." (let* ((string (widget-get widget :value)) (symbol (intern string))) - (if (and (fboundp symbol) (boundp symbol)) - ;; If there are two doc strings, give the user a way to pick one. - (apropos (concat "\\`" (regexp-quote string) "\\'")) - (cond - ((fboundp symbol) - (describe-function symbol)) - ((facep symbol) - (describe-face symbol)) - ((featurep symbol) - (describe-package symbol)) - ((or (boundp symbol) (get symbol 'variable-documentation)) - (describe-variable symbol)) - (t - (message "No documentation available for %s" symbol)))))) + (cond + ((and (fboundp symbol) (boundp symbol)) + ;; If there are two doc strings, give the user a way to pick one. + (apropos (concat "\\`" (regexp-quote string) "\\'"))) + ((fboundp symbol) + (describe-function symbol)) + ((facep symbol) + (describe-face symbol)) + ((featurep symbol) + (describe-package symbol)) + ((or (boundp symbol) (get symbol 'variable-documentation)) + (describe-variable symbol)) + (t + (message "No documentation available for %s" symbol))))) (defcustom widget-documentation-links t "Add hyperlinks to documentation strings when non-nil." @@ -3240,7 +3203,7 @@ Optional ARGS specifies additional keyword arguments for the (unless (or (numberp doc-indent) (null doc-indent)) (setq doc-indent 0)) (widget-put widget :buttons - (cons (apply 'widget-create-child-and-convert + (cons (apply #'widget-create-child-and-convert widget 'documentation-string :indent doc-indent (nconc args (list doc))) @@ -3352,18 +3315,18 @@ It reads a file name from an editable text field." (must-match (widget-get widget :must-match))) (read-file-name (format-prompt prompt value) dir nil must-match file))))) -;;;(defun widget-file-action (widget &optional event) -;;; ;; Read a file name from the minibuffer. -;;; (let* ((value (widget-value widget)) -;;; (dir (file-name-directory value)) -;;; (file (file-name-nondirectory value)) -;;; (menu-tag (widget-apply widget :menu-tag-get)) -;;; (must-match (widget-get widget :must-match)) -;;; (answer (read-file-name (format-prompt menu-tag value) -;;; dir nil must-match file))) -;;; (widget-value-set widget (abbreviate-file-name answer)) -;;; (widget-setup) -;;; (widget-apply widget :notify widget event))) +;;(defun widget-file-action (widget &optional event) +;; ;; Read a file name from the minibuffer. +;; (let* ((value (widget-value widget)) +;; (dir (file-name-directory value)) +;; (file (file-name-nondirectory value)) +;; (menu-tag (widget-apply widget :menu-tag-get)) +;; (must-match (widget-get widget :must-match)) +;; (answer (read-file-name (format-prompt menu-tag value) +;; dir nil must-match file))) +;; (widget-value-set widget (abbreviate-file-name answer)) +;; (widget-setup) +;; (widget-apply widget :notify widget event))) ;; Fixme: use file-name-as-directory. (define-widget 'directory 'file @@ -3552,7 +3515,7 @@ It reads a directory name from an editable text field." (if (stringp value) (if (string-match "\\`[[:space:]]*\\'" value) widget-key-sequence-default-value - (read-kbd-macro value)) + (key-parse value)) value)) @@ -3825,7 +3788,7 @@ or a list with the default value of each component of the list WIDGET." :format "%{%t%}:\n%v" :match 'widget-vector-match :value-to-internal (lambda (_widget value) (append value nil)) - :value-to-external (lambda (_widget value) (apply 'vector value))) + :value-to-external (lambda (_widget value) (apply #'vector value))) (defun widget-vector-match (widget value) (and (vectorp value) @@ -3840,7 +3803,7 @@ or a list with the default value of each component of the list WIDGET." :value-to-internal (lambda (_widget value) (list (car value) (cdr value))) :value-to-external (lambda (_widget value) - (apply 'cons value))) + (apply #'cons value))) (defun widget-cons-match (widget value) (and (consp value) @@ -3927,7 +3890,7 @@ example: (args (if options (list `(checklist :inline t :greedy t - ,@(mapcar 'widget-plist-convert-option + ,@(mapcar #'widget-plist-convert-option options)) other) (list other)))) @@ -3940,9 +3903,7 @@ example: (if (listp option) (let ((key (nth 0 option))) (setq value-type (nth 1 option)) - (if (listp key) - (setq key-type key) - (setq key-type `(const ,key)))) + (setq key-type (if (listp key) key `(const ,key)))) (setq key-type `(const ,option) value-type widget-plist-value-type)) `(group :format "Key: %v" :inline t ,key-type ,value-type))) @@ -3972,7 +3933,7 @@ example: (args (if options (list `(checklist :inline t :greedy t - ,@(mapcar 'widget-alist-convert-option + ,@(mapcar #'widget-alist-convert-option options)) other) (list other)))) @@ -3985,9 +3946,7 @@ example: (if (listp option) (let ((key (nth 0 option))) (setq value-type (nth 1 option)) - (if (listp key) - (setq key-type key) - (setq key-type `(const ,key)))) + (setq key-type (if (listp key) key `(const ,key)))) (setq key-type `(const ,option) value-type widget-alist-value-type)) `(cons :format "Key: %v" ,key-type ,value-type))) @@ -4045,17 +4004,13 @@ current choice is inline." ((and widget-choice-toggle (= (length args) 2) (memq old args)) - (if (eq old (nth 0 args)) - (nth 1 args) - (nth 0 args))) + (nth (if (eq old (nth 0 args)) 1 0) + args)) (t - (while args - (setq current (car args) - args (cdr args)) - (setq choices - (cons (cons (widget-apply current :menu-tag-get) - current) - choices))) + (dolist (current args) + (push (cons (widget-apply current :menu-tag-get) + current) + choices)) (let ((val (completing-read prompt choices nil t))) (if (stringp val) (let ((try (try-completion val choices))) @@ -4206,7 +4161,7 @@ is inline." (help-echo (and widget (widget-get widget :help-echo)))) (if (functionp help-echo) (setq help-echo (funcall help-echo widget))) - (if help-echo (message "%s" (eval help-echo))))) + (if help-echo (message "%s" (eval help-echo t))))) (define-obsolete-function-alias 'widget-sublist #'seq-subseq "28.1") (define-obsolete-function-alias 'widget-visibility-value-create commit 3a902db97a99525b6f54100dc45a8cffcd3c5c8e Author: Stefan Monnier Date: Thu Mar 21 11:38:12 2024 -0400 (widget--allow-insertion): New macro * lisp/wid-edit.el (widget--allow-insertion): New macro. (widget-specify-insert, widget-insert, widget-setup) (widget-default-delete, widget-editable-list-insert-before) (widget-editable-list-delete-at): Use it. diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index cd06acd3f99..0645871f16d 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -510,14 +510,20 @@ With CHECK-AFTER non-nil, considers also the content after point, if needed." ;; indented it. (not (eq (following-char) ?\s)))))) -(defmacro widget-specify-insert (&rest form) - "Execute FORM without inheriting any text properties." - (declare (debug (body))) +(defmacro widget--allow-insertion (&rest forms) + "Run FORMS such that they can insert widgets in the current buffer." + (declare (debug t)) + `(let ((inhibit-read-only t) + (inhibit-modification-hooks t)) ;; FIXME: Why? This is risky! + ,@forms)) + +(defmacro widget-specify-insert (&rest forms) + "Execute FORMS without inheriting any text properties." + (declare (debug t)) `(save-restriction - (let ((inhibit-read-only t) - (inhibit-modification-hooks t)) + (widget--allow-insertion (narrow-to-region (point) (point)) - (prog1 (progn ,@form) + (prog1 (progn ,@forms) (goto-char (point-max)))))) (defface widget-inactive @@ -954,9 +960,8 @@ The optional ARGS are additional keyword arguments." ;;;###autoload (defun widget-insert (&rest args) "Call `insert' with ARGS even if surrounding text is read only." - (let ((inhibit-read-only t) - (inhibit-modification-hooks t)) - (apply 'insert args))) + (widget--allow-insertion + (apply #'insert args))) (defun widget-convert-text (type from to &optional button-from button-to @@ -1376,19 +1381,18 @@ When not inside a field, signal an error." ;;;###autoload (defun widget-setup () "Setup current buffer so editing string widgets works." - (let ((inhibit-read-only t) - (inhibit-modification-hooks t) - field) - (while widget-field-new - (setq field (car widget-field-new) - widget-field-new (cdr widget-field-new) - widget-field-list (cons field widget-field-list)) - (let ((from (car (widget-get field :field-overlay))) - (to (cdr (widget-get field :field-overlay)))) - (widget-specify-field field - (marker-position from) (marker-position to)) - (set-marker from nil) - (set-marker to nil)))) + (widget--allow-insertion + (let (field) + (while widget-field-new + (setq field (car widget-field-new) + widget-field-new (cdr widget-field-new) + widget-field-list (cons field widget-field-list)) + (let ((from (car (widget-get field :field-overlay))) + (to (cdr (widget-get field :field-overlay)))) + (widget-specify-field field + (marker-position from) (marker-position to)) + (set-marker from nil) + (set-marker to nil))))) (widget-clear-undo) (widget-add-change)) @@ -1773,24 +1777,23 @@ The value of the :type attribute should be an unconverted widget type." (inactive-overlay (widget-get widget :inactive)) (button-overlay (widget-get widget :button-overlay)) (sample-overlay (widget-get widget :sample-overlay)) - (doc-overlay (widget-get widget :doc-overlay)) - (inhibit-modification-hooks t) - (inhibit-read-only t)) - (widget-apply widget :value-delete) - (widget-children-value-delete widget) - (when inactive-overlay - (delete-overlay inactive-overlay)) - (when button-overlay - (delete-overlay button-overlay)) - (when sample-overlay - (delete-overlay sample-overlay)) - (when doc-overlay - (delete-overlay doc-overlay)) - (when (< from to) - ;; Kludge: this doesn't need to be true for empty formats. - (delete-region from to)) - (set-marker from nil) - (set-marker to nil)) + (doc-overlay (widget-get widget :doc-overlay))) + (widget--allow-insertion + (widget-apply widget :value-delete) + (widget-children-value-delete widget) + (when inactive-overlay + (delete-overlay inactive-overlay)) + (when button-overlay + (delete-overlay button-overlay)) + (when sample-overlay + (delete-overlay sample-overlay)) + (when doc-overlay + (delete-overlay doc-overlay)) + (when (< from to) + ;; Kludge: this doesn't need to be true for empty formats. + (delete-region from to)) + (set-marker from nil) + (set-marker to nil))) (widget-clear-undo)) (defun widget-default-value-set (widget value) @@ -2885,27 +2888,26 @@ The new widget gets inserted at the position of the BEFORE child." (last-deleted (when-let ((lst (widget-get widget :last-deleted))) (prog1 (pop lst) - (widget-put widget :last-deleted lst)))) - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (cond (before - (goto-char (widget-get before :entry-from))) - (t - (goto-char (widget-get widget :value-pos)))) - (let ((child (widget-editable-list-entry-create - widget (and last-deleted - (widget-apply last-deleted - :value-to-external - (widget-get last-deleted :value))) - last-deleted))) - (when (< (widget-get child :entry-from) (widget-get widget :from)) - (set-marker (widget-get widget :from) - (widget-get child :entry-from))) - (if (eq (car children) before) - (widget-put widget :children (cons child children)) - (while (not (eq (car (cdr children)) before)) - (setq children (cdr children))) - (setcdr children (cons child (cdr children))))))) + (widget-put widget :last-deleted lst))))) + (widget--allow-insertion + (cond (before + (goto-char (widget-get before :entry-from))) + (t + (goto-char (widget-get widget :value-pos)))) + (let ((child (widget-editable-list-entry-create + widget (and last-deleted + (widget-apply last-deleted + :value-to-external + (widget-get last-deleted :value))) + last-deleted))) + (when (< (widget-get child :entry-from) (widget-get widget :from)) + (set-marker (widget-get widget :from) + (widget-get child :entry-from))) + (if (eq (car children) before) + (widget-put widget :children (cons child children)) + (while (not (eq (car (cdr children)) before)) + (setq children (cdr children))) + (setcdr children (cons child (cdr children)))))))) (widget-setup) (widget-apply widget :notify widget)) @@ -2922,24 +2924,22 @@ Save CHILD into the :last-deleted list, so it can be inserted later." ;; Delete child from list of children. (save-excursion (let ((buttons (copy-sequence (widget-get widget :buttons))) - button - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (while buttons - (setq button (car buttons) - buttons (cdr buttons)) - (when (eq (widget-get button :widget) child) - (widget-put widget - :buttons (delq button (widget-get widget :buttons))) - (widget-delete button)))) + button) + (widget--allow-insertion + (while buttons + (setq button (car buttons) + buttons (cdr buttons)) + (when (eq (widget-get button :widget) child) + (widget-put widget + :buttons (delq button (widget-get widget :buttons))) + (widget-delete button))))) (let ((entry-from (widget-get child :entry-from)) - (entry-to (widget-get child :entry-to)) - (inhibit-read-only t) - (inhibit-modification-hooks t)) - (widget-delete child) - (delete-region entry-from entry-to) - (set-marker entry-from nil) - (set-marker entry-to nil)) + (entry-to (widget-get child :entry-to))) + (widget--allow-insertion + (widget-delete child) + (delete-region entry-from entry-to) + (set-marker entry-from nil) + (set-marker entry-to nil))) (widget-put widget :children (delq child (widget-get widget :children)))) (widget-setup) (widget-apply widget :notify widget)) commit 5a09cc111f052c120eddf0bcc98eeb1fd5435ae2 Author: Po Lu Date: Thu Mar 21 20:45:25 2024 +0800 ; * src/xterm.c (syms_of_xterm): Document x-*-keysym's default values. diff --git a/src/xterm.c b/src/xterm.c index b30a2485148..c0aef65ab66 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -32547,7 +32547,8 @@ Android does not support scroll bars at all. */); doc: /* Which modifer value Emacs reports when Ctrl is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the -Ctrl modifier (i.e. the keysym Ctrl_L or Ctrl_R) depressed. */); +Ctrl modifier (i.e. the keysym Ctrl_L or Ctrl_R) depressed, with nil or +any other value equivalent to `ctrl'. */); Vx_ctrl_keysym = Qnil; DEFVAR_LISP ("x-alt-keysym", Vx_alt_keysym, @@ -32555,14 +32556,16 @@ Ctrl modifier (i.e. the keysym Ctrl_L or Ctrl_R) depressed. */); This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the Alt modifier (e.g. the keysym Alt_L or Alt_R, if the keyboard features a -dedicated key for Meta) depressed. */); +dedicated key for Meta) depressed, with nil or any other value +equivalent to `alt'. */); Vx_alt_keysym = Qnil; DEFVAR_LISP ("x-hyper-keysym", Vx_hyper_keysym, doc: /* Which modifer value Emacs reports when Hyper is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the -Hyper modifier (i.e. the keysym Hyper_L or Hyper_R) depressed. */); +Hyper modifier (i.e. the keysym Hyper_L or Hyper_R) depressed, with nil +or any other value equivalent to `hyper'. */); Vx_hyper_keysym = Qnil; DEFVAR_LISP ("x-meta-keysym", Vx_meta_keysym, @@ -32570,14 +32573,16 @@ Hyper modifier (i.e. the keysym Hyper_L or Hyper_R) depressed. */); This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the Meta modifier (e.g. the keysym Alt_L or Alt_R, when the keyboard does -not feature a dedicated key for Meta) depressed. */); +not feature a dedicated key for Meta) depressed, with nil or any other +value equivalent to `meta'. */); Vx_meta_keysym = Qnil; DEFVAR_LISP ("x-super-keysym", Vx_super_keysym, doc: /* Which modifer value Emacs reports when Super is depressed. This should be one of the symbols `ctrl', `alt', `hyper', `meta', or `super', representing a modifier to be reported for key events with the -Super modifier (i.e. the keysym Super_L or Super_R) depressed. */); +Super modifier (i.e. the keysym Super_L or Super_R) depressed, with nil +or any other value equivalent to `super'. */); Vx_super_keysym = Qnil; DEFVAR_LISP ("x-wait-for-event-timeout", Vx_wait_for_event_timeout, commit 393f58c85aeb78f814866ccaad9ae7efd3fa6766 Author: Adam Porter Date: Fri Mar 8 23:43:14 2024 -0600 'vtable-update-object' can now be called with one argument It's often necessary to update the representation of a single object in a table (e.g a struct, whose identity does not change when its slots' values are changed). To do so, now the function may be called like this: (vtable-update-object table object) Instead of like this: (vtable-update-object table object object) This also documents the behavior of the just-discovered limitation filed as bug#69837. * lisp/emacs-lisp/vtable.el (vtable-update-object): Make 'old-object' argument optional. (Bug#69666) * doc/misc/vtable.texi (Interface Functions): Update documentation. * etc/NEWS: Add news entry. diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi index a4f2ed29d93..dd5b70cf32f 100644 --- a/doc/misc/vtable.texi +++ b/doc/misc/vtable.texi @@ -554,12 +554,19 @@ the object after this object; otherwise append to @var{table}. This also updates the displayed table. @end defun -@defun vtable-update-object table object old-object -Change @var{old-object} into @var{object} in @var{table}. This also -updates the displayed table. +@defun vtable-update-object table object &optional old-object +Update @var{object}'s representation in @var{table}. Optional argument +@var{old-object}, if non-@code{nil}, means to replace @var{old-object} +with @var{object} and redisplay the associated row in the table. In +either case, if the existing object is not found in the table (being +compared with @code{equal}), signal an error. This has the same effect as calling @code{vtable-remove-object} and then @code{vtable-insert-object}, but is more efficient. + +Note a limitation: if the table's buffer is not in a visible window, or +if its window has changed width since it was updated, updating the table +is not possible, and an error is signaled. @end defun @defun vtable-column table index diff --git a/etc/NEWS b/etc/NEWS index 69e61d91b0e..ba0e4c80fa0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2197,6 +2197,15 @@ aforementioned functions: (and (arrayp executing-kbd-macro) (>= executing-kbd-macro-index (length executing-kbd-macro)))) ++++ +** 'vtable-update-object' updates an existing object with just two arguments. +It is now possible to update the representation of an object in a vtable +by calling 'vtable-update-object' with just the vtable and the object as +arguments. (Previously the 'old-object' argument was required which, in +this case, would mean repeating the object in the argument list.) When +replacing an object with a different one, passing both the new and old +objects is still necessary. + * Changes in Emacs 30.1 on Non-Free Operating Systems diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 5f7d3ae5210..d8e5136c666 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -283,8 +283,16 @@ If it can't be found, return nil and don't move point." (goto-char (prop-match-beginning match)) (end-of-line))) -(defun vtable-update-object (table object old-object) - "Replace OLD-OBJECT in TABLE with OBJECT." +(defun vtable-update-object (table object &optional old-object) + "Update OBJECT's representation in TABLE. +If OLD-OBJECT is non-nil, replace OLD-OBJECT with OBJECT and display it. +In either case, if the existing object is not found in the table (being +compared with `equal'), signal an error. Note a limitation: if TABLE's +buffer is not in a visible window, or if its window has changed width +since it was updated, updating the TABLE is not possible, and an error +is signaled." + (unless old-object + (setq old-object object)) (let* ((objects (vtable-objects table)) (inhibit-read-only t)) ;; First replace the object in the object storage. @@ -300,6 +308,9 @@ If it can't be found, return nil and don't move point." (error "Can't find the old object")) (setcar (cdr objects) object)) ;; Then update the cache... + ;; FIXME: If the table's buffer has no visible window, or if its + ;; width has changed since the table was updated, the cache key will + ;; not match and the object can't be updated. (Bug #69837). (if-let ((line-number (seq-position (car (vtable--cache table)) old-object (lambda (a b) (equal (car a) b)))) commit fe24a8c3c091c1e051fe6a8c1ec4fd30ca052ca7 Author: Eli Zaretskii Date: Thu Mar 21 10:25:56 2024 +0200 Speed up display of RTL text with many character compositions * src/bidi.c (bidi_level_start): New function. * src/dispextern.h (bidi_level_start): Add prototype. * src/xdisp.c (compute_stop_pos, set_iterator_to_next) (get_visually_first_element, next_element_from_buffer): Call 'bidi_level_start' when looking for composed characters backwards, to set limit of searching back, instead of looking all the way to BOB. (Bug#69385) diff --git a/src/bidi.c b/src/bidi.c index 36d1a0496b8..bdf60001781 100644 --- a/src/bidi.c +++ b/src/bidi.c @@ -754,6 +754,19 @@ bidi_cache_find_level_change (int level, int dir, bool before) return -1; } +/* Find the previous character position where LEVEL changes to a lower + one. Return -1 if not found (which really shouldn't happen if this + function is called on a backward scan). */ +ptrdiff_t +bidi_level_start (int level) +{ + ptrdiff_t slot = bidi_cache_find_level_change (level, -1, true); + + if (slot >= 0) + return bidi_cache[slot].charpos; + return -1; +} + static void bidi_cache_ensure_space (ptrdiff_t idx) { diff --git a/src/dispextern.h b/src/dispextern.h index 5387cb45603..1c3232fae3d 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3438,6 +3438,7 @@ extern void bidi_pop_it (struct bidi_it *); extern void *bidi_shelve_cache (void); extern void bidi_unshelve_cache (void *, bool); extern ptrdiff_t bidi_find_first_overridden (struct bidi_it *); +extern ptrdiff_t bidi_level_start (int); /* Defined in xdisp.c */ diff --git a/src/xdisp.c b/src/xdisp.c index d03769e2a31..140d71129f3 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -4353,7 +4353,7 @@ compute_stop_pos (struct it *it) an automatic composition, limit the search of composable characters to that position. */ if (it->bidi_p && it->bidi_it.scan_dir < 0) - stoppos = -1; + stoppos = bidi_level_start (it->bidi_it.resolved_level) - 1; else if (!STRINGP (it->string) && it->cmp_it.stop_pos <= IT_CHARPOS (*it) && cmp_limit_pos > 0) @@ -8712,9 +8712,8 @@ set_iterator_to_next (struct it *it, bool reseat_p) ptrdiff_t stop = it->end_charpos; if (it->bidi_it.scan_dir < 0) - /* Now we are scanning backward and don't know - where to stop. */ - stop = -1; + /* Now we are scanning backward; figure out where to stop. */ + stop = bidi_level_start (it->bidi_it.resolved_level) - 1; composition_compute_stop_pos (&it->cmp_it, IT_CHARPOS (*it), IT_BYTEPOS (*it), stop, Qnil, true); } @@ -8745,7 +8744,7 @@ set_iterator_to_next (struct it *it, bool reseat_p) re-compute the stop position for composition. */ ptrdiff_t stop = it->end_charpos; if (it->bidi_it.scan_dir < 0) - stop = -1; + stop = bidi_level_start (it->bidi_it.resolved_level) - 1; composition_compute_stop_pos (&it->cmp_it, IT_CHARPOS (*it), IT_BYTEPOS (*it), stop, Qnil, true); @@ -9190,7 +9189,9 @@ get_visually_first_element (struct it *it) bytepos = IT_BYTEPOS (*it); } if (it->bidi_it.scan_dir < 0) - stop = -1; + stop = STRINGP (it->string) + ? -1 + : bidi_level_start (it->bidi_it.resolved_level) - 1; composition_compute_stop_pos (&it->cmp_it, charpos, bytepos, stop, it->string, true); } @@ -9694,9 +9695,10 @@ next_element_from_buffer (struct it *it) && PT < it->end_charpos) ? PT : it->end_charpos; } else - stop = it->bidi_it.scan_dir < 0 ? -1 : it->end_charpos; - if (CHAR_COMPOSED_P (it, IT_CHARPOS (*it), IT_BYTEPOS (*it), - stop) + stop = it->bidi_it.scan_dir < 0 + ? bidi_level_start (it->bidi_it.resolved_level) - 1 + : it->end_charpos; + if (CHAR_COMPOSED_P (it, IT_CHARPOS (*it), IT_BYTEPOS (*it), stop) && next_element_from_composition (it)) { return true; commit b3f04eb68499f285e05b5b74e9cbd67f3140fb3c Author: Adam Porter Date: Thu Mar 21 02:13:28 2024 -0500 Avoid recomputing the whole table in 'vtable--recompute-numerical' Each element of LINE being tested is a list, the first element of which is the value actually being represented in the table. Previously, the 'numberp' test would always fail, because it was being compared with the list rather than the intended value in it; that could cause the whole table to be recomputed, sometimes unnecessarily. * lisp/emacs-lisp/vtable.el (vtable--recompute-numerical): Test the car of ELEM, not ELEM itself, which is a list. (Bug#69927) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index 15a430f5c26..5f7d3ae5210 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -743,7 +743,7 @@ If NEXT, do the next column." (seq-do-indexed (lambda (elem index) (when (and (vtable-column--numerical (elt columns index)) - (not (numberp elem))) + (not (numberp (car elem)))) (setq recompute t))) line) (when recompute commit ad0492c5a97aaad7f784f7834772400d9af96b69 Author: Po Lu Date: Thu Mar 21 14:23:40 2024 +0800 Android compatibility fixes * doc/emacs/android.texi (Android Windowing): Document restrictions on number of windows under Android 4.4 and earlier. * java/AndroidManifest.xml.in : Assign each class of activity a unique task affinity. * java/org/gnu/emacs/EmacsDesktopNotification.java (display1): Remove redundant priority assignment. * java/org/gnu/emacs/EmacsOpenActivity.java (onCreate): Handle file URIs when processing attachments from a mailto URI, and check for KitKat before opening content ones. * java/org/gnu/emacs/EmacsWindow.java (figureChange): Replace coordinate HashMap with a SparseArray. * java/org/gnu/emacs/EmacsWindowAttachmentManager.java (registerWindow): Don't specify FLAG_ACTIVITY_NEW_DOCUMENT on systems where it is absent. diff --git a/doc/emacs/android.texi b/doc/emacs/android.texi index 56bfa2591f6..b367515cb35 100644 --- a/doc/emacs/android.texi +++ b/doc/emacs/android.texi @@ -864,6 +864,12 @@ behalf of a specific frame, Emacs deletes the frame displayed within that window. @end itemize + When the system predates Android 5.0, the window manager will not +accept more than one user-created Emacs window. If frame creation gives +rise to windows in excess of this limit, the window manager will +arbitrarily select one of their number to display, with the rest +remaining invisible until that window is destroyed with its frame. + @cindex windowing limitations, android @cindex frame parameters, android Emacs only supports a limited subset of GUI features on Android; the diff --git a/java/AndroidManifest.xml.in b/java/AndroidManifest.xml.in index 4d23c752747..563914fb02c 100644 --- a/java/AndroidManifest.xml.in +++ b/java/AndroidManifest.xml.in @@ -218,6 +218,7 @@ along with GNU Emacs. If not, see . --> @@ -229,7 +230,7 @@ along with GNU Emacs. If not, see . --> @@ -273,6 +274,7 @@ along with GNU Emacs. If not, see . --> diff --git a/java/org/gnu/emacs/EmacsDesktopNotification.java b/java/org/gnu/emacs/EmacsDesktopNotification.java index c80aa21b4fe..72569631a8c 100644 --- a/java/org/gnu/emacs/EmacsDesktopNotification.java +++ b/java/org/gnu/emacs/EmacsDesktopNotification.java @@ -208,22 +208,6 @@ else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) distinct categories, but permit an importance to be assigned to each individual notification. */ - switch (importance) - { - case 2: /* IMPORTANCE_LOW */ - default: - priority = Notification.PRIORITY_LOW; - break; - - case 3: /* IMPORTANCE_DEFAULT */ - priority = Notification.PRIORITY_DEFAULT; - break; - - case 4: /* IMPORTANCE_HIGH */ - priority = Notification.PRIORITY_HIGH; - break; - } - builder = new Notification.Builder (context); builder.setContentTitle (title); builder.setContentText (content); @@ -231,15 +215,28 @@ else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.JELLY_BEAN) { + switch (importance) + { + case 2: /* IMPORTANCE_LOW */ + default: + priority = Notification.PRIORITY_LOW; + break; + + case 3: /* IMPORTANCE_DEFAULT */ + priority = Notification.PRIORITY_DEFAULT; + break; + + case 4: /* IMPORTANCE_HIGH */ + priority = Notification.PRIORITY_HIGH; + break; + } + builder.setPriority (priority); insertActions (context, builder); notification = builder.build (); } else notification = builder.getNotification (); - - if (Build.VERSION.SDK_INT > Build.VERSION_CODES.JELLY_BEAN) - notification.priority = priority; } else { diff --git a/java/org/gnu/emacs/EmacsOpenActivity.java b/java/org/gnu/emacs/EmacsOpenActivity.java index 2cdfa2ec776..327a53bc417 100644 --- a/java/org/gnu/emacs/EmacsOpenActivity.java +++ b/java/org/gnu/emacs/EmacsOpenActivity.java @@ -535,7 +535,9 @@ private class EmacsClientThread extends Thread uri = intent.getParcelableExtra (Intent.EXTRA_STREAM); if ((scheme = uri.getScheme ()) != null - && scheme.equals ("content")) + && scheme.equals ("content") + && (Build.VERSION.SDK_INT + >= Build.VERSION_CODES.KITKAT)) { tem1 = EmacsService.buildContentName (uri, resolver); attachmentString = ("'(\"" + (tem1.replace ("\\", "\\\\") @@ -543,6 +545,14 @@ private class EmacsClientThread extends Thread .replace ("$", "\\$")) + "\")"); } + else if (scheme != null && scheme.equals ("file")) + { + tem1 = uri.getPath (); + attachmentString = ("'(\"" + (tem1.replace ("\\", "\\\\") + .replace ("\"", "\\\"") + .replace ("$", "\\$")) + + "\")"); + } } else { @@ -567,7 +577,9 @@ private class EmacsClientThread extends Thread if (uri != null && (scheme = uri.getScheme ()) != null - && scheme.equals ("content")) + && scheme.equals ("content") + && (Build.VERSION.SDK_INT + >= Build.VERSION_CODES.KITKAT)) { tem1 = EmacsService.buildContentName (uri, resolver); @@ -577,6 +589,16 @@ private class EmacsClientThread extends Thread .replace ("$", "\\$")); builder.append ("\""); } + else if (scheme != null + && scheme.equals ("file")) + { + tem1 = uri.getPath (); + builder.append ("\""); + builder.append (tem1.replace ("\\", "\\\\") + .replace ("\"", "\\\"") + .replace ("$", "\\$")); + builder.append ("\""); + } } builder.append (")"); @@ -604,7 +626,13 @@ private class EmacsClientThread extends Thread { fileName = null; - if (scheme.equals ("content")) + if (scheme.equals ("content") + /* Retrieving the native file descriptor of a + ParcelFileDescriptor requires Honeycomb, and + proceeding without this capability is pointless on + systems before KitKat, since Emacs doesn't support + opening content files on those. */ + && Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB) { /* This is one of the annoying Android ``content'' URIs. Most of the time, there is actually an diff --git a/java/org/gnu/emacs/EmacsWindow.java b/java/org/gnu/emacs/EmacsWindow.java index 93a512cc7ef..2baede1d2d0 100644 --- a/java/org/gnu/emacs/EmacsWindow.java +++ b/java/org/gnu/emacs/EmacsWindow.java @@ -23,7 +23,6 @@ import java.util.ArrayList; import java.util.List; import java.util.ListIterator; -import java.util.HashMap; import java.util.LinkedHashMap; import java.util.Map; @@ -50,6 +49,7 @@ import android.view.ViewManager; import android.view.WindowManager; +import android.util.SparseArray; import android.util.Log; import android.os.Build; @@ -109,7 +109,7 @@ private static class Coordinate /* Map between pointer identifiers and last known position. Used to compute which pointer changed upon a touch event. */ - private HashMap pointerMap; + private SparseArray pointerMap; /* The window consumer currently attached, if it exists. */ private EmacsWindowAttachmentManager.WindowConsumer attached; @@ -166,7 +166,7 @@ private static class Coordinate super (handle); rect = new Rect (x, y, x + width, y + height); - pointerMap = new HashMap (); + pointerMap = new SparseArray (); /* Create the view from the context's UI thread. The window is unmapped, so the view is GONE. */ @@ -1001,7 +1001,8 @@ private static class Coordinate case MotionEvent.ACTION_CANCEL: /* Primary pointer released with index 0. */ pointerID = event.getPointerId (0); - coordinate = pointerMap.remove (pointerID); + coordinate = pointerMap.get (pointerID); + pointerMap.delete (pointerID); break; case MotionEvent.ACTION_POINTER_DOWN: @@ -1020,7 +1021,8 @@ private static class Coordinate /* Pointer removed. Remove it from the map. */ pointerIndex = event.getActionIndex (); pointerID = event.getPointerId (pointerIndex); - coordinate = pointerMap.remove (pointerID); + coordinate = pointerMap.get (pointerID); + pointerMap.delete (pointerID); break; default: diff --git a/java/org/gnu/emacs/EmacsWindowAttachmentManager.java b/java/org/gnu/emacs/EmacsWindowAttachmentManager.java index 18bdb6dbf60..aae4e2ee49b 100644 --- a/java/org/gnu/emacs/EmacsWindowAttachmentManager.java +++ b/java/org/gnu/emacs/EmacsWindowAttachmentManager.java @@ -124,10 +124,15 @@ public interface WindowConsumer intent = new Intent (EmacsService.SERVICE, EmacsMultitaskActivity.class); - intent.addFlags (Intent.FLAG_ACTIVITY_NEW_DOCUMENT - | Intent.FLAG_ACTIVITY_NEW_TASK + + intent.addFlags (Intent.FLAG_ACTIVITY_NEW_TASK | Intent.FLAG_ACTIVITY_MULTIPLE_TASK); + /* Intent.FLAG_ACTIVITY_NEW_DOCUMENT is lamentably unavailable on + older systems than Lolipop. */ + if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.LOLLIPOP) + intent.addFlags (Intent.FLAG_ACTIVITY_NEW_DOCUMENT); + if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N) EmacsService.SERVICE.startActivity (intent); else