branch: externals/transient
commit bcc0bf836808e156262d9ff631be7d91a0ec201d
Author: Jonas Bernoulli <jo...@bernoul.li>
Commit: Jonas Bernoulli <jo...@bernoul.li>
Improve format of layout and handling of included groups
- Improve the internal format used to store layouts. This makes
handling easier and results in prettier pretty-printing.
- Store the level property in the same plist for all other properties.
- Reduce nesting of elements.
- Wrap a prefix's top-level groups in a vector, which has the same
form the vectors used for actual groups, except that its first
element specifies the layout format version (currently 2), instead
of the group class. Previously a raw list was used, which had the
considerable disadvantage that the top-level required special cases,
compared to groups and suffixes found at deeper levels.
- When encountering a layout that still used the old format, convert
it on the fly and update the store layout.
- No longer inline included groups by default.
- Store the symbol that identifies the separately defined group in the
layout of the prefix (or other group) that includes it. Previously
its expansion was immediately inlined.
- When modifying an included group, either directly or via a prefix
which includes it, then this affects all prefixes that include it.
- The new function `transient-inline-group' can be used in the rare
case that this is not desirable.
- Instead of group vectors that macro also accepts suffix lists as
arguments, to maintain the ability to include lists of suffixes,
not just individual groups or list of groups. However, this is
semi-deprecated and undocumented.
- The new function `transient-define-group' can be used to define a
group or set of groups, to be included in prefixes. It stores the
layout the same way as `transient-define-prefix', in parsed form.
---
lisp/transient.el | 271 ++++++++++++++++++++++++++++++++----------------------
1 file changed, 163 insertions(+), 108 deletions(-)
diff --git a/lisp/transient.el b/lisp/transient.el
index 20200f91e0..cc6b2b8414 100644
--- a/lisp/transient.el
+++ b/lisp/transient.el
@@ -1083,6 +1083,19 @@ to the setup function:
',name
(list ,@(mapcan (lambda (s) (transient--parse-child name s))
groups))))))
+(defmacro transient-define-group (name &rest groups)
+ "Define one or more groups and store them in symbol NAME.
+
+Groups defined using this macro, can be used inside the
+definition of transient prefix commands, by using the symbol
+NAME where a group vector is expected. GROUPS has the same
+form as for `transient-define-prefix'."
+ (declare (debug (&define name [&rest vectorp]))
+ (indent defun))
+ `(transient--set-layout
+ ',name
+ (list ,@(mapcan (lambda (s) (transient--parse-child name s)) groups))))
+
(defmacro transient-define-suffix (name arglist &rest args)
"Define NAME as a transient suffix command.
@@ -1272,34 +1285,19 @@ commands are aliases for."
(defun transient--parse-child (prefix 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))
- (vectorp (car value))))
- (mapcan (lambda (s) (transient--parse-child prefix s))
value)
- (transient--parse-child prefix value))))
+ (symbol (list `',spec))
(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))
(t (error "Invalid transient--parse-child spec: %s" spec))))
(defun transient--parse-group (prefix spec)
- (let ((spec (append spec nil))
- level class args)
+ (let (class args)
+ (setq spec (append spec nil))
(when (integerp (car spec))
- (setq level (pop spec)))
+ (setq args (plist-put args :level (pop spec))))
(when (stringp (car spec))
(setq args (plist-put args :description (pop spec))))
- ;; Merge value of [... GROUP-VARIABLE], if any.
- (let ((spec* spec))
- (while (keywordp (car spec*))
- (setq spec* (cddr spec*)))
- (when (and (length= spec* 1) (symbolp (car spec*)))
- (let ((rest (append (symbol-value (car spec*)) nil))
- (args nil))
- (while (keywordp (car rest))
- (setq args (nconc (list (pop rest) (pop rest)) args)))
- (setq spec (nconc args (butlast spec) rest)))))
(while (keywordp (car spec))
(let* ((key (pop spec))
(val (if spec (pop spec) (error "No value for `%s'" key))))
@@ -1314,7 +1312,6 @@ commands are aliases for."
(message "WARNING: %s: When %s is used, %s must also be specified"
'transient-define-prefix :setup-children :class))
(list 'vector
- level
(list 'quote
(cond (class)
((cl-typep (car spec)
@@ -1326,12 +1323,12 @@ commands are aliases for."
(mapcan (lambda (s) (transient--parse-child prefix s))
spec)))))
(defun transient--parse-suffix (prefix spec)
- (let (level class args)
+ (let (class args)
(cl-flet ((use (prop value)
(setq args (plist-put args prop value))))
(pcase (car spec)
((cl-type integer)
- (setq level (pop spec))))
+ (use :level (pop spec))))
(pcase (car spec)
((cl-type (or string vector))
(use :key (pop spec))))
@@ -1397,7 +1394,6 @@ commands are aliases for."
(val (if spec (pop spec) (error "No value for `%s'" key))))
(pcase key
(:class (setq class val))
- (:level (setq level val))
(:info (setq class 'transient-information)
(use :description val))
(:info* (setq class 'transient-information*)
@@ -1417,8 +1413,7 @@ commands are aliases for."
(replace-match transient-common-command-prefix t t key 1)))
(when-let ((shortarg (plist-get args :shortarg)))
(use :key shortarg))))
- (list 'list
- level
+ (list 'cons
(macroexp-quote (or class 'transient-suffix))
(cons 'list args))))
@@ -1448,13 +1443,56 @@ symbol property.")
#'transient-command-completion-not-suffix-only-p))
(defun transient--set-layout (prefix layout)
- (put prefix 'transient--layout layout))
+ (put prefix 'transient--layout (vector 2 nil layout)))
(defun transient--get-layout (prefix)
- (or (get prefix 'transient--layout)
- (error "Not a transient prefix command: %s" prefix)))
-
-(defalias 'transient--get-children #'transient--get-layout)
+ (if-let*
+ ((layout
+ (or (get prefix 'transient--layout)
+ ;; Migrate unparsed legacy group definition.
+ (condition-case-unless-debug err
+ (and-let* ((value (symbol-value prefix)))
+ (transient--set-layout
+ prefix
+ (if (and (listp value)
+ (or (listp (car value))
+ (vectorp (car value))))
+ (transient-parse-suffixes prefix value)
+ (list (transient-parse-suffix prefix value)))))
+ (error
+ (message "Not a legacy group definition: %s: %S" prefix err)
+ nil)))))
+ (if (vectorp layout)
+ (let ((version (aref layout 0)))
+ (if (= version 2)
+ layout
+ (error "Unsupported layout version %s for %s" version prefix)))
+ ;; Upgrade from version 1.
+ (cl-labels
+ ((upgrade (spec)
+ (cond
+ ((vectorp spec)
+ (pcase-let ((`[,level ,class ,args ,children] spec))
+ (when level
+ (setq args (plist-put args :level level)))
+ (vector class args (mapcar #'upgrade children))))
+ ((and (listp spec)
+ (length= spec 3)
+ (or (null (car spec))
+ (natnump (car spec)))
+ (symbolp (cadr spec)))
+ (pcase-let ((`(,level ,class ,args) spec))
+ (when level
+ (setq args (plist-put args :level level)))
+ (cons class args)))
+ ((listp spec)
+ (mapcar #'upgrade spec))
+ (t spec))))
+ (transient--set-layout prefix (upgrade layout))))
+ (error "Not a transient prefix command or group definition: %s" prefix)))
+
+(defun transient--get-children (prefix)
+ (aref (transient--get-layout prefix) 2))
(defun transient-parse-suffix (prefix suffix)
"Parse SUFFIX, to be added to PREFIX.
@@ -1481,14 +1519,14 @@ Intended for use in a group's `:setup-children'
function."
;;; Edit
(defun transient--insert-suffix (prefix loc suffix action &optional keep-other)
- (let* ((suf (cl-etypecase suffix
- (vector (eval (transient--parse-group prefix suffix) t))
- (list (eval (transient--parse-suffix prefix suffix) t))
- (string suffix)))
- (mem (transient--layout-member loc prefix))
- (elt (car mem)))
+ (pcase-let* ((suf (cl-etypecase suffix
+ (vector (eval (transient--parse-group prefix suffix) t))
+ (list (eval (transient--parse-suffix prefix suffix) t))
+ (string suffix)
+ (symbol suffix)))
+ (`(,elt ,group) (transient--locate-child prefix loc)))
(cond
- ((not mem)
+ ((not elt)
(funcall (if transient-error-on-insert-failure #'error #'message)
"Cannot insert %S into %s; %s not found"
suffix prefix loc))
@@ -1503,7 +1541,7 @@ Intended for use in a group's `:setup-children' function."
(when-let* (((not (eq keep-other 'always)))
(bindingp (listp suf))
(key (transient--spec-key suf))
- (conflict (car (transient--layout-member key prefix)))
+ (conflict (car (transient--locate-child prefix key)))
(conflictp
(and (not (and (eq action 'replace)
(eq conflict elt)))
@@ -1515,11 +1553,12 @@ Intended for use in a group's `:setup-children'
function."
(equal (transient--suffix-predicate suf)
(transient--suffix-predicate conflict)))))
(transient-remove-suffix prefix key))
- (pcase-exhaustive action
- ('insert (setcdr mem (cons elt (cdr mem)))
- (setcar mem suf))
- ('append (setcdr mem (cons suf (cdr mem))))
- ('replace (setcar mem suf)))))))
+ (let ((mem (memq elt (aref group 2))))
+ (pcase-exhaustive action
+ ('insert (setcdr mem (cons elt (cdr mem)))
+ (setcar mem suf))
+ ('append (setcdr mem (cons suf (cdr mem))))
+ ('replace (setcar mem suf))))))))
;;;###autoload
(defun transient-insert-suffix (prefix loc suffix &optional keep-other)
@@ -1568,6 +1607,22 @@ See info node `(transient)Modifying Existing
Transients'."
(declare (indent defun))
(transient--insert-suffix prefix loc suffix 'replace))
+;;;###autoload
+(defun transient-inline-group (prefix group)
+ "Inline the included GROUP into PREFIX.
+Replace the symbol GROUP with its expanded layout in the
+layout of PREFIX."
+ (declare (indent defun))
+ (cl-assert (symbolp group))
+ (pcase-let ((`(,suffix ,parent) (transient--locate-child prefix group)))
+ (when suffix
+ (let* ((siblings (aref parent 2))
+ (pos (cl-position group siblings)))
+ (aset parent 2
+ (nconc (seq-take siblings pos)
+ (transient--get-children group)
+ (seq-drop siblings (1+ pos))))))))
+
;;;###autoload
(defun transient-remove-suffix (prefix loc)
"Remove the suffix or group at LOC in PREFIX.
@@ -1577,7 +1632,9 @@ LOC is a command, a key vector, a key description (a
string
(whose last element may also be a command or key).
See info node `(transient)Modifying Existing Transients'."
(declare (indent defun))
- (transient--layout-member loc prefix 'remove))
+ (pcase-let ((`(,suffix ,group) (transient--locate-child prefix loc)))
+ (when suffix
+ (aset group 2 (delq suffix (aref group 2))))))
(defun transient-suffix-put (prefix loc prop value)
"Edit the suffix at LOC in PREFIX, setting PROP to VALUE.
@@ -1590,11 +1647,10 @@ LOC is a command, a key vector, a key description (a
string
See info node `(transient)Modifying Existing Transients'."
(let ((child (transient-get-suffix prefix loc)))
(if (vectorp child)
- (aset child 2 (plist-put (aref child 2) prop value))
- (setf (caddr child)
- (plist-put (transient--suffix-props child) prop value)))))
+ (aset child 1 (plist-put (aref child 1) prop value))
+ (setcdr child (plist-put (transient--suffix-props child) prop value)))))
-(defalias 'transient--suffix-props #'caddr)
+(defalias 'transient--suffix-props #'cdr)
(defun transient-get-suffix (prefix loc)
"Return the suffix or group at LOC in PREFIX.
@@ -1603,56 +1659,51 @@ LOC is a command, a key vector, a key description (a
string
as returned by `key-description'), or a coordination list
(whose last element may also be a command or key).
See info node `(transient)Modifying Existing Transients'."
- (or (car (transient--layout-member loc prefix))
+ (or (car (transient--locate-child prefix loc))
(error "%s not found in %s" loc prefix)))
-(defun transient--layout-member (loc prefix &optional remove)
- (let ((layout (transient--get-layout prefix)))
- (when (vectorp loc)
- (setq loc (append loc nil)))
- (when (listp loc)
- (while (integerp (car loc))
- (let* ((children (if (vectorp layout) (aref layout 3) layout))
- (mem (transient--nthcdr (pop loc) children)))
- (if (and remove (not loc))
- (let ((rest (delq (car mem) children)))
- (if (vectorp layout)
- (aset layout 3 rest)
- (transient--set-layout prefix rest))
- (setq layout nil))
- (setq layout (if loc (car mem) mem)))))
- (setq loc (car loc)))
- (when (stringp loc)
- (setq loc (kbd loc)))
- (if loc
- (transient--layout-member-1 loc layout remove)
- layout)))
-
-(defun transient--layout-member-1 (loc layout remove)
- (cond ((listp layout)
- (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove))
- layout))
- ((vectorp (car (aref layout 3)))
- (seq-some (lambda (elt) (transient--layout-member-1 loc elt remove))
- (aref layout 3)))
- (remove
- (aset layout 3
- (delq (car (transient--group-member loc layout))
- (aref layout 3)))
- nil)
- ((transient--group-member loc layout))))
-
-(defun transient--group-member (loc group)
- (cl-member-if (lambda (suffix)
- (and (listp suffix)
- (let* ((props (transient--suffix-props suffix))
- (cmd (plist-get props :command)))
- (if (symbolp loc)
- (eq cmd loc)
- (equal (kbd (or (plist-get props :key)
- (transient--command-key cmd)))
- loc)))))
- (aref group 3)))
+(defun transient--locate-child (group loc)
+ (when (symbolp group)
+ (setq group (transient--get-layout group)))
+ (when (vectorp loc)
+ (setq loc (append loc nil)))
+ (if (listp loc)
+ (and-let* ((match (transient--nth (pop loc) (aref group 2))))
+ (if loc
+ (transient--locate-child
+ match (cond ((or (stringp (car loc))
+ (symbolp (car loc)))
+ (car loc))
+ ((symbolp match)
+ (vconcat (cons 0 loc)))
+ ((vconcat loc))))
+ (list match group)))
+ (seq-some (lambda (child)
+ (transient--match-child group loc child))
+ (aref group 2))))
+
+(defun transient--match-child (group loc child)
+ (cl-etypecase child
+ (string nil)
+ (symbol (if (symbolp loc)
+ (and (eq child loc)
+ (list child group))
+ (and-let* ((include (transient--get-layout child)))
+ (transient--locate-child include loc))))
+ (vector (seq-some (lambda (subgroup)
+ (transient--locate-child subgroup loc))
+ (aref group 2)))
+ (list (let* ((props (transient--suffix-props child))
+ (cmd (plist-get props :command)))
+ (and (if (symbolp loc)
+ (eq cmd loc)
+ (equal (kbd (or (plist-get props :key)
+ (transient--command-key cmd)))
+ (kbd loc)))
+ (list child group))))))
+
+(defun transient--nth (n list)
+ (nth (if (< n 0) (- (length list) (abs n)) n) list))
(defun transient--spec-key (spec)
(let ((props (transient--suffix-props spec)))
@@ -1669,9 +1720,6 @@ See info node `(transient)Modifying Existing Transients'."
(oref obj shortarg)
(transient--derive-shortarg (oref obj argument)))))))
-(defun transient--nthcdr (n list)
- (nthcdr (if (< n 0) (- (length list) (abs n)) n) list))
-
(defun transient-set-default-level (command level)
"Set the default level of suffix COMMAND to LEVEL.
@@ -2012,11 +2060,14 @@ to `transient-predicate-map'. See also
`transient-base-map'.")
("{p} l" "Show/hide suffixes" transient-set-level)
("{p} a" transient-toggle-level-limit)]]
"Commands available in all transient menus.
-The same functions that are used to change bindings in transient prefix
-commands, can be used to modify these bindings as well, but note that
-customizing `transient-common-command-prefix' resets these bindings and
-that the special meaning of \"{p}\" does not apply when modifying these
-bindings.")
+
+The same functions, that are used to change bindings in transient prefix
+commands and transient groups (defined using `transient-define-group'),
+should be used to modify these bindings as well. The actual layout is
+stored in the symbol's `transient--layout' property. The variable value
+is only used when customizing `transient-common-command-prefix', which
+resets the value of `transient--layout' based on the values of that
+option and this variable.")
(defun transient--init-common-commands ()
(transient--set-layout
@@ -2412,13 +2463,16 @@ value. Otherwise return CHILDREN as is.")
(defun transient--init-child (levels spec parent)
(cl-etypecase spec
+ (symbol (mapcan (lambda (c) (transient--init-child levels c parent))
+ (transient--get-children spec)))
(vector (transient--init-group levels spec parent))
(list (transient--init-suffix levels spec parent))
(string (list spec))))
(defun transient--init-group (levels spec parent)
- (pcase-let* ((`(,level ,class ,args ,children) (append spec nil))
- (level (or level transient--default-child-level)))
+ (pcase-let* ((`[,class ,args ,children] spec)
+ (level (or (plist-get args :level)
+ transient--default-child-level)))
(and-let* (((transient--use-level-p level))
(obj (apply class :parent parent :level level args))
((transient--use-suffix-p obj))
@@ -2432,14 +2486,14 @@ value. Otherwise return CHILDREN as is.")
(list obj)))))
(defun transient--init-suffix (levels spec parent)
- (pcase-let* ((`(,level ,class ,args) spec)
+ (pcase-let* ((`(,class . ,args) spec)
(cmd (plist-get args :command))
(_ (transient--load-command-if-autoload cmd))
(key (kbd (plist-get args :key)))
(proto (and cmd (transient--suffix-prototype cmd)))
(level (or (alist-get (cons cmd key) levels nil nil #'equal)
(alist-get cmd levels)
- level
+ (plist-get args :level)
(and proto (oref proto level))
transient--default-child-level)))
(when (transient--use-level-p level)
@@ -5204,6 +5258,7 @@ as stand-in for elements of exhausted lists."
(eval-when-compile
`((,(concat "("
(regexp-opt (list "transient-define-prefix"
+ "transient-define-group"
"transient-define-infix"
"transient-define-argument"
"transient-define-suffix")
