From 16604de81858b42701815850a80e2b6651ce0fc2 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Sun, 6 Feb 2022 22:14:50 -0600 Subject: Change compat logic --- lisp/compat/keymap.el | 590 ++++++++++++ lisp/compat/tab-bar.el | 2424 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 3014 insertions(+) create mode 100644 lisp/compat/keymap.el create mode 100644 lisp/compat/tab-bar.el (limited to 'lisp/compat') diff --git a/lisp/compat/keymap.el b/lisp/compat/keymap.el new file mode 100644 index 0000000..3e9189f --- /dev/null +++ b/lisp/compat/keymap.el @@ -0,0 +1,590 @@ +;;; 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 new file mode 100644 index 0000000..d49fc2e --- /dev/null +++ b/lisp/compat/tab-bar.el @@ -0,0 +1,2424 @@ +;;; 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