;; Author: Jonas Bernoulli <jonas@bernoul.li>
;; URL: https://github.com/magit/transient
;; Keywords: extensions
-;; Version: 0.6.0
+;; Version: 0.7.0
;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'format-spec)
(eval-and-compile
- (when (and (featurep' seq)
+ (when (and (featurep 'seq)
(not (fboundp 'seq-keep)))
(unload-feature 'seq 'force)))
(require 'seq)
(if-not-derived
:initarg :if-not-derived
:initform nil
- :documentation "Enable if major-mode does not derive from value."))
- "Abstract superclass for group and suffix classes.
-
-It is undefined what happens if more than one `if*' predicate
-slot is non-nil."
- :abstract t)
-
-(defclass transient-suffix (transient-child)
- ((definition :allocation :class :initform nil)
- (key :initarg :key)
- (command :initarg :command)
- (transient :initarg :transient)
- (format :initarg :format :initform " %k %d")
- (description :initarg :description :initform nil)
- (face :initarg :face :initform nil)
- (show-help :initarg :show-help :initform nil)
- (inapt-face :initarg :inapt-face :initform 'transient-inapt-suffix)
- (inapt :initform nil)
+ :documentation "Enable if major-mode does not derive from value.")
+ (inapt
+ :initform nil)
+ (inapt-face
+ :initarg :inapt-face
+ :initform 'transient-inapt-suffix)
(inapt-if
:initarg :inapt-if
:initform nil
:initarg :inapt-if-not-derived
:initform nil
:documentation "Inapt if major-mode does not derive from value."))
+ "Abstract superclass for group and suffix classes.
+
+It is undefined what happens if more than one `if*' predicate
+slot is non-nil."
+ :abstract t)
+
+(defclass transient-suffix (transient-child)
+ ((definition :allocation :class :initform nil)
+ (key :initarg :key)
+ (command :initarg :command)
+ (transient :initarg :transient)
+ (format :initarg :format :initform " %k %d")
+ (description :initarg :description :initform nil)
+ (face :initarg :face :initform nil)
+ (show-help :initarg :show-help :initform nil))
"Superclass for suffix command.")
(defclass transient-information (transient-suffix)
((format :initform " %k %d")
(key :initform " "))
- "Display-only information.
-A suffix object with no associated command.")
+ "Display-only information, aligned with suffix keys.
+Technically a suffix object with no associated command.")
+
+(defclass transient-information* (transient-information)
+ ((format :initform " %d"))
+ "Display-only information, aligned with suffix descriptions.
+Technically a suffix object with no associated command.")
(defclass transient-infix (transient-suffix)
((transient :initform t)
(hide :initarg :hide :initform nil)
(description :initarg :description :initform nil)
(pad-keys :initarg :pad-keys :initform nil)
+ (info-format :initarg :info-format :initform nil)
(setup-children :initarg :setup-children))
"Abstract superclass of all group classes."
:abstract t)
[&optional ("interactive" interactive) def-body]))
(indent defun)
(doc-string 3))
- (pcase-let ((`(,class ,slots ,suffixes ,docstr ,body)
- (transient--expand-define-args args arglist)))
+ (pcase-let
+ ((`(,class ,slots ,suffixes ,docstr ,body ,interactive-only)
+ (transient--expand-define-args args arglist 'transient-define-prefix)))
`(progn
(defalias ',name
,(if body
`(lambda ()
(interactive)
(transient-setup ',name))))
- (put ',name 'interactive-only t)
+ (put ',name 'interactive-only ,interactive-only)
(put ',name 'function-documentation ,docstr)
(put ',name 'transient--prefix
(,(or class 'transient-prefix) :command ',name ,@slots))
ARGLIST. The infix arguments are usually accessed by using
`transient-args' inside `interactive'.
-\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... BODY...)"
+\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... [BODY...])"
(declare (debug ( &define name lambda-list
[&optional lambda-doc]
[&rest keywordp sexp]
- ("interactive" interactive)
- def-body))
+ [&optional ("interactive" interactive) def-body]))
(indent defun)
(doc-string 3))
- (pcase-let ((`(,class ,slots ,_ ,docstr ,body)
- (transient--expand-define-args args arglist)))
+ (pcase-let
+ ((`(,class ,slots ,_ ,docstr ,body ,interactive-only)
+ (transient--expand-define-args args arglist 'transient-define-suffix)))
`(progn
(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 'interactive-only ,interactive-only)
(put ',name 'function-documentation ,docstr)
(put ',name 'transient--suffix
(,(or class 'transient-suffix) :command ',name ,@slots)))))
+(defmacro transient-augment-suffix (name &rest args)
+ "Augment existing command NAME with a new transient suffix object.
+Similar to `transient-define-suffix' but define a suffix object only.
+\n\(fn NAME [KEYWORD VALUE]...)"
+ (declare (debug (&define name [&rest keywordp sexp]))
+ (indent defun))
+ (pcase-let
+ ((`(,class ,slots)
+ (transient--expand-define-args args nil 'transient-augment-suffix t)))
+ `(put ',name 'transient--suffix
+ (,(or class 'transient-suffix) :command ',name ,@slots))))
+
(defmacro transient-define-infix (name arglist &rest args)
"Define NAME as a transient infix command.
ARGLIST is always ignored and reserved for future use.
DOCSTRING is the documentation string and is optional.
-The key-value pairs are mandatory. All transient infix commands
-are equal to each other (but not eq), so it is meaningless to
-define an infix command without also setting at least `:class'
-and one other keyword (which it is depends on the used class,
-usually `:argument' or `:variable').
-
-Each key has to be a keyword symbol, either `:class' or a keyword
-argument supported by the constructor of that class. The
-`transient-switch' class is used if the class is not specified
-explicitly.
+At least one key-value pair is required. All transient infix
+commands are equal to each other (but not eq). It is meaning-
+less to define an infix command, without providing at least one
+keyword argument (usually `:argument' or `:variable', depending
+on the class). The suffix class defaults to `transient-switch'
+and can be set using the `:class' keyword.
The function definitions is always:
the infix command and use t as the value of the `:transient'
keyword.
-\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)"
+\(fn NAME ARGLIST [DOCSTRING] KEYWORD VALUE [KEYWORD VALUE]...)"
(declare (debug ( &define name lambda-list
[&optional lambda-doc]
+ keywordp sexp
[&rest keywordp sexp]))
(indent defun)
(doc-string 3))
- (pcase-let ((`(,class ,slots ,_ ,docstr ,_)
- (transient--expand-define-args args arglist)))
+ (pcase-let
+ ((`(,class ,slots ,_ ,docstr ,_ ,interactive-only)
+ (transient--expand-define-args args arglist 'transient-define-infix t)))
`(progn
(defalias ',name #'transient--default-infix-command)
- (put ',name 'interactive-only t)
+ (put ',name 'interactive-only ,interactive-only)
(put ',name 'completion-predicate #'transient--suffix-only)
(put ',name 'function-documentation ,docstr)
(put ',name 'transient--suffix
(put 'transient--default-infix-command 'completion-predicate
#'transient--suffix-only)
-(defun transient--find-function-advised-original (fn func)
+(define-advice find-function-advised-original
+ (:around (fn func) transient-default-infix)
"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
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)
+(eval-and-compile ;transient--expand-define-args
+ (defun transient--expand-define-args (args arglist form &optional nobody)
(unless (listp arglist)
(error "Mandatory ARGLIST is missing"))
- (let (class keys suffixes docstr)
+ (let (class keys suffixes docstr declare (interactive-only t))
(when (stringp (car args))
(setq docstr (pop args)))
(while (keywordp (car args))
(or (vectorp arg)
(and arg (symbolp arg))))
(push (pop args) suffixes))
+ (when (eq (car-safe (car args)) 'declare)
+ (setq declare (car args))
+ (setq args (cdr args))
+ (when-let ((int (assq 'interactive-only declare)))
+ (setq interactive-only (cadr int))
+ (delq int declare))
+ (unless (cdr declare)
+ (setq declare nil)))
+ (cond
+ ((not args))
+ (nobody
+ (error "%s: No function body allowed" form))
+ ((not (eq (car-safe (nth (if declare 1 0) args)) 'interactive))
+ (error "%s: Interactive form missing" form)))
(list (if (eq (car-safe class) 'quote)
(cadr class)
class)
(nreverse keys)
(nreverse suffixes)
docstr
- args))))
+ (if declare (cons declare args) args)
+ interactive-only))))
(defun transient--parse-child (prefix spec)
(cl-typecase spec
(commandp (cadr spec)))
(setq args (plist-put args :description (macroexp-quote pop)))))
(cond
- ((eq car :info))
+ ((memq car '(:info :info*)))
((keywordp car)
- (error "Need command or `:info', got `%s'" car))
+ (error "Need command, `:info' or `:info*', got `%s'" car))
((symbolp car)
(setq args (plist-put args :command (macroexp-quote pop))))
((and (commandp car)
((eq key :info)
(setq class 'transient-information)
(setq args (plist-put args :description val)))
+ ((eq key :info*)
+ (setq class 'transient-information*)
+ (setq args (plist-put args :description val)))
((eq (car-safe val) '\,)
(setq args (plist-put args key (cadr val))))
((or (symbolp val)
(defvar transient-exit-hook nil
"Hook run after exiting a transient.")
+(defvar transient-setup-buffer-hook nil
+ "Hook run when setting up the transient buffer.
+That buffer is current and empty when this hook runs.")
+
(defvar transient--prefix nil)
(defvar transient--layout nil)
(defvar transient--suffixes nil)
(defvar transient--buffer-name " *transient*"
"Name of the transient buffer.")
+(defvar transient--buffer nil
+ "The transient menu buffer.")
+
(defvar transient--window nil
"The window used to display the transient popup buffer.")
(setq key (save-match-data
(funcall transient-substitute-key-function obj)))
(oset obj key key))
- (let ((kbd (kbd key))
- (cmd (oref obj command)))
- (when-let ((conflict (and transient-detect-key-conflicts
- (transient--lookup-key map kbd))))
- (unless (eq cmd conflict)
- (error "Cannot bind %S to %s and also %s"
- (string-trim key)
- cmd conflict)))
- (define-key map kbd cmd))))
+ (let* ((kbd (kbd key))
+ (cmd (oref obj command))
+ (alt (transient--lookup-key map kbd)))
+ (cond ((not alt)
+ (define-key map kbd cmd))
+ ((eq alt cmd))
+ ((transient--inapt-suffix-p obj))
+ ((and-let* ((obj (transient-suffix-object alt)))
+ (transient--inapt-suffix-p obj))
+ (define-key map kbd cmd))
+ (transient-detect-key-conflicts
+ (error "Cannot bind %S to %s and also %s"
+ (string-trim key) cmd alt))
+ ((define-key map kbd cmd))))))
(when-let ((b (keymap-lookup map "-"))) (keymap-set map "<kp-subtract>" b))
(when-let ((b (keymap-lookup map "="))) (keymap-set map "<kp-equal>" b))
(when-let ((b (keymap-lookup map "+"))) (keymap-set map "<kp-add>" b))
(defun transient--init-suffixes (name)
(let ((levels (alist-get name transient-levels)))
- (cl-mapcan (lambda (c) (transient--init-child levels c))
+ (cl-mapcan (lambda (c) (transient--init-child levels c nil))
(append (get name 'transient--layout)
(and (not transient--editp)
(get 'transient-common-commands
(list def)))))
(cl-mapcan #'s layout)))
-(defun transient--init-child (levels spec)
+(defun transient--init-child (levels spec parent)
(cl-etypecase spec
- (vector (transient--init-group levels spec))
- (list (transient--init-suffix levels spec))
+ (vector (transient--init-group levels spec parent))
+ (list (transient--init-suffix levels spec parent))
(string (list spec))))
-(defun transient--init-group (levels spec)
+(defun transient--init-group (levels spec parent)
(pcase-let ((`(,level ,class ,args ,children) (append spec nil)))
- (and-let* ((- (transient--use-level-p level))
+ (and-let* (((transient--use-level-p level))
(obj (apply class :level level args))
- (- (transient--use-suffix-p obj))
- (suffixes (cl-mapcan (lambda (c) (transient--init-child levels c))
- (transient-setup-children obj children))))
+ ((transient--use-suffix-p obj))
+ ((prog1 t
+ (when (or (and parent (oref parent inapt))
+ (transient--inapt-suffix-p obj))
+ (oset obj inapt t))))
+ (suffixes (cl-mapcan
+ (lambda (c) (transient--init-child levels c obj))
+ (transient-setup-children obj children))))
(progn ; work around debbugs#31840
(oset obj suffixes suffixes)
(list obj)))))
-(defun transient--init-suffix (levels spec)
+(defun transient--init-suffix (levels spec parent)
(pcase-let* ((`(,level ,class ,args) spec)
(cmd (plist-get args :command))
(key (transient--kbd (plist-get args :key)))
(unless (cl-typep obj 'transient-information)
(transient--init-suffix-key obj))
(when (transient--use-suffix-p obj)
- (if (transient--inapt-suffix-p obj)
+ (if (or (and parent (oref parent inapt))
+ (transient--inapt-suffix-p obj))
(oset obj inapt t)
(transient-init-scope obj)
(transient-init-value obj))
'other)
(with-demoted-errors "Error while exiting transient: %S"
(delete-window transient--window)))
- (when-let ((buffer (get-buffer transient--buffer-name)))
- (kill-buffer buffer))
+ (when (buffer-live-p transient--buffer)
+ (kill-buffer transient--buffer))
+ (setq transient--buffer nil)
(when remain-in-minibuffer-window
(select-window remain-in-minibuffer-window)))))
;; We cannot use `current-prefix-arg' because it is set
;; too late (in `command-execute'), and if it were set
;; earlier, then we likely still would not be able to
- ;; rely on it and `prefix-command-preserve-state-hook'
+ ;; rely on it, and `prefix-command-preserve-state-hook'
;; would have to be used to record that a universal
;; argument is in effect.
(not prefix-arg)))
mouse-set-region))
(equal (key-description (this-command-keys-vector))
"<mouse-movement>"))
- (and (eq (current-buffer)
- (get-buffer transient--buffer-name)))))
+ (and (eq (current-buffer) transient--buffer))))
(transient--show))
(when (and (numberp transient-show-popup)
(not (zerop transient-show-popup))
(if (symbolp arg)
(message "-- %-22s (cmd: %s, event: %S, exit: %s%s)"
arg
- (if (fboundp 'help-fns-function-name)
- (help-fns-function-name this-command)
- (if (byte-code-function-p this-command)
- "#[...]"
- this-command))
+ (cond ((and (symbolp this-command) this-command))
+ ((fboundp 'help-fns-function-name)
+ (help-fns-function-name this-command))
+ ((byte-code-function-p this-command)
+ "#[...]")
+ (this-command))
(key-description (this-command-keys-vector))
transient--exitp
(cond ((keywordp (car args))
(cl-defmethod transient-infix-set :after ((obj transient-argument) value)
"Unset incompatible infix arguments."
- (when-let* ((--- value)
+ (when-let* ((value)
(val (transient-infix-value obj))
(arg (if (slot-boundp obj 'argument)
(oref obj argument)
(and (not (equal val arg))
(cl-mapcan (apply-partially filter val) spec)))))
(dolist (obj transient--suffixes)
- (when-let* ((--- (cl-typep obj 'transient-argument))
+ (when-let* (((cl-typep obj 'transient-argument))
(val (transient-infix-value obj))
(arg (if (slot-boundp obj 'argument)
(oref obj argument)
(oref obj argument-format)))
- (--- (if (equal val arg)
- (member arg incomp)
- (or (member val incomp)
- (member arg incomp)))))
+ ((if (equal val arg)
+ (member arg incomp)
+ (or (member val incomp)
+ (member arg incomp)))))
(transient-infix-set obj nil)))))
(cl-defgeneric transient-set-value (obj)
(or (match-string 1 match) "")))
(and (member arg args) t)))
+(defun transient-scope ()
+ "Return the value of the `scope' slot of the current prefix."
+ (oref (transient-prefix-object) scope))
+
;;; History
(cl-defgeneric transient--history-key (obj)
(transient--timer-cancel)
(setq transient--showp t)
(let ((transient--shadowed-buffer (current-buffer))
- (buf (get-buffer-create transient--buffer-name))
(focus nil))
- (with-current-buffer buf
+ (setq transient--buffer (get-buffer-create transient--buffer-name))
+ (with-current-buffer transient--buffer
(when transient-enable-popup-navigation
(setq focus (or (button-get (point) 'command)
(and (not (bobp))
(button-get (1- (point)) 'command))
(transient--heading-at-point))))
(erase-buffer)
+ (run-hooks 'transient-setup-buffer-hook)
+ (when transient-force-fixed-pitch
+ (transient--force-fixed-pitch))
(setq window-size-fixed t)
(when (bound-and-true-p tab-line-format)
(setq tab-line-format nil))
(when (or transient--helpp transient--editp)
(transient--insert-help))
(when-let ((line (transient--separator-line)))
- (insert line))
- (when transient-force-fixed-pitch
- (transient--force-fixed-pitch)))
+ (insert line)))
(unless (window-live-p transient--window)
(setq transient--window
- (display-buffer buf transient-display-buffer-action)))
+ (display-buffer transient--buffer
+ transient-display-buffer-action)))
(when (window-live-p transient--window)
(with-selected-window transient--window
(goto-char (point-min))
(transient-with-shadowed-buffer
(funcall hide))))
(list group))))
- transient--layout))
- group)
- (while (setq group (pop groups))
+ transient--layout)))
+ (while-let ((group (pop groups)))
(transient--insert-group group)
(when groups
(insert ?\n)))))
(transient-with-shadowed-buffer
(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))))
+ (if-let ((desc (transient-format-description column)))
+ (cons desc rows)
+ rows))))
(oref group suffixes)))
(vp (or (oref transient--prefix variable-pitch)
transient-align-variable-pitch))
col))))
columns))
(cc (transient--seq-reductions-from
- (apply-partially #'+ (* 3 (if vp (transient--pixel-width " ") 1)))
+ (apply-partially #'+ (* 2 (if vp (transient--pixel-width " ") 1)))
cw 0)))
(if transient-force-single-column
(dotimes (c cs)
(insert ?\n))))))))
(cl-defmethod transient--insert-group ((group transient-subgroups))
- (let* ((subgroups (oref group suffixes))
- (n (length subgroups)))
- (dotimes (s n)
- (let ((subgroup (nth s subgroups)))
- (transient--maybe-pad-keys subgroup group)
- (transient--insert-group subgroup)
- (when (< s (1- n))
- (insert ?\n))))))
+ (let ((subgroups (oref group suffixes)))
+ (while-let ((subgroup (pop subgroups)))
+ (transient--maybe-pad-keys subgroup group)
+ (transient--insert-group subgroup)
+ (when subgroups
+ (insert ?\n)))))
(cl-defgeneric transient-format (obj)
"Format and return OBJ for display.
(cl-defgeneric transient-format-description (obj)
"Format OBJ's `description' for display and return the result.")
-(cl-defmethod transient-format-description ((obj transient-child))
+(cl-defmethod transient-format-description ((obj transient-suffix))
"The `description' slot may be a function, in which case that is
called inside the correct buffer (see `transient--insert-group')
and its value is returned to the caller."
- (and-let* ((desc (oref obj description))
- (desc (if (functionp desc)
- (if (= (car (func-arity desc)) 1)
- (funcall desc obj)
- (funcall desc))
- desc)))
- (if-let* ((face (transient--get-face obj 'face)))
- (transient--add-face desc face t)
- desc)))
+ (transient--get-description obj))
(cl-defmethod transient-format-description ((obj transient-group))
"Format the description by calling the next method. If the result
doesn't use the `face' property at all, then apply the face
`transient-heading' to the complete string."
- (and-let* ((desc (cl-call-next-method obj)))
- (if (text-property-not-all 0 (length desc) 'face nil desc)
- desc
- (propertize desc 'face 'transient-heading))))
+ (and-let* ((desc (transient--get-description obj)))
+ (cond ((oref obj inapt)
+ (propertize desc 'face 'transient-inapt-suffix))
+ ((text-property-not-all 0 (length desc) 'face nil desc)
+ desc)
+ ((propertize desc 'face 'transient-heading)))))
(cl-defmethod transient-format-description :around ((obj transient-suffix))
"Format the description by calling the next method. If the result
(let ((desc (or (cl-call-next-method obj)
(and (slot-boundp transient--prefix 'suffix-description)
(funcall (oref transient--prefix suffix-description)
- obj))
- (propertize "(BUG: no description)" 'face 'error))))
+ obj)))))
+ (if desc
+ (when-let ((face (transient--get-face obj 'face)))
+ (setq desc (transient--add-face desc face t)))
+ (setq desc (propertize "(BUG: no description)" 'face 'error)))
(when (if transient--all-levels-p
(> (oref obj level) transient--default-prefix-level)
(and transient-highlight-higher-levels
choices
(propertize "|" 'face 'transient-delimiter))))))
-(defun transient--add-face (string face &optional append beg end)
- (let ((str (copy-sequence string)))
- (add-face-text-property (or beg 0) (or end (length str)) face append str)
- str))
+(cl-defmethod transient--get-description ((obj transient-child))
+ (and-let* ((desc (oref obj description)))
+ (if (functionp desc)
+ (if (= (car (transient--func-arity desc)) 1)
+ (funcall desc obj)
+ (funcall desc))
+ desc)))
-(defun transient--get-face (obj slot)
- (and-let* ((! (slot-exists-p obj slot))
- (! (slot-boundp obj slot))
+(cl-defmethod transient--get-face ((obj transient-suffix) slot)
+ (and-let* (((slot-boundp obj slot))
(face (slot-value obj slot)))
(if (and (not (facep face))
(functionp face))
(let ((transient--pending-suffix obj))
- (if (= (car (func-arity face)) 1)
+ (if (= (car (transient--func-arity face)) 1)
(funcall face obj)
(funcall face)))
face)))
+(defun transient--add-face (string face &optional append beg end)
+ (let ((str (copy-sequence string)))
+ (add-face-text-property (or beg 0) (or end (length str)) face append str)
+ str))
+
(defun transient--key-face (&optional cmd enforce-type)
(or (and transient-semantic-coloring
(not transient--helpp)
(when-let ((pad (or (oref group pad-keys)
(and parent (oref parent pad-keys)))))
(oset group pad-keys
- (apply #'max (cons (if (integerp pad) pad 0)
- (seq-keep (lambda (suffix)
- (and (eieio-object-p suffix)
- (slot-boundp suffix 'key)
- (length (oref suffix key))))
- (oref group suffixes)))))))
+ (apply #'max
+ (if (integerp pad) pad 0)
+ (seq-keep (lambda (suffix)
+ (and (eieio-object-p suffix)
+ (slot-boundp suffix 'key)
+ (length (oref suffix key))))
+ (oref group suffixes))))))
(defun transient--pixel-width (string)
(save-window-excursion
(face-remap-reset-base 'default)
(face-remap-add-relative 'default 'fixed-pitch))
-;;;; Missing from Emacs
+(defun transient--func-arity (fn)
+ (func-arity (advice--cd*r (if (symbolp fn) (symbol-function fn) fn))))
(defun transient--seq-reductions-from (function sequence initial-value)
(let ((acc (list initial-value)))
(push (funcall function (car acc) elt) acc))
(nreverse acc)))
-(defun transient-plist-to-alist (plist)
- (let (alist)
- (while plist
- (push (cons (let* ((symbol (pop plist))
- (name (symbol-name symbol)))
- (if (eq (aref name 0) ?:)
- (intern (substring name 1))
- symbol))
- (pop plist))
- alist))
- (nreverse alist)))
-
;;; Font-Lock
(defconst transient-font-lock-keywords
projects / emacs.git / commitdiff