diff options
author | Case Duckworth | 2022-07-06 16:47:32 -0500 |
---|---|---|
committer | Case Duckworth | 2022-07-06 16:47:32 -0500 |
commit | 42947150adc2639bf7456d40dedce09338cec303 (patch) | |
tree | 87d0c4eac037266581f2c3599c308a0b616cf358 /lisp | |
parent | Update readme (diff) | |
download | emacs-42947150adc2639bf7456d40dedce09338cec303.tar.gz emacs-42947150adc2639bf7456d40dedce09338cec303.zip |
Rename +compat.el to avoid collision; add a thing
Diffstat (limited to 'lisp')
-rw-r--r-- | lisp/+compat.el | 64 | ||||
-rw-r--r-- | lisp/compat.el | 34 | ||||
-rw-r--r-- | lisp/compat/keymap.el | 590 | ||||
-rw-r--r-- | lisp/compat/tab-bar.el | 2424 |
4 files changed, 64 insertions, 3048 deletions
diff --git a/lisp/+compat.el b/lisp/+compat.el new file mode 100644 index 0000000..286d5da --- /dev/null +++ b/lisp/+compat.el | |||
@@ -0,0 +1,64 @@ | |||
1 | ;;; +compat.el --- Thin backward-compatibility shim -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Commentary: | ||
4 | |||
5 | ;; I use different versionso of Emacs. Sometimes I have to copy-paste functions | ||
6 | ;; from newer Emacs to make my customizations work. This is that file. | ||
7 | |||
8 | ;; This is probably ill-advised. | ||
9 | |||
10 | ;;; Code: | ||
11 | |||
12 | ;;; Load stuff in +compat/ subdirectory | ||
13 | (dolist (file (directory-files (locate-user-emacs-file "lisp/+compat") :full "\\.el\\'")) | ||
14 | (load file :noerror)) | ||
15 | |||
16 | ;;; Only define things if not already defined | ||
17 | (defmacro +compat-defun (name &rest args) | ||
18 | `(if (fboundp ',name) | ||
19 | (message "+compat: `%s' already bound." ',name) | ||
20 | (defun ,name ,@args))) | ||
21 | |||
22 | (defmacro +compat-defmacro (name &rest args) | ||
23 | `(if (fboundp ',name) | ||
24 | (message "+compat: `%s' already bound." ',name) | ||
25 | (defmacro ,name ,@args))) | ||
26 | |||
27 | ;;; Single functions | ||
28 | |||
29 | (+compat-defmacro dlet (binders &rest body) | ||
30 | "Like `let' but using dynamic scoping." | ||
31 | (declare (indent 1) (debug let)) | ||
32 | ;; (defvar FOO) only affects the current scope, but in order for | ||
33 | ;; this not to affect code after the main `let' we need to create a new scope, | ||
34 | ;; which is what the surrounding `let' is for. | ||
35 | ;; FIXME: (let () ...) currently doesn't actually create a new scope, | ||
36 | ;; which is why we use (let (_) ...). | ||
37 | `(let (_) | ||
38 | ,@(mapcar (lambda (binder) | ||
39 | `(defvar ,(if (consp binder) (car binder) binder))) | ||
40 | binders) | ||
41 | (let ,binders ,@body))) | ||
42 | |||
43 | ;; https://git.savannah.gnu.org/cgit/emacs.git/diff/?id=772b189143453745a8e014e21d4b6b78f855bba3 | ||
44 | (+compat-defun rename-visited-file (new-location) | ||
45 | "Rename the file visited by the current buffer to NEW-LOCATION. | ||
46 | This command also sets the visited file name. If the buffer | ||
47 | isn't visiting any file, that's all it does. | ||
48 | |||
49 | Interactively, this prompts for NEW-LOCATION." | ||
50 | (interactive | ||
51 | (list (if buffer-file-name | ||
52 | (read-file-name "Rename visited file to: ") | ||
53 | (read-file-name "Set visited file name: " | ||
54 | default-directory | ||
55 | (expand-file-name | ||
56 | (file-name-nondirectory (buffer-name)) | ||
57 | default-directory))))) | ||
58 | (when (and buffer-file-name | ||
59 | (file-exists-p buffer-file-name)) | ||
60 | (rename-file buffer-file-name new-location)) | ||
61 | (set-visited-file-name new-location nil t)) | ||
62 | |||
63 | (provide '+compat) | ||
64 | ;;; +compat.el ends here | ||
diff --git a/lisp/compat.el b/lisp/compat.el deleted file mode 100644 index 4bb8706..0000000 --- a/lisp/compat.el +++ /dev/null | |||
@@ -1,34 +0,0 @@ | |||
1 | ;;; compat.el --- Thin backward-compatibility shim -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;;; Commentary: | ||
4 | |||
5 | ;; I use different versionso of Emacs. Sometimes I have to copy-paste functions | ||
6 | ;; from newer Emacs to make my customizations work. This is that file. | ||
7 | |||
8 | ;; This is probably ill-advised. | ||
9 | |||
10 | ;;; Code: | ||
11 | |||
12 | ;; Load stuff in compat/ subdirectory | ||
13 | (dolist (file (directory-files (locate-user-emacs-file "lisp/compat") :full "\\.el\\'")) | ||
14 | (load file :noerror)) | ||
15 | |||
16 | ;; Other stuff... | ||
17 | |||
18 | (unless (fboundp 'dlet) | ||
19 | (defmacro dlet (binders &rest body) | ||
20 | "Like `let' but using dynamic scoping." | ||
21 | (declare (indent 1) (debug let)) | ||
22 | ;; (defvar FOO) only affects the current scope, but in order for | ||
23 | ;; this not to affect code after the main `let' we need to create a new scope, | ||
24 | ;; which is what the surrounding `let' is for. | ||
25 | ;; FIXME: (let () ...) currently doesn't actually create a new scope, | ||
26 | ;; which is why we use (let (_) ...). | ||
27 | `(let (_) | ||
28 | ,@(mapcar (lambda (binder) | ||
29 | `(defvar ,(if (consp binder) (car binder) binder))) | ||
30 | binders) | ||
31 | (let ,binders ,@body)))) | ||
32 | |||
33 | (provide 'compat) | ||
34 | ;;; compat.el ends here | ||
diff --git a/lisp/compat/keymap.el b/lisp/compat/keymap.el deleted file mode 100644 index 3e9189f..0000000 --- a/lisp/compat/keymap.el +++ /dev/null | |||
@@ -1,590 +0,0 @@ | |||
1 | ;;; keymap.el --- Keymap functions -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;; Copyright (C) 2021-2022 Free Software Foundation, Inc. | ||
4 | |||
5 | ;; This file is part of GNU Emacs. | ||
6 | |||
7 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
8 | ;; it under the terms of the GNU General Public License as published by | ||
9 | ;; the Free Software Foundation, either version 3 of the License, or | ||
10 | ;; (at your option) any later version. | ||
11 | |||
12 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
15 | ;; GNU General Public License for more details. | ||
16 | |||
17 | ;; You should have received a copy of the GNU General Public License | ||
18 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
19 | |||
20 | ;;; Commentary: | ||
21 | |||
22 | ;; This library deals with the "new" keymap binding interface: The | ||
23 | ;; only key syntax allowed by these functions is the `kbd' one. | ||
24 | |||
25 | ;;; Code: | ||
26 | |||
27 | |||
28 | |||
29 | (defun keymap--check (key) | ||
30 | "Signal an error if KEY doesn't have a valid syntax." | ||
31 | (unless (key-valid-p key) | ||
32 | (error "%S is not a valid key definition; see `key-valid-p'" key))) | ||
33 | |||
34 | (defun keymap--compile-check (&rest keys) | ||
35 | (dolist (key keys) | ||
36 | (when (or (vectorp key) | ||
37 | (and (stringp key) (not (key-valid-p key)))) | ||
38 | (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) | ||
39 | |||
40 | (defun keymap-set (keymap key definition) | ||
41 | "Set KEY to DEFINITION in KEYMAP. | ||
42 | KEY is a string that satisfies `key-valid-p'. | ||
43 | |||
44 | DEFINITION is anything that can be a key's definition: | ||
45 | nil (means key is undefined in this keymap), | ||
46 | a command (a Lisp function suitable for interactive calling), | ||
47 | a string (treated as a keyboard macro), | ||
48 | a keymap (to define a prefix key), | ||
49 | a symbol (when the key is looked up, the symbol will stand for its | ||
50 | function definition, which should at that time be one of the above, | ||
51 | or another symbol whose function definition is used, etc.), | ||
52 | a cons (STRING . DEFN), meaning that DEFN is the definition | ||
53 | (DEFN should be a valid definition in its own right) and | ||
54 | STRING is the menu item name (which is used only if the containing | ||
55 | keymap has been created with a menu name, see `make-keymap'), | ||
56 | or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, | ||
57 | or an extended menu item definition. | ||
58 | (See info node `(elisp)Extended Menu Items'.)" | ||
59 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
60 | (keymap--check key) | ||
61 | ;; If we're binding this key to another key, then parse that other | ||
62 | ;; key, too. | ||
63 | (when (stringp definition) | ||
64 | (keymap--check definition) | ||
65 | (setq definition (key-parse definition))) | ||
66 | (define-key keymap (key-parse key) definition)) | ||
67 | |||
68 | (defun keymap-global-set (key command) | ||
69 | "Give KEY a global binding as COMMAND. | ||
70 | COMMAND is the command definition to use; usually it is | ||
71 | a symbol naming an interactively-callable function. | ||
72 | |||
73 | KEY is a string that satisfies `key-valid-p'. | ||
74 | |||
75 | Note that if KEY has a local binding in the current buffer, | ||
76 | that local binding will continue to shadow any global binding | ||
77 | that you make with this function." | ||
78 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
79 | (interactive | ||
80 | (let* ((menu-prompting nil) | ||
81 | (key (read-key-sequence "Set key globally: " nil t))) | ||
82 | (list key | ||
83 | (read-command (format "Set key %s to command: " | ||
84 | (key-description key)))))) | ||
85 | (keymap-set (current-global-map) key command)) | ||
86 | |||
87 | (defun keymap-local-set (key command) | ||
88 | "Give KEY a local binding as COMMAND. | ||
89 | COMMAND is the command definition to use; usually it is | ||
90 | a symbol naming an interactively-callable function. | ||
91 | |||
92 | KEY is a string that satisfies `key-valid-p'. | ||
93 | |||
94 | The binding goes in the current buffer's local map, which in most | ||
95 | cases is shared with all other buffers in the same major mode." | ||
96 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
97 | (interactive "KSet key locally: \nCSet key %s locally to command: ") | ||
98 | (let ((map (current-local-map))) | ||
99 | (unless map | ||
100 | (use-local-map (setq map (make-sparse-keymap)))) | ||
101 | (keymap-set map key command))) | ||
102 | |||
103 | (defun keymap-global-unset (key &optional remove) | ||
104 | "Remove global binding of KEY (if any). | ||
105 | KEY is a string that satisfies `key-valid-p'. | ||
106 | |||
107 | If REMOVE (interactively, the prefix arg), remove the binding | ||
108 | instead of unsetting it. See `keymap-unset' for details." | ||
109 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
110 | (interactive | ||
111 | (list (key-description (read-key-sequence "Set key locally: ")) | ||
112 | current-prefix-arg)) | ||
113 | (keymap-unset (current-global-map) key remove)) | ||
114 | |||
115 | (defun keymap-local-unset (key &optional remove) | ||
116 | "Remove local binding of KEY (if any). | ||
117 | KEY is a string that satisfies `key-valid-p'. | ||
118 | |||
119 | If REMOVE (interactively, the prefix arg), remove the binding | ||
120 | instead of unsetting it. See `keymap-unset' for details." | ||
121 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
122 | (interactive | ||
123 | (list (key-description (read-key-sequence "Unset key locally: ")) | ||
124 | current-prefix-arg)) | ||
125 | (when (current-local-map) | ||
126 | (keymap-unset (current-local-map) key remove))) | ||
127 | |||
128 | (defun keymap-unset (keymap key &optional remove) | ||
129 | "Remove key sequence KEY from KEYMAP. | ||
130 | KEY is a string that satisfies `key-valid-p'. | ||
131 | |||
132 | If REMOVE, remove the binding instead of unsetting it. This only | ||
133 | makes a difference when there's a parent keymap. When unsetting | ||
134 | a key in a child map, it will still shadow the same key in the | ||
135 | parent keymap. Removing the binding will allow the key in the | ||
136 | parent keymap to be used." | ||
137 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
138 | (keymap--check key) | ||
139 | (define-key keymap (key-parse key) nil remove)) | ||
140 | |||
141 | (defun keymap-substitute (keymap olddef newdef &optional oldmap prefix) | ||
142 | "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. | ||
143 | In other words, OLDDEF is replaced with NEWDEF wherever it appears. | ||
144 | Alternatively, if optional fourth argument OLDMAP is specified, we redefine | ||
145 | in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. | ||
146 | |||
147 | If you don't specify OLDMAP, you can usually get the same results | ||
148 | in a cleaner way with command remapping, like this: | ||
149 | (define-key KEYMAP [remap OLDDEF] NEWDEF) | ||
150 | \n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" | ||
151 | ;; Don't document PREFIX in the doc string because we don't want to | ||
152 | ;; advertise it. It's meant for recursive calls only. Here's its | ||
153 | ;; meaning | ||
154 | |||
155 | ;; If optional argument PREFIX is specified, it should be a key | ||
156 | ;; prefix, a string. Redefined bindings will then be bound to the | ||
157 | ;; original key, with PREFIX added at the front. | ||
158 | (unless prefix | ||
159 | (setq prefix "")) | ||
160 | (let* ((scan (or oldmap keymap)) | ||
161 | (prefix1 (vconcat prefix [nil])) | ||
162 | (key-substitution-in-progress | ||
163 | (cons scan key-substitution-in-progress))) | ||
164 | ;; Scan OLDMAP, finding each char or event-symbol that | ||
165 | ;; has any definition, and act on it with hack-key. | ||
166 | (map-keymap | ||
167 | (lambda (char defn) | ||
168 | (aset prefix1 (length prefix) char) | ||
169 | (substitute-key-definition-key defn olddef newdef prefix1 keymap)) | ||
170 | scan))) | ||
171 | |||
172 | (defun keymap-set-after (keymap key definition &optional after) | ||
173 | "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. | ||
174 | This is like `keymap-set' except that the binding for KEY is placed | ||
175 | just after the binding for the event AFTER, instead of at the beginning | ||
176 | of the map. Note that AFTER must be an event type (like KEY), NOT a command | ||
177 | \(like DEFINITION). | ||
178 | |||
179 | If AFTER is t or omitted, the new binding goes at the end of the keymap. | ||
180 | AFTER should be a single event type--a symbol or a character, not a sequence. | ||
181 | |||
182 | Bindings are always added before any inherited map. | ||
183 | |||
184 | The order of bindings in a keymap matters only when it is used as | ||
185 | a menu, so this function is not useful for non-menu keymaps." | ||
186 | (declare (indent defun) | ||
187 | (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
188 | (keymap--check key) | ||
189 | (when after | ||
190 | (keymap--check after)) | ||
191 | (define-key-after keymap (key-parse key) definition | ||
192 | (and after (key-parse after)))) | ||
193 | |||
194 | (defun key-parse (keys) | ||
195 | "Convert KEYS to the internal Emacs key representation. | ||
196 | See `kbd' for a descripion of KEYS." | ||
197 | (declare (pure t) (side-effect-free t)) | ||
198 | ;; A pure function is expected to preserve the match data. | ||
199 | (save-match-data | ||
200 | (let ((case-fold-search nil) | ||
201 | (len (length keys)) ; We won't alter keys in the loop below. | ||
202 | (pos 0) | ||
203 | (res [])) | ||
204 | (while (and (< pos len) | ||
205 | (string-match "[^ \t\n\f]+" keys pos)) | ||
206 | (let* ((word-beg (match-beginning 0)) | ||
207 | (word-end (match-end 0)) | ||
208 | (word (substring keys word-beg len)) | ||
209 | (times 1) | ||
210 | key) | ||
211 | ;; Try to catch events of the form "<as df>". | ||
212 | (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) | ||
213 | (setq word (match-string 0 word) | ||
214 | pos (+ word-beg (match-end 0))) | ||
215 | (setq word (substring keys word-beg word-end) | ||
216 | pos word-end)) | ||
217 | (when (string-match "\\([0-9]+\\)\\*." word) | ||
218 | (setq times (string-to-number (substring word 0 (match-end 1)))) | ||
219 | (setq word (substring word (1+ (match-end 1))))) | ||
220 | (cond ((string-match "^<<.+>>$" word) | ||
221 | (setq key (vconcat (if (eq (key-binding [?\M-x]) | ||
222 | 'execute-extended-command) | ||
223 | [?\M-x] | ||
224 | (or (car (where-is-internal | ||
225 | 'execute-extended-command)) | ||
226 | [?\M-x])) | ||
227 | (substring word 2 -2) "\r"))) | ||
228 | ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) | ||
229 | (progn | ||
230 | (setq word (concat (match-string 1 word) | ||
231 | (match-string 3 word))) | ||
232 | (not (string-match | ||
233 | "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" | ||
234 | word)))) | ||
235 | (setq key (list (intern word)))) | ||
236 | ((or (equal word "REM") (string-match "^;;" word)) | ||
237 | (setq pos (string-match "$" keys pos))) | ||
238 | (t | ||
239 | (let ((orig-word word) (prefix 0) (bits 0)) | ||
240 | (while (string-match "^[ACHMsS]-." word) | ||
241 | (setq bits (+ bits | ||
242 | (cdr | ||
243 | (assq (aref word 0) | ||
244 | '((?A . ?\A-\^@) (?C . ?\C-\^@) | ||
245 | (?H . ?\H-\^@) (?M . ?\M-\^@) | ||
246 | (?s . ?\s-\^@) (?S . ?\S-\^@)))))) | ||
247 | (setq prefix (+ prefix 2)) | ||
248 | (setq word (substring word 2))) | ||
249 | (when (string-match "^\\^.$" word) | ||
250 | (setq bits (+ bits ?\C-\^@)) | ||
251 | (setq prefix (1+ prefix)) | ||
252 | (setq word (substring word 1))) | ||
253 | (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") | ||
254 | ("LFD" . "\n") ("TAB" . "\t") | ||
255 | ("ESC" . "\e") ("SPC" . " ") | ||
256 | ("DEL" . "\177"))))) | ||
257 | (when found (setq word (cdr found)))) | ||
258 | (when (string-match "^\\\\[0-7]+$" word) | ||
259 | (let ((n 0)) | ||
260 | (dolist (ch (cdr (string-to-list word))) | ||
261 | (setq n (+ (* n 8) ch -48))) | ||
262 | (setq word (vector n)))) | ||
263 | (cond ((= bits 0) | ||
264 | (setq key word)) | ||
265 | ((and (= bits ?\M-\^@) (stringp word) | ||
266 | (string-match "^-?[0-9]+$" word)) | ||
267 | (setq key (mapcar (lambda (x) (+ x bits)) | ||
268 | (append word nil)))) | ||
269 | ((/= (length word) 1) | ||
270 | (error "%s must prefix a single character, not %s" | ||
271 | (substring orig-word 0 prefix) word)) | ||
272 | ((and (/= (logand bits ?\C-\^@) 0) (stringp word) | ||
273 | ;; We used to accept . and ? here, | ||
274 | ;; but . is simply wrong, | ||
275 | ;; and C-? is not used (we use DEL instead). | ||
276 | (string-match "[@-_a-z]" word)) | ||
277 | (setq key (list (+ bits (- ?\C-\^@) | ||
278 | (logand (aref word 0) 31))))) | ||
279 | (t | ||
280 | (setq key (list (+ bits (aref word 0))))))))) | ||
281 | (when key | ||
282 | (dolist (_ (number-sequence 1 times)) | ||
283 | (setq res (vconcat res key)))))) | ||
284 | (if (and (>= (length res) 4) | ||
285 | (eq (aref res 0) ?\C-x) | ||
286 | (eq (aref res 1) ?\() | ||
287 | (eq (aref res (- (length res) 2)) ?\C-x) | ||
288 | (eq (aref res (- (length res) 1)) ?\))) | ||
289 | (apply #'vector (let ((lres (append res nil))) | ||
290 | ;; Remove the first and last two elements. | ||
291 | (setq lres (cdr (cdr lres))) | ||
292 | (nreverse lres) | ||
293 | (setq lres (cdr (cdr lres))) | ||
294 | (nreverse lres))) | ||
295 | res)))) | ||
296 | |||
297 | (defun key-valid-p (keys) | ||
298 | "Say whether KEYS is a valid key. | ||
299 | A key is a string consisting of one or more key strokes. | ||
300 | The key strokes are separated by single space characters. | ||
301 | |||
302 | Each key stroke is either a single character, or the name of an | ||
303 | event, surrounded by angle brackets. In addition, any key stroke | ||
304 | may be preceded by one or more modifier keys. Finally, a limited | ||
305 | number of characters have a special shorthand syntax. | ||
306 | |||
307 | Here's some example key sequences. | ||
308 | |||
309 | \"f\" (the key 'f') | ||
310 | \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') | ||
311 | \"C-c o\" (a two key sequence of the keys 'c' with the control modifier | ||
312 | and then the key 'o') | ||
313 | \"H-<left>\" (the key named \"left\" with the hyper modifier) | ||
314 | \"M-RET\" (the \"return\" key with a meta modifier) | ||
315 | \"C-M-<space>\" (the \"space\" key with both the control and meta modifiers) | ||
316 | |||
317 | These are the characters that have shorthand syntax: | ||
318 | NUL, RET, TAB, LFD, ESC, SPC, DEL. | ||
319 | |||
320 | Modifiers have to be specified in this order: | ||
321 | |||
322 | A-C-H-M-S-s | ||
323 | |||
324 | which is | ||
325 | |||
326 | Alt-Control-Hyper-Meta-Shift-super" | ||
327 | (declare (pure t) (side-effect-free t)) | ||
328 | (and | ||
329 | (stringp keys) | ||
330 | (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) | ||
331 | (save-match-data | ||
332 | (catch 'exit | ||
333 | (let ((prefixes | ||
334 | "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") | ||
335 | (case-fold-search nil)) | ||
336 | (dolist (key (split-string keys " ")) | ||
337 | ;; Every key might have these modifiers, and they should be | ||
338 | ;; in this order. | ||
339 | (when (string-match (concat "\\`" prefixes) key) | ||
340 | (setq key (substring key (match-end 0)))) | ||
341 | (unless (or (and (= (length key) 1) | ||
342 | ;; Don't accept control characters as keys. | ||
343 | (not (< (aref key 0) ?\s)) | ||
344 | ;; Don't accept Meta'd characters as keys. | ||
345 | (or (multibyte-string-p key) | ||
346 | (not (<= 127 (aref key 0) 255)))) | ||
347 | (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) | ||
348 | ;; Don't allow <M-C-down>. | ||
349 | (= (progn | ||
350 | (string-match | ||
351 | (concat "\\`<" prefixes) key) | ||
352 | (match-end 0)) | ||
353 | 1)) | ||
354 | (string-match-p | ||
355 | "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" | ||
356 | key)) | ||
357 | ;; Invalid. | ||
358 | (throw 'exit nil))) | ||
359 | t))))) | ||
360 | |||
361 | (defun key-translate (from to) | ||
362 | "Translate character FROM to TO on the current terminal. | ||
363 | This function creates a `keyboard-translate-table' if necessary | ||
364 | and then modifies one entry in it. | ||
365 | |||
366 | Both KEY and TO are strings that satisfy `key-valid-p'." | ||
367 | (declare (compiler-macro | ||
368 | (lambda (form) (keymap--compile-check from to) form))) | ||
369 | (keymap--check from) | ||
370 | (keymap--check to) | ||
371 | (or (char-table-p keyboard-translate-table) | ||
372 | (setq keyboard-translate-table | ||
373 | (make-char-table 'keyboard-translate-table nil))) | ||
374 | (aset keyboard-translate-table (key-parse from) (key-parse to))) | ||
375 | |||
376 | (defun keymap-lookup (keymap key &optional accept-default no-remap position) | ||
377 | "Return the binding for command KEY. | ||
378 | KEY is a string that satisfies `key-valid-p'. | ||
379 | |||
380 | If KEYMAP is nil, look up in the current keymaps. If non-nil, it | ||
381 | should either be a keymap or a list of keymaps, and only these | ||
382 | keymap(s) will be consulted. | ||
383 | |||
384 | The binding is probably a symbol with a function definition. | ||
385 | |||
386 | Normally, `keymap-lookup' ignores bindings for t, which act as | ||
387 | default bindings, used when nothing else in the keymap applies; | ||
388 | this makes it usable as a general function for probing keymaps. | ||
389 | However, if the optional second argument ACCEPT-DEFAULT is | ||
390 | non-nil, `keymap-lookup' does recognize the default bindings, | ||
391 | just as `read-key-sequence' does. | ||
392 | |||
393 | Like the normal command loop, `keymap-lookup' will remap the | ||
394 | command resulting from looking up KEY by looking up the command | ||
395 | in the current keymaps. However, if the optional third argument | ||
396 | NO-REMAP is non-nil, `keymap-lookup' returns the unmapped | ||
397 | command. | ||
398 | |||
399 | If KEY is a key sequence initiated with the mouse, the used keymaps | ||
400 | will depend on the clicked mouse position with regard to the buffer | ||
401 | and possible local keymaps on strings. | ||
402 | |||
403 | If the optional argument POSITION is non-nil, it specifies a mouse | ||
404 | position as returned by `event-start' and `event-end', and the lookup | ||
405 | occurs in the keymaps associated with it instead of KEY. It can also | ||
406 | be a number or marker, in which case the keymap properties at the | ||
407 | specified buffer position instead of point are used." | ||
408 | (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) | ||
409 | (keymap--check key) | ||
410 | (when (and keymap position) | ||
411 | (error "Can't pass in both keymap and position")) | ||
412 | (if keymap | ||
413 | (let ((value (lookup-key keymap (key-parse key) accept-default))) | ||
414 | (if (and (not no-remap) | ||
415 | (symbolp value)) | ||
416 | (or (command-remapping value) value) | ||
417 | value)) | ||
418 | (key-binding (kbd key) accept-default no-remap position))) | ||
419 | |||
420 | (defun keymap-local-lookup (keys &optional accept-default) | ||
421 | "Return the binding for command KEYS in current local keymap only. | ||
422 | KEY is a string that satisfies `key-valid-p'. | ||
423 | |||
424 | The binding is probably a symbol with a function definition. | ||
425 | |||
426 | If optional argument ACCEPT-DEFAULT is non-nil, recognize default | ||
427 | bindings; see the description of `keymap-lookup' for more details | ||
428 | about this." | ||
429 | (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) | ||
430 | (when-let ((map (current-local-map))) | ||
431 | (keymap-lookup map keys accept-default))) | ||
432 | |||
433 | (defun keymap-global-lookup (keys &optional accept-default message) | ||
434 | "Return the binding for command KEYS in current global keymap only. | ||
435 | KEY is a string that satisfies `key-valid-p'. | ||
436 | |||
437 | The binding is probably a symbol with a function definition. | ||
438 | This function's return values are the same as those of `keymap-lookup' | ||
439 | \(which see). | ||
440 | |||
441 | If optional argument ACCEPT-DEFAULT is non-nil, recognize default | ||
442 | bindings; see the description of `keymap-lookup' for more details | ||
443 | about this. | ||
444 | |||
445 | If MESSAGE (and interactively), message the result." | ||
446 | (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) | ||
447 | (interactive | ||
448 | (list (key-description (read-key-sequence "Look up key in global keymap: ")) | ||
449 | nil t)) | ||
450 | (let ((def (keymap-lookup (current-global-map) keys accept-default))) | ||
451 | (when message | ||
452 | (message "%s is bound to %s globally" keys def)) | ||
453 | def)) | ||
454 | |||
455 | |||
456 | ;;; define-keymap and defvar-keymap | ||
457 | |||
458 | (defun define-keymap--compile (form &rest args) | ||
459 | ;; This compiler macro is only there for compile-time | ||
460 | ;; error-checking; it does not change the call in any way. | ||
461 | (while (and args | ||
462 | (keywordp (car args)) | ||
463 | (not (eq (car args) :menu))) | ||
464 | (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix)) | ||
465 | (byte-compile-warn "Invalid keyword: %s" (car args))) | ||
466 | (setq args (cdr args)) | ||
467 | (when (null args) | ||
468 | (byte-compile-warn "Uneven number of keywords in %S" form)) | ||
469 | (setq args (cdr args))) | ||
470 | ;; Bindings. | ||
471 | (while args | ||
472 | (let ((key (pop args))) | ||
473 | (when (and (stringp key) (not (key-valid-p key))) | ||
474 | (byte-compile-warn "Invalid `kbd' syntax: %S" key))) | ||
475 | (when (null args) | ||
476 | (byte-compile-warn "Uneven number of key bindings in %S" form)) | ||
477 | (setq args (cdr args))) | ||
478 | form) | ||
479 | |||
480 | (defun define-keymap (&rest definitions) | ||
481 | "Create a new keymap and define KEY/DEFINITION pairs as key bindings. | ||
482 | The new keymap is returned. | ||
483 | |||
484 | Options can be given as keywords before the KEY/DEFINITION | ||
485 | pairs. Available keywords are: | ||
486 | |||
487 | :full If non-nil, create a chartable alist (see `make-keymap'). | ||
488 | If nil (i.e., the default), create a sparse keymap (see | ||
489 | `make-sparse-keymap'). | ||
490 | |||
491 | :suppress If non-nil, the keymap will be suppressed (see `suppress-keymap'). | ||
492 | If `nodigits', treat digits like other chars. | ||
493 | |||
494 | :parent If non-nil, this should be a keymap to use as the parent | ||
495 | (see `set-keymap-parent'). | ||
496 | |||
497 | :keymap If non-nil, instead of creating a new keymap, the given keymap | ||
498 | will be destructively modified instead. | ||
499 | |||
500 | :name If non-nil, this should be a string to use as the menu for | ||
501 | the keymap in case you use it as a menu with `x-popup-menu'. | ||
502 | |||
503 | :prefix If non-nil, this should be a symbol to be used as a prefix | ||
504 | command (see `define-prefix-command'). If this is the case, | ||
505 | this symbol is returned instead of the map itself. | ||
506 | |||
507 | KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can | ||
508 | also be the special symbol `:menu', in which case DEFINITION | ||
509 | should be a MENU form as accepted by `easy-menu-define'. | ||
510 | |||
511 | \(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" | ||
512 | (declare (indent defun) | ||
513 | (compiler-macro define-keymap--compile)) | ||
514 | (let (full suppress parent name prefix keymap) | ||
515 | ;; Handle keywords. | ||
516 | (while (and definitions | ||
517 | (keywordp (car definitions)) | ||
518 | (not (eq (car definitions) :menu))) | ||
519 | (let ((keyword (pop definitions))) | ||
520 | (unless definitions | ||
521 | (error "Missing keyword value for %s" keyword)) | ||
522 | (let ((value (pop definitions))) | ||
523 | (pcase keyword | ||
524 | (:full (setq full value)) | ||
525 | (:keymap (setq keymap value)) | ||
526 | (:parent (setq parent value)) | ||
527 | (:suppress (setq suppress value)) | ||
528 | (:name (setq name value)) | ||
529 | (:prefix (setq prefix value)) | ||
530 | (_ (error "Invalid keyword: %s" keyword)))))) | ||
531 | |||
532 | (when (and prefix | ||
533 | (or full parent suppress keymap)) | ||
534 | (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords")) | ||
535 | |||
536 | (when (and keymap full) | ||
537 | (error "Invalid combination: :keymap with :full")) | ||
538 | |||
539 | (let ((keymap (cond | ||
540 | (keymap keymap) | ||
541 | (prefix (define-prefix-command prefix nil name)) | ||
542 | (full (make-keymap name)) | ||
543 | (t (make-sparse-keymap name))))) | ||
544 | (when suppress | ||
545 | (suppress-keymap keymap (eq suppress 'nodigits))) | ||
546 | (when parent | ||
547 | (set-keymap-parent keymap parent)) | ||
548 | |||
549 | ;; Do the bindings. | ||
550 | (while definitions | ||
551 | (let ((key (pop definitions))) | ||
552 | (unless definitions | ||
553 | (error "Uneven number of key/definition pairs")) | ||
554 | (let ((def (pop definitions))) | ||
555 | (if (eq key :menu) | ||
556 | (easy-menu-define nil keymap "" def) | ||
557 | (keymap-set keymap key def))))) | ||
558 | keymap))) | ||
559 | |||
560 | (defmacro defvar-keymap (variable-name &rest defs) | ||
561 | "Define VARIABLE-NAME as a variable with a keymap definition. | ||
562 | See `define-keymap' for an explanation of the keywords and KEY/DEFINITION. | ||
563 | |||
564 | In addition to the keywords accepted by `define-keymap', this | ||
565 | macro also accepts a `:doc' keyword, which (if present) is used | ||
566 | as the variable documentation string. | ||
567 | |||
568 | \(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" | ||
569 | (declare (indent 1)) | ||
570 | (let ((opts nil) | ||
571 | doc) | ||
572 | (while (and defs | ||
573 | (keywordp (car defs)) | ||
574 | (not (eq (car defs) :menu))) | ||
575 | (let ((keyword (pop defs))) | ||
576 | (unless defs | ||
577 | (error "Uneven number of keywords")) | ||
578 | (if (eq keyword :doc) | ||
579 | (setq doc (pop defs)) | ||
580 | (push keyword opts) | ||
581 | (push (pop defs) opts)))) | ||
582 | (unless (zerop (% (length defs) 2)) | ||
583 | (error "Uneven number of key/definition pairs: %s" defs)) | ||
584 | `(defvar ,variable-name | ||
585 | (define-keymap ,@(nreverse opts) ,@defs) | ||
586 | ,@(and doc (list doc))))) | ||
587 | |||
588 | (provide 'keymap) | ||
589 | |||
590 | ;;; keymap.el ends here | ||
diff --git a/lisp/compat/tab-bar.el b/lisp/compat/tab-bar.el deleted file mode 100644 index d49fc2e..0000000 --- a/lisp/compat/tab-bar.el +++ /dev/null | |||
@@ -1,2424 +0,0 @@ | |||
1 | ;;; tab-bar.el --- frame-local tabs with named persistent window configurations -*- lexical-binding: t; -*- | ||
2 | |||
3 | ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. | ||
4 | |||
5 | ;; Author: Juri Linkov <juri@linkov.net> | ||
6 | ;; Keywords: frames tabs | ||
7 | ;; Maintainer: emacs-devel@gnu.org | ||
8 | |||
9 | ;; This file is part of GNU Emacs. | ||
10 | |||
11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
12 | ;; it under the terms of the GNU General Public License as published by | ||
13 | ;; the Free Software Foundation, either version 3 of the License, or | ||
14 | ;; (at your option) any later version. | ||
15 | |||
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
19 | ;; GNU General Public License for more details. | ||
20 | |||
21 | ;; You should have received a copy of the GNU General Public License | ||
22 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | ||
23 | |||
24 | ;;; Commentary: | ||
25 | |||
26 | ;; Provides `tab-bar-mode' to control display of the tab bar and | ||
27 | ;; bindings for the global tab bar. | ||
28 | |||
29 | ;; The normal global binding for [tab-bar] (below) uses the value of | ||
30 | ;; `tab-bar-map' as the actual keymap to define the tab bar. | ||
31 | |||
32 | ;;; Code: | ||
33 | |||
34 | (eval-when-compile | ||
35 | (require 'cl-lib) | ||
36 | (require 'seq)) | ||
37 | |||
38 | |||
39 | (defgroup tab-bar nil | ||
40 | "Frame-local tabs." | ||
41 | :group 'convenience | ||
42 | :version "27.1") | ||
43 | |||
44 | (defgroup tab-bar-faces '((tab-bar custom-face)) ; tab-bar is defined in faces.el | ||
45 | "Faces used in the tab bar." | ||
46 | :group 'tab-bar | ||
47 | :group 'faces | ||
48 | :version "27.1") | ||
49 | |||
50 | (defface tab-bar-tab | ||
51 | '((default | ||
52 | :inherit tab-bar) | ||
53 | (((class color) (min-colors 88)) | ||
54 | :box (:line-width 1 :style released-button)) | ||
55 | (t | ||
56 | :inverse-video nil)) | ||
57 | "Tab bar face for selected tab." | ||
58 | :version "27.1" | ||
59 | :group 'tab-bar-faces) | ||
60 | |||
61 | (defface tab-bar-tab-inactive | ||
62 | '((default | ||
63 | :inherit tab-bar-tab) | ||
64 | (((class color) (min-colors 88)) | ||
65 | :background "grey75") | ||
66 | (t | ||
67 | :inverse-video t)) | ||
68 | "Tab bar face for non-selected tab." | ||
69 | :version "27.1" | ||
70 | :group 'tab-bar-faces) | ||
71 | |||
72 | (defface tab-bar-tab-group-current | ||
73 | '((t :inherit tab-bar-tab :box nil :weight bold)) | ||
74 | "Tab bar face for current group tab." | ||
75 | :version "28.1" | ||
76 | :group 'tab-bar-faces) | ||
77 | |||
78 | (defface tab-bar-tab-group-inactive | ||
79 | '((t :inherit (shadow tab-bar-tab-inactive))) | ||
80 | "Tab bar face for inactive group tab." | ||
81 | :version "28.1" | ||
82 | :group 'tab-bar-faces) | ||
83 | |||
84 | (defface tab-bar-tab-ungrouped | ||
85 | '((t :inherit (shadow tab-bar-tab-inactive))) | ||
86 | "Tab bar face for ungrouped tab when tab groups are used." | ||
87 | :version "28.1" | ||
88 | :group 'tab-bar-faces) | ||
89 | |||
90 | |||
91 | (defcustom tab-bar-select-tab-modifiers '() | ||
92 | "List of modifier keys for selecting tab-bar tabs by their numbers. | ||
93 | Possible modifier keys are `control', `meta', `shift', `hyper', `super' and | ||
94 | `alt'. Pressing one of the modifiers in the list and a digit selects the | ||
95 | tab whose number equals the digit (see `tab-bar-select-tab'). | ||
96 | The digit 9 selects the last (rightmost) tab (see `tab-last'). | ||
97 | The digit 0 selects the most recently visited tab (see `tab-recent'). | ||
98 | For easier selection of tabs by their numbers, consider customizing | ||
99 | `tab-bar-tab-hints', which will show tab numbers alongside the tab name." | ||
100 | :type '(set :tag "Tab selection modifier keys" | ||
101 | (const control) | ||
102 | (const meta) | ||
103 | (const shift) | ||
104 | (const hyper) | ||
105 | (const super) | ||
106 | (const alt)) | ||
107 | :initialize 'custom-initialize-default | ||
108 | :set (lambda (sym val) | ||
109 | (set-default sym val) | ||
110 | ;; Reenable the tab-bar with new keybindings | ||
111 | (when tab-bar-mode | ||
112 | (tab-bar--undefine-keys) | ||
113 | (tab-bar--define-keys))) | ||
114 | :group 'tab-bar | ||
115 | :version "27.1") | ||
116 | |||
117 | (defun tab-bar--define-keys () | ||
118 | "Install key bindings for switching between tabs if the user has configured them." | ||
119 | (when tab-bar-select-tab-modifiers | ||
120 | (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?0))) | ||
121 | 'tab-recent) | ||
122 | (dotimes (i 8) | ||
123 | (global-set-key (vector (append tab-bar-select-tab-modifiers | ||
124 | (list (+ i 1 ?0)))) | ||
125 | 'tab-bar-select-tab)) | ||
126 | (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?9))) | ||
127 | 'tab-last)) | ||
128 | ;; Don't override user customized key bindings | ||
129 | (unless (global-key-binding [(control tab)]) | ||
130 | (global-set-key [(control tab)] 'tab-next)) | ||
131 | (unless (global-key-binding [(control shift tab)]) | ||
132 | (global-set-key [(control shift tab)] 'tab-previous)) | ||
133 | (unless (global-key-binding [(control shift iso-lefttab)]) | ||
134 | (global-set-key [(control shift iso-lefttab)] 'tab-previous)) | ||
135 | |||
136 | ;; Replace default value with a condition that supports displaying | ||
137 | ;; global-mode-string in the tab bar instead of the mode line. | ||
138 | (when (and (memq 'tab-bar-format-global tab-bar-format) | ||
139 | (member '(global-mode-string ("" global-mode-string)) | ||
140 | mode-line-misc-info)) | ||
141 | (setf (alist-get 'global-mode-string mode-line-misc-info) | ||
142 | '(("" (:eval (if (and tab-bar-mode | ||
143 | (memq 'tab-bar-format-global | ||
144 | tab-bar-format)) | ||
145 | "" global-mode-string))))))) | ||
146 | |||
147 | (defun tab-bar--undefine-keys () | ||
148 | "Uninstall key bindings previously bound by `tab-bar--define-keys'." | ||
149 | (when (eq (global-key-binding [(control tab)]) 'tab-next) | ||
150 | (global-unset-key [(control tab)])) | ||
151 | (when (eq (global-key-binding [(control shift tab)]) 'tab-previous) | ||
152 | (global-unset-key [(control shift tab)])) | ||
153 | (when (eq (global-key-binding [(control shift iso-lefttab)]) 'tab-previous) | ||
154 | (global-unset-key [(control shift iso-lefttab)]))) | ||
155 | |||
156 | (defun tab-bar--load-buttons () | ||
157 | "Load the icons for the tab buttons." | ||
158 | (when (and tab-bar-new-button | ||
159 | (not (get-text-property 0 'display tab-bar-new-button))) | ||
160 | ;; This file is pre-loaded so only here we can use the right data-directory: | ||
161 | (add-text-properties 0 (length tab-bar-new-button) | ||
162 | `(display (image :type xpm | ||
163 | :file "tabs/new.xpm" | ||
164 | :margin ,tab-bar-button-margin | ||
165 | :ascent center)) | ||
166 | tab-bar-new-button)) | ||
167 | |||
168 | (when (and tab-bar-close-button | ||
169 | (not (get-text-property 0 'display tab-bar-close-button))) | ||
170 | ;; This file is pre-loaded so only here we can use the right data-directory: | ||
171 | (add-text-properties 0 (length tab-bar-close-button) | ||
172 | `(display (image :type xpm | ||
173 | :file "tabs/close.xpm" | ||
174 | :margin ,tab-bar-button-margin | ||
175 | :ascent center)) | ||
176 | tab-bar-close-button))) | ||
177 | |||
178 | (defun tab-bar--tab-bar-lines-for-frame (frame) | ||
179 | "Determine and return the value of `tab-bar-lines' for FRAME. | ||
180 | Return 0 if `tab-bar-mode' is not enabled. Otherwise return | ||
181 | either 1 or 0 depending on the value of the customizable variable | ||
182 | `tab-bar-show', which see." | ||
183 | (cond | ||
184 | ((not tab-bar-mode) 0) | ||
185 | ((not tab-bar-show) 0) | ||
186 | ((eq tab-bar-show t) 1) | ||
187 | ((natnump tab-bar-show) | ||
188 | (if (> (length (funcall tab-bar-tabs-function frame)) tab-bar-show) 1 0)))) | ||
189 | |||
190 | (defun tab-bar--update-tab-bar-lines (&optional frames) | ||
191 | "Update the `tab-bar-lines' frame parameter in FRAMES. | ||
192 | If the optional parameter FRAMES is omitted, update only | ||
193 | the currently selected frame. If it is t, update all frames | ||
194 | as well as the default for new frames. Otherwise FRAMES should be | ||
195 | a list of frames to update." | ||
196 | (let ((frame-lst (cond ((null frames) | ||
197 | (list (selected-frame))) | ||
198 | ((eq frames t) | ||
199 | (frame-list)) | ||
200 | (t frames)))) | ||
201 | ;; Loop over all frames and update `tab-bar-lines' | ||
202 | (dolist (frame frame-lst) | ||
203 | (unless (frame-parameter frame 'tab-bar-lines-keep-state) | ||
204 | (set-frame-parameter frame 'tab-bar-lines | ||
205 | (tab-bar--tab-bar-lines-for-frame frame))))) | ||
206 | ;; Update `default-frame-alist' | ||
207 | (when (eq frames t) | ||
208 | (setq default-frame-alist | ||
209 | (cons (cons 'tab-bar-lines (if (and tab-bar-mode (eq tab-bar-show t)) 1 0)) | ||
210 | (assq-delete-all 'tab-bar-lines default-frame-alist))))) | ||
211 | |||
212 | (define-minor-mode tab-bar-mode | ||
213 | "Toggle the tab bar in all graphical frames (Tab Bar mode)." | ||
214 | :global t | ||
215 | ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again. | ||
216 | :variable tab-bar-mode | ||
217 | |||
218 | ;; Recalculate `tab-bar-lines' for all frames | ||
219 | (tab-bar--update-tab-bar-lines t) | ||
220 | |||
221 | (when tab-bar-mode | ||
222 | (tab-bar--load-buttons)) | ||
223 | (if tab-bar-mode | ||
224 | (tab-bar--define-keys) | ||
225 | (tab-bar--undefine-keys))) | ||
226 | |||
227 | |||
228 | ;;; Key bindings | ||
229 | |||
230 | (defun tab-bar--key-to-number (key) | ||
231 | "Return the tab number represented by KEY. | ||
232 | If KEY is a symbol 'tab-N', where N is a tab number, the value is N. | ||
233 | If KEY is \\='current-tab, the value is nil. | ||
234 | For any other value of KEY, the value is t." | ||
235 | (cond | ||
236 | ((null key) t) | ||
237 | ((eq key 'current-tab) nil) | ||
238 | ((let ((key-name (format "%S" key))) | ||
239 | (when (string-prefix-p "tab-" key-name) | ||
240 | (string-to-number (string-replace "tab-" "" key-name))))) | ||
241 | (t t))) | ||
242 | |||
243 | (defvar tab-bar--dragging-in-progress) | ||
244 | |||
245 | (defun tab-bar--event-to-item (posn) | ||
246 | "This function extracts extra info from the mouse event at position POSN. | ||
247 | It returns a list of the form (KEY KEY-BINDING CLOSE-P), where: | ||
248 | KEY is a symbol representing a tab, such as \\='tab-1 or \\='current-tab; | ||
249 | KEY-BINDING is the binding of KEY; | ||
250 | CLOSE-P is non-nil if the mouse event was a click on the close button \"x\", | ||
251 | nil otherwise." | ||
252 | (setq tab-bar--dragging-in-progress nil) | ||
253 | (if (posn-window posn) | ||
254 | (let ((caption (car (posn-string posn)))) | ||
255 | (when caption | ||
256 | (get-text-property 0 'menu-item caption))) | ||
257 | ;; Text-mode emulation of switching tabs on the tab bar. | ||
258 | ;; This code is used when you click the mouse in the tab bar | ||
259 | ;; on a console which has no window system but does have a mouse. | ||
260 | (let* ((x-position (car (posn-x-y posn))) | ||
261 | (keymap (lookup-key (cons 'keymap (nreverse (current-active-maps))) [tab-bar])) | ||
262 | (column 0)) | ||
263 | (when x-position | ||
264 | (catch 'done | ||
265 | (map-keymap | ||
266 | (lambda (key binding) | ||
267 | (when (eq (car-safe binding) 'menu-item) | ||
268 | (when (> (+ column (length (nth 1 binding))) x-position) | ||
269 | (throw 'done (list key (nth 2 binding) | ||
270 | (get-text-property | ||
271 | (- x-position column) | ||
272 | 'close-tab (nth 1 binding))))) | ||
273 | (setq column (+ column (length (nth 1 binding)))))) | ||
274 | keymap)))))) | ||
275 | |||
276 | (defun tab-bar-mouse-down-1 (event) | ||
277 | "Select the tab at mouse click, or add a new tab on the tab bar. | ||
278 | Whether this command adds a new tab or selects an existing tab | ||
279 | depends on whether the click is on the \"+\" button or on an | ||
280 | existing tab." | ||
281 | (interactive "e") | ||
282 | (let* ((item (tab-bar--event-to-item (event-start event))) | ||
283 | (tab-number (tab-bar--key-to-number (nth 0 item)))) | ||
284 | (setq tab-bar--dragging-in-progress t) | ||
285 | ;; Don't close the tab when clicked on the close button. Also | ||
286 | ;; don't add new tab on down-mouse. Let `tab-bar-mouse-1' do this. | ||
287 | (unless (or (memq (car item) '(add-tab history-back history-forward)) | ||
288 | (nth 2 item)) | ||
289 | (if (functionp (nth 1 item)) | ||
290 | (call-interactively (nth 1 item)) | ||
291 | (unless (eq tab-number t) | ||
292 | (tab-bar-select-tab tab-number)))))) | ||
293 | |||
294 | (defun tab-bar-mouse-1 (event) | ||
295 | "Close the tab whose \"x\" close button you click. | ||
296 | See also `tab-bar-mouse-close-tab', which closes the tab | ||
297 | regardless of where you click on it. Also add a new tab." | ||
298 | (interactive "e") | ||
299 | (let* ((item (tab-bar--event-to-item (event-start event))) | ||
300 | (tab-number (tab-bar--key-to-number (nth 0 item)))) | ||
301 | (cond | ||
302 | ((and (memq (car item) '(add-tab history-back history-forward)) | ||
303 | (functionp (nth 1 item))) | ||
304 | (call-interactively (nth 1 item))) | ||
305 | ((and (nth 2 item) (not (eq tab-number t))) | ||
306 | (tab-bar-close-tab tab-number))))) | ||
307 | |||
308 | (defun tab-bar-mouse-close-tab (event) | ||
309 | "Close the tab you click on. | ||
310 | This is in contrast with `tab-bar-mouse-1' that closes a tab | ||
311 | only when you click on its \"x\" close button." | ||
312 | (interactive "e") | ||
313 | (let* ((item (tab-bar--event-to-item (event-start event))) | ||
314 | (tab-number (tab-bar--key-to-number (nth 0 item)))) | ||
315 | (unless (eq tab-number t) | ||
316 | (tab-bar-close-tab tab-number)))) | ||
317 | |||
318 | (defun tab-bar-mouse-context-menu (event) | ||
319 | "Pop up the context menu for the tab on which you click." | ||
320 | (interactive "e") | ||
321 | (let* ((item (tab-bar--event-to-item (event-start event))) | ||
322 | (tab-number (tab-bar--key-to-number (nth 0 item))) | ||
323 | (menu (make-sparse-keymap (propertize "Context Menu" 'hide t)))) | ||
324 | |||
325 | (cond | ||
326 | ((eq tab-number t) | ||
327 | (define-key-after menu [new-tab] | ||
328 | '(menu-item "New tab" tab-bar-new-tab | ||
329 | :help "Create a new tab")) | ||
330 | (when tab-bar-closed-tabs | ||
331 | (define-key-after menu [undo-close] | ||
332 | '(menu-item "Reopen closed tab" tab-bar-undo-close-tab | ||
333 | :help "Undo closing the tab")))) | ||
334 | |||
335 | (t | ||
336 | (define-key-after menu [duplicate-tab] | ||
337 | `(menu-item "Duplicate" (lambda () (interactive) | ||
338 | (tab-bar-duplicate-tab | ||
339 | nil ,tab-number)) | ||
340 | :help "Clone the tab")) | ||
341 | (define-key-after menu [detach-tab] | ||
342 | `(menu-item "Detach" (lambda () (interactive) | ||
343 | (tab-bar-detach-tab | ||
344 | ,tab-number)) | ||
345 | :help "Move the tab to new frame")) | ||
346 | (define-key-after menu [close] | ||
347 | `(menu-item "Close" (lambda () (interactive) | ||
348 | (tab-bar-close-tab ,tab-number)) | ||
349 | :help "Close the tab")) | ||
350 | (define-key-after menu [close-other] | ||
351 | `(menu-item "Close other tabs" | ||
352 | (lambda () (interactive) | ||
353 | (tab-bar-close-other-tabs ,tab-number)) | ||
354 | :help "Close all other tabs")))) | ||
355 | |||
356 | (popup-menu menu event))) | ||
357 | |||
358 | (defun tab-bar-mouse-move-tab (event) | ||
359 | "Move a tab to a different position on the tab bar. | ||
360 | This command should be bound to a drag event. It moves the tab | ||
361 | at the mouse-down event to the position at mouse-up event." | ||
362 | (interactive "e") | ||
363 | (setq tab-bar--dragging-in-progress nil) | ||
364 | (let ((from (tab-bar--key-to-number | ||
365 | (nth 0 (tab-bar--event-to-item | ||
366 | (event-start event))))) | ||
367 | (to (tab-bar--key-to-number | ||
368 | (nth 0 (tab-bar--event-to-item | ||
369 | (event-end event)))))) | ||
370 | (unless (or (eq from to) (eq from t) (eq to t)) | ||
371 | (tab-bar-move-tab-to | ||
372 | (if (null to) (1+ (tab-bar--current-tab-index)) to) from)))) | ||
373 | |||
374 | (defvar tab-bar-map | ||
375 | (let ((map (make-sparse-keymap))) | ||
376 | (define-key map [down-mouse-1] 'tab-bar-mouse-down-1) | ||
377 | (define-key map [drag-mouse-1] 'tab-bar-mouse-move-tab) | ||
378 | (define-key map [mouse-1] 'tab-bar-mouse-1) | ||
379 | (define-key map [down-mouse-2] 'tab-bar-mouse-close-tab) | ||
380 | (define-key map [mouse-2] 'ignore) | ||
381 | (define-key map [down-mouse-3] 'tab-bar-mouse-context-menu) | ||
382 | |||
383 | (define-key map [mouse-4] 'tab-previous) | ||
384 | (define-key map [mouse-5] 'tab-next) | ||
385 | (define-key map [wheel-up] 'tab-previous) | ||
386 | (define-key map [wheel-down] 'tab-next) | ||
387 | (define-key map [wheel-left] 'tab-previous) | ||
388 | (define-key map [wheel-right] 'tab-next) | ||
389 | |||
390 | (define-key map [S-mouse-4] 'tab-bar-move-tab-backward) | ||
391 | (define-key map [S-mouse-5] 'tab-bar-move-tab) | ||
392 | (define-key map [S-wheel-up] 'tab-bar-move-tab-backward) | ||
393 | (define-key map [S-wheel-down] 'tab-bar-move-tab) | ||
394 | (define-key map [S-wheel-left] 'tab-bar-move-tab-backward) | ||
395 | (define-key map [S-wheel-right] 'tab-bar-move-tab) | ||
396 | |||
397 | map) | ||
398 | "Keymap for the commands used on the tab bar.") | ||
399 | |||
400 | (global-set-key [tab-bar] | ||
401 | `(menu-item ,(purecopy "tab bar") ignore | ||
402 | :filter tab-bar-make-keymap)) | ||
403 | |||
404 | (defun tab-bar-make-keymap (&optional _ignore) | ||
405 | "Generate an actual keymap from `tab-bar-map'. | ||
406 | Its main job is to show tabs in the tab bar | ||
407 | and to bind mouse events to the commands." | ||
408 | (tab-bar-make-keymap-1)) | ||
409 | |||
410 | |||
411 | (defun toggle-tab-bar-mode-from-frame (&optional arg) | ||
412 | "Toggle tab bar on or off, based on the status of the current frame. | ||
413 | Used in the Show/Hide menu, to have the toggle reflect the current frame. | ||
414 | See `tab-bar-mode' for more information." | ||
415 | (interactive (list (or current-prefix-arg 'toggle))) | ||
416 | (if (eq arg 'toggle) | ||
417 | (tab-bar-mode (if (> (frame-parameter nil 'tab-bar-lines) 0) 0 1)) | ||
418 | (tab-bar-mode arg))) | ||
419 | |||
420 | (defun toggle-frame-tab-bar (&optional frame) | ||
421 | "Toggle tab bar of the selected frame. | ||
422 | When calling from Lisp, use the optional argument FRAME to toggle | ||
423 | the tab bar on that frame. | ||
424 | This is useful if you want to enable the tab bar individually | ||
425 | on each new frame when the global `tab-bar-mode' is disabled, | ||
426 | or if you want to disable the tab bar individually on each | ||
427 | new frame when the global `tab-bar-mode' is enabled, by using | ||
428 | |||
429 | (add-hook 'after-make-frame-functions 'toggle-frame-tab-bar)" | ||
430 | (interactive) | ||
431 | (set-frame-parameter frame 'tab-bar-lines | ||
432 | (if (> (frame-parameter frame 'tab-bar-lines) 0) 0 1)) | ||
433 | (set-frame-parameter frame 'tab-bar-lines-keep-state | ||
434 | (not (frame-parameter frame 'tab-bar-lines-keep-state)))) | ||
435 | |||
436 | |||
437 | (defcustom tab-bar-show t | ||
438 | "Defines when to show the tab bar. | ||
439 | If t, the default, enable `tab-bar-mode' automatically upon using | ||
440 | the commands that create new window configurations (e.g., `tab-new'). | ||
441 | If a non-negative integer, show the tab bar only if the number of | ||
442 | the tabs exceeds the value of this variable. In particular, | ||
443 | if the value is 1, hide the tab bar when it has only one tab, and | ||
444 | show it again once more tabs are created. A value that is a | ||
445 | non-negative integer also makes the tab bar appearance be different | ||
446 | on different frames: the tab bar can be shown on some frames and | ||
447 | hidden on others, depending on how many tab-bar tabs are on that | ||
448 | frame, and whether that number is greater than the numerical value | ||
449 | of this variable. | ||
450 | If nil, always keep the tab bar hidden. In this case it's still | ||
451 | possible to use persistent named window configurations by relying on | ||
452 | keyboard commands `tab-new', `tab-close', `tab-next', `tab-switcher', etc. | ||
453 | |||
454 | Setting this variable directly does not take effect; please customize | ||
455 | it (see the info node `Easy Customization'), then it will automatically | ||
456 | update the tab bar on all frames according to the new value. | ||
457 | |||
458 | To enable or disable the tab bar individually on each frame, | ||
459 | you can use the command `toggle-frame-tab-bar'." | ||
460 | :type '(choice (const :tag "Always" t) | ||
461 | (const :tag "When more than one tab" 1) | ||
462 | (const :tag "Never" nil)) | ||
463 | :initialize 'custom-initialize-default | ||
464 | :set (lambda (sym val) | ||
465 | (set-default sym val) | ||
466 | (if val | ||
467 | (tab-bar-mode 1) | ||
468 | (tab-bar--update-tab-bar-lines t))) | ||
469 | :group 'tab-bar | ||
470 | :version "27.1") | ||
471 | |||
472 | (defcustom tab-bar-new-tab-choice t | ||
473 | "Defines what to show in a new tab. | ||
474 | If t, start a new tab with the current buffer, i.e. the buffer | ||
475 | that was current before calling the command that adds a new tab | ||
476 | (this is the same what `make-frame' does by default). | ||
477 | If the value is a string, use it as a buffer name to switch to | ||
478 | if such buffer exists, or switch to a buffer visiting the file or | ||
479 | directory that the string specifies. If the value is a function, | ||
480 | call it with no arguments and switch to the buffer that it returns. | ||
481 | If nil, duplicate the contents of the tab that was active | ||
482 | before calling the command that adds a new tab." | ||
483 | :type '(choice (const :tag "Current buffer" t) | ||
484 | (string :tag "Buffer" "*scratch*") | ||
485 | (directory :tag "Directory" :value "~/") | ||
486 | (file :tag "File" :value "~/.emacs") | ||
487 | (function :tag "Function") | ||
488 | (const :tag "Duplicate tab" nil)) | ||
489 | :group 'tab-bar | ||
490 | :version "27.1") | ||
491 | |||
492 | (defcustom tab-bar-new-tab-group t | ||
493 | "Defines what group to assign to a new tab. | ||
494 | If nil, don't set a default group automatically. | ||
495 | If t, inherit the group name from the previous tab. | ||
496 | If the value is a string, use it as the group name of a new tab. | ||
497 | If the value is a function, call it with no arguments | ||
498 | to get the group name." | ||
499 | :type '(choice (const :tag "No automatic group" nil) | ||
500 | (const :tag "Inherit group from previous tab" t) | ||
501 | (string :tag "Fixed group name") | ||
502 | (function :tag "Function that returns group name")) | ||
503 | :group 'tab-bar | ||
504 | :version "28.1") | ||
505 | |||
506 | (defcustom tab-bar-new-button-show t | ||
507 | "If non-nil, show the \"New tab\" button in the tab bar. | ||
508 | When this is nil, you can create new tabs with \\[tab-new]." | ||
509 | :type 'boolean | ||
510 | :initialize 'custom-initialize-default | ||
511 | :set (lambda (sym val) | ||
512 | (set-default sym val) | ||
513 | (force-mode-line-update)) | ||
514 | :group 'tab-bar | ||
515 | :version "27.1") | ||
516 | (make-obsolete-variable 'tab-bar-new-button-show 'tab-bar-format "28.1") | ||
517 | |||
518 | (defvar tab-bar-new-button " + " | ||
519 | "Button for creating a new tab.") | ||
520 | |||
521 | (defcustom tab-bar-close-button-show t | ||
522 | "Defines where to show the close tab button. | ||
523 | If t, show the close tab button on all tabs. | ||
524 | If `selected', show it only on the selected tab. | ||
525 | If `non-selected', show it only on non-selected tab. | ||
526 | If nil, don't show it at all." | ||
527 | :type '(choice (const :tag "On all tabs" t) | ||
528 | (const :tag "On selected tab" selected) | ||
529 | (const :tag "On non-selected tabs" non-selected) | ||
530 | (const :tag "None" nil)) | ||
531 | :initialize 'custom-initialize-default | ||
532 | :set (lambda (sym val) | ||
533 | (set-default sym val) | ||
534 | (force-mode-line-update)) | ||
535 | :group 'tab-bar | ||
536 | :version "27.1") | ||
537 | |||
538 | (defvar tab-bar-close-button | ||
539 | (propertize " x" | ||
540 | 'close-tab t | ||
541 | :help "Click to close tab") | ||
542 | "Button for closing the clicked tab.") | ||
543 | |||
544 | (defvar tab-bar-back-button " < " | ||
545 | "Button for going back in tab history.") | ||
546 | |||
547 | (defvar tab-bar-forward-button " > " | ||
548 | "Button for going forward in tab history.") | ||
549 | |||
550 | (defcustom tab-bar-tab-hints nil | ||
551 | "Show absolute numbers on tabs in the tab bar before the tab name. | ||
552 | This helps to select the tab by its number using `tab-bar-select-tab' | ||
553 | and `tab-bar-select-tab-modifiers'." | ||
554 | :type 'boolean | ||
555 | :initialize 'custom-initialize-default | ||
556 | :set (lambda (sym val) | ||
557 | (set-default sym val) | ||
558 | (force-mode-line-update)) | ||
559 | :group 'tab-bar | ||
560 | :version "27.1") | ||
561 | |||
562 | (defvar tab-bar-separator nil | ||
563 | "String that delimits tabs.") | ||
564 | |||
565 | (defun tab-bar-separator () | ||
566 | "Separator between tabs." | ||
567 | (or tab-bar-separator (if window-system " " "|"))) | ||
568 | |||
569 | |||
570 | (defcustom tab-bar-tab-name-function #'tab-bar-tab-name-current | ||
571 | "Function to get a tab name. | ||
572 | Function gets no arguments. | ||
573 | The choice is between displaying only the name of the current buffer | ||
574 | in the tab name (default), or displaying the names of all buffers | ||
575 | from all windows in the window configuration." | ||
576 | :type '(choice (const :tag "Selected window buffer" | ||
577 | tab-bar-tab-name-current) | ||
578 | (const :tag "Selected window buffer with window count" | ||
579 | tab-bar-tab-name-current-with-count) | ||
580 | (const :tag "Truncated buffer name" | ||
581 | tab-bar-tab-name-truncated) | ||
582 | (const :tag "All window buffers" | ||
583 | tab-bar-tab-name-all) | ||
584 | (function :tag "Function")) | ||
585 | :initialize 'custom-initialize-default | ||
586 | :set (lambda (sym val) | ||
587 | (set-default sym val) | ||
588 | (force-mode-line-update)) | ||
589 | :group 'tab-bar | ||
590 | :version "27.1") | ||
591 | |||
592 | (defun tab-bar-tab-name-current () | ||
593 | "Generate tab name from the buffer of the selected window." | ||
594 | (buffer-name (window-buffer (minibuffer-selected-window)))) | ||
595 | |||
596 | (defun tab-bar-tab-name-current-with-count () | ||
597 | "Generate tab name from the buffer of the selected window. | ||
598 | Also add the number of windows in the window configuration." | ||
599 | (let ((count (length (window-list-1 nil 'nomini))) | ||
600 | (name (window-buffer (minibuffer-selected-window)))) | ||
601 | (if (> count 1) | ||
602 | (format "%s (%d)" name count) | ||
603 | (format "%s" name)))) | ||
604 | |||
605 | (defun tab-bar-tab-name-all () | ||
606 | "Generate tab name from buffers of all windows." | ||
607 | (mapconcat #'buffer-name | ||
608 | (delete-dups (mapcar #'window-buffer | ||
609 | (window-list-1 (frame-first-window) | ||
610 | 'nomini))) | ||
611 | ", ")) | ||
612 | |||
613 | (defcustom tab-bar-tab-name-truncated-max 20 | ||
614 | "Maximum length of the tab name from the current buffer. | ||
615 | Effective when `tab-bar-tab-name-function' is customized | ||
616 | to `tab-bar-tab-name-truncated'." | ||
617 | :type 'integer | ||
618 | :group 'tab-bar | ||
619 | :version "27.1") | ||
620 | |||
621 | (defvar tab-bar-tab-name-ellipsis t) | ||
622 | |||
623 | (defun tab-bar-tab-name-truncated () | ||
624 | "Generate tab name from the buffer of the selected window. | ||
625 | Truncate it to the length specified by `tab-bar-tab-name-truncated-max'. | ||
626 | Append ellipsis `tab-bar-tab-name-ellipsis' in this case." | ||
627 | (let ((tab-name (buffer-name (window-buffer (minibuffer-selected-window))))) | ||
628 | (if (< (length tab-name) tab-bar-tab-name-truncated-max) | ||
629 | tab-name | ||
630 | (propertize (truncate-string-to-width | ||
631 | tab-name tab-bar-tab-name-truncated-max nil nil | ||
632 | tab-bar-tab-name-ellipsis) | ||
633 | 'help-echo tab-name)))) | ||
634 | |||
635 | |||
636 | (defvar tab-bar-tabs-function #'tab-bar-tabs | ||
637 | "Function to get a list of tabs to display in the tab bar. | ||
638 | This function should have one optional argument FRAME, | ||
639 | defaulting to the selected frame when nil. | ||
640 | It should return a list of alists with parameters | ||
641 | that include at least the element (name . TAB-NAME). | ||
642 | For example, \\='((tab (name . \"Tab 1\")) (current-tab (name . \"Tab 2\"))) | ||
643 | By default, use function `tab-bar-tabs'.") | ||
644 | |||
645 | (defun tab-bar-tabs (&optional frame) | ||
646 | "Return a list of tabs belonging to the FRAME. | ||
647 | Ensure the frame parameter `tabs' is pre-populated. | ||
648 | Update the current tab name when it exists. | ||
649 | Return its existing value or a new value." | ||
650 | (let ((tabs (frame-parameter frame 'tabs))) | ||
651 | (if tabs | ||
652 | (let* ((current-tab (tab-bar--current-tab-find tabs)) | ||
653 | (current-tab-name (assq 'name current-tab)) | ||
654 | (current-tab-explicit-name (assq 'explicit-name current-tab))) | ||
655 | (when (and current-tab-name | ||
656 | current-tab-explicit-name | ||
657 | (not (cdr current-tab-explicit-name))) | ||
658 | (setf (cdr current-tab-name) | ||
659 | (funcall tab-bar-tab-name-function)))) | ||
660 | ;; Create default tabs | ||
661 | (setq tabs (list (tab-bar--current-tab-make))) | ||
662 | (tab-bar-tabs-set tabs frame)) | ||
663 | tabs)) | ||
664 | |||
665 | (defun tab-bar-tabs-set (tabs &optional frame) | ||
666 | "Set a list of TABS on the FRAME." | ||
667 | (set-frame-parameter frame 'tabs tabs)) | ||
668 | |||
669 | |||
670 | (defcustom tab-bar-tab-face-function #'tab-bar-tab-face-default | ||
671 | "Function to define a tab face. | ||
672 | Function gets one argument: a tab." | ||
673 | :type 'function | ||
674 | :group 'tab-bar | ||
675 | :version "28.1") | ||
676 | |||
677 | (defun tab-bar-tab-face-default (tab) | ||
678 | (if (eq (car tab) 'current-tab) 'tab-bar-tab 'tab-bar-tab-inactive)) | ||
679 | |||
680 | (defcustom tab-bar-tab-name-format-function #'tab-bar-tab-name-format-default | ||
681 | "Function to format a tab name. | ||
682 | Function gets two arguments, the tab and its number, and should return | ||
683 | the formatted tab name to display in the tab bar." | ||
684 | :type 'function | ||
685 | :initialize 'custom-initialize-default | ||
686 | :set (lambda (sym val) | ||
687 | (set-default sym val) | ||
688 | (force-mode-line-update)) | ||
689 | :group 'tab-bar | ||
690 | :version "28.1") | ||
691 | |||
692 | (defun tab-bar-tab-name-format-default (tab i) | ||
693 | (let ((current-p (eq (car tab) 'current-tab))) | ||
694 | (propertize | ||
695 | (concat (if tab-bar-tab-hints (format "%d " i) "") | ||
696 | (alist-get 'name tab) | ||
697 | (or (and tab-bar-close-button-show | ||
698 | (not (eq tab-bar-close-button-show | ||
699 | (if current-p 'non-selected 'selected))) | ||
700 | tab-bar-close-button) | ||
701 | "")) | ||
702 | 'face (funcall tab-bar-tab-face-function tab)))) | ||
703 | |||
704 | (defcustom tab-bar-format '(tab-bar-format-history | ||
705 | tab-bar-format-tabs | ||
706 | tab-bar-separator | ||
707 | tab-bar-format-add-tab) | ||
708 | "Template for displaying tab bar items. | ||
709 | Every item in the list is a function that returns | ||
710 | a string, or a list of menu-item elements, or nil. | ||
711 | Adding a function to the list causes the tab bar to show | ||
712 | that string, or display a tab button which, when clicked, | ||
713 | will invoke the command that is the binding of the menu item. | ||
714 | The menu-item binding of nil will produce a tab clicking | ||
715 | on which will select that tab. The menu-item's title is | ||
716 | displayed as the label of the tab. | ||
717 | If a function returns nil, it doesn't directly affect the | ||
718 | tab bar appearance, but can do that by some side-effect. | ||
719 | If the list ends with `tab-bar-format-align-right' and | ||
720 | `tab-bar-format-global', then after enabling `display-time-mode' | ||
721 | (or any other mode that uses `global-mode-string'), | ||
722 | it will display time aligned to the right on the tab bar instead | ||
723 | of the mode line. Replacing `tab-bar-format-tabs' with | ||
724 | `tab-bar-format-tabs-groups' will group tabs on the tab bar." | ||
725 | :type 'hook | ||
726 | :options '(tab-bar-format-menu-bar | ||
727 | tab-bar-format-history | ||
728 | tab-bar-format-tabs | ||
729 | tab-bar-format-tabs-groups | ||
730 | tab-bar-separator | ||
731 | tab-bar-format-add-tab | ||
732 | tab-bar-format-align-right | ||
733 | tab-bar-format-global) | ||
734 | :initialize 'custom-initialize-default | ||
735 | :set (lambda (sym val) | ||
736 | (set-default sym val) | ||
737 | (force-mode-line-update)) | ||
738 | :group 'tab-bar | ||
739 | :version "28.1") | ||
740 | |||
741 | (defun tab-bar-menu-bar (event) | ||
742 | "Pop up the same menu as displayed by the menu bar. | ||
743 | Used by `tab-bar-format-menu-bar'." | ||
744 | (interactive "e") | ||
745 | (let ((menu (make-sparse-keymap (propertize "Menu Bar" 'hide t)))) | ||
746 | (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) | ||
747 | (map-keymap (lambda (key binding) | ||
748 | (when (consp binding) | ||
749 | (define-key-after menu (vector key) | ||
750 | (copy-sequence binding)))) | ||
751 | (menu-bar-keymap)) | ||
752 | (popup-menu menu event))) | ||
753 | |||
754 | (defun tab-bar-format-menu-bar () | ||
755 | "Produce the Menu button for the tab bar that shows the menu bar." | ||
756 | `((menu-bar menu-item (propertize "Menu" 'face 'tab-bar-tab-inactive) | ||
757 | tab-bar-menu-bar :help "Menu Bar"))) | ||
758 | |||
759 | (defun tab-bar-format-history () | ||
760 | "Produce back and forward buttons for the tab bar. | ||
761 | These buttons will be shown when `tab-bar-history-mode' is enabled. | ||
762 | You can hide these buttons by customizing `tab-bar-format' and removing | ||
763 | `tab-bar-format-history' from it." | ||
764 | (when tab-bar-history-mode | ||
765 | `((sep-history-back menu-item ,(tab-bar-separator) ignore) | ||
766 | (history-back | ||
767 | menu-item ,tab-bar-back-button tab-bar-history-back | ||
768 | :help "Click to go back in tab history") | ||
769 | (sep-history-forward menu-item ,(tab-bar-separator) ignore) | ||
770 | (history-forward | ||
771 | menu-item ,tab-bar-forward-button tab-bar-history-forward | ||
772 | :help "Click to go forward in tab history")))) | ||
773 | |||
774 | (defun tab-bar--format-tab (tab i) | ||
775 | "Format TAB using its index I and return the result as a keymap." | ||
776 | (append | ||
777 | `((,(intern (format "sep-%i" i)) menu-item ,(tab-bar-separator) ignore)) | ||
778 | (cond | ||
779 | ((eq (car tab) 'current-tab) | ||
780 | `((current-tab | ||
781 | menu-item | ||
782 | ,(funcall tab-bar-tab-name-format-function tab i) | ||
783 | ignore | ||
784 | :help "Current tab"))) | ||
785 | (t | ||
786 | `((,(intern (format "tab-%i" i)) | ||
787 | menu-item | ||
788 | ,(funcall tab-bar-tab-name-format-function tab i) | ||
789 | ,(alist-get 'binding tab) | ||
790 | :help "Click to visit tab")))) | ||
791 | (when (alist-get 'close-binding tab) | ||
792 | `((,(if (eq (car tab) 'current-tab) 'C-current-tab (intern (format "C-tab-%i" i))) | ||
793 | menu-item "" | ||
794 | ,(alist-get 'close-binding tab)))))) | ||
795 | |||
796 | (defun tab-bar-format-tabs () | ||
797 | "Produce all the tabs for the tab bar." | ||
798 | (let ((i 0)) | ||
799 | (mapcan | ||
800 | (lambda (tab) | ||
801 | (setq i (1+ i)) | ||
802 | (tab-bar--format-tab tab i)) | ||
803 | (funcall tab-bar-tabs-function)))) | ||
804 | |||
805 | (defcustom tab-bar-tab-group-function #'tab-bar-tab-group-default | ||
806 | "Function to get a tab group name. | ||
807 | Function gets one argument: a tab." | ||
808 | :type 'function | ||
809 | :initialize 'custom-initialize-default | ||
810 | :set (lambda (sym val) | ||
811 | (set-default sym val) | ||
812 | (force-mode-line-update)) | ||
813 | :group 'tab-bar | ||
814 | :version "28.1") | ||
815 | |||
816 | (defun tab-bar-tab-group-default (tab) | ||
817 | (alist-get 'group tab)) | ||
818 | |||
819 | (defcustom tab-bar-tab-group-format-function #'tab-bar-tab-group-format-default | ||
820 | "Function to format a tab group name. | ||
821 | Function gets two arguments, a tab with a group name and its number, | ||
822 | and should return the formatted tab group name to display in the tab bar." | ||
823 | :type 'function | ||
824 | :initialize 'custom-initialize-default | ||
825 | :set (lambda (sym val) | ||
826 | (set-default sym val) | ||
827 | (force-mode-line-update)) | ||
828 | :group 'tab-bar | ||
829 | :version "28.1") | ||
830 | |||
831 | (defun tab-bar-tab-group-format-default (tab i) | ||
832 | (propertize | ||
833 | (concat (if tab-bar-tab-hints (format "%d " i) "") | ||
834 | (funcall tab-bar-tab-group-function tab)) | ||
835 | 'face 'tab-bar-tab-group-inactive)) | ||
836 | |||
837 | (defcustom tab-bar-tab-group-face-function #'tab-bar-tab-group-face-default | ||
838 | "Function to define a tab group face. | ||
839 | Function gets one argument: a tab." | ||
840 | :type 'function | ||
841 | :group 'tab-bar | ||
842 | :version "28.1") | ||
843 | |||
844 | (defun tab-bar-tab-group-face-default (tab) | ||
845 | (if (not (or (eq (car tab) 'current-tab) | ||
846 | (funcall tab-bar-tab-group-function tab))) | ||
847 | 'tab-bar-tab-ungrouped | ||
848 | (tab-bar-tab-face-default tab))) | ||
849 | |||
850 | (defun tab-bar--format-tab-group (tab i &optional current-p) | ||
851 | "Format TAB as a tab that represents a group of tabs. | ||
852 | The argument I is the tab index, and CURRENT-P is non-nil | ||
853 | when the tab is current. Return the result as a keymap." | ||
854 | (append | ||
855 | `((,(intern (format "sep-%i" i)) menu-item ,(tab-bar-separator) ignore)) | ||
856 | `((,(intern (format "group-%i" i)) | ||
857 | menu-item | ||
858 | ,(if current-p | ||
859 | (propertize (funcall tab-bar-tab-group-function tab) | ||
860 | 'face 'tab-bar-tab-group-current) | ||
861 | (funcall tab-bar-tab-group-format-function tab i)) | ||
862 | ,(if current-p 'ignore | ||
863 | (or | ||
864 | (alist-get 'binding tab) | ||
865 | `(lambda () | ||
866 | (interactive) | ||
867 | (tab-bar-select-tab ,i)))) | ||
868 | :help "Click to visit group")))) | ||
869 | |||
870 | (defun tab-bar-format-tabs-groups () | ||
871 | "Produce tabs for the tab bar grouped according to their groups." | ||
872 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
873 | (current-group (funcall tab-bar-tab-group-function | ||
874 | (tab-bar--current-tab-find tabs))) | ||
875 | (previous-group nil) | ||
876 | (i 0)) | ||
877 | (mapcan | ||
878 | (lambda (tab) | ||
879 | (let ((tab-group (funcall tab-bar-tab-group-function tab))) | ||
880 | (setq i (1+ i)) | ||
881 | (prog1 (cond | ||
882 | ;; Show current group tabs and ungrouped tabs | ||
883 | ((or (equal tab-group current-group) (not tab-group)) | ||
884 | (append | ||
885 | ;; Prepend current group name before first tab | ||
886 | (when (and (not (equal previous-group tab-group)) tab-group) | ||
887 | (tab-bar--format-tab-group tab i t)) | ||
888 | ;; Override default tab faces to use group faces | ||
889 | (let ((tab-bar-tab-face-function tab-bar-tab-group-face-function)) | ||
890 | (tab-bar--format-tab tab i)))) | ||
891 | ;; Show first tab of other groups with a group name | ||
892 | ((not (equal previous-group tab-group)) | ||
893 | (tab-bar--format-tab-group tab i)) | ||
894 | ;; Hide other group tabs | ||
895 | (t nil)) | ||
896 | (setq previous-group tab-group)))) | ||
897 | tabs))) | ||
898 | |||
899 | (defun tab-bar-format-add-tab () | ||
900 | "Button to add a new tab." | ||
901 | (when (and tab-bar-new-button-show tab-bar-new-button) | ||
902 | `((add-tab menu-item ,tab-bar-new-button tab-bar-new-tab | ||
903 | :help "New tab")))) | ||
904 | |||
905 | (defun tab-bar-format-align-right () | ||
906 | "Align the rest of tab bar items to the right." | ||
907 | (let* ((rest (cdr (memq 'tab-bar-format-align-right tab-bar-format))) | ||
908 | (rest (tab-bar-format-list rest)) | ||
909 | (rest (mapconcat (lambda (item) (nth 2 item)) rest "")) | ||
910 | (hpos (length rest)) | ||
911 | (str (propertize " " 'display `(space :align-to (- right ,hpos))))) | ||
912 | `((align-right menu-item ,str ignore)))) | ||
913 | |||
914 | (defun tab-bar-format-global () | ||
915 | "Produce display of `global-mode-string' in the tab bar. | ||
916 | When `tab-bar-format-global' is added to `tab-bar-format' | ||
917 | (possibly appended after `tab-bar-format-align-right'), | ||
918 | then modes that display information on the mode line | ||
919 | using `global-mode-string' will display the same text | ||
920 | on the tab bar instead." | ||
921 | `((global menu-item ,(string-trim-right (format-mode-line global-mode-string)) ignore))) | ||
922 | |||
923 | (defun tab-bar-format-list (format-list) | ||
924 | (let ((i 0)) | ||
925 | (apply #'append | ||
926 | (mapcar | ||
927 | (lambda (format) | ||
928 | (setq i (1+ i)) | ||
929 | (cond | ||
930 | ((functionp format) | ||
931 | (let ((ret (funcall format))) | ||
932 | (when (stringp ret) | ||
933 | (setq ret `((,(intern (format "str-%i" i)) | ||
934 | menu-item ,ret ignore)))) | ||
935 | ret)))) | ||
936 | format-list)))) | ||
937 | |||
938 | (defun tab-bar-make-keymap-1 () | ||
939 | "Generate an actual keymap from `tab-bar-map', without caching." | ||
940 | (append tab-bar-map (tab-bar-format-list tab-bar-format))) | ||
941 | |||
942 | |||
943 | ;; Some window-configuration parameters don't need to be persistent. | ||
944 | ;; Don't save to the desktop file such tab parameters that are saved | ||
945 | ;; as "Unprintable entity" so can't be used after restoring the desktop. | ||
946 | ;; Actually tab-bar-select-tab already can handle unprintable entities, | ||
947 | ;; but it's better not to waste the desktop file with useless data. | ||
948 | (defun frameset-filter-tabs (current _filtered _parameters saving) | ||
949 | (if saving | ||
950 | (mapcar (lambda (current) | ||
951 | (if (consp current) | ||
952 | (seq-reduce (lambda (current param) | ||
953 | (assq-delete-all param current)) | ||
954 | '(wc wc-point wc-bl wc-bbl | ||
955 | wc-history-back wc-history-forward) | ||
956 | (copy-sequence current)) | ||
957 | current)) | ||
958 | current) | ||
959 | current)) | ||
960 | |||
961 | (push '(tabs . frameset-filter-tabs) frameset-filter-alist) | ||
962 | |||
963 | (defun tab-bar--tab (&optional frame) | ||
964 | "Make a new tab data structure that can be added to tabs on the FRAME." | ||
965 | (let* ((tab (tab-bar--current-tab-find nil frame)) | ||
966 | (tab-explicit-name (alist-get 'explicit-name tab)) | ||
967 | (tab-group (alist-get 'group tab)) | ||
968 | (bl (seq-filter #'buffer-live-p (frame-parameter | ||
969 | frame 'buffer-list))) | ||
970 | (bbl (seq-filter #'buffer-live-p (frame-parameter | ||
971 | frame 'buried-buffer-list)))) | ||
972 | `(tab | ||
973 | (name . ,(if tab-explicit-name | ||
974 | (alist-get 'name tab) | ||
975 | (funcall tab-bar-tab-name-function))) | ||
976 | (explicit-name . ,tab-explicit-name) | ||
977 | ,@(if tab-group `((group . ,tab-group))) | ||
978 | (time . ,(float-time)) | ||
979 | (ws . ,(window-state-get | ||
980 | (frame-root-window (or frame (selected-frame))) 'writable)) | ||
981 | (wc . ,(current-window-configuration)) | ||
982 | (wc-point . ,(point-marker)) | ||
983 | (wc-bl . ,bl) | ||
984 | (wc-bbl . ,bbl) | ||
985 | ,@(when tab-bar-history-mode | ||
986 | `((wc-history-back . ,(gethash (or frame (selected-frame)) | ||
987 | tab-bar-history-back)) | ||
988 | (wc-history-forward . ,(gethash (or frame (selected-frame)) | ||
989 | tab-bar-history-forward)))) | ||
990 | ;; Copy other possible parameters | ||
991 | ,@(mapcan (lambda (param) | ||
992 | (unless (memq (car param) | ||
993 | '(name explicit-name group time | ||
994 | ws wc wc-point wc-bl wc-bbl | ||
995 | wc-history-back wc-history-forward)) | ||
996 | (list param))) | ||
997 | (cdr tab))))) | ||
998 | |||
999 | (defun tab-bar--current-tab (&optional tab frame) | ||
1000 | "Make the current tab data structure from TAB on FRAME." | ||
1001 | (tab-bar--current-tab-make (or tab (tab-bar--current-tab-find nil frame)))) | ||
1002 | |||
1003 | (defun tab-bar--current-tab-make (&optional tab) | ||
1004 | "Make the current tab data structure from TAB. | ||
1005 | TAB here is an argument meaning \"use tab as template\", | ||
1006 | i.e. the tab is created using data from TAB. This is | ||
1007 | necessary when switching tabs, otherwise the destination tab | ||
1008 | inherits the current tab's `explicit-name' parameter." | ||
1009 | (let* ((tab-explicit-name (alist-get 'explicit-name tab)) | ||
1010 | (tab-group (if tab | ||
1011 | (alist-get 'group tab) | ||
1012 | (pcase tab-bar-new-tab-group | ||
1013 | ((pred stringp) tab-bar-new-tab-group) | ||
1014 | ((pred functionp) (funcall tab-bar-new-tab-group)))))) | ||
1015 | `(current-tab | ||
1016 | (name . ,(if tab-explicit-name | ||
1017 | (alist-get 'name tab) | ||
1018 | (funcall tab-bar-tab-name-function))) | ||
1019 | (explicit-name . ,tab-explicit-name) | ||
1020 | ,@(if tab-group `((group . ,tab-group))) | ||
1021 | ;; Copy other possible parameters | ||
1022 | ,@(mapcan (lambda (param) | ||
1023 | (unless (memq (car param) | ||
1024 | '(name explicit-name group time | ||
1025 | ws wc wc-point wc-bl wc-bbl | ||
1026 | wc-history-back wc-history-forward)) | ||
1027 | (list param))) | ||
1028 | (cdr tab))))) | ||
1029 | |||
1030 | (defun tab-bar--current-tab-find (&optional tabs frame) | ||
1031 | ;; Find the current tab as a pointer to its data structure. | ||
1032 | (assq 'current-tab (or tabs (funcall tab-bar-tabs-function frame)))) | ||
1033 | |||
1034 | (defun tab-bar--current-tab-index (&optional tabs frame) | ||
1035 | ;; Return the index of the current tab. | ||
1036 | (seq-position (or tabs (funcall tab-bar-tabs-function frame)) | ||
1037 | 'current-tab (lambda (a b) (eq (car a) b)))) | ||
1038 | |||
1039 | (defun tab-bar--tab-index (tab &optional tabs frame) | ||
1040 | ;; Return the index of TAB. | ||
1041 | (seq-position (or tabs (funcall tab-bar-tabs-function frame)) | ||
1042 | tab #'eq)) | ||
1043 | |||
1044 | (defun tab-bar--tab-index-by-name (name &optional tabs frame) | ||
1045 | ;; Return the index of TAB by the its NAME. | ||
1046 | (seq-position (or tabs (funcall tab-bar-tabs-function frame)) | ||
1047 | name (lambda (a b) (equal (alist-get 'name a) b)))) | ||
1048 | |||
1049 | (defun tab-bar--tab-index-recent (nth &optional tabs frame) | ||
1050 | ;; Return the index of NTH recent tab. | ||
1051 | (let* ((tabs (or tabs (funcall tab-bar-tabs-function frame))) | ||
1052 | (sorted-tabs (tab-bar--tabs-recent tabs frame)) | ||
1053 | (tab (nth (1- nth) sorted-tabs))) | ||
1054 | (tab-bar--tab-index tab tabs))) | ||
1055 | |||
1056 | (defun tab-bar--tabs-recent (&optional tabs frame) | ||
1057 | ;; Return the list of tabs sorted by recency. | ||
1058 | (let* ((tabs (or tabs (funcall tab-bar-tabs-function frame)))) | ||
1059 | (seq-sort-by (lambda (tab) (alist-get 'time tab)) #'> | ||
1060 | (seq-remove (lambda (tab) | ||
1061 | (eq (car tab) 'current-tab)) | ||
1062 | tabs)))) | ||
1063 | |||
1064 | |||
1065 | (defun tab-bar-select-tab (&optional tab-number) | ||
1066 | "Switch to the tab by its absolute position TAB-NUMBER in the tab bar. | ||
1067 | When this command is bound to a numeric key (with a key prefix or modifier key | ||
1068 | using `tab-bar-select-tab-modifiers'), calling it without an argument | ||
1069 | will translate its bound numeric key to the numeric argument. | ||
1070 | Also the prefix argument TAB-NUMBER can be used to override | ||
1071 | the numeric key, so it takes precedence over the bound digit key. | ||
1072 | For example, `<MODIFIER>-2' will select the second tab, but `C-u 15 | ||
1073 | <MODIFIER>-2' will select the 15th tab. TAB-NUMBER counts from 1. | ||
1074 | Negative TAB-NUMBER counts tabs from the end of the tab bar." | ||
1075 | (interactive "P") | ||
1076 | (unless (integerp tab-number) | ||
1077 | (let ((key (event-basic-type last-command-event))) | ||
1078 | (setq tab-number (if (and (characterp key) (>= key ?1) (<= key ?9)) | ||
1079 | (- key ?0) | ||
1080 | 0)))) | ||
1081 | |||
1082 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1083 | (from-index (tab-bar--current-tab-index tabs)) | ||
1084 | (to-number (cond ((< tab-number 0) (+ (length tabs) (1+ tab-number))) | ||
1085 | ((zerop tab-number) (1+ from-index)) | ||
1086 | (t tab-number))) | ||
1087 | (to-index (1- (max 1 (min to-number (length tabs)))))) | ||
1088 | |||
1089 | (unless (eq from-index to-index) | ||
1090 | (let* ((from-tab (tab-bar--tab)) | ||
1091 | (to-tab (nth to-index tabs)) | ||
1092 | (wc (alist-get 'wc to-tab)) | ||
1093 | (ws (alist-get 'ws to-tab))) | ||
1094 | |||
1095 | ;; During the same session, use window-configuration to switch | ||
1096 | ;; tabs, because window-configurations are more reliable | ||
1097 | ;; (they keep references to live buffers) than window-states. | ||
1098 | ;; But after restoring tabs from a previously saved session, | ||
1099 | ;; its value of window-configuration is unreadable, | ||
1100 | ;; so restore its saved window-state. | ||
1101 | (cond | ||
1102 | ((and (window-configuration-p wc) | ||
1103 | ;; Check for such cases as cloning a frame with tabs. | ||
1104 | ;; When tabs were cloned to another frame, then fall back | ||
1105 | ;; to using `window-state-put' below. | ||
1106 | (eq (window-configuration-frame wc) (selected-frame))) | ||
1107 | (let ((wc-point (alist-get 'wc-point to-tab)) | ||
1108 | (wc-bl (seq-filter #'buffer-live-p (alist-get 'wc-bl to-tab))) | ||
1109 | (wc-bbl (seq-filter #'buffer-live-p (alist-get 'wc-bbl to-tab))) | ||
1110 | (wc-history-back (alist-get 'wc-history-back to-tab)) | ||
1111 | (wc-history-forward (alist-get 'wc-history-forward to-tab))) | ||
1112 | |||
1113 | (set-window-configuration wc) | ||
1114 | |||
1115 | ;; set-window-configuration does not restore the value of | ||
1116 | ;; point in the current buffer, so restore it separately. | ||
1117 | (when (and (markerp wc-point) | ||
1118 | (marker-buffer wc-point) | ||
1119 | ;; FIXME: After dired-revert, marker relocates to 1. | ||
1120 | ;; window-configuration restores point to global point | ||
1121 | ;; in this dired buffer, not to its window point, | ||
1122 | ;; but this is slightly better than 1. | ||
1123 | ;; Maybe better to save dired-filename in each window? | ||
1124 | (not (eq 1 (marker-position wc-point)))) | ||
1125 | (goto-char wc-point)) | ||
1126 | |||
1127 | (when wc-bl (set-frame-parameter nil 'buffer-list wc-bl)) | ||
1128 | (when wc-bbl (set-frame-parameter nil 'buried-buffer-list wc-bbl)) | ||
1129 | |||
1130 | (when tab-bar-history-mode | ||
1131 | (puthash (selected-frame) | ||
1132 | (and (window-configuration-p (alist-get 'wc (car wc-history-back))) | ||
1133 | wc-history-back) | ||
1134 | tab-bar-history-back) | ||
1135 | (puthash (selected-frame) | ||
1136 | (and (window-configuration-p (alist-get 'wc (car wc-history-forward))) | ||
1137 | wc-history-forward) | ||
1138 | tab-bar-history-forward)))) | ||
1139 | |||
1140 | (ws | ||
1141 | (window-state-put ws nil 'safe))) | ||
1142 | |||
1143 | (when tab-bar-history-mode | ||
1144 | (setq tab-bar-history-omit t)) | ||
1145 | |||
1146 | (when from-index | ||
1147 | (setf (nth from-index tabs) from-tab)) | ||
1148 | (setf (nth to-index tabs) (tab-bar--current-tab-make (nth to-index tabs))) | ||
1149 | |||
1150 | (unless tab-bar-mode | ||
1151 | (message "Selected tab '%s'" (alist-get 'name to-tab)))) | ||
1152 | |||
1153 | (force-mode-line-update)))) | ||
1154 | |||
1155 | (defun tab-bar-switch-to-next-tab (&optional arg) | ||
1156 | "Switch to ARGth next tab. | ||
1157 | Interactively, ARG is the prefix numeric argument and defaults to 1." | ||
1158 | (interactive "p") | ||
1159 | (unless (integerp arg) | ||
1160 | (setq arg 1)) | ||
1161 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1162 | (from-index (or (tab-bar--current-tab-index tabs) 0)) | ||
1163 | (to-index (mod (+ from-index arg) (length tabs)))) | ||
1164 | (tab-bar-select-tab (1+ to-index)))) | ||
1165 | |||
1166 | (defun tab-bar-switch-to-prev-tab (&optional arg) | ||
1167 | "Switch to ARGth previous tab. | ||
1168 | Interactively, ARG is the prefix numeric argument and defaults to 1." | ||
1169 | (interactive "p") | ||
1170 | (unless (integerp arg) | ||
1171 | (setq arg 1)) | ||
1172 | (tab-bar-switch-to-next-tab (- arg))) | ||
1173 | |||
1174 | (defun tab-bar-switch-to-last-tab (&optional arg) | ||
1175 | "Switch to the last tab or ARGth tab from the end of the tab bar. | ||
1176 | Interactively, ARG is the prefix numeric argument; it defaults to 1, | ||
1177 | which means the last tab on the tab bar. For example, `C-u 2 | ||
1178 | <MODIFIER>-9' selects the tab before the last tab." | ||
1179 | (interactive "p") | ||
1180 | (tab-bar-select-tab (- (length (funcall tab-bar-tabs-function)) | ||
1181 | (1- (abs (or arg 1)))))) | ||
1182 | |||
1183 | (defun tab-bar-switch-to-recent-tab (&optional arg) | ||
1184 | "Switch to ARGth most recently visited tab. | ||
1185 | Interactively, ARG is the prefix numeric argument and defaults to 1." | ||
1186 | (interactive "p") | ||
1187 | (unless (integerp arg) | ||
1188 | (setq arg 1)) | ||
1189 | (let ((tab-index (tab-bar--tab-index-recent arg))) | ||
1190 | (if tab-index | ||
1191 | (tab-bar-select-tab (1+ tab-index)) | ||
1192 | (message "No more recent tabs")))) | ||
1193 | |||
1194 | (defun tab-bar-switch-to-tab (name) | ||
1195 | "Switch to the tab by NAME. | ||
1196 | Default values are tab names sorted by recency, so you can use \ | ||
1197 | \\<minibuffer-local-map>\\[next-history-element] | ||
1198 | to get the name of the most recently visited tab, the second | ||
1199 | most recent, and so on. | ||
1200 | When the tab with that NAME doesn't exist, create a new tab | ||
1201 | and rename it to NAME." | ||
1202 | (interactive | ||
1203 | (let* ((recent-tabs (mapcar (lambda (tab) | ||
1204 | (alist-get 'name tab)) | ||
1205 | (tab-bar--tabs-recent)))) | ||
1206 | (list (completing-read (format-prompt "Switch to tab by name" | ||
1207 | (car recent-tabs)) | ||
1208 | recent-tabs nil nil nil nil recent-tabs)))) | ||
1209 | (let ((tab-index (tab-bar--tab-index-by-name name))) | ||
1210 | (if tab-index | ||
1211 | (tab-bar-select-tab (1+ tab-index)) | ||
1212 | (tab-bar-new-tab) | ||
1213 | (tab-bar-rename-tab name)))) | ||
1214 | |||
1215 | (defalias 'tab-bar-select-tab-by-name 'tab-bar-switch-to-tab) | ||
1216 | |||
1217 | |||
1218 | (defun tab-bar-move-tab-to (to-number &optional from-number) | ||
1219 | "Move tab from FROM-NUMBER position to new position at TO-NUMBER. | ||
1220 | FROM-NUMBER defaults to the current tab number. | ||
1221 | FROM-NUMBER and TO-NUMBER count from 1. | ||
1222 | Negative TO-NUMBER counts tabs from the end of the tab bar. | ||
1223 | Argument addressing is absolute in contrast to `tab-bar-move-tab' | ||
1224 | where argument addressing is relative." | ||
1225 | (interactive "P") | ||
1226 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1227 | (from-number (or from-number (1+ (tab-bar--current-tab-index tabs)))) | ||
1228 | (from-tab (nth (1- from-number) tabs)) | ||
1229 | (to-number (if to-number (prefix-numeric-value to-number) 1)) | ||
1230 | (to-number (if (< to-number 0) (+ (length tabs) (1+ to-number)) to-number)) | ||
1231 | (to-index (max 0 (min (1- to-number) (1- (length tabs)))))) | ||
1232 | (setq tabs (delq from-tab tabs)) | ||
1233 | (cl-pushnew from-tab (nthcdr to-index tabs)) | ||
1234 | (tab-bar-tabs-set tabs) | ||
1235 | (force-mode-line-update))) | ||
1236 | |||
1237 | (defun tab-bar-move-tab (&optional arg) | ||
1238 | "Move the current tab ARG positions to the right. | ||
1239 | Interactively, ARG is the prefix numeric argument and defaults to 1. | ||
1240 | If ARG is negative, move the current tab ARG positions to the left. | ||
1241 | Argument addressing is relative in contrast to `tab-bar-move-tab-to', | ||
1242 | where argument addressing is absolute." | ||
1243 | (interactive "p") | ||
1244 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1245 | (from-index (or (tab-bar--current-tab-index tabs) 0)) | ||
1246 | (to-index (mod (+ from-index arg) (length tabs)))) | ||
1247 | (tab-bar-move-tab-to (1+ to-index) (1+ from-index)))) | ||
1248 | |||
1249 | (defun tab-bar-move-tab-backward (&optional arg) | ||
1250 | "Move the current tab ARG positions to the left. | ||
1251 | Interactively, ARG is the prefix numeric argument and defaults to 1. | ||
1252 | Like `tab-bar-move-tab', but moves in the opposite direction." | ||
1253 | (interactive "p") | ||
1254 | (tab-bar-move-tab (- (or arg 1)))) | ||
1255 | |||
1256 | (defun tab-bar-move-tab-to-frame (arg &optional from-frame from-number to-frame to-number) | ||
1257 | "Move tab from FROM-NUMBER position to new position at TO-NUMBER. | ||
1258 | FROM-NUMBER defaults to the current tab number. | ||
1259 | FROM-NUMBER and TO-NUMBER count from 1. | ||
1260 | FROM-FRAME specifies the source frame and defaults to the selected frame. | ||
1261 | TO-FRAME specifies the target frame and defaults the next frame. | ||
1262 | Interactively, ARG selects the ARGth next frame on the same terminal, | ||
1263 | to which to move the tab; ARG defaults to 1." | ||
1264 | (interactive "P") | ||
1265 | (unless from-frame | ||
1266 | (setq from-frame (selected-frame))) | ||
1267 | (unless to-frame | ||
1268 | (dotimes (_ (prefix-numeric-value arg)) | ||
1269 | (setq to-frame (next-frame to-frame)))) | ||
1270 | (unless (eq from-frame to-frame) | ||
1271 | (let* ((from-tabs (funcall tab-bar-tabs-function from-frame)) | ||
1272 | (from-number (or from-number (1+ (tab-bar--current-tab-index from-tabs)))) | ||
1273 | (from-tab (nth (1- from-number) from-tabs)) | ||
1274 | (to-tabs (funcall tab-bar-tabs-function to-frame)) | ||
1275 | (to-index (max 0 (min (1- (or to-number 1)) (1- (length to-tabs)))))) | ||
1276 | (cl-pushnew (assq-delete-all | ||
1277 | 'wc (if (eq (car from-tab) 'current-tab) | ||
1278 | (tab-bar--tab from-frame) | ||
1279 | from-tab)) | ||
1280 | (nthcdr to-index to-tabs)) | ||
1281 | (with-selected-frame from-frame | ||
1282 | (let ((inhibit-message t) ; avoid message about deleted tab | ||
1283 | (tab-bar-close-last-tab-choice 'delete-frame) | ||
1284 | tab-bar-closed-tabs) | ||
1285 | (tab-bar-close-tab from-number))) | ||
1286 | (tab-bar-tabs-set to-tabs to-frame) | ||
1287 | (force-mode-line-update t)))) | ||
1288 | |||
1289 | (defun tab-bar-detach-tab (&optional from-number) | ||
1290 | "Move tab number FROM-NUMBER to a new frame. | ||
1291 | FROM-NUMBER defaults to the current tab (which happens interactively)." | ||
1292 | (interactive (list (1+ (tab-bar--current-tab-index)))) | ||
1293 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1294 | (tab-index (1- (or from-number (1+ (tab-bar--current-tab-index tabs))))) | ||
1295 | (tab-name (alist-get 'name (nth tab-index tabs))) | ||
1296 | ;; On some window managers, `make-frame' selects the new frame, | ||
1297 | ;; so previously selected frame is saved to `from-frame'. | ||
1298 | (from-frame (selected-frame)) | ||
1299 | (new-frame (make-frame `((name . ,tab-name))))) | ||
1300 | (tab-bar-move-tab-to-frame nil from-frame from-number new-frame nil) | ||
1301 | (with-selected-frame new-frame | ||
1302 | (tab-bar-close-tab)))) | ||
1303 | |||
1304 | (defun tab-bar-move-window-to-tab () | ||
1305 | "Move the selected window to a new tab. | ||
1306 | This command removes the selected window from the configuration stored | ||
1307 | on the current tab, and makes a new tab with that window in its | ||
1308 | configuration." | ||
1309 | (interactive) | ||
1310 | (let ((tab-bar-new-tab-choice 'window)) | ||
1311 | (tab-bar-new-tab)) | ||
1312 | (tab-bar-switch-to-recent-tab) | ||
1313 | (delete-window) | ||
1314 | (tab-bar-switch-to-recent-tab)) | ||
1315 | |||
1316 | |||
1317 | (defcustom tab-bar-new-tab-to 'right | ||
1318 | "Where to create a new tab. | ||
1319 | If `leftmost', create as the first tab. | ||
1320 | If `left', create to the left of the current tab. | ||
1321 | If `right', create to the right of the current tab. | ||
1322 | If `rightmost', create as the last tab. | ||
1323 | If the value is a function, it should return a number as a position | ||
1324 | on the tab bar specifying where to add a new tab." | ||
1325 | :type '(choice (const :tag "Add as First" leftmost) | ||
1326 | (const :tag "Add to Left" left) | ||
1327 | (const :tag "Add to Right" right) | ||
1328 | (const :tag "Add as Last" rightmost) | ||
1329 | (function :tag "Function")) | ||
1330 | :group 'tab-bar | ||
1331 | :version "27.1") | ||
1332 | |||
1333 | (defcustom tab-bar-tab-post-open-functions nil | ||
1334 | "List of functions to call after creating a new tab. | ||
1335 | The current tab is supplied as an argument. Any modifications made | ||
1336 | to the tab argument will be applied after all functions are called." | ||
1337 | :type '(repeat function) | ||
1338 | :group 'tab-bar | ||
1339 | :version "27.1") | ||
1340 | |||
1341 | (defun tab-bar-new-tab-to (&optional tab-number) | ||
1342 | "Add a new tab at the absolute position TAB-NUMBER. | ||
1343 | TAB-NUMBER counts from 1. If no TAB-NUMBER is specified, then add | ||
1344 | a new tab at the position specified by `tab-bar-new-tab-to'. | ||
1345 | Negative TAB-NUMBER counts tabs from the end of the tab bar, | ||
1346 | and -1 means the new tab will become the last one. | ||
1347 | Argument addressing is absolute in contrast to `tab-bar-new-tab', | ||
1348 | where argument addressing is relative. | ||
1349 | After the tab is created, the hooks in | ||
1350 | `tab-bar-tab-post-open-functions' are run." | ||
1351 | (interactive "P") | ||
1352 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1353 | (from-index (tab-bar--current-tab-index tabs)) | ||
1354 | (from-tab (tab-bar--tab))) | ||
1355 | |||
1356 | (when tab-bar-new-tab-choice | ||
1357 | ;; Handle the case when it's called in the active minibuffer. | ||
1358 | (when (minibuffer-selected-window) | ||
1359 | (select-window (minibuffer-selected-window))) | ||
1360 | (let ((ignore-window-parameters t)) | ||
1361 | (delete-other-windows)) | ||
1362 | (unless (eq tab-bar-new-tab-choice 'window) | ||
1363 | ;; Create a new window to get rid of old window parameters | ||
1364 | ;; (e.g. prev/next buffers) of old window. | ||
1365 | (split-window) (delete-window)) | ||
1366 | (let ((buffer | ||
1367 | (if (functionp tab-bar-new-tab-choice) | ||
1368 | (funcall tab-bar-new-tab-choice) | ||
1369 | (if (stringp tab-bar-new-tab-choice) | ||
1370 | (or (get-buffer tab-bar-new-tab-choice) | ||
1371 | (find-file-noselect tab-bar-new-tab-choice)))))) | ||
1372 | (when (buffer-live-p buffer) | ||
1373 | (switch-to-buffer buffer)))) | ||
1374 | |||
1375 | (when from-index | ||
1376 | (setf (nth from-index tabs) from-tab)) | ||
1377 | |||
1378 | (let* ((to-tab (tab-bar--current-tab-make | ||
1379 | (when (eq tab-bar-new-tab-group t) | ||
1380 | `((group . ,(alist-get 'group from-tab)))))) | ||
1381 | (to-number (and tab-number (prefix-numeric-value tab-number))) | ||
1382 | (to-index (or (if to-number | ||
1383 | (if (< to-number 0) | ||
1384 | (+ (length tabs) (1+ to-number)) | ||
1385 | (1- to-number))) | ||
1386 | (pcase tab-bar-new-tab-to | ||
1387 | ('leftmost 0) | ||
1388 | ('rightmost (length tabs)) | ||
1389 | ('left (or from-index 1)) | ||
1390 | ('right (1+ (or from-index 0))) | ||
1391 | ((pred functionp) | ||
1392 | (funcall tab-bar-new-tab-to)))))) | ||
1393 | (setq to-index (max 0 (min (or to-index 0) (length tabs)))) | ||
1394 | (cl-pushnew to-tab (nthcdr to-index tabs)) | ||
1395 | |||
1396 | (when (eq to-index 0) | ||
1397 | ;; `pushnew' handles the head of tabs but not frame-parameter | ||
1398 | (tab-bar-tabs-set tabs)) | ||
1399 | |||
1400 | (when tab-bar-history-mode | ||
1401 | (puthash (selected-frame) nil tab-bar-history-back) | ||
1402 | (puthash (selected-frame) nil tab-bar-history-forward) | ||
1403 | (setq tab-bar-history-omit t)) | ||
1404 | |||
1405 | (run-hook-with-args 'tab-bar-tab-post-open-functions | ||
1406 | (nth to-index tabs))) | ||
1407 | |||
1408 | (when tab-bar-show | ||
1409 | (if (not tab-bar-mode) | ||
1410 | ;; Turn on `tab-bar-mode' since a tab was created. | ||
1411 | ;; Note: this also updates `tab-bar-lines'. | ||
1412 | (tab-bar-mode 1) | ||
1413 | (tab-bar--update-tab-bar-lines))) | ||
1414 | |||
1415 | (force-mode-line-update) | ||
1416 | (unless tab-bar-mode | ||
1417 | (message "Added new tab at %s" tab-bar-new-tab-to)))) | ||
1418 | |||
1419 | (defun tab-bar-new-tab (&optional arg from-number) | ||
1420 | "Create a new tab ARG positions to the right. | ||
1421 | If a negative ARG, create a new tab ARG positions to the left. | ||
1422 | If ARG is zero, create a new tab in place of the current tab. | ||
1423 | If no ARG is specified, then add a new tab at the position | ||
1424 | specified by `tab-bar-new-tab-to'. | ||
1425 | Argument addressing is relative in contrast to `tab-bar-new-tab-to', | ||
1426 | where argument addressing is absolute. | ||
1427 | If FROM-NUMBER is a tab number, a new tab is created from that tab." | ||
1428 | (interactive "P") | ||
1429 | (when from-number | ||
1430 | (let ((inhibit-message t)) | ||
1431 | (tab-bar-select-tab from-number))) | ||
1432 | (if arg | ||
1433 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1434 | (from-index (or (tab-bar--current-tab-index tabs) 0)) | ||
1435 | (to-index (+ from-index (prefix-numeric-value arg)))) | ||
1436 | (tab-bar-new-tab-to (1+ to-index))) | ||
1437 | (tab-bar-new-tab-to))) | ||
1438 | |||
1439 | (defun tab-bar-duplicate-tab (&optional arg from-number) | ||
1440 | "Clone the current tab to ARG positions to the right. | ||
1441 | ARG and FROM-NUMBER have the same meaning as in `tab-bar-new-tab'." | ||
1442 | (interactive "P") | ||
1443 | (let ((tab-bar-new-tab-choice nil) | ||
1444 | (tab-bar-new-tab-group t)) | ||
1445 | (tab-bar-new-tab arg from-number))) | ||
1446 | |||
1447 | |||
1448 | (defvar tab-bar-closed-tabs nil | ||
1449 | "A list of closed tabs to be able to undo their closing.") | ||
1450 | |||
1451 | (defcustom tab-bar-close-tab-select 'recent | ||
1452 | "Which tab to make current after closing the specified tab. | ||
1453 | If `left', select the adjacent left tab. | ||
1454 | If `right', select the adjacent right tab. | ||
1455 | If `recent', select the most recently visited tab." | ||
1456 | :type '(choice (const :tag "Select left tab" left) | ||
1457 | (const :tag "Select right tab" right) | ||
1458 | (const :tag "Select recent tab" recent)) | ||
1459 | :group 'tab-bar | ||
1460 | :version "27.1") | ||
1461 | |||
1462 | (defcustom tab-bar-close-last-tab-choice nil | ||
1463 | "What to do when the last tab is closed. | ||
1464 | If nil, do nothing and show a message, like closing the last window or frame. | ||
1465 | If `delete-frame', delete the containing frame, as a web browser would do. | ||
1466 | If `tab-bar-mode-disable', disable `tab-bar-mode' so that tabs no longer show | ||
1467 | in the frame. | ||
1468 | If the value is a function, call that function with the tab to be closed | ||
1469 | as an argument." | ||
1470 | :type '(choice (const :tag "Do nothing and show message" nil) | ||
1471 | (const :tag "Close the containing frame" delete-frame) | ||
1472 | (const :tag "Disable tab-bar-mode" tab-bar-mode-disable) | ||
1473 | (function :tag "Function")) | ||
1474 | :group 'tab-bar | ||
1475 | :version "27.1") | ||
1476 | |||
1477 | (defcustom tab-bar-tab-prevent-close-functions nil | ||
1478 | "List of functions to call to determine whether to close a tab. | ||
1479 | The tab to be closed and a boolean indicating whether or not it | ||
1480 | is the only tab in the frame are supplied as arguments. If any | ||
1481 | function returns a non-nil value, the tab will not be closed." | ||
1482 | :type '(repeat function) | ||
1483 | :group 'tab-bar | ||
1484 | :version "27.1") | ||
1485 | |||
1486 | (defcustom tab-bar-tab-pre-close-functions nil | ||
1487 | "List of functions to call before closing a tab. | ||
1488 | Each function is called with two arguments: the tab to be closed | ||
1489 | and a boolean indicating whether or not it is the only tab on its frame." | ||
1490 | :type '(repeat function) | ||
1491 | :group 'tab-bar | ||
1492 | :version "27.1") | ||
1493 | |||
1494 | (defun tab-bar-close-tab (&optional tab-number to-number) | ||
1495 | "Close the tab specified by its absolute position TAB-NUMBER. | ||
1496 | If no TAB-NUMBER is specified, then close the current tab and switch | ||
1497 | to the tab specified by `tab-bar-close-tab-select'. | ||
1498 | Interactively, TAB-NUMBER is the prefix numeric argument, and defaults to 1. | ||
1499 | TAB-NUMBER counts from 1. | ||
1500 | Optional TO-NUMBER could be specified to override the value of | ||
1501 | `tab-bar-close-tab-select' programmatically with a position | ||
1502 | of an existing tab to select after closing the current tab. | ||
1503 | TO-NUMBER counts from 1. | ||
1504 | |||
1505 | The functions in `tab-bar-tab-prevent-close-functions' will be | ||
1506 | run to determine whether or not to close the tab. | ||
1507 | Just before the tab is closed, the functions in | ||
1508 | `tab-bar-tab-pre-close-functions' will be run. The base behavior | ||
1509 | for the last tab on a frame is determined by | ||
1510 | `tab-bar-close-last-tab-choice'." | ||
1511 | (interactive "P") | ||
1512 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1513 | (current-index (tab-bar--current-tab-index tabs)) | ||
1514 | (close-index (if (integerp tab-number) (1- tab-number) current-index)) | ||
1515 | (last-tab-p (= 1 (length tabs))) | ||
1516 | (prevent-close (run-hook-with-args-until-success | ||
1517 | 'tab-bar-tab-prevent-close-functions | ||
1518 | (nth close-index tabs) | ||
1519 | last-tab-p))) | ||
1520 | |||
1521 | (unless prevent-close | ||
1522 | (run-hook-with-args 'tab-bar-tab-pre-close-functions | ||
1523 | (nth close-index tabs) | ||
1524 | last-tab-p) | ||
1525 | |||
1526 | (if last-tab-p | ||
1527 | (pcase tab-bar-close-last-tab-choice | ||
1528 | ('nil | ||
1529 | (user-error "Attempt to delete the sole tab in a frame")) | ||
1530 | ('delete-frame | ||
1531 | (delete-frame)) | ||
1532 | ('tab-bar-mode-disable | ||
1533 | (tab-bar-mode -1)) | ||
1534 | ((pred functionp) | ||
1535 | ;; Give the handler function the full extent of the tab's | ||
1536 | ;; data, not just it's name and explicit-name flag. | ||
1537 | (funcall tab-bar-close-last-tab-choice (tab-bar--tab)))) | ||
1538 | |||
1539 | ;; More than one tab still open | ||
1540 | (when (eq current-index close-index) | ||
1541 | ;; Select another tab before deleting the current tab | ||
1542 | (let ((to-index (or (if to-number (1- to-number)) | ||
1543 | (pcase tab-bar-close-tab-select | ||
1544 | ('left (1- (if (< current-index 1) 2 current-index))) | ||
1545 | ('right (if (> (length tabs) (1+ current-index)) | ||
1546 | (1+ current-index) | ||
1547 | (1- current-index))) | ||
1548 | ('recent (tab-bar--tab-index-recent 1 tabs)))))) | ||
1549 | (setq to-index (max 0 (min (or to-index 0) (1- (length tabs))))) | ||
1550 | (let ((inhibit-message t)) ; avoid message about selected tab | ||
1551 | (tab-bar-select-tab (1+ to-index))) | ||
1552 | ;; Re-read tabs after selecting another tab | ||
1553 | (setq tabs (funcall tab-bar-tabs-function)))) | ||
1554 | |||
1555 | (let ((close-tab (nth close-index tabs))) | ||
1556 | (push `((frame . ,(selected-frame)) | ||
1557 | (index . ,close-index) | ||
1558 | (tab . ,(if (eq (car close-tab) 'current-tab) | ||
1559 | (tab-bar--tab) | ||
1560 | close-tab))) | ||
1561 | tab-bar-closed-tabs) | ||
1562 | (tab-bar-tabs-set (delq close-tab tabs))) | ||
1563 | |||
1564 | ;; Recalculate `tab-bar-lines' and update frames | ||
1565 | (tab-bar--update-tab-bar-lines) | ||
1566 | |||
1567 | (force-mode-line-update) | ||
1568 | (unless tab-bar-mode | ||
1569 | (message "Deleted tab and switched to %s" tab-bar-close-tab-select)))))) | ||
1570 | |||
1571 | (defun tab-bar-close-tab-by-name (name) | ||
1572 | "Close the tab given its NAME. | ||
1573 | Interactively, prompt for NAME." | ||
1574 | (interactive | ||
1575 | (list (completing-read "Close tab by name: " | ||
1576 | (mapcar (lambda (tab) | ||
1577 | (alist-get 'name tab)) | ||
1578 | (funcall tab-bar-tabs-function))))) | ||
1579 | (tab-bar-close-tab (1+ (tab-bar--tab-index-by-name name)))) | ||
1580 | |||
1581 | (defun tab-bar-close-other-tabs (&optional tab-number) | ||
1582 | "Close all tabs on the selected frame, except the tab TAB-NUMBER. | ||
1583 | TAB-NUMBER counts from 1 and defaults to the current tab (which | ||
1584 | happens interactively)." | ||
1585 | (interactive) | ||
1586 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1587 | (current-index (tab-bar--current-tab-index tabs)) | ||
1588 | (keep-index (if (integerp tab-number) | ||
1589 | (1- (max 1 (min tab-number (length tabs)))) | ||
1590 | current-index)) | ||
1591 | (index 0)) | ||
1592 | |||
1593 | (when (nth keep-index tabs) | ||
1594 | (unless (eq keep-index current-index) | ||
1595 | (tab-bar-select-tab (1+ keep-index)) | ||
1596 | (setq tabs (funcall tab-bar-tabs-function))) | ||
1597 | |||
1598 | (dolist (tab tabs) | ||
1599 | (unless (or (eq index keep-index) | ||
1600 | (run-hook-with-args-until-success | ||
1601 | 'tab-bar-tab-prevent-close-functions tab | ||
1602 | ;; `last-tab-p' logically can't ever be true | ||
1603 | ;; if we make it this far | ||
1604 | nil)) | ||
1605 | (push `((frame . ,(selected-frame)) | ||
1606 | (index . ,index) | ||
1607 | (tab . ,tab)) | ||
1608 | tab-bar-closed-tabs) | ||
1609 | (run-hook-with-args 'tab-bar-tab-pre-close-functions tab nil) | ||
1610 | (setq tabs (delq tab tabs))) | ||
1611 | (setq index (1+ index))) | ||
1612 | (tab-bar-tabs-set tabs) | ||
1613 | |||
1614 | ;; Recalculate tab-bar-lines and update frames | ||
1615 | (tab-bar--update-tab-bar-lines) | ||
1616 | |||
1617 | (force-mode-line-update) | ||
1618 | (unless tab-bar-mode | ||
1619 | (message "Deleted all other tabs"))))) | ||
1620 | |||
1621 | (defun tab-bar-undo-close-tab () | ||
1622 | "Restore the most recently closed tab." | ||
1623 | (interactive) | ||
1624 | ;; Pop out closed tabs that were on already deleted frames | ||
1625 | (while (and tab-bar-closed-tabs | ||
1626 | (not (frame-live-p (alist-get 'frame (car tab-bar-closed-tabs))))) | ||
1627 | (pop tab-bar-closed-tabs)) | ||
1628 | |||
1629 | (if tab-bar-closed-tabs | ||
1630 | (let* ((closed (pop tab-bar-closed-tabs)) | ||
1631 | (frame (alist-get 'frame closed)) | ||
1632 | (index (alist-get 'index closed)) | ||
1633 | (tab (alist-get 'tab closed))) | ||
1634 | (unless (eq frame (selected-frame)) | ||
1635 | (select-frame-set-input-focus frame)) | ||
1636 | |||
1637 | (let ((tabs (funcall tab-bar-tabs-function))) | ||
1638 | (setq index (max 0 (min index (length tabs)))) | ||
1639 | (cl-pushnew tab (nthcdr index tabs)) | ||
1640 | (when (eq index 0) | ||
1641 | ;; pushnew handles the head of tabs but not frame-parameter | ||
1642 | (tab-bar-tabs-set tabs)) | ||
1643 | (tab-bar-select-tab (1+ index)))) | ||
1644 | |||
1645 | (message "No more closed tabs to undo"))) | ||
1646 | |||
1647 | |||
1648 | (defun tab-bar-rename-tab (name &optional tab-number) | ||
1649 | "Give the tab specified by its absolute position TAB-NUMBER a new NAME. | ||
1650 | If no TAB-NUMBER is specified, then rename the current tab. | ||
1651 | Interactively, TAB-NUMBER is the prefix numeric argument, and defaults | ||
1652 | to the current tab. | ||
1653 | TAB-NUMBER counts from 1. | ||
1654 | Interactively, prompt for the new NAME. | ||
1655 | If NAME is the empty string, then use the automatic name | ||
1656 | function `tab-bar-tab-name-function'." | ||
1657 | (interactive | ||
1658 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1659 | (tab-number (or current-prefix-arg (1+ (tab-bar--current-tab-index tabs)))) | ||
1660 | (tab-name (alist-get 'name (nth (1- tab-number) tabs)))) | ||
1661 | (list (read-from-minibuffer | ||
1662 | "New name for tab (leave blank for automatic naming): " | ||
1663 | nil nil nil nil tab-name) | ||
1664 | current-prefix-arg))) | ||
1665 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1666 | (tab-index (if (integerp tab-number) | ||
1667 | (1- (max 0 (min tab-number (length tabs)))) | ||
1668 | (tab-bar--current-tab-index tabs))) | ||
1669 | (tab-to-rename (nth tab-index tabs)) | ||
1670 | (tab-explicit-name (> (length name) 0)) | ||
1671 | (tab-new-name (if tab-explicit-name | ||
1672 | name | ||
1673 | (funcall tab-bar-tab-name-function)))) | ||
1674 | (setf (alist-get 'name tab-to-rename) tab-new-name | ||
1675 | (alist-get 'explicit-name tab-to-rename) tab-explicit-name) | ||
1676 | |||
1677 | (force-mode-line-update) | ||
1678 | (unless tab-bar-mode | ||
1679 | (message "Renamed tab to '%s'" tab-new-name)))) | ||
1680 | |||
1681 | (defun tab-bar-rename-tab-by-name (tab-name new-name) | ||
1682 | "Rename the tab named TAB-NAME to NEW-NAME. | ||
1683 | Interactively, prompt for TAB-NAME and NEW-NAME. | ||
1684 | If NEW-NAME is the empty string, then use the automatic name | ||
1685 | function `tab-bar-tab-name-function'." | ||
1686 | (interactive | ||
1687 | (let ((tab-name (completing-read "Rename tab by name: " | ||
1688 | (mapcar (lambda (tab) | ||
1689 | (alist-get 'name tab)) | ||
1690 | (funcall tab-bar-tabs-function))))) | ||
1691 | (list tab-name (read-from-minibuffer | ||
1692 | "New name for tab (leave blank for automatic naming): " | ||
1693 | nil nil nil nil tab-name)))) | ||
1694 | (tab-bar-rename-tab new-name (1+ (tab-bar--tab-index-by-name tab-name)))) | ||
1695 | |||
1696 | |||
1697 | ;;; Tab groups | ||
1698 | |||
1699 | (defun tab-bar-move-tab-to-group (&optional tab) | ||
1700 | "Relocate TAB (by default, the current tab) closer to its group." | ||
1701 | (interactive) | ||
1702 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1703 | (tab (or tab (tab-bar--current-tab-find tabs))) | ||
1704 | (tab-index (tab-bar--tab-index tab)) | ||
1705 | (group (alist-get 'group tab)) | ||
1706 | ;; Beginning position of the same group | ||
1707 | (beg (seq-position tabs group | ||
1708 | (lambda (tb gr) | ||
1709 | (and (not (eq tb tab)) | ||
1710 | (equal (alist-get 'group tb) gr))))) | ||
1711 | ;; Size of the same group | ||
1712 | (len (when beg | ||
1713 | (seq-position (nthcdr beg tabs) group | ||
1714 | (lambda (tb gr) | ||
1715 | (not (equal (alist-get 'group tb) gr)))))) | ||
1716 | (pos (when beg | ||
1717 | (cond | ||
1718 | ;; Don't move tab when it's already inside group bounds | ||
1719 | ((and len (>= tab-index beg) (<= tab-index (+ beg len))) nil) | ||
1720 | ;; Move tab from the right to the group end | ||
1721 | ((and len (> tab-index (+ beg len))) (+ beg len 1)) | ||
1722 | ;; Move tab from the left to the group beginning | ||
1723 | ((< tab-index beg) beg))))) | ||
1724 | (when pos | ||
1725 | (tab-bar-move-tab-to pos (1+ tab-index))))) | ||
1726 | |||
1727 | (defcustom tab-bar-tab-post-change-group-functions nil | ||
1728 | "List of functions to call after changing a tab group. | ||
1729 | The current tab is supplied as an argument." | ||
1730 | :type 'hook | ||
1731 | :options '(tab-bar-move-tab-to-group) | ||
1732 | :group 'tab-bar | ||
1733 | :version "28.1") | ||
1734 | |||
1735 | (defun tab-bar-change-tab-group (group-name &optional tab-number) | ||
1736 | "Add the tab specified by its absolute position TAB-NUMBER to GROUP-NAME. | ||
1737 | If no TAB-NUMBER is specified, then set the GROUP-NAME for the current tab. | ||
1738 | Interactively, TAB-NUMBER is the prefix numeric argument, and the command | ||
1739 | prompts for GROUP-NAME. | ||
1740 | TAB-NUMBER counts from 1. | ||
1741 | If GROUP-NAME is the empty string, then remove the tab from any group. | ||
1742 | While using this command, you might also want to replace | ||
1743 | `tab-bar-format-tabs' with `tab-bar-format-tabs-groups' in | ||
1744 | `tab-bar-format' to group tabs on the tab bar." | ||
1745 | (interactive | ||
1746 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1747 | (tab-number (or current-prefix-arg | ||
1748 | (1+ (tab-bar--current-tab-index tabs)))) | ||
1749 | (group-name (funcall tab-bar-tab-group-function | ||
1750 | (nth (1- tab-number) tabs)))) | ||
1751 | (list (completing-read | ||
1752 | "Group name for tab (leave blank to remove group): " | ||
1753 | (delete-dups | ||
1754 | (delq nil (cons group-name | ||
1755 | (mapcar (lambda (tab) | ||
1756 | (funcall tab-bar-tab-group-function tab)) | ||
1757 | (funcall tab-bar-tabs-function)))))) | ||
1758 | current-prefix-arg))) | ||
1759 | (let* ((tabs (funcall tab-bar-tabs-function)) | ||
1760 | (tab-index (if tab-number | ||
1761 | (1- (max 0 (min tab-number (length tabs)))) | ||
1762 | (tab-bar--current-tab-index tabs))) | ||
1763 | (tab (nth tab-index tabs)) | ||
1764 | (group (assq 'group tab)) | ||
1765 | (group-new-name (and (> (length group-name) 0) group-name))) | ||
1766 | (if group | ||
1767 | (setcdr group group-new-name) | ||
1768 | (nconc tab `((group . ,group-new-name)))) | ||
1769 | |||
1770 | (run-hook-with-args 'tab-bar-tab-post-change-group-functions tab) | ||
1771 | |||
1772 | (force-mode-line-update) | ||
1773 | (unless tab-bar-mode | ||
1774 | (message "Set tab group to '%s'" group-new-name)))) | ||
1775 | |||
1776 | (defun tab-bar-close-group-tabs (group-name) | ||
1777 | "Close all tabs that belong to GROUP-NAME on the selected frame. | ||
1778 | Interactively, prompt for GROUP-NAME." | ||
1779 | (interactive | ||
1780 | (let ((group-name (funcall tab-bar-tab-group-function | ||
1781 | (tab-bar--current-tab-find)))) | ||
1782 | (list (completing-read | ||
1783 | "Close all tabs with group name: " | ||
1784 | (delete-dups | ||
1785 | (delq nil (cons group-name | ||
1786 | (mapcar (lambda (tab) | ||
1787 | (funcall tab-bar-tab-group-function tab)) | ||
1788 | (funcall tab-bar-tabs-function))))))))) | ||
1789 | (let* ((close-group (and (> (length group-name) 0) group-name)) | ||
1790 | (tab-bar-tab-prevent-close-functions | ||
1791 | (cons (lambda (tab _last-tab-p) | ||
1792 | (not (equal (funcall tab-bar-tab-group-function tab) | ||
1793 | close-group))) | ||
1794 | tab-bar-tab-prevent-close-functions))) | ||
1795 | (tab-bar-close-other-tabs) | ||
1796 | |||
1797 | (when (equal (funcall tab-bar-tab-group-function | ||
1798 | (tab-bar--current-tab-find)) | ||
1799 | close-group) | ||
1800 | (tab-bar-close-tab)))) | ||
1801 | |||
1802 | |||
1803 | ;;; Tab history mode | ||
1804 | |||
1805 | (defvar tab-bar-history-limit 10 | ||
1806 | "The number of history elements to keep.") | ||
1807 | |||
1808 | (defvar tab-bar-history-omit nil | ||
1809 | "When non-nil, omit window-configuration changes from the current command.") | ||
1810 | |||
1811 | (defvar tab-bar-history-back (make-hash-table) | ||
1812 | "History of back changes in every tab per frame.") | ||
1813 | |||
1814 | (defvar tab-bar-history-forward (make-hash-table) | ||
1815 | "History of forward changes in every tab per frame.") | ||
1816 | |||
1817 | (defvar tab-bar-history-old nil | ||
1818 | "Window configuration before the current command.") | ||
1819 | |||
1820 | (defvar tab-bar-history-pre-command nil | ||
1821 | "Command set to `this-command' by `pre-command-hook'.") | ||
1822 | |||
1823 | (defvar tab-bar-history-done-command nil | ||
1824 | "Command handled by `window-configuration-change-hook'.") | ||
1825 | |||
1826 | (defun tab-bar--history-pre-change () | ||
1827 | ;; Reset before the command could set it | ||
1828 | (setq tab-bar-history-omit nil) | ||
1829 | (setq tab-bar-history-pre-command this-command) | ||
1830 | (when (zerop (minibuffer-depth)) | ||
1831 | (setq tab-bar-history-old | ||
1832 | `((wc . ,(current-window-configuration)) | ||
1833 | (wc-point . ,(point-marker)))))) | ||
1834 | |||
1835 | (defun tab-bar--history-change () | ||
1836 | (when (and (not tab-bar-history-omit) tab-bar-history-old | ||
1837 | ;; Don't register changes performed by the same command | ||
1838 | ;; repeated in sequence, such as incremental window resizing. | ||
1839 | (not (eq tab-bar-history-done-command tab-bar-history-pre-command)) | ||
1840 | (zerop (minibuffer-depth))) | ||
1841 | (puthash (selected-frame) | ||
1842 | (seq-take (cons tab-bar-history-old | ||
1843 | (gethash (selected-frame) tab-bar-history-back)) | ||
1844 | tab-bar-history-limit) | ||
1845 | tab-bar-history-back) | ||
1846 | (setq tab-bar-history-old nil)) | ||
1847 | (setq tab-bar-history-done-command tab-bar-history-pre-command)) | ||
1848 | |||
1849 | (defun tab-bar-history-back () | ||
1850 | "Restore a previous window configuration used in the current tab. | ||
1851 | This navigates back in the history of window configurations." | ||
1852 | (interactive) | ||
1853 | (setq tab-bar-history-omit t) | ||
1854 | (let* ((history (pop (gethash (selected-frame) tab-bar-history-back))) | ||
1855 | (wc (alist-get 'wc history)) | ||
1856 | (wc-point (alist-get 'wc-point history))) | ||
1857 | (if (window-configuration-p wc) | ||
1858 | (progn | ||
1859 | (puthash (selected-frame) | ||
1860 | (cons tab-bar-history-old | ||
1861 | (gethash (selected-frame) tab-bar-history-forward)) | ||
1862 | tab-bar-history-forward) | ||
1863 | (set-window-configuration wc) | ||
1864 | (when (and (markerp wc-point) (marker-buffer wc-point)) | ||
1865 | (goto-char wc-point))) | ||
1866 | (message "No more tab back history")))) | ||
1867 | |||
1868 | (defun tab-bar-history-forward () | ||
1869 | "Cancel restoration of the previous window configuration. | ||
1870 | This navigates forward in the history of window configurations." | ||
1871 | (interactive) | ||
1872 | (setq tab-bar-history-omit t) | ||
1873 | (let* ((history (pop (gethash (selected-frame) tab-bar-history-forward))) | ||
1874 | (wc (alist-get 'wc history)) | ||
1875 | (wc-point (alist-get 'wc-point history))) | ||
1876 | (if (window-configuration-p wc) | ||
1877 | (progn | ||
1878 | (puthash (selected-frame) | ||
1879 | (cons tab-bar-history-old | ||
1880 | (gethash (selected-frame) tab-bar-history-back)) | ||
1881 | tab-bar-history-back) | ||
1882 | (set-window-configuration wc) | ||
1883 | (when (and (markerp wc-point) (marker-buffer wc-point)) | ||
1884 | (goto-char wc-point))) | ||
1885 | (message "No more tab forward history")))) | ||
1886 | |||
1887 | (defvar-keymap tab-bar-history-mode-map | ||
1888 | "C-c <left>" #'tab-bar-history-back | ||
1889 | "C-c <right>" #'tab-bar-history-forward) | ||
1890 | |||
1891 | (define-minor-mode tab-bar-history-mode | ||
1892 | "Toggle tab history mode for the tab bar. | ||
1893 | Tab history mode remembers window configurations used in every tab, | ||
1894 | and can restore them." | ||
1895 | :global t :group 'tab-bar | ||
1896 | (if tab-bar-history-mode | ||
1897 | (progn | ||
1898 | (when (and tab-bar-mode (not (get-text-property 0 'display tab-bar-back-button))) | ||
1899 | ;; This file is pre-loaded so only here we can use the right data-directory: | ||
1900 | (add-text-properties 0 (length tab-bar-back-button) | ||
1901 | `(display (image :type xpm | ||
1902 | :file "tabs/left-arrow.xpm" | ||
1903 | :margin ,tab-bar-button-margin | ||
1904 | :ascent center)) | ||
1905 | tab-bar-back-button)) | ||
1906 | (when (and tab-bar-mode (not (get-text-property 0 'display tab-bar-forward-button))) | ||
1907 | ;; This file is pre-loaded so only here we can use the right data-directory: | ||
1908 | (add-text-properties 0 (length tab-bar-forward-button) | ||
1909 | `(display (image :type xpm | ||
1910 | :file "tabs/right-arrow.xpm" | ||
1911 | :margin ,tab-bar-button-margin | ||
1912 | :ascent center)) | ||
1913 | tab-bar-forward-button)) | ||
1914 | |||
1915 | (add-hook 'pre-command-hook 'tab-bar--history-pre-change) | ||
1916 | (add-hook 'window-configuration-change-hook 'tab-bar--history-change)) | ||
1917 | (remove-hook 'pre-command-hook 'tab-bar--history-pre-change) | ||
1918 | (remove-hook 'window-configuration-change-hook 'tab-bar--history-change))) | ||
1919 | |||
1920 | |||
1921 | ;;; Non-graphical access to frame-local tabs (named window configurations) | ||
1922 | |||
1923 | (defun tab-switcher () | ||
1924 | "Display a list of named window configurations. | ||
1925 | The list is displayed in the buffer `*Tabs*'. | ||
1926 | It's placed in the center of the frame to resemble a window list | ||
1927 | displayed by a window switcher in some window managers on Alt+Tab. | ||
1928 | |||
1929 | In this list of window configurations you can delete or select them. | ||
1930 | Type ? after invocation to get help on commands available. | ||
1931 | Type q to remove the list of window configurations from the display. | ||
1932 | |||
1933 | The first column shows `D' for a window configuration you have | ||
1934 | marked for deletion." | ||
1935 | (interactive) | ||
1936 | (let ((dir default-directory)) | ||
1937 | (let ((tab-bar-new-tab-choice t) | ||
1938 | ;; Don't enable tab-bar-mode if it's disabled | ||
1939 | (tab-bar-show nil)) | ||
1940 | (tab-bar-new-tab)) | ||
1941 | (let ((switch-to-buffer-preserve-window-point nil)) | ||
1942 | (switch-to-buffer (tab-switcher-noselect))) | ||
1943 | (setq default-directory dir)) | ||
1944 | (message "Commands: d, x; RET; q to quit; ? for help.")) | ||
1945 | |||
1946 | (defun tab-switcher-noselect () | ||
1947 | "Create and return a buffer with a list of window configurations. | ||
1948 | The list is displayed in a buffer named `*Tabs*'. | ||
1949 | |||
1950 | For more information, see the function `tab-switcher'." | ||
1951 | (let* ((tabs (seq-remove (lambda (tab) | ||
1952 | (eq (car tab) 'current-tab)) | ||
1953 | (funcall tab-bar-tabs-function))) | ||
1954 | ;; Sort by recency | ||
1955 | (tabs (sort tabs (lambda (a b) (< (alist-get 'time b) | ||
1956 | (alist-get 'time a)))))) | ||
1957 | (with-current-buffer (get-buffer-create | ||
1958 | (format " *Tabs*<%s>" (or (frame-parameter nil 'window-id) | ||
1959 | (frame-parameter nil 'name)))) | ||
1960 | (setq buffer-read-only nil) | ||
1961 | (erase-buffer) | ||
1962 | (tab-switcher-mode) | ||
1963 | ;; Vertical alignment to the center of the frame | ||
1964 | (insert-char ?\n (/ (- (frame-height) (length tabs) 1) 2)) | ||
1965 | ;; Horizontal alignment to the center of the frame | ||
1966 | (setq tab-switcher-column (- (/ (frame-width) 2) 15)) | ||
1967 | (dolist (tab tabs) | ||
1968 | (insert (propertize | ||
1969 | (format "%s %s\n" | ||
1970 | (make-string tab-switcher-column ?\040) | ||
1971 | (propertize | ||
1972 | (alist-get 'name tab) | ||
1973 | 'mouse-face 'highlight | ||
1974 | 'help-echo "mouse-2: select this window configuration")) | ||
1975 | 'tab tab))) | ||
1976 | (goto-char (point-min)) | ||
1977 | (goto-char (or (next-single-property-change (point) 'tab) (point-min))) | ||
1978 | (when (> (length tabs) 1) | ||
1979 | (tab-switcher-next-line)) | ||
1980 | (move-to-column tab-switcher-column) | ||
1981 | (set-buffer-modified-p nil) | ||
1982 | (setq buffer-read-only t) | ||
1983 | (current-buffer)))) | ||
1984 | |||
1985 | (defvar-local tab-switcher-column 3) | ||
1986 | |||
1987 | (defvar tab-switcher-mode-map | ||
1988 | (let ((map (make-keymap))) | ||
1989 | (suppress-keymap map t) | ||
1990 | (define-key map "q" 'quit-window) | ||
1991 | (define-key map "\C-m" 'tab-switcher-select) | ||
1992 | (define-key map "d" 'tab-switcher-delete) | ||
1993 | (define-key map "k" 'tab-switcher-delete) | ||
1994 | (define-key map "\C-d" 'tab-switcher-delete-backwards) | ||
1995 | (define-key map "\C-k" 'tab-switcher-delete) | ||
1996 | (define-key map "x" 'tab-switcher-execute) | ||
1997 | (define-key map " " 'tab-switcher-next-line) | ||
1998 | (define-key map "n" 'tab-switcher-next-line) | ||
1999 | (define-key map "p" 'tab-switcher-prev-line) | ||
2000 | (define-key map "\177" 'tab-switcher-backup-unmark) | ||
2001 | (define-key map "?" 'describe-mode) | ||
2002 | (define-key map "u" 'tab-switcher-unmark) | ||
2003 | (define-key map [mouse-2] 'tab-switcher-mouse-select) | ||
2004 | (define-key map [follow-link] 'mouse-face) | ||
2005 | map) | ||
2006 | "Local keymap for `tab-switcher-mode' buffers.") | ||
2007 | |||
2008 | (define-derived-mode tab-switcher-mode nil "Window Configurations" | ||
2009 | "Major mode for selecting a window configuration. | ||
2010 | Each line describes one window configuration in Emacs. | ||
2011 | Letters do not insert themselves; instead, they are commands. | ||
2012 | \\<tab-switcher-mode-map> | ||
2013 | \\[tab-switcher-mouse-select] -- select window configuration you click on. | ||
2014 | \\[tab-switcher-select] -- select current line's window configuration. | ||
2015 | \\[tab-switcher-delete] -- mark that window configuration to be deleted, and move down. | ||
2016 | \\[tab-switcher-delete-backwards] -- mark that window configuration to be deleted, and move up. | ||
2017 | \\[tab-switcher-execute] -- delete marked window configurations. | ||
2018 | \\[tab-switcher-unmark] -- remove all kinds of marks from current line. | ||
2019 | With prefix argument, also move up one line. | ||
2020 | \\[tab-switcher-backup-unmark] -- back up a line and remove marks." | ||
2021 | (setq truncate-lines t)) | ||
2022 | |||
2023 | (defun tab-switcher-current-tab (error-if-non-existent-p) | ||
2024 | "Return window configuration described by this line of the list." | ||
2025 | (let* ((where (save-excursion | ||
2026 | (beginning-of-line) | ||
2027 | (+ 2 (point) tab-switcher-column))) | ||
2028 | (tab (and (not (eobp)) (get-text-property where 'tab)))) | ||
2029 | (or tab | ||
2030 | (if error-if-non-existent-p | ||
2031 | (user-error "No window configuration on this line") | ||
2032 | nil)))) | ||
2033 | |||
2034 | (defun tab-switcher-next-line (&optional arg) | ||
2035 | "Move to ARGth next line in the list of tabs. | ||
2036 | Interactively, ARG is the prefix numeric argument and defaults to 1." | ||
2037 | (interactive "p") | ||
2038 | (forward-line arg) | ||
2039 | (beginning-of-line) | ||
2040 | (move-to-column tab-switcher-column)) | ||
2041 | |||
2042 | (defun tab-switcher-prev-line (&optional arg) | ||
2043 | "Move to ARGth previous line in the list of tabs. | ||
2044 | Interactively, ARG is the prefix numeric argument and defaults to 1." | ||
2045 | (interactive "p") | ||
2046 | (forward-line (- arg)) | ||
2047 | (beginning-of-line) | ||
2048 | (move-to-column tab-switcher-column)) | ||
2049 | |||
2050 | (defun tab-switcher-unmark (&optional backup) | ||
2051 | "Cancel requested operations on window configuration on this line and move down. | ||
2052 | With prefix arg, move up instead." | ||
2053 | (interactive "P") | ||
2054 | (beginning-of-line) | ||
2055 | (move-to-column tab-switcher-column) | ||
2056 | (let* ((buffer-read-only nil)) | ||
2057 | (delete-char 1) | ||
2058 | (insert " ")) | ||
2059 | (forward-line (if backup -1 1)) | ||
2060 | (move-to-column tab-switcher-column)) | ||
2061 | |||
2062 | (defun tab-switcher-backup-unmark () | ||
2063 | "Move up one line and cancel requested operations on window configuration there." | ||
2064 | (interactive) | ||
2065 | (forward-line -1) | ||
2066 | (tab-switcher-unmark) | ||
2067 | (forward-line -1) | ||
2068 | (move-to-column tab-switcher-column)) | ||
2069 | |||
2070 | (defun tab-switcher-delete (&optional arg) | ||
2071 | "Mark window configuration on this line to be deleted by \\<tab-switcher-mode-map>\\[tab-switcher-execute] command. | ||
2072 | Prefix arg says how many window configurations to delete. | ||
2073 | Negative arg means delete backwards." | ||
2074 | (interactive "p") | ||
2075 | (let ((buffer-read-only nil)) | ||
2076 | (if (or (null arg) (= arg 0)) | ||
2077 | (setq arg 1)) | ||
2078 | (while (> arg 0) | ||
2079 | (delete-char 1) | ||
2080 | (insert ?D) | ||
2081 | (forward-line 1) | ||
2082 | (setq arg (1- arg))) | ||
2083 | (while (< arg 0) | ||
2084 | (delete-char 1) | ||
2085 | (insert ?D) | ||
2086 | (forward-line -1) | ||
2087 | (setq arg (1+ arg))) | ||
2088 | (move-to-column tab-switcher-column))) | ||
2089 | |||
2090 | (defun tab-switcher-delete-backwards (&optional arg) | ||
2091 | "Mark window configuration on this line to be deleted by \\<tab-switcher-mode-map>\\[tab-switcher-execute] command. | ||
2092 | Then move up one line. Prefix arg means move that many lines." | ||
2093 | (interactive "p") | ||
2094 | (tab-switcher-delete (- (or arg 1)))) | ||
2095 | |||
2096 | (defun tab-switcher-delete-from-list (tab) | ||
2097 | "Delete the window configuration from the list of tabs." | ||
2098 | (push `((frame . ,(selected-frame)) | ||
2099 | (index . ,(tab-bar--tab-index tab)) | ||
2100 | (tab . ,tab)) | ||
2101 | tab-bar-closed-tabs) | ||
2102 | (tab-bar-tabs-set (delq tab (funcall tab-bar-tabs-function)))) | ||
2103 | |||
2104 | (defun tab-switcher-execute () | ||
2105 | "Delete window configurations marked with \\<tab-switcher-mode-map>\\[tab-switcher-delete] commands." | ||
2106 | (interactive) | ||
2107 | (save-excursion | ||
2108 | (goto-char (point-min)) | ||
2109 | (let ((buffer-read-only nil)) | ||
2110 | (while (re-search-forward | ||
2111 | (format "^%sD" (make-string tab-switcher-column ?\040)) | ||
2112 | nil t) | ||
2113 | (forward-char -1) | ||
2114 | (let ((tab (tab-switcher-current-tab nil))) | ||
2115 | (when tab | ||
2116 | (tab-switcher-delete-from-list tab) | ||
2117 | (beginning-of-line) | ||
2118 | (delete-region (point) (progn (forward-line 1) (point)))))))) | ||
2119 | (beginning-of-line) | ||
2120 | (move-to-column tab-switcher-column) | ||
2121 | (force-mode-line-update)) | ||
2122 | |||
2123 | (defun tab-switcher-select () | ||
2124 | "Select this line's window configuration. | ||
2125 | This command replaces all the existing windows in the selected frame | ||
2126 | with those specified by the selected window configuration." | ||
2127 | (interactive) | ||
2128 | (let* ((to-tab (tab-switcher-current-tab t))) | ||
2129 | (kill-buffer (current-buffer)) | ||
2130 | ;; Delete the current window configuration of tab list | ||
2131 | ;; without storing it in the undo list of closed tabs | ||
2132 | (let ((inhibit-message t) ; avoid message about deleted tab | ||
2133 | tab-bar-closed-tabs) | ||
2134 | (tab-bar-close-tab nil (1+ (tab-bar--tab-index to-tab)))))) | ||
2135 | |||
2136 | (defun tab-switcher-mouse-select (event) | ||
2137 | "Select the window configuration whose line you click on." | ||
2138 | (interactive "e") | ||
2139 | (set-buffer (window-buffer (posn-window (event-end event)))) | ||
2140 | (goto-char (posn-point (event-end event))) | ||
2141 | (tab-switcher-select)) | ||
2142 | |||
2143 | |||
2144 | (defun tab-bar--reusable-frames (all-frames) | ||
2145 | (cond | ||
2146 | ((eq all-frames t) (frame-list)) | ||
2147 | ((eq all-frames 'visible) (visible-frame-list)) | ||
2148 | ((framep all-frames) (list all-frames)) | ||
2149 | (t (list (selected-frame))))) | ||
2150 | |||
2151 | (defun tab-bar-get-buffer-tab (buffer-or-name &optional all-frames ignore-current-tab) | ||
2152 | "Return the tab that owns the window whose buffer is BUFFER-OR-NAME. | ||
2153 | BUFFER-OR-NAME may be a buffer or a buffer name, and defaults to | ||
2154 | the current buffer. | ||
2155 | |||
2156 | The optional argument ALL-FRAMES specifies the frames to consider: | ||
2157 | |||
2158 | - t means consider all tabs on all existing frames. | ||
2159 | |||
2160 | - `visible' means consider all tabs on all visible frames. | ||
2161 | |||
2162 | - A frame means consider all tabs on that frame only. | ||
2163 | |||
2164 | - Any other value of ALL-FRAMES means consider all tabs on the | ||
2165 | selected frame and no others. | ||
2166 | |||
2167 | When the optional argument IGNORE-CURRENT-TAB is non-nil, | ||
2168 | don't take into account the buffers in the currently selected tab. | ||
2169 | Otherwise, prefer buffers of the current tab." | ||
2170 | (let ((buffer (if buffer-or-name | ||
2171 | (get-buffer buffer-or-name) | ||
2172 | (current-buffer)))) | ||
2173 | (when (bufferp buffer) | ||
2174 | (seq-some | ||
2175 | (lambda (frame) | ||
2176 | (seq-some | ||
2177 | (lambda (tab) | ||
2178 | (when (if (eq (car tab) 'current-tab) | ||
2179 | (get-buffer-window buffer frame) | ||
2180 | (let* ((state (alist-get 'ws tab)) | ||
2181 | (buffers (when state | ||
2182 | (window-state-buffers state)))) | ||
2183 | (or | ||
2184 | ;; non-writable window-state | ||
2185 | (memq buffer buffers) | ||
2186 | ;; writable window-state | ||
2187 | (member (buffer-name buffer) buffers)))) | ||
2188 | (append tab `((index . ,(tab-bar--tab-index tab nil frame)) | ||
2189 | (frame . ,frame))))) | ||
2190 | (let* ((tabs (funcall tab-bar-tabs-function frame)) | ||
2191 | (current-tab (tab-bar--current-tab-find tabs))) | ||
2192 | (setq tabs (remq current-tab tabs)) | ||
2193 | (if ignore-current-tab | ||
2194 | ;; Use tabs without current-tab. | ||
2195 | tabs | ||
2196 | ;; Make sure current-tab is at the beginning of tabs. | ||
2197 | (cons current-tab tabs))))) | ||
2198 | (tab-bar--reusable-frames all-frames))))) | ||
2199 | |||
2200 | (defun display-buffer-in-tab (buffer alist) | ||
2201 | "Display BUFFER in a tab using display actions in ALIST. | ||
2202 | ALIST is an association list of action symbols and values. See | ||
2203 | Info node `(elisp) Buffer Display Action Alists' for details of | ||
2204 | such alists. | ||
2205 | |||
2206 | If ALIST contains a `tab-name' entry, it creates a new tab with that name and | ||
2207 | displays BUFFER in a new tab. If a tab with this name already exists, it | ||
2208 | switches to that tab before displaying BUFFER. The `tab-name' entry can be | ||
2209 | a function, in which case it is called with two arguments: BUFFER and ALIST, | ||
2210 | and should return the tab name. When a `tab-name' entry is omitted, create | ||
2211 | a new tab without an explicit name. | ||
2212 | |||
2213 | The ALIST entry `tab-group' (string or function) defines the tab group. | ||
2214 | |||
2215 | If ALIST contains a `reusable-frames' entry, its value determines | ||
2216 | which frames to search for a reusable tab: | ||
2217 | nil -- do not reuse any frames; | ||
2218 | a frame -- just that frame; | ||
2219 | `visible' -- all visible frames; | ||
2220 | 0 -- all frames on the current terminal; | ||
2221 | t -- all frames; | ||
2222 | other non-nil values -- use the selected frame. | ||
2223 | |||
2224 | If ALIST contains a non-nil `ignore-current-tab' entry, then the buffers | ||
2225 | of the current tab are skipped when searching for a reusable tab. | ||
2226 | Otherwise, prefer buffers of the current tab. | ||
2227 | |||
2228 | This is an action function for buffer display, see Info | ||
2229 | node `(elisp) Buffer Display Action Functions'. It should be | ||
2230 | called only by `display-buffer' or a function directly or | ||
2231 | indirectly called by the latter." | ||
2232 | (let* ((reusable-frames (alist-get 'reusable-frames alist)) | ||
2233 | (ignore-current-tab (alist-get 'ignore-current-tab alist)) | ||
2234 | (reusable-tab (when reusable-frames | ||
2235 | (tab-bar-get-buffer-tab buffer reusable-frames | ||
2236 | ignore-current-tab)))) | ||
2237 | (if reusable-tab | ||
2238 | (let* ((frame (alist-get 'frame reusable-tab)) | ||
2239 | (index (alist-get 'index reusable-tab))) | ||
2240 | (when frame | ||
2241 | (select-frame-set-input-focus frame)) | ||
2242 | (when index | ||
2243 | (tab-bar-select-tab (1+ index))) | ||
2244 | (when (get-buffer-window buffer frame) | ||
2245 | (select-window (get-buffer-window buffer frame)))) | ||
2246 | (let ((tab-name (alist-get 'tab-name alist))) | ||
2247 | (when (functionp tab-name) | ||
2248 | (setq tab-name (funcall tab-name buffer alist))) | ||
2249 | (if tab-name | ||
2250 | (let ((tab-index (tab-bar--tab-index-by-name tab-name))) | ||
2251 | (if tab-index | ||
2252 | (progn | ||
2253 | (tab-bar-select-tab (1+ tab-index)) | ||
2254 | (when (get-buffer-window buffer) | ||
2255 | (select-window (get-buffer-window buffer)))) | ||
2256 | (display-buffer-in-new-tab buffer alist))) | ||
2257 | (display-buffer-in-new-tab buffer alist)))))) | ||
2258 | |||
2259 | (defun display-buffer-in-new-tab (buffer alist) | ||
2260 | "Display BUFFER in a new tab using display actions in ALIST. | ||
2261 | ALIST is an association list of action symbols and values. See | ||
2262 | Info node `(elisp) Buffer Display Action Alists' for details of | ||
2263 | such alists. | ||
2264 | |||
2265 | Like `display-buffer-in-tab', but always creates a new tab unconditionally, | ||
2266 | without checking if a suitable tab already exists. | ||
2267 | |||
2268 | If ALIST contains a `tab-name' entry, it creates a new tab with that name | ||
2269 | and displays BUFFER in a new tab. The `tab-name' entry can be a function, | ||
2270 | in which case it is called with two arguments: BUFFER and ALIST, and should | ||
2271 | return the tab name. When a `tab-name' entry is omitted, create a new tab | ||
2272 | without an explicit name. | ||
2273 | |||
2274 | The ALIST entry `tab-group' (string or function) defines the tab group. | ||
2275 | |||
2276 | This is an action function for buffer display, see Info | ||
2277 | node `(elisp) Buffer Display Action Functions'. It should be | ||
2278 | called only by `display-buffer' or a function directly or | ||
2279 | indirectly called by the latter." | ||
2280 | (let ((tab-bar-new-tab-choice t)) | ||
2281 | (tab-bar-new-tab) | ||
2282 | (let ((tab-name (alist-get 'tab-name alist))) | ||
2283 | (when (functionp tab-name) | ||
2284 | (setq tab-name (funcall tab-name buffer alist))) | ||
2285 | (when tab-name | ||
2286 | (tab-bar-rename-tab tab-name))) | ||
2287 | (let ((tab-group (alist-get 'tab-group alist))) | ||
2288 | (when (functionp tab-group) | ||
2289 | (setq tab-group (funcall tab-group buffer alist))) | ||
2290 | (when tab-group | ||
2291 | (tab-bar-change-tab-group tab-group))) | ||
2292 | (window--display-buffer buffer (selected-window) 'tab alist))) | ||
2293 | |||
2294 | (defun switch-to-buffer-other-tab (buffer-or-name &optional _norecord) | ||
2295 | "Switch to buffer BUFFER-OR-NAME in another tab. | ||
2296 | Like \\[switch-to-buffer-other-frame] (which see), but creates a new tab. | ||
2297 | Interactively, prompt for the buffer to switch to." | ||
2298 | (declare (advertised-calling-convention (buffer-or-name) "28.1")) | ||
2299 | (interactive | ||
2300 | (list (read-buffer-to-switch "Switch to buffer in other tab: "))) | ||
2301 | (display-buffer (window-normalize-buffer-to-switch-to buffer-or-name) | ||
2302 | '((display-buffer-in-tab) | ||
2303 | (inhibit-same-window . nil)))) | ||
2304 | |||
2305 | (defun find-file-other-tab (filename &optional wildcards) | ||
2306 | "Edit file FILENAME, in another tab. | ||
2307 | Like \\[find-file-other-frame] (which see), but creates a new tab. | ||
2308 | Interactively, prompt for FILENAME. | ||
2309 | If WILDCARDS is non-nil, FILENAME can include widcards, and all matching | ||
2310 | files will be visited." | ||
2311 | (interactive | ||
2312 | (find-file-read-args "Find file in other tab: " | ||
2313 | (confirm-nonexistent-file-or-buffer))) | ||
2314 | (let ((value (find-file-noselect filename nil nil wildcards))) | ||
2315 | (if (listp value) | ||
2316 | (progn | ||
2317 | (setq value (nreverse value)) | ||
2318 | (switch-to-buffer-other-tab (car value)) | ||
2319 | (mapc 'switch-to-buffer (cdr value)) | ||
2320 | value) | ||
2321 | (switch-to-buffer-other-tab value)))) | ||
2322 | |||
2323 | (defun find-file-read-only-other-tab (filename &optional wildcards) | ||
2324 | "Edit file FILENAME, in another tab, but don't allow changes. | ||
2325 | Like \\[find-file-other-frame] (which see), but creates a new tab. | ||
2326 | Like \\[find-file-other-tab], but marks buffer as read-only. | ||
2327 | Use \\[read-only-mode] to permit editing. | ||
2328 | Interactively, prompt for FILENAME. | ||
2329 | If WILDCARDS is non-nil, FILENAME can include widcards, and all matching | ||
2330 | files will be visited." | ||
2331 | (interactive | ||
2332 | (find-file-read-args "Find file read-only in other tab: " | ||
2333 | (confirm-nonexistent-file-or-buffer))) | ||
2334 | (find-file--read-only (lambda (filename wildcards) | ||
2335 | (window-buffer | ||
2336 | (find-file-other-tab filename wildcards))) | ||
2337 | filename wildcards)) | ||
2338 | |||
2339 | (defun other-tab-prefix () | ||
2340 | "Display the buffer of the next command in a new tab. | ||
2341 | The next buffer is the buffer displayed by the next command invoked | ||
2342 | immediately after this command (ignoring reading from the minibuffer). | ||
2343 | Creates a new tab before displaying the buffer, or switches to the tab | ||
2344 | that already contains that buffer. | ||
2345 | When `switch-to-buffer-obey-display-actions' is non-nil, | ||
2346 | `switch-to-buffer' commands are also supported." | ||
2347 | (interactive) | ||
2348 | (display-buffer-override-next-command | ||
2349 | (lambda (buffer alist) | ||
2350 | (cons (progn | ||
2351 | (display-buffer-in-tab | ||
2352 | buffer (append alist '((inhibit-same-window . nil)))) | ||
2353 | (selected-window)) | ||
2354 | 'tab)) | ||
2355 | nil "[other-tab]") | ||
2356 | (message "Display next command buffer in a new tab...")) | ||
2357 | |||
2358 | |||
2359 | ;;; Short aliases and keybindings | ||
2360 | |||
2361 | (defalias 'tab-new 'tab-bar-new-tab) | ||
2362 | (defalias 'tab-new-to 'tab-bar-new-tab-to) | ||
2363 | (defalias 'tab-duplicate 'tab-bar-duplicate-tab) | ||
2364 | (defalias 'tab-detach 'tab-bar-detach-tab) | ||
2365 | (defalias 'tab-window-detach 'tab-bar-move-window-to-tab) | ||
2366 | (defalias 'tab-close 'tab-bar-close-tab) | ||
2367 | (defalias 'tab-close-other 'tab-bar-close-other-tabs) | ||
2368 | (defalias 'tab-close-group 'tab-bar-close-group-tabs) | ||
2369 | (defalias 'tab-undo 'tab-bar-undo-close-tab) | ||
2370 | (defalias 'tab-select 'tab-bar-select-tab) | ||
2371 | (defalias 'tab-switch 'tab-bar-switch-to-tab) | ||
2372 | (defalias 'tab-next 'tab-bar-switch-to-next-tab) | ||
2373 | (defalias 'tab-previous 'tab-bar-switch-to-prev-tab) | ||
2374 | (defalias 'tab-last 'tab-bar-switch-to-last-tab) | ||
2375 | (defalias 'tab-recent 'tab-bar-switch-to-recent-tab) | ||
2376 | (defalias 'tab-move 'tab-bar-move-tab) | ||
2377 | (defalias 'tab-move-to 'tab-bar-move-tab-to) | ||
2378 | (defalias 'tab-rename 'tab-bar-rename-tab) | ||
2379 | (defalias 'tab-group 'tab-bar-change-tab-group) | ||
2380 | (defalias 'tab-list 'tab-switcher) | ||
2381 | |||
2382 | (define-key tab-prefix-map "n" 'tab-duplicate) | ||
2383 | (define-key tab-prefix-map "N" 'tab-new-to) | ||
2384 | (define-key tab-prefix-map "2" 'tab-new) | ||
2385 | (define-key tab-prefix-map "1" 'tab-close-other) | ||
2386 | (define-key tab-prefix-map "0" 'tab-close) | ||
2387 | (define-key tab-prefix-map "u" 'tab-undo) | ||
2388 | (define-key tab-prefix-map "o" 'tab-next) | ||
2389 | (define-key tab-prefix-map "O" 'tab-previous) | ||
2390 | (define-key tab-prefix-map "m" 'tab-move) | ||
2391 | (define-key tab-prefix-map "M" 'tab-move-to) | ||
2392 | (define-key tab-prefix-map "G" 'tab-group) | ||
2393 | (define-key tab-prefix-map "r" 'tab-rename) | ||
2394 | (define-key tab-prefix-map "\r" 'tab-switch) | ||
2395 | (define-key tab-prefix-map "b" 'switch-to-buffer-other-tab) | ||
2396 | (define-key tab-prefix-map "f" 'find-file-other-tab) | ||
2397 | (define-key tab-prefix-map "\C-f" 'find-file-other-tab) | ||
2398 | (define-key tab-prefix-map "\C-r" 'find-file-read-only-other-tab) | ||
2399 | (define-key tab-prefix-map "t" 'other-tab-prefix) | ||
2400 | |||
2401 | (defvar tab-bar-switch-repeat-map | ||
2402 | (let ((map (make-sparse-keymap))) | ||
2403 | (define-key map "o" 'tab-next) | ||
2404 | (define-key map "O" 'tab-previous) | ||
2405 | map) | ||
2406 | "Keymap to repeat tab switch key sequences `C-x t o o O'. | ||
2407 | Used in `repeat-mode'.") | ||
2408 | (put 'tab-next 'repeat-map 'tab-bar-switch-repeat-map) | ||
2409 | (put 'tab-previous 'repeat-map 'tab-bar-switch-repeat-map) | ||
2410 | |||
2411 | (defvar tab-bar-move-repeat-map | ||
2412 | (let ((map (make-sparse-keymap))) | ||
2413 | (define-key map "m" 'tab-move) | ||
2414 | (define-key map "M" 'tab-bar-move-tab-backward) | ||
2415 | map) | ||
2416 | "Keymap to repeat tab move key sequences `C-x t m m M'. | ||
2417 | Used in `repeat-mode'.") | ||
2418 | (put 'tab-move 'repeat-map 'tab-bar-move-repeat-map) | ||
2419 | (put 'tab-bar-move-tab-backward 'repeat-map 'tab-bar-move-repeat-map) | ||
2420 | |||
2421 | |||
2422 | (provide 'tab-bar) | ||
2423 | |||
2424 | ;;; tab-bar.el ends here | ||