From 42947150adc2639bf7456d40dedce09338cec303 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Wed, 6 Jul 2022 16:47:32 -0500 Subject: Rename +compat.el to avoid collision; add a thing --- lisp/+compat.el | 64 ++ lisp/compat.el | 34 - lisp/compat/keymap.el | 590 ------------ lisp/compat/tab-bar.el | 2424 ------------------------------------------------ 4 files changed, 64 insertions(+), 3048 deletions(-) create mode 100644 lisp/+compat.el delete mode 100644 lisp/compat.el delete mode 100644 lisp/compat/keymap.el delete mode 100644 lisp/compat/tab-bar.el (limited to 'lisp') 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 @@ +;;; +compat.el --- Thin backward-compatibility shim -*- lexical-binding: t; -*- + +;;; Commentary: + +;; I use different versionso of Emacs. Sometimes I have to copy-paste functions +;; from newer Emacs to make my customizations work. This is that file. + +;; This is probably ill-advised. + +;;; Code: + +;;; Load stuff in +compat/ subdirectory +(dolist (file (directory-files (locate-user-emacs-file "lisp/+compat") :full "\\.el\\'")) + (load file :noerror)) + +;;; Only define things if not already defined +(defmacro +compat-defun (name &rest args) + `(if (fboundp ',name) + (message "+compat: `%s' already bound." ',name) + (defun ,name ,@args))) + +(defmacro +compat-defmacro (name &rest args) + `(if (fboundp ',name) + (message "+compat: `%s' already bound." ',name) + (defmacro ,name ,@args))) + +;;; Single functions + +(+compat-defmacro dlet (binders &rest body) + "Like `let' but using dynamic scoping." + (declare (indent 1) (debug let)) + ;; (defvar FOO) only affects the current scope, but in order for + ;; this not to affect code after the main `let' we need to create a new scope, + ;; which is what the surrounding `let' is for. + ;; FIXME: (let () ...) currently doesn't actually create a new scope, + ;; which is why we use (let (_) ...). + `(let (_) + ,@(mapcar (lambda (binder) + `(defvar ,(if (consp binder) (car binder) binder))) + binders) + (let ,binders ,@body))) + +;; https://git.savannah.gnu.org/cgit/emacs.git/diff/?id=772b189143453745a8e014e21d4b6b78f855bba3 +(+compat-defun rename-visited-file (new-location) + "Rename the file visited by the current buffer to NEW-LOCATION. +This command also sets the visited file name. If the buffer +isn't visiting any file, that's all it does. + +Interactively, this prompts for NEW-LOCATION." + (interactive + (list (if buffer-file-name + (read-file-name "Rename visited file to: ") + (read-file-name "Set visited file name: " + default-directory + (expand-file-name + (file-name-nondirectory (buffer-name)) + default-directory))))) + (when (and buffer-file-name + (file-exists-p buffer-file-name)) + (rename-file buffer-file-name new-location)) + (set-visited-file-name new-location nil t)) + +(provide '+compat) +;;; +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 @@ -;;; compat.el --- Thin backward-compatibility shim -*- lexical-binding: t; -*- - -;;; Commentary: - -;; I use different versionso of Emacs. Sometimes I have to copy-paste functions -;; from newer Emacs to make my customizations work. This is that file. - -;; This is probably ill-advised. - -;;; Code: - -;; Load stuff in compat/ subdirectory -(dolist (file (directory-files (locate-user-emacs-file "lisp/compat") :full "\\.el\\'")) - (load file :noerror)) - -;; Other stuff... - -(unless (fboundp 'dlet) - (defmacro dlet (binders &rest body) - "Like `let' but using dynamic scoping." - (declare (indent 1) (debug let)) - ;; (defvar FOO) only affects the current scope, but in order for - ;; this not to affect code after the main `let' we need to create a new scope, - ;; which is what the surrounding `let' is for. - ;; FIXME: (let () ...) currently doesn't actually create a new scope, - ;; which is why we use (let (_) ...). - `(let (_) - ,@(mapcar (lambda (binder) - `(defvar ,(if (consp binder) (car binder) binder))) - binders) - (let ,binders ,@body)))) - -(provide 'compat) -;;; 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 @@ -;;; keymap.el --- Keymap functions -*- lexical-binding: t; -*- - -;; Copyright (C) 2021-2022 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; This library deals with the "new" keymap binding interface: The -;; only key syntax allowed by these functions is the `kbd' one. - -;;; Code: - - - -(defun keymap--check (key) - "Signal an error if KEY doesn't have a valid syntax." - (unless (key-valid-p key) - (error "%S is not a valid key definition; see `key-valid-p'" key))) - -(defun keymap--compile-check (&rest keys) - (dolist (key keys) - (when (or (vectorp key) - (and (stringp key) (not (key-valid-p key)))) - (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) - -(defun keymap-set (keymap key definition) - "Set KEY to DEFINITION in KEYMAP. -KEY is a string that satisfies `key-valid-p'. - -DEFINITION is anything that can be a key's definition: - nil (means key is undefined in this keymap), - a command (a Lisp function suitable for interactive calling), - a string (treated as a keyboard macro), - a keymap (to define a prefix key), - a symbol (when the key is looked up, the symbol will stand for its - function definition, which should at that time be one of the above, - or another symbol whose function definition is used, etc.), - a cons (STRING . DEFN), meaning that DEFN is the definition - (DEFN should be a valid definition in its own right) and - STRING is the menu item name (which is used only if the containing - keymap has been created with a menu name, see `make-keymap'), - or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, - or an extended menu item definition. - (See info node `(elisp)Extended Menu Items'.)" - (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) - (keymap--check key) - ;; If we're binding this key to another key, then parse that other - ;; key, too. - (when (stringp definition) - (keymap--check definition) - (setq definition (key-parse definition))) - (define-key keymap (key-parse key) definition)) - -(defun keymap-global-set (key command) - "Give KEY a global binding as COMMAND. -COMMAND is the command definition to use; usually it is -a symbol naming an interactively-callable function. - -KEY is a string that satisfies `key-valid-p'. - -Note that if KEY has a local binding in the current buffer, -that local binding will continue to shadow any global binding -that you make with this function." - (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) - (interactive - (let* ((menu-prompting nil) - (key (read-key-sequence "Set key globally: " nil t))) - (list key - (read-command (format "Set key %s to command: " - (key-description key)))))) - (keymap-set (current-global-map) key command)) - -(defun keymap-local-set (key command) - "Give KEY a local binding as COMMAND. -COMMAND is the command definition to use; usually it is -a symbol naming an interactively-callable function. - -KEY is a string that satisfies `key-valid-p'. - -The binding goes in the current buffer's local map, which in most -cases is shared with all other buffers in the same major mode." - (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) - (interactive "KSet key locally: \nCSet key %s locally to command: ") - (let ((map (current-local-map))) - (unless map - (use-local-map (setq map (make-sparse-keymap)))) - (keymap-set map key command))) - -(defun keymap-global-unset (key &optional remove) - "Remove global binding of KEY (if any). -KEY is a string that satisfies `key-valid-p'. - -If REMOVE (interactively, the prefix arg), remove the binding -instead of unsetting it. See `keymap-unset' for details." - (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) - (interactive - (list (key-description (read-key-sequence "Set key locally: ")) - current-prefix-arg)) - (keymap-unset (current-global-map) key remove)) - -(defun keymap-local-unset (key &optional remove) - "Remove local binding of KEY (if any). -KEY is a string that satisfies `key-valid-p'. - -If REMOVE (interactively, the prefix arg), remove the binding -instead of unsetting it. See `keymap-unset' for details." - (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) - (interactive - (list (key-description (read-key-sequence "Unset key locally: ")) - current-prefix-arg)) - (when (current-local-map) - (keymap-unset (current-local-map) key remove))) - -(defun keymap-unset (keymap key &optional remove) - "Remove key sequence KEY from KEYMAP. -KEY is a string that satisfies `key-valid-p'. - -If REMOVE, remove the binding instead of unsetting it. This only -makes a difference when there's a parent keymap. When unsetting -a key in a child map, it will still shadow the same key in the -parent keymap. Removing the binding will allow the key in the -parent keymap to be used." - (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) - (keymap--check key) - (define-key keymap (key-parse key) nil remove)) - -(defun keymap-substitute (keymap olddef newdef &optional oldmap prefix) - "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. -In other words, OLDDEF is replaced with NEWDEF wherever it appears. -Alternatively, if optional fourth argument OLDMAP is specified, we redefine -in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. - -If you don't specify OLDMAP, you can usually get the same results -in a cleaner way with command remapping, like this: - (define-key KEYMAP [remap OLDDEF] NEWDEF) -\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" - ;; Don't document PREFIX in the doc string because we don't want to - ;; advertise it. It's meant for recursive calls only. Here's its - ;; meaning - - ;; If optional argument PREFIX is specified, it should be a key - ;; prefix, a string. Redefined bindings will then be bound to the - ;; original key, with PREFIX added at the front. - (unless prefix - (setq prefix "")) - (let* ((scan (or oldmap keymap)) - (prefix1 (vconcat prefix [nil])) - (key-substitution-in-progress - (cons scan key-substitution-in-progress))) - ;; Scan OLDMAP, finding each char or event-symbol that - ;; has any definition, and act on it with hack-key. - (map-keymap - (lambda (char defn) - (aset prefix1 (length prefix) char) - (substitute-key-definition-key defn olddef newdef prefix1 keymap)) - scan))) - -(defun keymap-set-after (keymap key definition &optional after) - "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. -This is like `keymap-set' except that the binding for KEY is placed -just after the binding for the event AFTER, instead of at the beginning -of the map. Note that AFTER must be an event type (like KEY), NOT a command -\(like DEFINITION). - -If AFTER is t or omitted, the new binding goes at the end of the keymap. -AFTER should be a single event type--a symbol or a character, not a sequence. - -Bindings are always added before any inherited map. - -The order of bindings in a keymap matters only when it is used as -a menu, so this function is not useful for non-menu keymaps." - (declare (indent defun) - (compiler-macro (lambda (form) (keymap--compile-check key) form))) - (keymap--check key) - (when after - (keymap--check after)) - (define-key-after keymap (key-parse key) definition - (and after (key-parse after)))) - -(defun key-parse (keys) - "Convert KEYS to the internal Emacs key representation. -See `kbd' for a descripion of KEYS." - (declare (pure t) (side-effect-free t)) - ;; A pure function is expected to preserve the match data. - (save-match-data - (let ((case-fold-search nil) - (len (length keys)) ; We won't alter keys in the loop below. - (pos 0) - (res [])) - (while (and (< pos len) - (string-match "[^ \t\n\f]+" keys pos)) - (let* ((word-beg (match-beginning 0)) - (word-end (match-end 0)) - (word (substring keys word-beg len)) - (times 1) - key) - ;; Try to catch events of the form "". - (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) - (setq word (match-string 0 word) - pos (+ word-beg (match-end 0))) - (setq word (substring keys word-beg word-end) - pos word-end)) - (when (string-match "\\([0-9]+\\)\\*." word) - (setq times (string-to-number (substring word 0 (match-end 1)))) - (setq word (substring word (1+ (match-end 1))))) - (cond ((string-match "^<<.+>>$" word) - (setq key (vconcat (if (eq (key-binding [?\M-x]) - 'execute-extended-command) - [?\M-x] - (or (car (where-is-internal - 'execute-extended-command)) - [?\M-x])) - (substring word 2 -2) "\r"))) - ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) - (progn - (setq word (concat (match-string 1 word) - (match-string 3 word))) - (not (string-match - "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" - word)))) - (setq key (list (intern word)))) - ((or (equal word "REM") (string-match "^;;" word)) - (setq pos (string-match "$" keys pos))) - (t - (let ((orig-word word) (prefix 0) (bits 0)) - (while (string-match "^[ACHMsS]-." word) - (setq bits (+ bits - (cdr - (assq (aref word 0) - '((?A . ?\A-\^@) (?C . ?\C-\^@) - (?H . ?\H-\^@) (?M . ?\M-\^@) - (?s . ?\s-\^@) (?S . ?\S-\^@)))))) - (setq prefix (+ prefix 2)) - (setq word (substring word 2))) - (when (string-match "^\\^.$" word) - (setq bits (+ bits ?\C-\^@)) - (setq prefix (1+ prefix)) - (setq word (substring word 1))) - (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") - ("LFD" . "\n") ("TAB" . "\t") - ("ESC" . "\e") ("SPC" . " ") - ("DEL" . "\177"))))) - (when found (setq word (cdr found)))) - (when (string-match "^\\\\[0-7]+$" word) - (let ((n 0)) - (dolist (ch (cdr (string-to-list word))) - (setq n (+ (* n 8) ch -48))) - (setq word (vector n)))) - (cond ((= bits 0) - (setq key word)) - ((and (= bits ?\M-\^@) (stringp word) - (string-match "^-?[0-9]+$" word)) - (setq key (mapcar (lambda (x) (+ x bits)) - (append word nil)))) - ((/= (length word) 1) - (error "%s must prefix a single character, not %s" - (substring orig-word 0 prefix) word)) - ((and (/= (logand bits ?\C-\^@) 0) (stringp word) - ;; We used to accept . and ? here, - ;; but . is simply wrong, - ;; and C-? is not used (we use DEL instead). - (string-match "[@-_a-z]" word)) - (setq key (list (+ bits (- ?\C-\^@) - (logand (aref word 0) 31))))) - (t - (setq key (list (+ bits (aref word 0))))))))) - (when key - (dolist (_ (number-sequence 1 times)) - (setq res (vconcat res key)))))) - (if (and (>= (length res) 4) - (eq (aref res 0) ?\C-x) - (eq (aref res 1) ?\() - (eq (aref res (- (length res) 2)) ?\C-x) - (eq (aref res (- (length res) 1)) ?\))) - (apply #'vector (let ((lres (append res nil))) - ;; Remove the first and last two elements. - (setq lres (cdr (cdr lres))) - (nreverse lres) - (setq lres (cdr (cdr lres))) - (nreverse lres))) - res)))) - -(defun key-valid-p (keys) - "Say whether KEYS is a valid key. -A key is a string consisting of one or more key strokes. -The key strokes are separated by single space characters. - -Each key stroke is either a single character, or the name of an -event, surrounded by angle brackets. In addition, any key stroke -may be preceded by one or more modifier keys. Finally, a limited -number of characters have a special shorthand syntax. - -Here's some example key sequences. - - \"f\" (the key 'f') - \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') - \"C-c o\" (a two key sequence of the keys 'c' with the control modifier - and then the key 'o') - \"H-\" (the key named \"left\" with the hyper modifier) - \"M-RET\" (the \"return\" key with a meta modifier) - \"C-M-\" (the \"space\" key with both the control and meta modifiers) - -These are the characters that have shorthand syntax: -NUL, RET, TAB, LFD, ESC, SPC, DEL. - -Modifiers have to be specified in this order: - - A-C-H-M-S-s - -which is - - Alt-Control-Hyper-Meta-Shift-super" - (declare (pure t) (side-effect-free t)) - (and - (stringp keys) - (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) - (save-match-data - (catch 'exit - (let ((prefixes - "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") - (case-fold-search nil)) - (dolist (key (split-string keys " ")) - ;; Every key might have these modifiers, and they should be - ;; in this order. - (when (string-match (concat "\\`" prefixes) key) - (setq key (substring key (match-end 0)))) - (unless (or (and (= (length key) 1) - ;; Don't accept control characters as keys. - (not (< (aref key 0) ?\s)) - ;; Don't accept Meta'd characters as keys. - (or (multibyte-string-p key) - (not (<= 127 (aref key 0) 255)))) - (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) - ;; Don't allow . - (= (progn - (string-match - (concat "\\`<" prefixes) key) - (match-end 0)) - 1)) - (string-match-p - "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" - key)) - ;; Invalid. - (throw 'exit nil))) - t))))) - -(defun key-translate (from to) - "Translate character FROM to TO on the current terminal. -This function creates a `keyboard-translate-table' if necessary -and then modifies one entry in it. - -Both KEY and TO are strings that satisfy `key-valid-p'." - (declare (compiler-macro - (lambda (form) (keymap--compile-check from to) form))) - (keymap--check from) - (keymap--check to) - (or (char-table-p keyboard-translate-table) - (setq keyboard-translate-table - (make-char-table 'keyboard-translate-table nil))) - (aset keyboard-translate-table (key-parse from) (key-parse to))) - -(defun keymap-lookup (keymap key &optional accept-default no-remap position) - "Return the binding for command KEY. -KEY is a string that satisfies `key-valid-p'. - -If KEYMAP is nil, look up in the current keymaps. If non-nil, it -should either be a keymap or a list of keymaps, and only these -keymap(s) will be consulted. - -The binding is probably a symbol with a function definition. - -Normally, `keymap-lookup' ignores bindings for t, which act as -default bindings, used when nothing else in the keymap applies; -this makes it usable as a general function for probing keymaps. -However, if the optional second argument ACCEPT-DEFAULT is -non-nil, `keymap-lookup' does recognize the default bindings, -just as `read-key-sequence' does. - -Like the normal command loop, `keymap-lookup' will remap the -command resulting from looking up KEY by looking up the command -in the current keymaps. However, if the optional third argument -NO-REMAP is non-nil, `keymap-lookup' returns the unmapped -command. - -If KEY is a key sequence initiated with the mouse, the used keymaps -will depend on the clicked mouse position with regard to the buffer -and possible local keymaps on strings. - -If the optional argument POSITION is non-nil, it specifies a mouse -position as returned by `event-start' and `event-end', and the lookup -occurs in the keymaps associated with it instead of KEY. It can also -be a number or marker, in which case the keymap properties at the -specified buffer position instead of point are used." - (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) - (keymap--check key) - (when (and keymap position) - (error "Can't pass in both keymap and position")) - (if keymap - (let ((value (lookup-key keymap (key-parse key) accept-default))) - (if (and (not no-remap) - (symbolp value)) - (or (command-remapping value) value) - value)) - (key-binding (kbd key) accept-default no-remap position))) - -(defun keymap-local-lookup (keys &optional accept-default) - "Return the binding for command KEYS in current local keymap only. -KEY is a string that satisfies `key-valid-p'. - -The binding is probably a symbol with a function definition. - -If optional argument ACCEPT-DEFAULT is non-nil, recognize default -bindings; see the description of `keymap-lookup' for more details -about this." - (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) - (when-let ((map (current-local-map))) - (keymap-lookup map keys accept-default))) - -(defun keymap-global-lookup (keys &optional accept-default message) - "Return the binding for command KEYS in current global keymap only. -KEY is a string that satisfies `key-valid-p'. - -The binding is probably a symbol with a function definition. -This function's return values are the same as those of `keymap-lookup' -\(which see). - -If optional argument ACCEPT-DEFAULT is non-nil, recognize default -bindings; see the description of `keymap-lookup' for more details -about this. - -If MESSAGE (and interactively), message the result." - (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) - (interactive - (list (key-description (read-key-sequence "Look up key in global keymap: ")) - nil t)) - (let ((def (keymap-lookup (current-global-map) keys accept-default))) - (when message - (message "%s is bound to %s globally" keys def)) - def)) - - -;;; define-keymap and defvar-keymap - -(defun define-keymap--compile (form &rest args) - ;; This compiler macro is only there for compile-time - ;; error-checking; it does not change the call in any way. - (while (and args - (keywordp (car args)) - (not (eq (car args) :menu))) - (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix)) - (byte-compile-warn "Invalid keyword: %s" (car args))) - (setq args (cdr args)) - (when (null args) - (byte-compile-warn "Uneven number of keywords in %S" form)) - (setq args (cdr args))) - ;; Bindings. - (while args - (let ((key (pop args))) - (when (and (stringp key) (not (key-valid-p key))) - (byte-compile-warn "Invalid `kbd' syntax: %S" key))) - (when (null args) - (byte-compile-warn "Uneven number of key bindings in %S" form)) - (setq args (cdr args))) - form) - -(defun define-keymap (&rest definitions) - "Create a new keymap and define KEY/DEFINITION pairs as key bindings. -The new keymap is returned. - -Options can be given as keywords before the KEY/DEFINITION -pairs. Available keywords are: - -:full If non-nil, create a chartable alist (see `make-keymap'). - If nil (i.e., the default), create a sparse keymap (see - `make-sparse-keymap'). - -:suppress If non-nil, the keymap will be suppressed (see `suppress-keymap'). - If `nodigits', treat digits like other chars. - -:parent If non-nil, this should be a keymap to use as the parent - (see `set-keymap-parent'). - -:keymap If non-nil, instead of creating a new keymap, the given keymap - will be destructively modified instead. - -:name If non-nil, this should be a string to use as the menu for - the keymap in case you use it as a menu with `x-popup-menu'. - -:prefix If non-nil, this should be a symbol to be used as a prefix - command (see `define-prefix-command'). If this is the case, - this symbol is returned instead of the map itself. - -KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can -also be the special symbol `:menu', in which case DEFINITION -should be a MENU form as accepted by `easy-menu-define'. - -\(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" - (declare (indent defun) - (compiler-macro define-keymap--compile)) - (let (full suppress parent name prefix keymap) - ;; Handle keywords. - (while (and definitions - (keywordp (car definitions)) - (not (eq (car definitions) :menu))) - (let ((keyword (pop definitions))) - (unless definitions - (error "Missing keyword value for %s" keyword)) - (let ((value (pop definitions))) - (pcase keyword - (:full (setq full value)) - (:keymap (setq keymap value)) - (:parent (setq parent value)) - (:suppress (setq suppress value)) - (:name (setq name value)) - (:prefix (setq prefix value)) - (_ (error "Invalid keyword: %s" keyword)))))) - - (when (and prefix - (or full parent suppress keymap)) - (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords")) - - (when (and keymap full) - (error "Invalid combination: :keymap with :full")) - - (let ((keymap (cond - (keymap keymap) - (prefix (define-prefix-command prefix nil name)) - (full (make-keymap name)) - (t (make-sparse-keymap name))))) - (when suppress - (suppress-keymap keymap (eq suppress 'nodigits))) - (when parent - (set-keymap-parent keymap parent)) - - ;; Do the bindings. - (while definitions - (let ((key (pop definitions))) - (unless definitions - (error "Uneven number of key/definition pairs")) - (let ((def (pop definitions))) - (if (eq key :menu) - (easy-menu-define nil keymap "" def) - (keymap-set keymap key def))))) - keymap))) - -(defmacro defvar-keymap (variable-name &rest defs) - "Define VARIABLE-NAME as a variable with a keymap definition. -See `define-keymap' for an explanation of the keywords and KEY/DEFINITION. - -In addition to the keywords accepted by `define-keymap', this -macro also accepts a `:doc' keyword, which (if present) is used -as the variable documentation string. - -\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" - (declare (indent 1)) - (let ((opts nil) - doc) - (while (and defs - (keywordp (car defs)) - (not (eq (car defs) :menu))) - (let ((keyword (pop defs))) - (unless defs - (error "Uneven number of keywords")) - (if (eq keyword :doc) - (setq doc (pop defs)) - (push keyword opts) - (push (pop defs) opts)))) - (unless (zerop (% (length defs) 2)) - (error "Uneven number of key/definition pairs: %s" defs)) - `(defvar ,variable-name - (define-keymap ,@(nreverse opts) ,@defs) - ,@(and doc (list doc))))) - -(provide 'keymap) - -;;; 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 @@ -;;; tab-bar.el --- frame-local tabs with named persistent window configurations -*- lexical-binding: t; -*- - -;; Copyright (C) 2019-2022 Free Software Foundation, Inc. - -;; Author: Juri Linkov -;; Keywords: frames tabs -;; Maintainer: emacs-devel@gnu.org - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; Provides `tab-bar-mode' to control display of the tab bar and -;; bindings for the global tab bar. - -;; The normal global binding for [tab-bar] (below) uses the value of -;; `tab-bar-map' as the actual keymap to define the tab bar. - -;;; Code: - -(eval-when-compile - (require 'cl-lib) - (require 'seq)) - - -(defgroup tab-bar nil - "Frame-local tabs." - :group 'convenience - :version "27.1") - -(defgroup tab-bar-faces '((tab-bar custom-face)) ; tab-bar is defined in faces.el - "Faces used in the tab bar." - :group 'tab-bar - :group 'faces - :version "27.1") - -(defface tab-bar-tab - '((default - :inherit tab-bar) - (((class color) (min-colors 88)) - :box (:line-width 1 :style released-button)) - (t - :inverse-video nil)) - "Tab bar face for selected tab." - :version "27.1" - :group 'tab-bar-faces) - -(defface tab-bar-tab-inactive - '((default - :inherit tab-bar-tab) - (((class color) (min-colors 88)) - :background "grey75") - (t - :inverse-video t)) - "Tab bar face for non-selected tab." - :version "27.1" - :group 'tab-bar-faces) - -(defface tab-bar-tab-group-current - '((t :inherit tab-bar-tab :box nil :weight bold)) - "Tab bar face for current group tab." - :version "28.1" - :group 'tab-bar-faces) - -(defface tab-bar-tab-group-inactive - '((t :inherit (shadow tab-bar-tab-inactive))) - "Tab bar face for inactive group tab." - :version "28.1" - :group 'tab-bar-faces) - -(defface tab-bar-tab-ungrouped - '((t :inherit (shadow tab-bar-tab-inactive))) - "Tab bar face for ungrouped tab when tab groups are used." - :version "28.1" - :group 'tab-bar-faces) - - -(defcustom tab-bar-select-tab-modifiers '() - "List of modifier keys for selecting tab-bar tabs by their numbers. -Possible modifier keys are `control', `meta', `shift', `hyper', `super' and -`alt'. Pressing one of the modifiers in the list and a digit selects the -tab whose number equals the digit (see `tab-bar-select-tab'). -The digit 9 selects the last (rightmost) tab (see `tab-last'). -The digit 0 selects the most recently visited tab (see `tab-recent'). -For easier selection of tabs by their numbers, consider customizing -`tab-bar-tab-hints', which will show tab numbers alongside the tab name." - :type '(set :tag "Tab selection modifier keys" - (const control) - (const meta) - (const shift) - (const hyper) - (const super) - (const alt)) - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - ;; Reenable the tab-bar with new keybindings - (when tab-bar-mode - (tab-bar--undefine-keys) - (tab-bar--define-keys))) - :group 'tab-bar - :version "27.1") - -(defun tab-bar--define-keys () - "Install key bindings for switching between tabs if the user has configured them." - (when tab-bar-select-tab-modifiers - (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?0))) - 'tab-recent) - (dotimes (i 8) - (global-set-key (vector (append tab-bar-select-tab-modifiers - (list (+ i 1 ?0)))) - 'tab-bar-select-tab)) - (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?9))) - 'tab-last)) - ;; Don't override user customized key bindings - (unless (global-key-binding [(control tab)]) - (global-set-key [(control tab)] 'tab-next)) - (unless (global-key-binding [(control shift tab)]) - (global-set-key [(control shift tab)] 'tab-previous)) - (unless (global-key-binding [(control shift iso-lefttab)]) - (global-set-key [(control shift iso-lefttab)] 'tab-previous)) - - ;; Replace default value with a condition that supports displaying - ;; global-mode-string in the tab bar instead of the mode line. - (when (and (memq 'tab-bar-format-global tab-bar-format) - (member '(global-mode-string ("" global-mode-string)) - mode-line-misc-info)) - (setf (alist-get 'global-mode-string mode-line-misc-info) - '(("" (:eval (if (and tab-bar-mode - (memq 'tab-bar-format-global - tab-bar-format)) - "" global-mode-string))))))) - -(defun tab-bar--undefine-keys () - "Uninstall key bindings previously bound by `tab-bar--define-keys'." - (when (eq (global-key-binding [(control tab)]) 'tab-next) - (global-unset-key [(control tab)])) - (when (eq (global-key-binding [(control shift tab)]) 'tab-previous) - (global-unset-key [(control shift tab)])) - (when (eq (global-key-binding [(control shift iso-lefttab)]) 'tab-previous) - (global-unset-key [(control shift iso-lefttab)]))) - -(defun tab-bar--load-buttons () - "Load the icons for the tab buttons." - (when (and tab-bar-new-button - (not (get-text-property 0 'display tab-bar-new-button))) - ;; This file is pre-loaded so only here we can use the right data-directory: - (add-text-properties 0 (length tab-bar-new-button) - `(display (image :type xpm - :file "tabs/new.xpm" - :margin ,tab-bar-button-margin - :ascent center)) - tab-bar-new-button)) - - (when (and tab-bar-close-button - (not (get-text-property 0 'display tab-bar-close-button))) - ;; This file is pre-loaded so only here we can use the right data-directory: - (add-text-properties 0 (length tab-bar-close-button) - `(display (image :type xpm - :file "tabs/close.xpm" - :margin ,tab-bar-button-margin - :ascent center)) - tab-bar-close-button))) - -(defun tab-bar--tab-bar-lines-for-frame (frame) - "Determine and return the value of `tab-bar-lines' for FRAME. -Return 0 if `tab-bar-mode' is not enabled. Otherwise return -either 1 or 0 depending on the value of the customizable variable -`tab-bar-show', which see." - (cond - ((not tab-bar-mode) 0) - ((not tab-bar-show) 0) - ((eq tab-bar-show t) 1) - ((natnump tab-bar-show) - (if (> (length (funcall tab-bar-tabs-function frame)) tab-bar-show) 1 0)))) - -(defun tab-bar--update-tab-bar-lines (&optional frames) - "Update the `tab-bar-lines' frame parameter in FRAMES. -If the optional parameter FRAMES is omitted, update only -the currently selected frame. If it is t, update all frames -as well as the default for new frames. Otherwise FRAMES should be -a list of frames to update." - (let ((frame-lst (cond ((null frames) - (list (selected-frame))) - ((eq frames t) - (frame-list)) - (t frames)))) - ;; Loop over all frames and update `tab-bar-lines' - (dolist (frame frame-lst) - (unless (frame-parameter frame 'tab-bar-lines-keep-state) - (set-frame-parameter frame 'tab-bar-lines - (tab-bar--tab-bar-lines-for-frame frame))))) - ;; Update `default-frame-alist' - (when (eq frames t) - (setq default-frame-alist - (cons (cons 'tab-bar-lines (if (and tab-bar-mode (eq tab-bar-show t)) 1 0)) - (assq-delete-all 'tab-bar-lines default-frame-alist))))) - -(define-minor-mode tab-bar-mode - "Toggle the tab bar in all graphical frames (Tab Bar mode)." - :global t - ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again. - :variable tab-bar-mode - - ;; Recalculate `tab-bar-lines' for all frames - (tab-bar--update-tab-bar-lines t) - - (when tab-bar-mode - (tab-bar--load-buttons)) - (if tab-bar-mode - (tab-bar--define-keys) - (tab-bar--undefine-keys))) - - -;;; Key bindings - -(defun tab-bar--key-to-number (key) - "Return the tab number represented by KEY. -If KEY is a symbol 'tab-N', where N is a tab number, the value is N. -If KEY is \\='current-tab, the value is nil. -For any other value of KEY, the value is t." - (cond - ((null key) t) - ((eq key 'current-tab) nil) - ((let ((key-name (format "%S" key))) - (when (string-prefix-p "tab-" key-name) - (string-to-number (string-replace "tab-" "" key-name))))) - (t t))) - -(defvar tab-bar--dragging-in-progress) - -(defun tab-bar--event-to-item (posn) - "This function extracts extra info from the mouse event at position POSN. -It returns a list of the form (KEY KEY-BINDING CLOSE-P), where: - KEY is a symbol representing a tab, such as \\='tab-1 or \\='current-tab; - KEY-BINDING is the binding of KEY; - CLOSE-P is non-nil if the mouse event was a click on the close button \"x\", - nil otherwise." - (setq tab-bar--dragging-in-progress nil) - (if (posn-window posn) - (let ((caption (car (posn-string posn)))) - (when caption - (get-text-property 0 'menu-item caption))) - ;; Text-mode emulation of switching tabs on the tab bar. - ;; This code is used when you click the mouse in the tab bar - ;; on a console which has no window system but does have a mouse. - (let* ((x-position (car (posn-x-y posn))) - (keymap (lookup-key (cons 'keymap (nreverse (current-active-maps))) [tab-bar])) - (column 0)) - (when x-position - (catch 'done - (map-keymap - (lambda (key binding) - (when (eq (car-safe binding) 'menu-item) - (when (> (+ column (length (nth 1 binding))) x-position) - (throw 'done (list key (nth 2 binding) - (get-text-property - (- x-position column) - 'close-tab (nth 1 binding))))) - (setq column (+ column (length (nth 1 binding)))))) - keymap)))))) - -(defun tab-bar-mouse-down-1 (event) - "Select the tab at mouse click, or add a new tab on the tab bar. -Whether this command adds a new tab or selects an existing tab -depends on whether the click is on the \"+\" button or on an -existing tab." - (interactive "e") - (let* ((item (tab-bar--event-to-item (event-start event))) - (tab-number (tab-bar--key-to-number (nth 0 item)))) - (setq tab-bar--dragging-in-progress t) - ;; Don't close the tab when clicked on the close button. Also - ;; don't add new tab on down-mouse. Let `tab-bar-mouse-1' do this. - (unless (or (memq (car item) '(add-tab history-back history-forward)) - (nth 2 item)) - (if (functionp (nth 1 item)) - (call-interactively (nth 1 item)) - (unless (eq tab-number t) - (tab-bar-select-tab tab-number)))))) - -(defun tab-bar-mouse-1 (event) - "Close the tab whose \"x\" close button you click. -See also `tab-bar-mouse-close-tab', which closes the tab -regardless of where you click on it. Also add a new tab." - (interactive "e") - (let* ((item (tab-bar--event-to-item (event-start event))) - (tab-number (tab-bar--key-to-number (nth 0 item)))) - (cond - ((and (memq (car item) '(add-tab history-back history-forward)) - (functionp (nth 1 item))) - (call-interactively (nth 1 item))) - ((and (nth 2 item) (not (eq tab-number t))) - (tab-bar-close-tab tab-number))))) - -(defun tab-bar-mouse-close-tab (event) - "Close the tab you click on. -This is in contrast with `tab-bar-mouse-1' that closes a tab -only when you click on its \"x\" close button." - (interactive "e") - (let* ((item (tab-bar--event-to-item (event-start event))) - (tab-number (tab-bar--key-to-number (nth 0 item)))) - (unless (eq tab-number t) - (tab-bar-close-tab tab-number)))) - -(defun tab-bar-mouse-context-menu (event) - "Pop up the context menu for the tab on which you click." - (interactive "e") - (let* ((item (tab-bar--event-to-item (event-start event))) - (tab-number (tab-bar--key-to-number (nth 0 item))) - (menu (make-sparse-keymap (propertize "Context Menu" 'hide t)))) - - (cond - ((eq tab-number t) - (define-key-after menu [new-tab] - '(menu-item "New tab" tab-bar-new-tab - :help "Create a new tab")) - (when tab-bar-closed-tabs - (define-key-after menu [undo-close] - '(menu-item "Reopen closed tab" tab-bar-undo-close-tab - :help "Undo closing the tab")))) - - (t - (define-key-after menu [duplicate-tab] - `(menu-item "Duplicate" (lambda () (interactive) - (tab-bar-duplicate-tab - nil ,tab-number)) - :help "Clone the tab")) - (define-key-after menu [detach-tab] - `(menu-item "Detach" (lambda () (interactive) - (tab-bar-detach-tab - ,tab-number)) - :help "Move the tab to new frame")) - (define-key-after menu [close] - `(menu-item "Close" (lambda () (interactive) - (tab-bar-close-tab ,tab-number)) - :help "Close the tab")) - (define-key-after menu [close-other] - `(menu-item "Close other tabs" - (lambda () (interactive) - (tab-bar-close-other-tabs ,tab-number)) - :help "Close all other tabs")))) - - (popup-menu menu event))) - -(defun tab-bar-mouse-move-tab (event) - "Move a tab to a different position on the tab bar. -This command should be bound to a drag event. It moves the tab -at the mouse-down event to the position at mouse-up event." - (interactive "e") - (setq tab-bar--dragging-in-progress nil) - (let ((from (tab-bar--key-to-number - (nth 0 (tab-bar--event-to-item - (event-start event))))) - (to (tab-bar--key-to-number - (nth 0 (tab-bar--event-to-item - (event-end event)))))) - (unless (or (eq from to) (eq from t) (eq to t)) - (tab-bar-move-tab-to - (if (null to) (1+ (tab-bar--current-tab-index)) to) from)))) - -(defvar tab-bar-map - (let ((map (make-sparse-keymap))) - (define-key map [down-mouse-1] 'tab-bar-mouse-down-1) - (define-key map [drag-mouse-1] 'tab-bar-mouse-move-tab) - (define-key map [mouse-1] 'tab-bar-mouse-1) - (define-key map [down-mouse-2] 'tab-bar-mouse-close-tab) - (define-key map [mouse-2] 'ignore) - (define-key map [down-mouse-3] 'tab-bar-mouse-context-menu) - - (define-key map [mouse-4] 'tab-previous) - (define-key map [mouse-5] 'tab-next) - (define-key map [wheel-up] 'tab-previous) - (define-key map [wheel-down] 'tab-next) - (define-key map [wheel-left] 'tab-previous) - (define-key map [wheel-right] 'tab-next) - - (define-key map [S-mouse-4] 'tab-bar-move-tab-backward) - (define-key map [S-mouse-5] 'tab-bar-move-tab) - (define-key map [S-wheel-up] 'tab-bar-move-tab-backward) - (define-key map [S-wheel-down] 'tab-bar-move-tab) - (define-key map [S-wheel-left] 'tab-bar-move-tab-backward) - (define-key map [S-wheel-right] 'tab-bar-move-tab) - - map) - "Keymap for the commands used on the tab bar.") - -(global-set-key [tab-bar] - `(menu-item ,(purecopy "tab bar") ignore - :filter tab-bar-make-keymap)) - -(defun tab-bar-make-keymap (&optional _ignore) - "Generate an actual keymap from `tab-bar-map'. -Its main job is to show tabs in the tab bar -and to bind mouse events to the commands." - (tab-bar-make-keymap-1)) - - -(defun toggle-tab-bar-mode-from-frame (&optional arg) - "Toggle tab bar on or off, based on the status of the current frame. -Used in the Show/Hide menu, to have the toggle reflect the current frame. -See `tab-bar-mode' for more information." - (interactive (list (or current-prefix-arg 'toggle))) - (if (eq arg 'toggle) - (tab-bar-mode (if (> (frame-parameter nil 'tab-bar-lines) 0) 0 1)) - (tab-bar-mode arg))) - -(defun toggle-frame-tab-bar (&optional frame) - "Toggle tab bar of the selected frame. -When calling from Lisp, use the optional argument FRAME to toggle -the tab bar on that frame. -This is useful if you want to enable the tab bar individually -on each new frame when the global `tab-bar-mode' is disabled, -or if you want to disable the tab bar individually on each -new frame when the global `tab-bar-mode' is enabled, by using - - (add-hook 'after-make-frame-functions 'toggle-frame-tab-bar)" - (interactive) - (set-frame-parameter frame 'tab-bar-lines - (if (> (frame-parameter frame 'tab-bar-lines) 0) 0 1)) - (set-frame-parameter frame 'tab-bar-lines-keep-state - (not (frame-parameter frame 'tab-bar-lines-keep-state)))) - - -(defcustom tab-bar-show t - "Defines when to show the tab bar. -If t, the default, enable `tab-bar-mode' automatically upon using -the commands that create new window configurations (e.g., `tab-new'). -If a non-negative integer, show the tab bar only if the number of -the tabs exceeds the value of this variable. In particular, -if the value is 1, hide the tab bar when it has only one tab, and -show it again once more tabs are created. A value that is a -non-negative integer also makes the tab bar appearance be different -on different frames: the tab bar can be shown on some frames and -hidden on others, depending on how many tab-bar tabs are on that -frame, and whether that number is greater than the numerical value -of this variable. -If nil, always keep the tab bar hidden. In this case it's still -possible to use persistent named window configurations by relying on -keyboard commands `tab-new', `tab-close', `tab-next', `tab-switcher', etc. - -Setting this variable directly does not take effect; please customize -it (see the info node `Easy Customization'), then it will automatically -update the tab bar on all frames according to the new value. - -To enable or disable the tab bar individually on each frame, -you can use the command `toggle-frame-tab-bar'." - :type '(choice (const :tag "Always" t) - (const :tag "When more than one tab" 1) - (const :tag "Never" nil)) - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - (if val - (tab-bar-mode 1) - (tab-bar--update-tab-bar-lines t))) - :group 'tab-bar - :version "27.1") - -(defcustom tab-bar-new-tab-choice t - "Defines what to show in a new tab. -If t, start a new tab with the current buffer, i.e. the buffer -that was current before calling the command that adds a new tab -(this is the same what `make-frame' does by default). -If the value is a string, use it as a buffer name to switch to -if such buffer exists, or switch to a buffer visiting the file or -directory that the string specifies. If the value is a function, -call it with no arguments and switch to the buffer that it returns. -If nil, duplicate the contents of the tab that was active -before calling the command that adds a new tab." - :type '(choice (const :tag "Current buffer" t) - (string :tag "Buffer" "*scratch*") - (directory :tag "Directory" :value "~/") - (file :tag "File" :value "~/.emacs") - (function :tag "Function") - (const :tag "Duplicate tab" nil)) - :group 'tab-bar - :version "27.1") - -(defcustom tab-bar-new-tab-group t - "Defines what group to assign to a new tab. -If nil, don't set a default group automatically. -If t, inherit the group name from the previous tab. -If the value is a string, use it as the group name of a new tab. -If the value is a function, call it with no arguments -to get the group name." - :type '(choice (const :tag "No automatic group" nil) - (const :tag "Inherit group from previous tab" t) - (string :tag "Fixed group name") - (function :tag "Function that returns group name")) - :group 'tab-bar - :version "28.1") - -(defcustom tab-bar-new-button-show t - "If non-nil, show the \"New tab\" button in the tab bar. -When this is nil, you can create new tabs with \\[tab-new]." - :type 'boolean - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - (force-mode-line-update)) - :group 'tab-bar - :version "27.1") -(make-obsolete-variable 'tab-bar-new-button-show 'tab-bar-format "28.1") - -(defvar tab-bar-new-button " + " - "Button for creating a new tab.") - -(defcustom tab-bar-close-button-show t - "Defines where to show the close tab button. -If t, show the close tab button on all tabs. -If `selected', show it only on the selected tab. -If `non-selected', show it only on non-selected tab. -If nil, don't show it at all." - :type '(choice (const :tag "On all tabs" t) - (const :tag "On selected tab" selected) - (const :tag "On non-selected tabs" non-selected) - (const :tag "None" nil)) - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - (force-mode-line-update)) - :group 'tab-bar - :version "27.1") - -(defvar tab-bar-close-button - (propertize " x" - 'close-tab t - :help "Click to close tab") - "Button for closing the clicked tab.") - -(defvar tab-bar-back-button " < " - "Button for going back in tab history.") - -(defvar tab-bar-forward-button " > " - "Button for going forward in tab history.") - -(defcustom tab-bar-tab-hints nil - "Show absolute numbers on tabs in the tab bar before the tab name. -This helps to select the tab by its number using `tab-bar-select-tab' -and `tab-bar-select-tab-modifiers'." - :type 'boolean - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - (force-mode-line-update)) - :group 'tab-bar - :version "27.1") - -(defvar tab-bar-separator nil - "String that delimits tabs.") - -(defun tab-bar-separator () - "Separator between tabs." - (or tab-bar-separator (if window-system " " "|"))) - - -(defcustom tab-bar-tab-name-function #'tab-bar-tab-name-current - "Function to get a tab name. -Function gets no arguments. -The choice is between displaying only the name of the current buffer -in the tab name (default), or displaying the names of all buffers -from all windows in the window configuration." - :type '(choice (const :tag "Selected window buffer" - tab-bar-tab-name-current) - (const :tag "Selected window buffer with window count" - tab-bar-tab-name-current-with-count) - (const :tag "Truncated buffer name" - tab-bar-tab-name-truncated) - (const :tag "All window buffers" - tab-bar-tab-name-all) - (function :tag "Function")) - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - (force-mode-line-update)) - :group 'tab-bar - :version "27.1") - -(defun tab-bar-tab-name-current () - "Generate tab name from the buffer of the selected window." - (buffer-name (window-buffer (minibuffer-selected-window)))) - -(defun tab-bar-tab-name-current-with-count () - "Generate tab name from the buffer of the selected window. -Also add the number of windows in the window configuration." - (let ((count (length (window-list-1 nil 'nomini))) - (name (window-buffer (minibuffer-selected-window)))) - (if (> count 1) - (format "%s (%d)" name count) - (format "%s" name)))) - -(defun tab-bar-tab-name-all () - "Generate tab name from buffers of all windows." - (mapconcat #'buffer-name - (delete-dups (mapcar #'window-buffer - (window-list-1 (frame-first-window) - 'nomini))) - ", ")) - -(defcustom tab-bar-tab-name-truncated-max 20 - "Maximum length of the tab name from the current buffer. -Effective when `tab-bar-tab-name-function' is customized -to `tab-bar-tab-name-truncated'." - :type 'integer - :group 'tab-bar - :version "27.1") - -(defvar tab-bar-tab-name-ellipsis t) - -(defun tab-bar-tab-name-truncated () - "Generate tab name from the buffer of the selected window. -Truncate it to the length specified by `tab-bar-tab-name-truncated-max'. -Append ellipsis `tab-bar-tab-name-ellipsis' in this case." - (let ((tab-name (buffer-name (window-buffer (minibuffer-selected-window))))) - (if (< (length tab-name) tab-bar-tab-name-truncated-max) - tab-name - (propertize (truncate-string-to-width - tab-name tab-bar-tab-name-truncated-max nil nil - tab-bar-tab-name-ellipsis) - 'help-echo tab-name)))) - - -(defvar tab-bar-tabs-function #'tab-bar-tabs - "Function to get a list of tabs to display in the tab bar. -This function should have one optional argument FRAME, -defaulting to the selected frame when nil. -It should return a list of alists with parameters -that include at least the element (name . TAB-NAME). -For example, \\='((tab (name . \"Tab 1\")) (current-tab (name . \"Tab 2\"))) -By default, use function `tab-bar-tabs'.") - -(defun tab-bar-tabs (&optional frame) - "Return a list of tabs belonging to the FRAME. -Ensure the frame parameter `tabs' is pre-populated. -Update the current tab name when it exists. -Return its existing value or a new value." - (let ((tabs (frame-parameter frame 'tabs))) - (if tabs - (let* ((current-tab (tab-bar--current-tab-find tabs)) - (current-tab-name (assq 'name current-tab)) - (current-tab-explicit-name (assq 'explicit-name current-tab))) - (when (and current-tab-name - current-tab-explicit-name - (not (cdr current-tab-explicit-name))) - (setf (cdr current-tab-name) - (funcall tab-bar-tab-name-function)))) - ;; Create default tabs - (setq tabs (list (tab-bar--current-tab-make))) - (tab-bar-tabs-set tabs frame)) - tabs)) - -(defun tab-bar-tabs-set (tabs &optional frame) - "Set a list of TABS on the FRAME." - (set-frame-parameter frame 'tabs tabs)) - - -(defcustom tab-bar-tab-face-function #'tab-bar-tab-face-default - "Function to define a tab face. -Function gets one argument: a tab." - :type 'function - :group 'tab-bar - :version "28.1") - -(defun tab-bar-tab-face-default (tab) - (if (eq (car tab) 'current-tab) 'tab-bar-tab 'tab-bar-tab-inactive)) - -(defcustom tab-bar-tab-name-format-function #'tab-bar-tab-name-format-default - "Function to format a tab name. -Function gets two arguments, the tab and its number, and should return -the formatted tab name to display in the tab bar." - :type 'function - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - (force-mode-line-update)) - :group 'tab-bar - :version "28.1") - -(defun tab-bar-tab-name-format-default (tab i) - (let ((current-p (eq (car tab) 'current-tab))) - (propertize - (concat (if tab-bar-tab-hints (format "%d " i) "") - (alist-get 'name tab) - (or (and tab-bar-close-button-show - (not (eq tab-bar-close-button-show - (if current-p 'non-selected 'selected))) - tab-bar-close-button) - "")) - 'face (funcall tab-bar-tab-face-function tab)))) - -(defcustom tab-bar-format '(tab-bar-format-history - tab-bar-format-tabs - tab-bar-separator - tab-bar-format-add-tab) - "Template for displaying tab bar items. -Every item in the list is a function that returns -a string, or a list of menu-item elements, or nil. -Adding a function to the list causes the tab bar to show -that string, or display a tab button which, when clicked, -will invoke the command that is the binding of the menu item. -The menu-item binding of nil will produce a tab clicking -on which will select that tab. The menu-item's title is -displayed as the label of the tab. -If a function returns nil, it doesn't directly affect the -tab bar appearance, but can do that by some side-effect. -If the list ends with `tab-bar-format-align-right' and -`tab-bar-format-global', then after enabling `display-time-mode' -(or any other mode that uses `global-mode-string'), -it will display time aligned to the right on the tab bar instead -of the mode line. Replacing `tab-bar-format-tabs' with -`tab-bar-format-tabs-groups' will group tabs on the tab bar." - :type 'hook - :options '(tab-bar-format-menu-bar - tab-bar-format-history - tab-bar-format-tabs - tab-bar-format-tabs-groups - tab-bar-separator - tab-bar-format-add-tab - tab-bar-format-align-right - tab-bar-format-global) - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - (force-mode-line-update)) - :group 'tab-bar - :version "28.1") - -(defun tab-bar-menu-bar (event) - "Pop up the same menu as displayed by the menu bar. -Used by `tab-bar-format-menu-bar'." - (interactive "e") - (let ((menu (make-sparse-keymap (propertize "Menu Bar" 'hide t)))) - (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) - (map-keymap (lambda (key binding) - (when (consp binding) - (define-key-after menu (vector key) - (copy-sequence binding)))) - (menu-bar-keymap)) - (popup-menu menu event))) - -(defun tab-bar-format-menu-bar () - "Produce the Menu button for the tab bar that shows the menu bar." - `((menu-bar menu-item (propertize "Menu" 'face 'tab-bar-tab-inactive) - tab-bar-menu-bar :help "Menu Bar"))) - -(defun tab-bar-format-history () - "Produce back and forward buttons for the tab bar. -These buttons will be shown when `tab-bar-history-mode' is enabled. -You can hide these buttons by customizing `tab-bar-format' and removing -`tab-bar-format-history' from it." - (when tab-bar-history-mode - `((sep-history-back menu-item ,(tab-bar-separator) ignore) - (history-back - menu-item ,tab-bar-back-button tab-bar-history-back - :help "Click to go back in tab history") - (sep-history-forward menu-item ,(tab-bar-separator) ignore) - (history-forward - menu-item ,tab-bar-forward-button tab-bar-history-forward - :help "Click to go forward in tab history")))) - -(defun tab-bar--format-tab (tab i) - "Format TAB using its index I and return the result as a keymap." - (append - `((,(intern (format "sep-%i" i)) menu-item ,(tab-bar-separator) ignore)) - (cond - ((eq (car tab) 'current-tab) - `((current-tab - menu-item - ,(funcall tab-bar-tab-name-format-function tab i) - ignore - :help "Current tab"))) - (t - `((,(intern (format "tab-%i" i)) - menu-item - ,(funcall tab-bar-tab-name-format-function tab i) - ,(alist-get 'binding tab) - :help "Click to visit tab")))) - (when (alist-get 'close-binding tab) - `((,(if (eq (car tab) 'current-tab) 'C-current-tab (intern (format "C-tab-%i" i))) - menu-item "" - ,(alist-get 'close-binding tab)))))) - -(defun tab-bar-format-tabs () - "Produce all the tabs for the tab bar." - (let ((i 0)) - (mapcan - (lambda (tab) - (setq i (1+ i)) - (tab-bar--format-tab tab i)) - (funcall tab-bar-tabs-function)))) - -(defcustom tab-bar-tab-group-function #'tab-bar-tab-group-default - "Function to get a tab group name. -Function gets one argument: a tab." - :type 'function - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - (force-mode-line-update)) - :group 'tab-bar - :version "28.1") - -(defun tab-bar-tab-group-default (tab) - (alist-get 'group tab)) - -(defcustom tab-bar-tab-group-format-function #'tab-bar-tab-group-format-default - "Function to format a tab group name. -Function gets two arguments, a tab with a group name and its number, -and should return the formatted tab group name to display in the tab bar." - :type 'function - :initialize 'custom-initialize-default - :set (lambda (sym val) - (set-default sym val) - (force-mode-line-update)) - :group 'tab-bar - :version "28.1") - -(defun tab-bar-tab-group-format-default (tab i) - (propertize - (concat (if tab-bar-tab-hints (format "%d " i) "") - (funcall tab-bar-tab-group-function tab)) - 'face 'tab-bar-tab-group-inactive)) - -(defcustom tab-bar-tab-group-face-function #'tab-bar-tab-group-face-default - "Function to define a tab group face. -Function gets one argument: a tab." - :type 'function - :group 'tab-bar - :version "28.1") - -(defun tab-bar-tab-group-face-default (tab) - (if (not (or (eq (car tab) 'current-tab) - (funcall tab-bar-tab-group-function tab))) - 'tab-bar-tab-ungrouped - (tab-bar-tab-face-default tab))) - -(defun tab-bar--format-tab-group (tab i &optional current-p) - "Format TAB as a tab that represents a group of tabs. -The argument I is the tab index, and CURRENT-P is non-nil -when the tab is current. Return the result as a keymap." - (append - `((,(intern (format "sep-%i" i)) menu-item ,(tab-bar-separator) ignore)) - `((,(intern (format "group-%i" i)) - menu-item - ,(if current-p - (propertize (funcall tab-bar-tab-group-function tab) - 'face 'tab-bar-tab-group-current) - (funcall tab-bar-tab-group-format-function tab i)) - ,(if current-p 'ignore - (or - (alist-get 'binding tab) - `(lambda () - (interactive) - (tab-bar-select-tab ,i)))) - :help "Click to visit group")))) - -(defun tab-bar-format-tabs-groups () - "Produce tabs for the tab bar grouped according to their groups." - (let* ((tabs (funcall tab-bar-tabs-function)) - (current-group (funcall tab-bar-tab-group-function - (tab-bar--current-tab-find tabs))) - (previous-group nil) - (i 0)) - (mapcan - (lambda (tab) - (let ((tab-group (funcall tab-bar-tab-group-function tab))) - (setq i (1+ i)) - (prog1 (cond - ;; Show current group tabs and ungrouped tabs - ((or (equal tab-group current-group) (not tab-group)) - (append - ;; Prepend current group name before first tab - (when (and (not (equal previous-group tab-group)) tab-group) - (tab-bar--format-tab-group tab i t)) - ;; Override default tab faces to use group faces - (let ((tab-bar-tab-face-function tab-bar-tab-group-face-function)) - (tab-bar--format-tab tab i)))) - ;; Show first tab of other groups with a group name - ((not (equal previous-group tab-group)) - (tab-bar--format-tab-group tab i)) - ;; Hide other group tabs - (t nil)) - (setq previous-group tab-group)))) - tabs))) - -(defun tab-bar-format-add-tab () - "Button to add a new tab." - (when (and tab-bar-new-button-show tab-bar-new-button) - `((add-tab menu-item ,tab-bar-new-button tab-bar-new-tab - :help "New tab")))) - -(defun tab-bar-format-align-right () - "Align the rest of tab bar items to the right." - (let* ((rest (cdr (memq 'tab-bar-format-align-right tab-bar-format))) - (rest (tab-bar-format-list rest)) - (rest (mapconcat (lambda (item) (nth 2 item)) rest "")) - (hpos (length rest)) - (str (propertize " " 'display `(space :align-to (- right ,hpos))))) - `((align-right menu-item ,str ignore)))) - -(defun tab-bar-format-global () - "Produce display of `global-mode-string' in the tab bar. -When `tab-bar-format-global' is added to `tab-bar-format' -(possibly appended after `tab-bar-format-align-right'), -then modes that display information on the mode line -using `global-mode-string' will display the same text -on the tab bar instead." - `((global menu-item ,(string-trim-right (format-mode-line global-mode-string)) ignore))) - -(defun tab-bar-format-list (format-list) - (let ((i 0)) - (apply #'append - (mapcar - (lambda (format) - (setq i (1+ i)) - (cond - ((functionp format) - (let ((ret (funcall format))) - (when (stringp ret) - (setq ret `((,(intern (format "str-%i" i)) - menu-item ,ret ignore)))) - ret)))) - format-list)))) - -(defun tab-bar-make-keymap-1 () - "Generate an actual keymap from `tab-bar-map', without caching." - (append tab-bar-map (tab-bar-format-list tab-bar-format))) - - -;; Some window-configuration parameters don't need to be persistent. -;; Don't save to the desktop file such tab parameters that are saved -;; as "Unprintable entity" so can't be used after restoring the desktop. -;; Actually tab-bar-select-tab already can handle unprintable entities, -;; but it's better not to waste the desktop file with useless data. -(defun frameset-filter-tabs (current _filtered _parameters saving) - (if saving - (mapcar (lambda (current) - (if (consp current) - (seq-reduce (lambda (current param) - (assq-delete-all param current)) - '(wc wc-point wc-bl wc-bbl - wc-history-back wc-history-forward) - (copy-sequence current)) - current)) - current) - current)) - -(push '(tabs . frameset-filter-tabs) frameset-filter-alist) - -(defun tab-bar--tab (&optional frame) - "Make a new tab data structure that can be added to tabs on the FRAME." - (let* ((tab (tab-bar--current-tab-find nil frame)) - (tab-explicit-name (alist-get 'explicit-name tab)) - (tab-group (alist-get 'group tab)) - (bl (seq-filter #'buffer-live-p (frame-parameter - frame 'buffer-list))) - (bbl (seq-filter #'buffer-live-p (frame-parameter - frame 'buried-buffer-list)))) - `(tab - (name . ,(if tab-explicit-name - (alist-get 'name tab) - (funcall tab-bar-tab-name-function))) - (explicit-name . ,tab-explicit-name) - ,@(if tab-group `((group . ,tab-group))) - (time . ,(float-time)) - (ws . ,(window-state-get - (frame-root-window (or frame (selected-frame))) 'writable)) - (wc . ,(current-window-configuration)) - (wc-point . ,(point-marker)) - (wc-bl . ,bl) - (wc-bbl . ,bbl) - ,@(when tab-bar-history-mode - `((wc-history-back . ,(gethash (or frame (selected-frame)) - tab-bar-history-back)) - (wc-history-forward . ,(gethash (or frame (selected-frame)) - tab-bar-history-forward)))) - ;; Copy other possible parameters - ,@(mapcan (lambda (param) - (unless (memq (car param) - '(name explicit-name group time - ws wc wc-point wc-bl wc-bbl - wc-history-back wc-history-forward)) - (list param))) - (cdr tab))))) - -(defun tab-bar--current-tab (&optional tab frame) - "Make the current tab data structure from TAB on FRAME." - (tab-bar--current-tab-make (or tab (tab-bar--current-tab-find nil frame)))) - -(defun tab-bar--current-tab-make (&optional tab) - "Make the current tab data structure from TAB. -TAB here is an argument meaning \"use tab as template\", -i.e. the tab is created using data from TAB. This is -necessary when switching tabs, otherwise the destination tab -inherits the current tab's `explicit-name' parameter." - (let* ((tab-explicit-name (alist-get 'explicit-name tab)) - (tab-group (if tab - (alist-get 'group tab) - (pcase tab-bar-new-tab-group - ((pred stringp) tab-bar-new-tab-group) - ((pred functionp) (funcall tab-bar-new-tab-group)))))) - `(current-tab - (name . ,(if tab-explicit-name - (alist-get 'name tab) - (funcall tab-bar-tab-name-function))) - (explicit-name . ,tab-explicit-name) - ,@(if tab-group `((group . ,tab-group))) - ;; Copy other possible parameters - ,@(mapcan (lambda (param) - (unless (memq (car param) - '(name explicit-name group time - ws wc wc-point wc-bl wc-bbl - wc-history-back wc-history-forward)) - (list param))) - (cdr tab))))) - -(defun tab-bar--current-tab-find (&optional tabs frame) - ;; Find the current tab as a pointer to its data structure. - (assq 'current-tab (or tabs (funcall tab-bar-tabs-function frame)))) - -(defun tab-bar--current-tab-index (&optional tabs frame) - ;; Return the index of the current tab. - (seq-position (or tabs (funcall tab-bar-tabs-function frame)) - 'current-tab (lambda (a b) (eq (car a) b)))) - -(defun tab-bar--tab-index (tab &optional tabs frame) - ;; Return the index of TAB. - (seq-position (or tabs (funcall tab-bar-tabs-function frame)) - tab #'eq)) - -(defun tab-bar--tab-index-by-name (name &optional tabs frame) - ;; Return the index of TAB by the its NAME. - (seq-position (or tabs (funcall tab-bar-tabs-function frame)) - name (lambda (a b) (equal (alist-get 'name a) b)))) - -(defun tab-bar--tab-index-recent (nth &optional tabs frame) - ;; Return the index of NTH recent tab. - (let* ((tabs (or tabs (funcall tab-bar-tabs-function frame))) - (sorted-tabs (tab-bar--tabs-recent tabs frame)) - (tab (nth (1- nth) sorted-tabs))) - (tab-bar--tab-index tab tabs))) - -(defun tab-bar--tabs-recent (&optional tabs frame) - ;; Return the list of tabs sorted by recency. - (let* ((tabs (or tabs (funcall tab-bar-tabs-function frame)))) - (seq-sort-by (lambda (tab) (alist-get 'time tab)) #'> - (seq-remove (lambda (tab) - (eq (car tab) 'current-tab)) - tabs)))) - - -(defun tab-bar-select-tab (&optional tab-number) - "Switch to the tab by its absolute position TAB-NUMBER in the tab bar. -When this command is bound to a numeric key (with a key prefix or modifier key -using `tab-bar-select-tab-modifiers'), calling it without an argument -will translate its bound numeric key to the numeric argument. -Also the prefix argument TAB-NUMBER can be used to override -the numeric key, so it takes precedence over the bound digit key. -For example, `-2' will select the second tab, but `C-u 15 --2' will select the 15th tab. TAB-NUMBER counts from 1. -Negative TAB-NUMBER counts tabs from the end of the tab bar." - (interactive "P") - (unless (integerp tab-number) - (let ((key (event-basic-type last-command-event))) - (setq tab-number (if (and (characterp key) (>= key ?1) (<= key ?9)) - (- key ?0) - 0)))) - - (let* ((tabs (funcall tab-bar-tabs-function)) - (from-index (tab-bar--current-tab-index tabs)) - (to-number (cond ((< tab-number 0) (+ (length tabs) (1+ tab-number))) - ((zerop tab-number) (1+ from-index)) - (t tab-number))) - (to-index (1- (max 1 (min to-number (length tabs)))))) - - (unless (eq from-index to-index) - (let* ((from-tab (tab-bar--tab)) - (to-tab (nth to-index tabs)) - (wc (alist-get 'wc to-tab)) - (ws (alist-get 'ws to-tab))) - - ;; During the same session, use window-configuration to switch - ;; tabs, because window-configurations are more reliable - ;; (they keep references to live buffers) than window-states. - ;; But after restoring tabs from a previously saved session, - ;; its value of window-configuration is unreadable, - ;; so restore its saved window-state. - (cond - ((and (window-configuration-p wc) - ;; Check for such cases as cloning a frame with tabs. - ;; When tabs were cloned to another frame, then fall back - ;; to using `window-state-put' below. - (eq (window-configuration-frame wc) (selected-frame))) - (let ((wc-point (alist-get 'wc-point to-tab)) - (wc-bl (seq-filter #'buffer-live-p (alist-get 'wc-bl to-tab))) - (wc-bbl (seq-filter #'buffer-live-p (alist-get 'wc-bbl to-tab))) - (wc-history-back (alist-get 'wc-history-back to-tab)) - (wc-history-forward (alist-get 'wc-history-forward to-tab))) - - (set-window-configuration wc) - - ;; set-window-configuration does not restore the value of - ;; point in the current buffer, so restore it separately. - (when (and (markerp wc-point) - (marker-buffer wc-point) - ;; FIXME: After dired-revert, marker relocates to 1. - ;; window-configuration restores point to global point - ;; in this dired buffer, not to its window point, - ;; but this is slightly better than 1. - ;; Maybe better to save dired-filename in each window? - (not (eq 1 (marker-position wc-point)))) - (goto-char wc-point)) - - (when wc-bl (set-frame-parameter nil 'buffer-list wc-bl)) - (when wc-bbl (set-frame-parameter nil 'buried-buffer-list wc-bbl)) - - (when tab-bar-history-mode - (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-back))) - wc-history-back) - tab-bar-history-back) - (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-forward))) - wc-history-forward) - tab-bar-history-forward)))) - - (ws - (window-state-put ws nil 'safe))) - - (when tab-bar-history-mode - (setq tab-bar-history-omit t)) - - (when from-index - (setf (nth from-index tabs) from-tab)) - (setf (nth to-index tabs) (tab-bar--current-tab-make (nth to-index tabs))) - - (unless tab-bar-mode - (message "Selected tab '%s'" (alist-get 'name to-tab)))) - - (force-mode-line-update)))) - -(defun tab-bar-switch-to-next-tab (&optional arg) - "Switch to ARGth next tab. -Interactively, ARG is the prefix numeric argument and defaults to 1." - (interactive "p") - (unless (integerp arg) - (setq arg 1)) - (let* ((tabs (funcall tab-bar-tabs-function)) - (from-index (or (tab-bar--current-tab-index tabs) 0)) - (to-index (mod (+ from-index arg) (length tabs)))) - (tab-bar-select-tab (1+ to-index)))) - -(defun tab-bar-switch-to-prev-tab (&optional arg) - "Switch to ARGth previous tab. -Interactively, ARG is the prefix numeric argument and defaults to 1." - (interactive "p") - (unless (integerp arg) - (setq arg 1)) - (tab-bar-switch-to-next-tab (- arg))) - -(defun tab-bar-switch-to-last-tab (&optional arg) - "Switch to the last tab or ARGth tab from the end of the tab bar. -Interactively, ARG is the prefix numeric argument; it defaults to 1, -which means the last tab on the tab bar. For example, `C-u 2 --9' selects the tab before the last tab." - (interactive "p") - (tab-bar-select-tab (- (length (funcall tab-bar-tabs-function)) - (1- (abs (or arg 1)))))) - -(defun tab-bar-switch-to-recent-tab (&optional arg) - "Switch to ARGth most recently visited tab. -Interactively, ARG is the prefix numeric argument and defaults to 1." - (interactive "p") - (unless (integerp arg) - (setq arg 1)) - (let ((tab-index (tab-bar--tab-index-recent arg))) - (if tab-index - (tab-bar-select-tab (1+ tab-index)) - (message "No more recent tabs")))) - -(defun tab-bar-switch-to-tab (name) - "Switch to the tab by NAME. -Default values are tab names sorted by recency, so you can use \ -\\\\[next-history-element] -to get the name of the most recently visited tab, the second -most recent, and so on. -When the tab with that NAME doesn't exist, create a new tab -and rename it to NAME." - (interactive - (let* ((recent-tabs (mapcar (lambda (tab) - (alist-get 'name tab)) - (tab-bar--tabs-recent)))) - (list (completing-read (format-prompt "Switch to tab by name" - (car recent-tabs)) - recent-tabs nil nil nil nil recent-tabs)))) - (let ((tab-index (tab-bar--tab-index-by-name name))) - (if tab-index - (tab-bar-select-tab (1+ tab-index)) - (tab-bar-new-tab) - (tab-bar-rename-tab name)))) - -(defalias 'tab-bar-select-tab-by-name 'tab-bar-switch-to-tab) - - -(defun tab-bar-move-tab-to (to-number &optional from-number) - "Move tab from FROM-NUMBER position to new position at TO-NUMBER. -FROM-NUMBER defaults to the current tab number. -FROM-NUMBER and TO-NUMBER count from 1. -Negative TO-NUMBER counts tabs from the end of the tab bar. -Argument addressing is absolute in contrast to `tab-bar-move-tab' -where argument addressing is relative." - (interactive "P") - (let* ((tabs (funcall tab-bar-tabs-function)) - (from-number (or from-number (1+ (tab-bar--current-tab-index tabs)))) - (from-tab (nth (1- from-number) tabs)) - (to-number (if to-number (prefix-numeric-value to-number) 1)) - (to-number (if (< to-number 0) (+ (length tabs) (1+ to-number)) to-number)) - (to-index (max 0 (min (1- to-number) (1- (length tabs)))))) - (setq tabs (delq from-tab tabs)) - (cl-pushnew from-tab (nthcdr to-index tabs)) - (tab-bar-tabs-set tabs) - (force-mode-line-update))) - -(defun tab-bar-move-tab (&optional arg) - "Move the current tab ARG positions to the right. -Interactively, ARG is the prefix numeric argument and defaults to 1. -If ARG is negative, move the current tab ARG positions to the left. -Argument addressing is relative in contrast to `tab-bar-move-tab-to', -where argument addressing is absolute." - (interactive "p") - (let* ((tabs (funcall tab-bar-tabs-function)) - (from-index (or (tab-bar--current-tab-index tabs) 0)) - (to-index (mod (+ from-index arg) (length tabs)))) - (tab-bar-move-tab-to (1+ to-index) (1+ from-index)))) - -(defun tab-bar-move-tab-backward (&optional arg) - "Move the current tab ARG positions to the left. -Interactively, ARG is the prefix numeric argument and defaults to 1. -Like `tab-bar-move-tab', but moves in the opposite direction." - (interactive "p") - (tab-bar-move-tab (- (or arg 1)))) - -(defun tab-bar-move-tab-to-frame (arg &optional from-frame from-number to-frame to-number) - "Move tab from FROM-NUMBER position to new position at TO-NUMBER. -FROM-NUMBER defaults to the current tab number. -FROM-NUMBER and TO-NUMBER count from 1. -FROM-FRAME specifies the source frame and defaults to the selected frame. -TO-FRAME specifies the target frame and defaults the next frame. -Interactively, ARG selects the ARGth next frame on the same terminal, -to which to move the tab; ARG defaults to 1." - (interactive "P") - (unless from-frame - (setq from-frame (selected-frame))) - (unless to-frame - (dotimes (_ (prefix-numeric-value arg)) - (setq to-frame (next-frame to-frame)))) - (unless (eq from-frame to-frame) - (let* ((from-tabs (funcall tab-bar-tabs-function from-frame)) - (from-number (or from-number (1+ (tab-bar--current-tab-index from-tabs)))) - (from-tab (nth (1- from-number) from-tabs)) - (to-tabs (funcall tab-bar-tabs-function to-frame)) - (to-index (max 0 (min (1- (or to-number 1)) (1- (length to-tabs)))))) - (cl-pushnew (assq-delete-all - 'wc (if (eq (car from-tab) 'current-tab) - (tab-bar--tab from-frame) - from-tab)) - (nthcdr to-index to-tabs)) - (with-selected-frame from-frame - (let ((inhibit-message t) ; avoid message about deleted tab - (tab-bar-close-last-tab-choice 'delete-frame) - tab-bar-closed-tabs) - (tab-bar-close-tab from-number))) - (tab-bar-tabs-set to-tabs to-frame) - (force-mode-line-update t)))) - -(defun tab-bar-detach-tab (&optional from-number) - "Move tab number FROM-NUMBER to a new frame. -FROM-NUMBER defaults to the current tab (which happens interactively)." - (interactive (list (1+ (tab-bar--current-tab-index)))) - (let* ((tabs (funcall tab-bar-tabs-function)) - (tab-index (1- (or from-number (1+ (tab-bar--current-tab-index tabs))))) - (tab-name (alist-get 'name (nth tab-index tabs))) - ;; On some window managers, `make-frame' selects the new frame, - ;; so previously selected frame is saved to `from-frame'. - (from-frame (selected-frame)) - (new-frame (make-frame `((name . ,tab-name))))) - (tab-bar-move-tab-to-frame nil from-frame from-number new-frame nil) - (with-selected-frame new-frame - (tab-bar-close-tab)))) - -(defun tab-bar-move-window-to-tab () - "Move the selected window to a new tab. -This command removes the selected window from the configuration stored -on the current tab, and makes a new tab with that window in its -configuration." - (interactive) - (let ((tab-bar-new-tab-choice 'window)) - (tab-bar-new-tab)) - (tab-bar-switch-to-recent-tab) - (delete-window) - (tab-bar-switch-to-recent-tab)) - - -(defcustom tab-bar-new-tab-to 'right - "Where to create a new tab. -If `leftmost', create as the first tab. -If `left', create to the left of the current tab. -If `right', create to the right of the current tab. -If `rightmost', create as the last tab. -If the value is a function, it should return a number as a position -on the tab bar specifying where to add a new tab." - :type '(choice (const :tag "Add as First" leftmost) - (const :tag "Add to Left" left) - (const :tag "Add to Right" right) - (const :tag "Add as Last" rightmost) - (function :tag "Function")) - :group 'tab-bar - :version "27.1") - -(defcustom tab-bar-tab-post-open-functions nil - "List of functions to call after creating a new tab. -The current tab is supplied as an argument. Any modifications made -to the tab argument will be applied after all functions are called." - :type '(repeat function) - :group 'tab-bar - :version "27.1") - -(defun tab-bar-new-tab-to (&optional tab-number) - "Add a new tab at the absolute position TAB-NUMBER. -TAB-NUMBER counts from 1. If no TAB-NUMBER is specified, then add -a new tab at the position specified by `tab-bar-new-tab-to'. -Negative TAB-NUMBER counts tabs from the end of the tab bar, -and -1 means the new tab will become the last one. -Argument addressing is absolute in contrast to `tab-bar-new-tab', -where argument addressing is relative. -After the tab is created, the hooks in -`tab-bar-tab-post-open-functions' are run." - (interactive "P") - (let* ((tabs (funcall tab-bar-tabs-function)) - (from-index (tab-bar--current-tab-index tabs)) - (from-tab (tab-bar--tab))) - - (when tab-bar-new-tab-choice - ;; Handle the case when it's called in the active minibuffer. - (when (minibuffer-selected-window) - (select-window (minibuffer-selected-window))) - (let ((ignore-window-parameters t)) - (delete-other-windows)) - (unless (eq tab-bar-new-tab-choice 'window) - ;; Create a new window to get rid of old window parameters - ;; (e.g. prev/next buffers) of old window. - (split-window) (delete-window)) - (let ((buffer - (if (functionp tab-bar-new-tab-choice) - (funcall tab-bar-new-tab-choice) - (if (stringp tab-bar-new-tab-choice) - (or (get-buffer tab-bar-new-tab-choice) - (find-file-noselect tab-bar-new-tab-choice)))))) - (when (buffer-live-p buffer) - (switch-to-buffer buffer)))) - - (when from-index - (setf (nth from-index tabs) from-tab)) - - (let* ((to-tab (tab-bar--current-tab-make - (when (eq tab-bar-new-tab-group t) - `((group . ,(alist-get 'group from-tab)))))) - (to-number (and tab-number (prefix-numeric-value tab-number))) - (to-index (or (if to-number - (if (< to-number 0) - (+ (length tabs) (1+ to-number)) - (1- to-number))) - (pcase tab-bar-new-tab-to - ('leftmost 0) - ('rightmost (length tabs)) - ('left (or from-index 1)) - ('right (1+ (or from-index 0))) - ((pred functionp) - (funcall tab-bar-new-tab-to)))))) - (setq to-index (max 0 (min (or to-index 0) (length tabs)))) - (cl-pushnew to-tab (nthcdr to-index tabs)) - - (when (eq to-index 0) - ;; `pushnew' handles the head of tabs but not frame-parameter - (tab-bar-tabs-set tabs)) - - (when tab-bar-history-mode - (puthash (selected-frame) nil tab-bar-history-back) - (puthash (selected-frame) nil tab-bar-history-forward) - (setq tab-bar-history-omit t)) - - (run-hook-with-args 'tab-bar-tab-post-open-functions - (nth to-index tabs))) - - (when tab-bar-show - (if (not tab-bar-mode) - ;; Turn on `tab-bar-mode' since a tab was created. - ;; Note: this also updates `tab-bar-lines'. - (tab-bar-mode 1) - (tab-bar--update-tab-bar-lines))) - - (force-mode-line-update) - (unless tab-bar-mode - (message "Added new tab at %s" tab-bar-new-tab-to)))) - -(defun tab-bar-new-tab (&optional arg from-number) - "Create a new tab ARG positions to the right. -If a negative ARG, create a new tab ARG positions to the left. -If ARG is zero, create a new tab in place of the current tab. -If no ARG is specified, then add a new tab at the position -specified by `tab-bar-new-tab-to'. -Argument addressing is relative in contrast to `tab-bar-new-tab-to', -where argument addressing is absolute. -If FROM-NUMBER is a tab number, a new tab is created from that tab." - (interactive "P") - (when from-number - (let ((inhibit-message t)) - (tab-bar-select-tab from-number))) - (if arg - (let* ((tabs (funcall tab-bar-tabs-function)) - (from-index (or (tab-bar--current-tab-index tabs) 0)) - (to-index (+ from-index (prefix-numeric-value arg)))) - (tab-bar-new-tab-to (1+ to-index))) - (tab-bar-new-tab-to))) - -(defun tab-bar-duplicate-tab (&optional arg from-number) - "Clone the current tab to ARG positions to the right. -ARG and FROM-NUMBER have the same meaning as in `tab-bar-new-tab'." - (interactive "P") - (let ((tab-bar-new-tab-choice nil) - (tab-bar-new-tab-group t)) - (tab-bar-new-tab arg from-number))) - - -(defvar tab-bar-closed-tabs nil - "A list of closed tabs to be able to undo their closing.") - -(defcustom tab-bar-close-tab-select 'recent - "Which tab to make current after closing the specified tab. -If `left', select the adjacent left tab. -If `right', select the adjacent right tab. -If `recent', select the most recently visited tab." - :type '(choice (const :tag "Select left tab" left) - (const :tag "Select right tab" right) - (const :tag "Select recent tab" recent)) - :group 'tab-bar - :version "27.1") - -(defcustom tab-bar-close-last-tab-choice nil - "What to do when the last tab is closed. -If nil, do nothing and show a message, like closing the last window or frame. -If `delete-frame', delete the containing frame, as a web browser would do. -If `tab-bar-mode-disable', disable `tab-bar-mode' so that tabs no longer show -in the frame. -If the value is a function, call that function with the tab to be closed -as an argument." - :type '(choice (const :tag "Do nothing and show message" nil) - (const :tag "Close the containing frame" delete-frame) - (const :tag "Disable tab-bar-mode" tab-bar-mode-disable) - (function :tag "Function")) - :group 'tab-bar - :version "27.1") - -(defcustom tab-bar-tab-prevent-close-functions nil - "List of functions to call to determine whether to close a tab. -The tab to be closed and a boolean indicating whether or not it -is the only tab in the frame are supplied as arguments. If any -function returns a non-nil value, the tab will not be closed." - :type '(repeat function) - :group 'tab-bar - :version "27.1") - -(defcustom tab-bar-tab-pre-close-functions nil - "List of functions to call before closing a tab. -Each function is called with two arguments: the tab to be closed -and a boolean indicating whether or not it is the only tab on its frame." - :type '(repeat function) - :group 'tab-bar - :version "27.1") - -(defun tab-bar-close-tab (&optional tab-number to-number) - "Close the tab specified by its absolute position TAB-NUMBER. -If no TAB-NUMBER is specified, then close the current tab and switch -to the tab specified by `tab-bar-close-tab-select'. -Interactively, TAB-NUMBER is the prefix numeric argument, and defaults to 1. -TAB-NUMBER counts from 1. -Optional TO-NUMBER could be specified to override the value of -`tab-bar-close-tab-select' programmatically with a position -of an existing tab to select after closing the current tab. -TO-NUMBER counts from 1. - -The functions in `tab-bar-tab-prevent-close-functions' will be -run to determine whether or not to close the tab. -Just before the tab is closed, the functions in -`tab-bar-tab-pre-close-functions' will be run. The base behavior -for the last tab on a frame is determined by -`tab-bar-close-last-tab-choice'." - (interactive "P") - (let* ((tabs (funcall tab-bar-tabs-function)) - (current-index (tab-bar--current-tab-index tabs)) - (close-index (if (integerp tab-number) (1- tab-number) current-index)) - (last-tab-p (= 1 (length tabs))) - (prevent-close (run-hook-with-args-until-success - 'tab-bar-tab-prevent-close-functions - (nth close-index tabs) - last-tab-p))) - - (unless prevent-close - (run-hook-with-args 'tab-bar-tab-pre-close-functions - (nth close-index tabs) - last-tab-p) - - (if last-tab-p - (pcase tab-bar-close-last-tab-choice - ('nil - (user-error "Attempt to delete the sole tab in a frame")) - ('delete-frame - (delete-frame)) - ('tab-bar-mode-disable - (tab-bar-mode -1)) - ((pred functionp) - ;; Give the handler function the full extent of the tab's - ;; data, not just it's name and explicit-name flag. - (funcall tab-bar-close-last-tab-choice (tab-bar--tab)))) - - ;; More than one tab still open - (when (eq current-index close-index) - ;; Select another tab before deleting the current tab - (let ((to-index (or (if to-number (1- to-number)) - (pcase tab-bar-close-tab-select - ('left (1- (if (< current-index 1) 2 current-index))) - ('right (if (> (length tabs) (1+ current-index)) - (1+ current-index) - (1- current-index))) - ('recent (tab-bar--tab-index-recent 1 tabs)))))) - (setq to-index (max 0 (min (or to-index 0) (1- (length tabs))))) - (let ((inhibit-message t)) ; avoid message about selected tab - (tab-bar-select-tab (1+ to-index))) - ;; Re-read tabs after selecting another tab - (setq tabs (funcall tab-bar-tabs-function)))) - - (let ((close-tab (nth close-index tabs))) - (push `((frame . ,(selected-frame)) - (index . ,close-index) - (tab . ,(if (eq (car close-tab) 'current-tab) - (tab-bar--tab) - close-tab))) - tab-bar-closed-tabs) - (tab-bar-tabs-set (delq close-tab tabs))) - - ;; Recalculate `tab-bar-lines' and update frames - (tab-bar--update-tab-bar-lines) - - (force-mode-line-update) - (unless tab-bar-mode - (message "Deleted tab and switched to %s" tab-bar-close-tab-select)))))) - -(defun tab-bar-close-tab-by-name (name) - "Close the tab given its NAME. -Interactively, prompt for NAME." - (interactive - (list (completing-read "Close tab by name: " - (mapcar (lambda (tab) - (alist-get 'name tab)) - (funcall tab-bar-tabs-function))))) - (tab-bar-close-tab (1+ (tab-bar--tab-index-by-name name)))) - -(defun tab-bar-close-other-tabs (&optional tab-number) - "Close all tabs on the selected frame, except the tab TAB-NUMBER. -TAB-NUMBER counts from 1 and defaults to the current tab (which -happens interactively)." - (interactive) - (let* ((tabs (funcall tab-bar-tabs-function)) - (current-index (tab-bar--current-tab-index tabs)) - (keep-index (if (integerp tab-number) - (1- (max 1 (min tab-number (length tabs)))) - current-index)) - (index 0)) - - (when (nth keep-index tabs) - (unless (eq keep-index current-index) - (tab-bar-select-tab (1+ keep-index)) - (setq tabs (funcall tab-bar-tabs-function))) - - (dolist (tab tabs) - (unless (or (eq index keep-index) - (run-hook-with-args-until-success - 'tab-bar-tab-prevent-close-functions tab - ;; `last-tab-p' logically can't ever be true - ;; if we make it this far - nil)) - (push `((frame . ,(selected-frame)) - (index . ,index) - (tab . ,tab)) - tab-bar-closed-tabs) - (run-hook-with-args 'tab-bar-tab-pre-close-functions tab nil) - (setq tabs (delq tab tabs))) - (setq index (1+ index))) - (tab-bar-tabs-set tabs) - - ;; Recalculate tab-bar-lines and update frames - (tab-bar--update-tab-bar-lines) - - (force-mode-line-update) - (unless tab-bar-mode - (message "Deleted all other tabs"))))) - -(defun tab-bar-undo-close-tab () - "Restore the most recently closed tab." - (interactive) - ;; Pop out closed tabs that were on already deleted frames - (while (and tab-bar-closed-tabs - (not (frame-live-p (alist-get 'frame (car tab-bar-closed-tabs))))) - (pop tab-bar-closed-tabs)) - - (if tab-bar-closed-tabs - (let* ((closed (pop tab-bar-closed-tabs)) - (frame (alist-get 'frame closed)) - (index (alist-get 'index closed)) - (tab (alist-get 'tab closed))) - (unless (eq frame (selected-frame)) - (select-frame-set-input-focus frame)) - - (let ((tabs (funcall tab-bar-tabs-function))) - (setq index (max 0 (min index (length tabs)))) - (cl-pushnew tab (nthcdr index tabs)) - (when (eq index 0) - ;; pushnew handles the head of tabs but not frame-parameter - (tab-bar-tabs-set tabs)) - (tab-bar-select-tab (1+ index)))) - - (message "No more closed tabs to undo"))) - - -(defun tab-bar-rename-tab (name &optional tab-number) - "Give the tab specified by its absolute position TAB-NUMBER a new NAME. -If no TAB-NUMBER is specified, then rename the current tab. -Interactively, TAB-NUMBER is the prefix numeric argument, and defaults -to the current tab. -TAB-NUMBER counts from 1. -Interactively, prompt for the new NAME. -If NAME is the empty string, then use the automatic name -function `tab-bar-tab-name-function'." - (interactive - (let* ((tabs (funcall tab-bar-tabs-function)) - (tab-number (or current-prefix-arg (1+ (tab-bar--current-tab-index tabs)))) - (tab-name (alist-get 'name (nth (1- tab-number) tabs)))) - (list (read-from-minibuffer - "New name for tab (leave blank for automatic naming): " - nil nil nil nil tab-name) - current-prefix-arg))) - (let* ((tabs (funcall tab-bar-tabs-function)) - (tab-index (if (integerp tab-number) - (1- (max 0 (min tab-number (length tabs)))) - (tab-bar--current-tab-index tabs))) - (tab-to-rename (nth tab-index tabs)) - (tab-explicit-name (> (length name) 0)) - (tab-new-name (if tab-explicit-name - name - (funcall tab-bar-tab-name-function)))) - (setf (alist-get 'name tab-to-rename) tab-new-name - (alist-get 'explicit-name tab-to-rename) tab-explicit-name) - - (force-mode-line-update) - (unless tab-bar-mode - (message "Renamed tab to '%s'" tab-new-name)))) - -(defun tab-bar-rename-tab-by-name (tab-name new-name) - "Rename the tab named TAB-NAME to NEW-NAME. -Interactively, prompt for TAB-NAME and NEW-NAME. -If NEW-NAME is the empty string, then use the automatic name -function `tab-bar-tab-name-function'." - (interactive - (let ((tab-name (completing-read "Rename tab by name: " - (mapcar (lambda (tab) - (alist-get 'name tab)) - (funcall tab-bar-tabs-function))))) - (list tab-name (read-from-minibuffer - "New name for tab (leave blank for automatic naming): " - nil nil nil nil tab-name)))) - (tab-bar-rename-tab new-name (1+ (tab-bar--tab-index-by-name tab-name)))) - - -;;; Tab groups - -(defun tab-bar-move-tab-to-group (&optional tab) - "Relocate TAB (by default, the current tab) closer to its group." - (interactive) - (let* ((tabs (funcall tab-bar-tabs-function)) - (tab (or tab (tab-bar--current-tab-find tabs))) - (tab-index (tab-bar--tab-index tab)) - (group (alist-get 'group tab)) - ;; Beginning position of the same group - (beg (seq-position tabs group - (lambda (tb gr) - (and (not (eq tb tab)) - (equal (alist-get 'group tb) gr))))) - ;; Size of the same group - (len (when beg - (seq-position (nthcdr beg tabs) group - (lambda (tb gr) - (not (equal (alist-get 'group tb) gr)))))) - (pos (when beg - (cond - ;; Don't move tab when it's already inside group bounds - ((and len (>= tab-index beg) (<= tab-index (+ beg len))) nil) - ;; Move tab from the right to the group end - ((and len (> tab-index (+ beg len))) (+ beg len 1)) - ;; Move tab from the left to the group beginning - ((< tab-index beg) beg))))) - (when pos - (tab-bar-move-tab-to pos (1+ tab-index))))) - -(defcustom tab-bar-tab-post-change-group-functions nil - "List of functions to call after changing a tab group. -The current tab is supplied as an argument." - :type 'hook - :options '(tab-bar-move-tab-to-group) - :group 'tab-bar - :version "28.1") - -(defun tab-bar-change-tab-group (group-name &optional tab-number) - "Add the tab specified by its absolute position TAB-NUMBER to GROUP-NAME. -If no TAB-NUMBER is specified, then set the GROUP-NAME for the current tab. -Interactively, TAB-NUMBER is the prefix numeric argument, and the command -prompts for GROUP-NAME. -TAB-NUMBER counts from 1. -If GROUP-NAME is the empty string, then remove the tab from any group. -While using this command, you might also want to replace -`tab-bar-format-tabs' with `tab-bar-format-tabs-groups' in -`tab-bar-format' to group tabs on the tab bar." - (interactive - (let* ((tabs (funcall tab-bar-tabs-function)) - (tab-number (or current-prefix-arg - (1+ (tab-bar--current-tab-index tabs)))) - (group-name (funcall tab-bar-tab-group-function - (nth (1- tab-number) tabs)))) - (list (completing-read - "Group name for tab (leave blank to remove group): " - (delete-dups - (delq nil (cons group-name - (mapcar (lambda (tab) - (funcall tab-bar-tab-group-function tab)) - (funcall tab-bar-tabs-function)))))) - current-prefix-arg))) - (let* ((tabs (funcall tab-bar-tabs-function)) - (tab-index (if tab-number - (1- (max 0 (min tab-number (length tabs)))) - (tab-bar--current-tab-index tabs))) - (tab (nth tab-index tabs)) - (group (assq 'group tab)) - (group-new-name (and (> (length group-name) 0) group-name))) - (if group - (setcdr group group-new-name) - (nconc tab `((group . ,group-new-name)))) - - (run-hook-with-args 'tab-bar-tab-post-change-group-functions tab) - - (force-mode-line-update) - (unless tab-bar-mode - (message "Set tab group to '%s'" group-new-name)))) - -(defun tab-bar-close-group-tabs (group-name) - "Close all tabs that belong to GROUP-NAME on the selected frame. -Interactively, prompt for GROUP-NAME." - (interactive - (let ((group-name (funcall tab-bar-tab-group-function - (tab-bar--current-tab-find)))) - (list (completing-read - "Close all tabs with group name: " - (delete-dups - (delq nil (cons group-name - (mapcar (lambda (tab) - (funcall tab-bar-tab-group-function tab)) - (funcall tab-bar-tabs-function))))))))) - (let* ((close-group (and (> (length group-name) 0) group-name)) - (tab-bar-tab-prevent-close-functions - (cons (lambda (tab _last-tab-p) - (not (equal (funcall tab-bar-tab-group-function tab) - close-group))) - tab-bar-tab-prevent-close-functions))) - (tab-bar-close-other-tabs) - - (when (equal (funcall tab-bar-tab-group-function - (tab-bar--current-tab-find)) - close-group) - (tab-bar-close-tab)))) - - -;;; Tab history mode - -(defvar tab-bar-history-limit 10 - "The number of history elements to keep.") - -(defvar tab-bar-history-omit nil - "When non-nil, omit window-configuration changes from the current command.") - -(defvar tab-bar-history-back (make-hash-table) - "History of back changes in every tab per frame.") - -(defvar tab-bar-history-forward (make-hash-table) - "History of forward changes in every tab per frame.") - -(defvar tab-bar-history-old nil - "Window configuration before the current command.") - -(defvar tab-bar-history-pre-command nil - "Command set to `this-command' by `pre-command-hook'.") - -(defvar tab-bar-history-done-command nil - "Command handled by `window-configuration-change-hook'.") - -(defun tab-bar--history-pre-change () - ;; Reset before the command could set it - (setq tab-bar-history-omit nil) - (setq tab-bar-history-pre-command this-command) - (when (zerop (minibuffer-depth)) - (setq tab-bar-history-old - `((wc . ,(current-window-configuration)) - (wc-point . ,(point-marker)))))) - -(defun tab-bar--history-change () - (when (and (not tab-bar-history-omit) tab-bar-history-old - ;; Don't register changes performed by the same command - ;; repeated in sequence, such as incremental window resizing. - (not (eq tab-bar-history-done-command tab-bar-history-pre-command)) - (zerop (minibuffer-depth))) - (puthash (selected-frame) - (seq-take (cons tab-bar-history-old - (gethash (selected-frame) tab-bar-history-back)) - tab-bar-history-limit) - tab-bar-history-back) - (setq tab-bar-history-old nil)) - (setq tab-bar-history-done-command tab-bar-history-pre-command)) - -(defun tab-bar-history-back () - "Restore a previous window configuration used in the current tab. -This navigates back in the history of window configurations." - (interactive) - (setq tab-bar-history-omit t) - (let* ((history (pop (gethash (selected-frame) tab-bar-history-back))) - (wc (alist-get 'wc history)) - (wc-point (alist-get 'wc-point history))) - (if (window-configuration-p wc) - (progn - (puthash (selected-frame) - (cons tab-bar-history-old - (gethash (selected-frame) tab-bar-history-forward)) - tab-bar-history-forward) - (set-window-configuration wc) - (when (and (markerp wc-point) (marker-buffer wc-point)) - (goto-char wc-point))) - (message "No more tab back history")))) - -(defun tab-bar-history-forward () - "Cancel restoration of the previous window configuration. -This navigates forward in the history of window configurations." - (interactive) - (setq tab-bar-history-omit t) - (let* ((history (pop (gethash (selected-frame) tab-bar-history-forward))) - (wc (alist-get 'wc history)) - (wc-point (alist-get 'wc-point history))) - (if (window-configuration-p wc) - (progn - (puthash (selected-frame) - (cons tab-bar-history-old - (gethash (selected-frame) tab-bar-history-back)) - tab-bar-history-back) - (set-window-configuration wc) - (when (and (markerp wc-point) (marker-buffer wc-point)) - (goto-char wc-point))) - (message "No more tab forward history")))) - -(defvar-keymap tab-bar-history-mode-map - "C-c " #'tab-bar-history-back - "C-c " #'tab-bar-history-forward) - -(define-minor-mode tab-bar-history-mode - "Toggle tab history mode for the tab bar. -Tab history mode remembers window configurations used in every tab, -and can restore them." - :global t :group 'tab-bar - (if tab-bar-history-mode - (progn - (when (and tab-bar-mode (not (get-text-property 0 'display tab-bar-back-button))) - ;; This file is pre-loaded so only here we can use the right data-directory: - (add-text-properties 0 (length tab-bar-back-button) - `(display (image :type xpm - :file "tabs/left-arrow.xpm" - :margin ,tab-bar-button-margin - :ascent center)) - tab-bar-back-button)) - (when (and tab-bar-mode (not (get-text-property 0 'display tab-bar-forward-button))) - ;; This file is pre-loaded so only here we can use the right data-directory: - (add-text-properties 0 (length tab-bar-forward-button) - `(display (image :type xpm - :file "tabs/right-arrow.xpm" - :margin ,tab-bar-button-margin - :ascent center)) - tab-bar-forward-button)) - - (add-hook 'pre-command-hook 'tab-bar--history-pre-change) - (add-hook 'window-configuration-change-hook 'tab-bar--history-change)) - (remove-hook 'pre-command-hook 'tab-bar--history-pre-change) - (remove-hook 'window-configuration-change-hook 'tab-bar--history-change))) - - -;;; Non-graphical access to frame-local tabs (named window configurations) - -(defun tab-switcher () - "Display a list of named window configurations. -The list is displayed in the buffer `*Tabs*'. -It's placed in the center of the frame to resemble a window list -displayed by a window switcher in some window managers on Alt+Tab. - -In this list of window configurations you can delete or select them. -Type ? after invocation to get help on commands available. -Type q to remove the list of window configurations from the display. - -The first column shows `D' for a window configuration you have -marked for deletion." - (interactive) - (let ((dir default-directory)) - (let ((tab-bar-new-tab-choice t) - ;; Don't enable tab-bar-mode if it's disabled - (tab-bar-show nil)) - (tab-bar-new-tab)) - (let ((switch-to-buffer-preserve-window-point nil)) - (switch-to-buffer (tab-switcher-noselect))) - (setq default-directory dir)) - (message "Commands: d, x; RET; q to quit; ? for help.")) - -(defun tab-switcher-noselect () - "Create and return a buffer with a list of window configurations. -The list is displayed in a buffer named `*Tabs*'. - -For more information, see the function `tab-switcher'." - (let* ((tabs (seq-remove (lambda (tab) - (eq (car tab) 'current-tab)) - (funcall tab-bar-tabs-function))) - ;; Sort by recency - (tabs (sort tabs (lambda (a b) (< (alist-get 'time b) - (alist-get 'time a)))))) - (with-current-buffer (get-buffer-create - (format " *Tabs*<%s>" (or (frame-parameter nil 'window-id) - (frame-parameter nil 'name)))) - (setq buffer-read-only nil) - (erase-buffer) - (tab-switcher-mode) - ;; Vertical alignment to the center of the frame - (insert-char ?\n (/ (- (frame-height) (length tabs) 1) 2)) - ;; Horizontal alignment to the center of the frame - (setq tab-switcher-column (- (/ (frame-width) 2) 15)) - (dolist (tab tabs) - (insert (propertize - (format "%s %s\n" - (make-string tab-switcher-column ?\040) - (propertize - (alist-get 'name tab) - 'mouse-face 'highlight - 'help-echo "mouse-2: select this window configuration")) - 'tab tab))) - (goto-char (point-min)) - (goto-char (or (next-single-property-change (point) 'tab) (point-min))) - (when (> (length tabs) 1) - (tab-switcher-next-line)) - (move-to-column tab-switcher-column) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (current-buffer)))) - -(defvar-local tab-switcher-column 3) - -(defvar tab-switcher-mode-map - (let ((map (make-keymap))) - (suppress-keymap map t) - (define-key map "q" 'quit-window) - (define-key map "\C-m" 'tab-switcher-select) - (define-key map "d" 'tab-switcher-delete) - (define-key map "k" 'tab-switcher-delete) - (define-key map "\C-d" 'tab-switcher-delete-backwards) - (define-key map "\C-k" 'tab-switcher-delete) - (define-key map "x" 'tab-switcher-execute) - (define-key map " " 'tab-switcher-next-line) - (define-key map "n" 'tab-switcher-next-line) - (define-key map "p" 'tab-switcher-prev-line) - (define-key map "\177" 'tab-switcher-backup-unmark) - (define-key map "?" 'describe-mode) - (define-key map "u" 'tab-switcher-unmark) - (define-key map [mouse-2] 'tab-switcher-mouse-select) - (define-key map [follow-link] 'mouse-face) - map) - "Local keymap for `tab-switcher-mode' buffers.") - -(define-derived-mode tab-switcher-mode nil "Window Configurations" - "Major mode for selecting a window configuration. -Each line describes one window configuration in Emacs. -Letters do not insert themselves; instead, they are commands. -\\ -\\[tab-switcher-mouse-select] -- select window configuration you click on. -\\[tab-switcher-select] -- select current line's window configuration. -\\[tab-switcher-delete] -- mark that window configuration to be deleted, and move down. -\\[tab-switcher-delete-backwards] -- mark that window configuration to be deleted, and move up. -\\[tab-switcher-execute] -- delete marked window configurations. -\\[tab-switcher-unmark] -- remove all kinds of marks from current line. - With prefix argument, also move up one line. -\\[tab-switcher-backup-unmark] -- back up a line and remove marks." - (setq truncate-lines t)) - -(defun tab-switcher-current-tab (error-if-non-existent-p) - "Return window configuration described by this line of the list." - (let* ((where (save-excursion - (beginning-of-line) - (+ 2 (point) tab-switcher-column))) - (tab (and (not (eobp)) (get-text-property where 'tab)))) - (or tab - (if error-if-non-existent-p - (user-error "No window configuration on this line") - nil)))) - -(defun tab-switcher-next-line (&optional arg) - "Move to ARGth next line in the list of tabs. -Interactively, ARG is the prefix numeric argument and defaults to 1." - (interactive "p") - (forward-line arg) - (beginning-of-line) - (move-to-column tab-switcher-column)) - -(defun tab-switcher-prev-line (&optional arg) - "Move to ARGth previous line in the list of tabs. -Interactively, ARG is the prefix numeric argument and defaults to 1." - (interactive "p") - (forward-line (- arg)) - (beginning-of-line) - (move-to-column tab-switcher-column)) - -(defun tab-switcher-unmark (&optional backup) - "Cancel requested operations on window configuration on this line and move down. -With prefix arg, move up instead." - (interactive "P") - (beginning-of-line) - (move-to-column tab-switcher-column) - (let* ((buffer-read-only nil)) - (delete-char 1) - (insert " ")) - (forward-line (if backup -1 1)) - (move-to-column tab-switcher-column)) - -(defun tab-switcher-backup-unmark () - "Move up one line and cancel requested operations on window configuration there." - (interactive) - (forward-line -1) - (tab-switcher-unmark) - (forward-line -1) - (move-to-column tab-switcher-column)) - -(defun tab-switcher-delete (&optional arg) - "Mark window configuration on this line to be deleted by \\\\[tab-switcher-execute] command. -Prefix arg says how many window configurations to delete. -Negative arg means delete backwards." - (interactive "p") - (let ((buffer-read-only nil)) - (if (or (null arg) (= arg 0)) - (setq arg 1)) - (while (> arg 0) - (delete-char 1) - (insert ?D) - (forward-line 1) - (setq arg (1- arg))) - (while (< arg 0) - (delete-char 1) - (insert ?D) - (forward-line -1) - (setq arg (1+ arg))) - (move-to-column tab-switcher-column))) - -(defun tab-switcher-delete-backwards (&optional arg) - "Mark window configuration on this line to be deleted by \\\\[tab-switcher-execute] command. -Then move up one line. Prefix arg means move that many lines." - (interactive "p") - (tab-switcher-delete (- (or arg 1)))) - -(defun tab-switcher-delete-from-list (tab) - "Delete the window configuration from the list of tabs." - (push `((frame . ,(selected-frame)) - (index . ,(tab-bar--tab-index tab)) - (tab . ,tab)) - tab-bar-closed-tabs) - (tab-bar-tabs-set (delq tab (funcall tab-bar-tabs-function)))) - -(defun tab-switcher-execute () - "Delete window configurations marked with \\\\[tab-switcher-delete] commands." - (interactive) - (save-excursion - (goto-char (point-min)) - (let ((buffer-read-only nil)) - (while (re-search-forward - (format "^%sD" (make-string tab-switcher-column ?\040)) - nil t) - (forward-char -1) - (let ((tab (tab-switcher-current-tab nil))) - (when tab - (tab-switcher-delete-from-list tab) - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point)))))))) - (beginning-of-line) - (move-to-column tab-switcher-column) - (force-mode-line-update)) - -(defun tab-switcher-select () - "Select this line's window configuration. -This command replaces all the existing windows in the selected frame -with those specified by the selected window configuration." - (interactive) - (let* ((to-tab (tab-switcher-current-tab t))) - (kill-buffer (current-buffer)) - ;; Delete the current window configuration of tab list - ;; without storing it in the undo list of closed tabs - (let ((inhibit-message t) ; avoid message about deleted tab - tab-bar-closed-tabs) - (tab-bar-close-tab nil (1+ (tab-bar--tab-index to-tab)))))) - -(defun tab-switcher-mouse-select (event) - "Select the window configuration whose line you click on." - (interactive "e") - (set-buffer (window-buffer (posn-window (event-end event)))) - (goto-char (posn-point (event-end event))) - (tab-switcher-select)) - - -(defun tab-bar--reusable-frames (all-frames) - (cond - ((eq all-frames t) (frame-list)) - ((eq all-frames 'visible) (visible-frame-list)) - ((framep all-frames) (list all-frames)) - (t (list (selected-frame))))) - -(defun tab-bar-get-buffer-tab (buffer-or-name &optional all-frames ignore-current-tab) - "Return the tab that owns the window whose buffer is BUFFER-OR-NAME. -BUFFER-OR-NAME may be a buffer or a buffer name, and defaults to -the current buffer. - -The optional argument ALL-FRAMES specifies the frames to consider: - -- t means consider all tabs on all existing frames. - -- `visible' means consider all tabs on all visible frames. - -- A frame means consider all tabs on that frame only. - -- Any other value of ALL-FRAMES means consider all tabs on the -selected frame and no others. - -When the optional argument IGNORE-CURRENT-TAB is non-nil, -don't take into account the buffers in the currently selected tab. -Otherwise, prefer buffers of the current tab." - (let ((buffer (if buffer-or-name - (get-buffer buffer-or-name) - (current-buffer)))) - (when (bufferp buffer) - (seq-some - (lambda (frame) - (seq-some - (lambda (tab) - (when (if (eq (car tab) 'current-tab) - (get-buffer-window buffer frame) - (let* ((state (alist-get 'ws tab)) - (buffers (when state - (window-state-buffers state)))) - (or - ;; non-writable window-state - (memq buffer buffers) - ;; writable window-state - (member (buffer-name buffer) buffers)))) - (append tab `((index . ,(tab-bar--tab-index tab nil frame)) - (frame . ,frame))))) - (let* ((tabs (funcall tab-bar-tabs-function frame)) - (current-tab (tab-bar--current-tab-find tabs))) - (setq tabs (remq current-tab tabs)) - (if ignore-current-tab - ;; Use tabs without current-tab. - tabs - ;; Make sure current-tab is at the beginning of tabs. - (cons current-tab tabs))))) - (tab-bar--reusable-frames all-frames))))) - -(defun display-buffer-in-tab (buffer alist) - "Display BUFFER in a tab using display actions in ALIST. -ALIST is an association list of action symbols and values. See -Info node `(elisp) Buffer Display Action Alists' for details of -such alists. - -If ALIST contains a `tab-name' entry, it creates a new tab with that name and -displays BUFFER in a new tab. If a tab with this name already exists, it -switches to that tab before displaying BUFFER. The `tab-name' entry can be -a function, in which case it is called with two arguments: BUFFER and ALIST, -and should return the tab name. When a `tab-name' entry is omitted, create -a new tab without an explicit name. - -The ALIST entry `tab-group' (string or function) defines the tab group. - -If ALIST contains a `reusable-frames' entry, its value determines -which frames to search for a reusable tab: - nil -- do not reuse any frames; - a frame -- just that frame; - `visible' -- all visible frames; - 0 -- all frames on the current terminal; - t -- all frames; - other non-nil values -- use the selected frame. - -If ALIST contains a non-nil `ignore-current-tab' entry, then the buffers -of the current tab are skipped when searching for a reusable tab. -Otherwise, prefer buffers of the current tab. - -This is an action function for buffer display, see Info -node `(elisp) Buffer Display Action Functions'. It should be -called only by `display-buffer' or a function directly or -indirectly called by the latter." - (let* ((reusable-frames (alist-get 'reusable-frames alist)) - (ignore-current-tab (alist-get 'ignore-current-tab alist)) - (reusable-tab (when reusable-frames - (tab-bar-get-buffer-tab buffer reusable-frames - ignore-current-tab)))) - (if reusable-tab - (let* ((frame (alist-get 'frame reusable-tab)) - (index (alist-get 'index reusable-tab))) - (when frame - (select-frame-set-input-focus frame)) - (when index - (tab-bar-select-tab (1+ index))) - (when (get-buffer-window buffer frame) - (select-window (get-buffer-window buffer frame)))) - (let ((tab-name (alist-get 'tab-name alist))) - (when (functionp tab-name) - (setq tab-name (funcall tab-name buffer alist))) - (if tab-name - (let ((tab-index (tab-bar--tab-index-by-name tab-name))) - (if tab-index - (progn - (tab-bar-select-tab (1+ tab-index)) - (when (get-buffer-window buffer) - (select-window (get-buffer-window buffer)))) - (display-buffer-in-new-tab buffer alist))) - (display-buffer-in-new-tab buffer alist)))))) - -(defun display-buffer-in-new-tab (buffer alist) - "Display BUFFER in a new tab using display actions in ALIST. -ALIST is an association list of action symbols and values. See -Info node `(elisp) Buffer Display Action Alists' for details of -such alists. - -Like `display-buffer-in-tab', but always creates a new tab unconditionally, -without checking if a suitable tab already exists. - -If ALIST contains a `tab-name' entry, it creates a new tab with that name -and displays BUFFER in a new tab. The `tab-name' entry can be a function, -in which case it is called with two arguments: BUFFER and ALIST, and should -return the tab name. When a `tab-name' entry is omitted, create a new tab -without an explicit name. - -The ALIST entry `tab-group' (string or function) defines the tab group. - -This is an action function for buffer display, see Info -node `(elisp) Buffer Display Action Functions'. It should be -called only by `display-buffer' or a function directly or -indirectly called by the latter." - (let ((tab-bar-new-tab-choice t)) - (tab-bar-new-tab) - (let ((tab-name (alist-get 'tab-name alist))) - (when (functionp tab-name) - (setq tab-name (funcall tab-name buffer alist))) - (when tab-name - (tab-bar-rename-tab tab-name))) - (let ((tab-group (alist-get 'tab-group alist))) - (when (functionp tab-group) - (setq tab-group (funcall tab-group buffer alist))) - (when tab-group - (tab-bar-change-tab-group tab-group))) - (window--display-buffer buffer (selected-window) 'tab alist))) - -(defun switch-to-buffer-other-tab (buffer-or-name &optional _norecord) - "Switch to buffer BUFFER-OR-NAME in another tab. -Like \\[switch-to-buffer-other-frame] (which see), but creates a new tab. -Interactively, prompt for the buffer to switch to." - (declare (advertised-calling-convention (buffer-or-name) "28.1")) - (interactive - (list (read-buffer-to-switch "Switch to buffer in other tab: "))) - (display-buffer (window-normalize-buffer-to-switch-to buffer-or-name) - '((display-buffer-in-tab) - (inhibit-same-window . nil)))) - -(defun find-file-other-tab (filename &optional wildcards) - "Edit file FILENAME, in another tab. -Like \\[find-file-other-frame] (which see), but creates a new tab. -Interactively, prompt for FILENAME. -If WILDCARDS is non-nil, FILENAME can include widcards, and all matching -files will be visited." - (interactive - (find-file-read-args "Find file in other tab: " - (confirm-nonexistent-file-or-buffer))) - (let ((value (find-file-noselect filename nil nil wildcards))) - (if (listp value) - (progn - (setq value (nreverse value)) - (switch-to-buffer-other-tab (car value)) - (mapc 'switch-to-buffer (cdr value)) - value) - (switch-to-buffer-other-tab value)))) - -(defun find-file-read-only-other-tab (filename &optional wildcards) - "Edit file FILENAME, in another tab, but don't allow changes. -Like \\[find-file-other-frame] (which see), but creates a new tab. -Like \\[find-file-other-tab], but marks buffer as read-only. -Use \\[read-only-mode] to permit editing. -Interactively, prompt for FILENAME. -If WILDCARDS is non-nil, FILENAME can include widcards, and all matching -files will be visited." - (interactive - (find-file-read-args "Find file read-only in other tab: " - (confirm-nonexistent-file-or-buffer))) - (find-file--read-only (lambda (filename wildcards) - (window-buffer - (find-file-other-tab filename wildcards))) - filename wildcards)) - -(defun other-tab-prefix () - "Display the buffer of the next command in a new tab. -The next buffer is the buffer displayed by the next command invoked -immediately after this command (ignoring reading from the minibuffer). -Creates a new tab before displaying the buffer, or switches to the tab -that already contains that buffer. -When `switch-to-buffer-obey-display-actions' is non-nil, -`switch-to-buffer' commands are also supported." - (interactive) - (display-buffer-override-next-command - (lambda (buffer alist) - (cons (progn - (display-buffer-in-tab - buffer (append alist '((inhibit-same-window . nil)))) - (selected-window)) - 'tab)) - nil "[other-tab]") - (message "Display next command buffer in a new tab...")) - - -;;; Short aliases and keybindings - -(defalias 'tab-new 'tab-bar-new-tab) -(defalias 'tab-new-to 'tab-bar-new-tab-to) -(defalias 'tab-duplicate 'tab-bar-duplicate-tab) -(defalias 'tab-detach 'tab-bar-detach-tab) -(defalias 'tab-window-detach 'tab-bar-move-window-to-tab) -(defalias 'tab-close 'tab-bar-close-tab) -(defalias 'tab-close-other 'tab-bar-close-other-tabs) -(defalias 'tab-close-group 'tab-bar-close-group-tabs) -(defalias 'tab-undo 'tab-bar-undo-close-tab) -(defalias 'tab-select 'tab-bar-select-tab) -(defalias 'tab-switch 'tab-bar-switch-to-tab) -(defalias 'tab-next 'tab-bar-switch-to-next-tab) -(defalias 'tab-previous 'tab-bar-switch-to-prev-tab) -(defalias 'tab-last 'tab-bar-switch-to-last-tab) -(defalias 'tab-recent 'tab-bar-switch-to-recent-tab) -(defalias 'tab-move 'tab-bar-move-tab) -(defalias 'tab-move-to 'tab-bar-move-tab-to) -(defalias 'tab-rename 'tab-bar-rename-tab) -(defalias 'tab-group 'tab-bar-change-tab-group) -(defalias 'tab-list 'tab-switcher) - -(define-key tab-prefix-map "n" 'tab-duplicate) -(define-key tab-prefix-map "N" 'tab-new-to) -(define-key tab-prefix-map "2" 'tab-new) -(define-key tab-prefix-map "1" 'tab-close-other) -(define-key tab-prefix-map "0" 'tab-close) -(define-key tab-prefix-map "u" 'tab-undo) -(define-key tab-prefix-map "o" 'tab-next) -(define-key tab-prefix-map "O" 'tab-previous) -(define-key tab-prefix-map "m" 'tab-move) -(define-key tab-prefix-map "M" 'tab-move-to) -(define-key tab-prefix-map "G" 'tab-group) -(define-key tab-prefix-map "r" 'tab-rename) -(define-key tab-prefix-map "\r" 'tab-switch) -(define-key tab-prefix-map "b" 'switch-to-buffer-other-tab) -(define-key tab-prefix-map "f" 'find-file-other-tab) -(define-key tab-prefix-map "\C-f" 'find-file-other-tab) -(define-key tab-prefix-map "\C-r" 'find-file-read-only-other-tab) -(define-key tab-prefix-map "t" 'other-tab-prefix) - -(defvar tab-bar-switch-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "o" 'tab-next) - (define-key map "O" 'tab-previous) - map) - "Keymap to repeat tab switch key sequences `C-x t o o O'. -Used in `repeat-mode'.") -(put 'tab-next 'repeat-map 'tab-bar-switch-repeat-map) -(put 'tab-previous 'repeat-map 'tab-bar-switch-repeat-map) - -(defvar tab-bar-move-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "m" 'tab-move) - (define-key map "M" 'tab-bar-move-tab-backward) - map) - "Keymap to repeat tab move key sequences `C-x t m m M'. -Used in `repeat-mode'.") -(put 'tab-move 'repeat-map 'tab-bar-move-repeat-map) -(put 'tab-bar-move-tab-backward 'repeat-map 'tab-bar-move-repeat-map) - - -(provide 'tab-bar) - -;;; tab-bar.el ends here -- cgit 1.4.1-21-gabe81