mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-22 07:09:54 +00:00
Code Issues Releases Activity
e881a172d4
emacs/lisp/tab-line.el

1066 lines
44 KiB
EmacsLisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; tab-line.el --- window-local tabs with window buffers -*- lexical-binding: t; -*-
;; Copyright (C) 2019-2023 Free Software Foundation, Inc.
;; Author: Juri Linkov <juri@linkov.net>
;; Keywords: windows 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; To enable this mode, run `M-x global-tab-line-mode'.
;;; Code:
(require 'cl-lib)
(require 'seq)
(require 'icons)
(defgroup tab-line nil
"Window-local tabs."
:group 'convenience
:version "27.1")
(defcustom tab-line-tab-face-functions
'(tab-line-tab-face-modified tab-line-tab-face-special)
"Functions called to modify tab faces.
Each function is called with five arguments: the tab, a list of
all tabs, the face returned by the previously called modifier,
whether the tab is a buffer, and whether the tab is selected."
:type '(repeat
(choice (function-item tab-line-tab-face-special)
(function-item tab-line-tab-face-modified)
(function-item tab-line-tab-face-inactive-alternating)
(function-item tab-line-tab-face-group)
(function :tag "Custom function")))
:group 'tab-line
:version "28.1")
(defgroup tab-line-faces '((tab-line custom-face)) ; tab-line is defined in faces.el
"Faces used in the tab line."
:group 'tab-line
:group 'faces
:version "27.1")
(defface tab-line-tab
'((default :inherit tab-line)
(((class color) (min-colors 88))
:box (:line-width 1 :style released-button))
(t :inverse-video nil))
"Tab line face for selected tab."
:version "27.1"
:group 'tab-line-faces)
(defface tab-line-tab-inactive
'((default :inherit tab-line-tab)
(((class color) (min-colors 88))
:background "grey75")
(t :inverse-video t))
"Tab line face for non-selected tab."
:version "27.1"
:group 'tab-line-faces)
(defface tab-line-tab-inactive-alternate
'((t :inherit tab-line-tab-inactive :background "grey65"))
"Alternate face for inactive tab-line tabs.
Applied to alternating tabs when option
`tab-line-tab-face-functions' includes function
`tab-line-tab-face-inactive-alternating'."
:version "28.1"
:group 'tab-line-faces)
(defface tab-line-tab-special
'((default :weight bold)
(((supports :slant italic))
:slant italic :weight normal))
"Face for special (i.e. non-file-backed) tabs.
Applied when option `tab-line-tab-face-functions' includes
function `tab-line-tab-face-special'."
:version "28.1"
:group 'tab-line-faces)
(defface tab-line-tab-modified
'((t :inherit font-lock-doc-face))
"Face for modified tabs.
Applied when option `tab-line-tab-face-functions' includes
function `tab-line-tab-face-modified'."
:version "28.1"
:group 'tab-line-faces)
(defface tab-line-tab-group
'((t :inherit tab-line :box nil))
"Face for group tabs.
Applied when option `tab-line-tab-face-functions' includes
function `tab-line-tab-face-group'."
:version "28.1"
:group 'tab-line-faces)
(defface tab-line-tab-current
'((default :inherit tab-line-tab)
(((class color) (min-colors 88))
:background "grey85"))
"Tab line face for tab with current buffer in selected window."
:version "27.1"
:group 'tab-line-faces)
(defface tab-line-highlight
'((((class color) (min-colors 88))
:box (:line-width 1 :style released-button)
:background "grey85"
:foreground "black")
(t :inverse-video nil))
"Tab line face for highlighting."
:version "27.1"
:group 'tab-line-faces)
(defface tab-line-close-highlight
'((t :foreground "red"))
"Tab line face for highlighting of the close button."
:version "27.1"
:group 'tab-line-faces)
(defvar-keymap tab-line-tab-map
:doc "Local keymap for `tab-line-mode' window tabs."
"<tab-line> <down-mouse-1>" #'tab-line-select-tab
"<tab-line> <mouse-2>" #'tab-line-close-tab
"<tab-line> <down-mouse-3>" #'tab-line-tab-context-menu
"<tab-line> <touchscreen-begin>" #'tab-line-select-tab
"RET" #'tab-line-select-tab)
(defvar-keymap tab-line-add-map
:doc "Local keymap to add `tab-line-mode' window tabs."
"<tab-line> <down-mouse-1>" #'tab-line-new-tab
"<tab-line> <down-mouse-2>" #'tab-line-new-tab
"<tab-line> <touchscreen-begin>" #'tab-line-new-tab
"RET" #'tab-line-new-tab)
(defvar-keymap tab-line-tab-close-map
:doc "Local keymap to close `tab-line-mode' window tabs."
"<tab-line> <mouse-1>" #'tab-line-close-tab
"<tab-line> <mouse-2>" #'tab-line-close-tab
"<tab-line> <touchscreen-begin>" #'tab-line-close-tab)
(defvar-keymap tab-line-left-map
:doc "Local keymap to scroll `tab-line-mode' window tabs to the left."
"<tab-line> <down-mouse-1>" #'tab-line-hscroll-left
"<tab-line> <down-mouse-2>" #'tab-line-hscroll-left
"<tab-line> <touchscreen-begin>" #'tab-line-hscroll-left
"RET" #'tab-line-new-tab)
(defvar-keymap tab-line-right-map
:doc "Local keymap to scroll `tab-line-mode' window tabs to the right."
"<tab-line> <down-mouse-1>" #'tab-line-hscroll-right
"<tab-line> <down-mouse-2>" #'tab-line-hscroll-right
"<tab-line> <touchscreen-begin>" #'tab-line-hscroll-right
"RET" #'tab-line-new-tab)
(defcustom tab-line-new-tab-choice t
"Defines what to show in a new tab.
If t, display a selection menu with all available buffers.
If the value is a function, call it with no arguments."
:type '(choice (const :tag "Buffer menu" t)
(function :tag "Function"))
:group 'tab-line
:version "27.1")
(defcustom tab-line-new-button-show t
"If non-nil, show the \"New tab\" button in the tab line."
:type 'boolean
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
:group 'tab-line
:version "27.1")
(define-icon tab-line-new nil
`((image "symbols/plus_16.svg" "tabs/new.xpm"
:face shadow
:height (1 . em)
:margin (2 . 0)
:ascent center)
(text " + "))
"Icon for creating a new tab."
:version "30.1"
:help-echo "New tab")
(defvar tab-line-new-button
(propertize (icon-string 'tab-line-new)
'rear-nonsticky nil
'keymap tab-line-add-map
'mouse-face 'tab-line-highlight
'help-echo "Click to add tab")
"Button for creating a new tab.")
(defcustom tab-line-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-line
:version "27.1")
(define-icon tab-line-close nil
`((image "symbols/cross_16.svg" "tabs/close.xpm"
:face shadow
:height (1 . em)
:margin (2 . 0)
:ascent center)
(text " x"))
"Icon for closing the clicked tab."
:version "30.1"
:help-echo "Click to close tab")
(defvar tab-line-close-button
(propertize (icon-string 'tab-line-close)
'rear-nonsticky nil ;; important to not break auto-scroll
'keymap tab-line-tab-close-map
'mouse-face 'tab-line-close-highlight
'help-echo "Click to close tab")
"Button for closing the clicked tab.")
(define-icon tab-line-left nil
`((image "symbols/chevron_left_16.svg" "tabs/left-arrow.xpm"
:face shadow
:height (1 . em)
:margin (2 . 0)
:ascent center)
(text " <"))
"Icon for scrolling horizontally to the left."
:version "30.1")
(defvar tab-line-left-button
(propertize (icon-string 'tab-line-left)
'rear-nonsticky nil
'keymap tab-line-left-map
'mouse-face 'tab-line-highlight
'help-echo "Click to scroll left")
"Button for scrolling horizontally to the left.")
(define-icon tab-line-right nil
`((image "symbols/chevron_right_16.svg" "tabs/right-arrow.xpm"
:face shadow
:height (1 . em)
:margin (2 . 0)
:ascent center)
(text "> "))
"Icon for scrolling horizontally to the right."
:version "30.1")
(defvar tab-line-right-button
(propertize (icon-string 'tab-line-right)
'rear-nonsticky nil
'keymap tab-line-right-map
'mouse-face 'tab-line-highlight
'help-echo "Click to scroll right")
"Button for scrolling horizontally to the right.")
(defvar tab-line-separator nil
"String that delimits tabs.")
(defcustom tab-line-tab-name-function #'tab-line-tab-name-buffer
"Function to get a tab name.
The function is called with one or two arguments: the buffer or
another object whose tab's name is requested, and, optionally,
the list of all tabs."
:type '(choice (const :tag "Buffer name"
tab-line-tab-name-buffer)
(const :tag "Truncated buffer name"
tab-line-tab-name-truncated-buffer)
(function :tag "Function"))
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
:group 'tab-line
:version "27.1")
(defun tab-line-tab-name-buffer (buffer &optional _buffers)
"Generate tab name from BUFFER.
Reduce tab width proportionally to space taken by other tabs.
This function can be overridden by changing the default value of the
variable `tab-line-tab-name-function'."
(buffer-name buffer))
(defcustom tab-line-tab-name-truncated-max 20
"Maximum length of the tab name from the current buffer.
Effective when `tab-line-tab-name-function' is customized
to `tab-line-tab-name-truncated-buffer'."
:type 'natnum
:group 'tab-line
:version "27.1")
(defvar tab-line-tab-name-ellipsis t)
(defun tab-line-tab-name-truncated-buffer (buffer &optional _buffers)
"Generate tab name from BUFFER, truncating it as needed.
Truncate it to the length specified by `tab-line-tab-name-truncated-max'.
If truncated, append ellipsis per `tab-line-tab-name-ellipsis'."
(let ((tab-name (buffer-name buffer)))
(if (< (length tab-name) tab-line-tab-name-truncated-max)
tab-name
(propertize (truncate-string-to-width
tab-name tab-line-tab-name-truncated-max nil nil
tab-line-tab-name-ellipsis)
'help-echo tab-name))))
(defcustom tab-line-tabs-function #'tab-line-tabs-window-buffers
"Function to get a list of tabs to display in the tab line.
This function should return either a list of buffers whose names will
be displayed, or just a list of strings to display in the tab line.
By default, use function `tab-line-tabs-window-buffers' that
returns a list of buffers associated with the selected window.
When `tab-line-tabs-mode-buffers', return a list of buffers
with the same major mode as the current buffer.
When `tab-line-tabs-buffer-groups', return a list of buffers
grouped either by `tab-line-tabs-buffer-group-function', when set,
or by `tab-line-tabs-buffer-groups'."
:type '(choice (const :tag "Window buffers"
tab-line-tabs-window-buffers)
(const :tag "Same mode buffers"
tab-line-tabs-mode-buffers)
(const :tag "Grouped buffers"
tab-line-tabs-buffer-groups)
(function :tag "Function"))
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
:group 'tab-line
:version "27.1")
(defvar tab-line-tabs-buffer-list-function #'tab-line-tabs-buffer-list
"Function to return a global list of buffers.
Used only for `tab-line-tabs-mode-buffers' and `tab-line-tabs-buffer-groups'.")
;;; Touch screen support.
(defun tab-line-track-tap (event &optional function)
"Track a tap starting from EVENT.
If EVENT is not a `touchscreen-begin' event, return t.
Otherwise, return t if the tap completes successfully, and nil if
the tap should be ignored.
If FUNCTION is specified and the tap does not complete within
`touch-screen-delay' seconds, display the appropriate context
menu by calling FUNCTION with EVENT, and return nil."
(if (not (eq (car-safe event) 'touchscreen-begin))
t
(let ((result (catch 'context-menu
(let (timer)
(unwind-protect
(progn
(when function
(setq timer
(run-at-time touch-screen-delay t
#'throw 'context-menu
'context-menu)))
(touch-screen-track-tap event))
(when timer
(cancel-timer timer)))))))
(cond ((eq result 'context-menu)
(prog1 nil
(funcall function event)))
(result t)))))
(defun tab-line-event-start (event)
"Like `event-start'.
However, return the correct mouse position list if EVENT is a
`touchscreen-begin' event."
(or (and (eq (car-safe event) 'touchscreen-begin)
(cdadr event))
(event-start event)))
(defun tab-line-tabs-buffer-list ()
(seq-filter (lambda (b) (and (buffer-live-p b)
(/= (aref (buffer-name b) 0) ?\s)))
(seq-uniq (append (list (current-buffer))
(mapcar #'car (window-prev-buffers))
(buffer-list)))))
(defun tab-line-tabs-mode-buffers ()
"Return a list of buffers with the same major mode as the current buffer."
(let ((mode major-mode))
(seq-sort-by #'buffer-name #'string<
(seq-filter (lambda (b) (with-current-buffer b
(derived-mode-p mode)))
(funcall tab-line-tabs-buffer-list-function)))))
(defvar tab-line-tabs-buffer-group-function nil
"Function to add a buffer to the appropriate group of tabs.
Takes a buffer as arg and should return a group name as a string.
If the return value is nil, the buffer should be filtered out.")
(defvar tab-line-tabs-buffer-group-sort-function nil
"Function to sort buffers in a group.")
(defvar tab-line-tabs-buffer-groups-sort-function #'string<
"Function to sort group names.")
(defvar tab-line-tabs-buffer-groups mouse-buffer-menu-mode-groups
"How to group various major modes together in the tab line.
Each element has the form (REGEXP . GROUPNAME).
If the major mode's name matches REGEXP, it belongs to GROUPNAME.
The default is for each major mode to have a separate group
named the same as the mode.")
(defun tab-line-tabs-buffer-group-name (&optional buffer)
(if (functionp tab-line-tabs-buffer-group-function)
(funcall tab-line-tabs-buffer-group-function buffer)
(let ((mode (if buffer (with-current-buffer buffer
(format-mode-line mode-name))
(format-mode-line mode-name))))
(or (cdr (seq-find (lambda (group)
(string-match-p (car group) mode))
tab-line-tabs-buffer-groups))
mode))))
(defun tab-line-tabs-buffer-groups ()
"Return a list of tabs that should be displayed in the tab line.
By default return a list of buffers grouped by major mode,
according to `tab-line-tabs-buffer-groups'.
If non-nil, `tab-line-tabs-buffer-group-function' is used to
generate the group name."
(if (window-parameter nil 'tab-line-groups)
(let* ((buffers (funcall tab-line-tabs-buffer-list-function))
(groups
(seq-sort tab-line-tabs-buffer-groups-sort-function
(delq nil (mapcar #'car (seq-group-by
(lambda (buffer)
(tab-line-tabs-buffer-group-name
buffer))
buffers)))))
(selected-group (window-parameter nil 'tab-line-group))
(tabs
(mapcar (lambda (group)
`(tab
(name . ,group)
(selected . ,(equal group selected-group))
(select . ,(lambda ()
(set-window-parameter nil 'tab-line-groups nil)
(set-window-parameter nil 'tab-line-group group)
(set-window-parameter nil 'tab-line-hscroll nil)))))
groups)))
tabs)
(let* ((window-parameter (window-parameter nil 'tab-line-group))
(group-name (tab-line-tabs-buffer-group-name (current-buffer)))
(group (prog1 (or window-parameter group-name "All")
(when (equal window-parameter group-name)
(set-window-parameter nil 'tab-line-group nil))))
(group-tab `(tab
(name . ,group)
(group-tab . t)
(select . ,(lambda ()
(set-window-parameter nil 'tab-line-groups t)
(set-window-parameter nil 'tab-line-group group)
(set-window-parameter nil 'tab-line-hscroll nil)))))
(buffers
(seq-filter (lambda (b)
(equal (tab-line-tabs-buffer-group-name b) group))
(funcall tab-line-tabs-buffer-list-function)))
(sorted-buffers (if (functionp tab-line-tabs-buffer-group-sort-function)
(seq-sort tab-line-tabs-buffer-group-sort-function
buffers)
buffers))
(tabs (mapcar (lambda (buffer)
`(tab
(name . ,(funcall tab-line-tab-name-function buffer))
(selected . ,(eq buffer (current-buffer)))
(buffer . ,buffer)
(close . ,(lambda (&optional b)
;; kill-buffer because bury-buffer
;; won't remove the buffer from tab-line
(kill-buffer (or b buffer))))))
sorted-buffers)))
(cons group-tab tabs))))
(defun tab-line-tabs-window-buffers ()
"Return a list of tabs that should be displayed in the tab line.
By default returns a list of window buffers, i.e. buffers previously
shown in the same window where the tab line is displayed.
This list can be overridden by changing the default value of the
variable `tab-line-tabs-function'."
(let* ((window (selected-window))
(buffer (window-buffer window))
(next-buffers (seq-remove (lambda (b) (eq b buffer))
(window-next-buffers window)))
(next-buffers (seq-filter #'buffer-live-p next-buffers))
(prev-buffers (seq-remove (lambda (b) (eq b buffer))
(mapcar #'car (window-prev-buffers window))))
(prev-buffers (seq-filter #'buffer-live-p prev-buffers))
;; Remove next-buffers from prev-buffers
(prev-buffers (seq-difference prev-buffers next-buffers)))
(append (reverse prev-buffers)
(list buffer)
next-buffers)))
(defcustom tab-line-tab-name-format-function #'tab-line-tab-name-format-default
"Function to format a tab name.
The function will be called two arguments: the tab whose name to format,
and the list of all the tabs; it should return the formatted tab name
to display in the tab line.
The first argument could also be a different object, for example the buffer
which the tab will represent."
:type 'function
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(force-mode-line-update))
:group 'tab-line
:version "28.1")
(defun tab-line-tab-name-format-default (tab tabs)
"Default function to use as `tab-line-tab-name-format-function', which see."
(let* ((buffer-p (bufferp tab))
(selected-p (if buffer-p
(eq tab (window-buffer))
(cdr (assq 'selected tab))))
(name (if buffer-p
(funcall tab-line-tab-name-function tab tabs)
(cdr (assq 'name tab))))
(face (if selected-p
(if (mode-line-window-selected-p)
'tab-line-tab-current
'tab-line-tab)
'tab-line-tab-inactive)))
(dolist (fn tab-line-tab-face-functions)
(setf face (funcall fn tab tabs face buffer-p selected-p)))
(apply 'propertize
(concat (propertize (string-replace "%" "%%" name) ;; (bug#57848)
'face face
'keymap tab-line-tab-map
'help-echo (if selected-p "Current tab"
"Click to select tab")
;; Don't turn mouse-1 into mouse-2 (bug#49247)
'follow-link 'ignore)
(let ((close (or (and (or buffer-p (assq 'buffer tab)
(assq 'close tab))
tab-line-close-button-show
(not (eq tab-line-close-button-show
(if selected-p 'non-selected
'selected)))
tab-line-close-button)
"")))
(setq close (copy-sequence close))
;; Don't overwrite the icon face
(add-face-text-property 0 (length close) face t close)
close))
`(
tab ,tab
,@(if selected-p '(selected t))
mouse-face tab-line-highlight))))
(defun tab-line-format-template (tabs)
"Template of the format for displaying tab line for selected window.
This is used by `tab-line-format'."
(let* ((separator (or tab-line-separator (if (window-system) " " "|")))
(hscroll (window-parameter nil 'tab-line-hscroll))
(strings
(mapcar
(lambda (tab)
(concat separator
(funcall tab-line-tab-name-format-function tab tabs)))
tabs))
(hscroll-data (tab-line-auto-hscroll strings hscroll)))
(setq hscroll (nth 1 hscroll-data))
(append
(if (null (nth 0 hscroll-data))
(when hscroll
(setq hscroll nil)
(set-window-parameter nil 'tab-line-hscroll hscroll))
(list separator
(when (and (numberp hscroll) (not (zerop hscroll)))
tab-line-left-button)
(when (if (numberp hscroll)
(< (truncate hscroll) (1- (length strings)))
(> (length strings) 1))
tab-line-right-button)))
(if hscroll (nthcdr (truncate hscroll) strings) strings)
(list separator)
(when (and (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
tab-line-new-button-show
tab-line-new-button)
(list tab-line-new-button)))))
(defun tab-line-tab-face-inactive-alternating (tab tabs face _buffer-p selected-p)
"Return FACE for TAB in TABS with alternation.
SELECTED-P nil means TAB is not the selected tab.
When TAB is not selected and is even-numbered, make FACE
inherit from `tab-line-tab-inactive-alternate'. For use in
`tab-line-tab-face-functions'."
(when (and (not selected-p) (cl-evenp (cl-position tab tabs)))
(setf face `(:inherit (tab-line-tab-inactive-alternate ,face))))
face)
(defun tab-line-tab-face-special (tab _tabs face buffer-p _selected-p)
"Return FACE for TAB according to whether its buffer is special.
When TAB is a non-file-visiting buffer, make FACE inherit from
`tab-line-tab-special'. For use in
`tab-line-tab-face-functions'."
(let ((buffer (if buffer-p tab (cdr (assq 'buffer tab)))))
(when (and buffer (not (buffer-file-name buffer)))
(setf face `(:inherit (tab-line-tab-special ,face)))))
face)
(defun tab-line-tab-face-modified (tab _tabs face buffer-p _selected-p)
"Return FACE for TAB according to whether its buffer is modified.
When TAB is a modified, file-backed buffer, make FACE inherit
from `tab-line-tab-modified'. For use in
`tab-line-tab-face-functions'."
(let ((buffer (if buffer-p tab (cdr (assq 'buffer tab)))))
(when (and buffer (buffer-file-name buffer) (buffer-modified-p buffer))
(setf face `(:inherit (tab-line-tab-modified ,face)))))
face)
(defun tab-line-tab-face-group (tab _tabs face _buffer-p _selected-p)
"Return FACE for TAB according to whether it's a group tab.
For use in `tab-line-tab-face-functions'."
(when (alist-get 'group-tab tab)
(setf face `(:inherit (tab-line-tab-group ,face))))
face)
(defvar tab-line-auto-hscroll)
(defun tab-line-cache-key-default (tabs)
"Return default list of cache keys."
(list
tabs
;; handle buffer renames
(buffer-name (window-buffer))
;; handle tab-line scrolling
(window-parameter nil 'tab-line-hscroll)
;; for setting face 'tab-line-tab-current'
(mode-line-window-selected-p)
;; for `tab-line-tab-face-modified'
(and (memq 'tab-line-tab-face-modified
tab-line-tab-face-functions)
(buffer-file-name)
(buffer-modified-p))))
(defvar tab-line-cache-key-function #'tab-line-cache-key-default
"Function that adds more cache keys.
It is called with one argument, a list of tabs, and should return a list
of cache keys. You can use `add-function' to add more cache keys.")
(defun tab-line-format ()
"Format for displaying the tab line of the selected window."
(let* ((tabs (funcall tab-line-tabs-function))
(cache-key (funcall tab-line-cache-key-function tabs))
(cache (window-parameter nil 'tab-line-cache)))
;; Enable auto-hscroll again after it was disabled on manual scrolling.
;; The moment to enable it is when the window-buffer was updated.
(when (and tab-line-auto-hscroll ; if auto-hscroll was enabled
(integerp (nth 2 cache-key)) ; integer on manual scroll
cache ; window-buffer was updated
(not (equal (nth 1 (car cache)) (nth 1 cache-key))))
(set-window-parameter nil 'tab-line-hscroll (float (nth 2 cache-key))))
(or (and cache (equal (car cache) cache-key) (cdr cache))
(cdr (set-window-parameter
nil 'tab-line-cache
(cons cache-key (tab-line-format-template tabs)))))))
(defcustom tab-line-auto-hscroll t
"Allow or disallow automatic horizontal scrolling of the tab line.
Non-nil means the tab lines are automatically scrolled horizontally to make
the selected tab visible."
:type 'boolean
:group 'tab-line
:version "27.1")
(defvar tab-line-auto-hscroll-buffer (generate-new-buffer " *tab-line-hscroll*"))
(defun tab-line--get-tab-property (prop string)
(or (get-pos-property 1 prop string) ;; for most cases of 1-char separator
(get-pos-property 0 prop string) ;; for empty separator
(let ((pos (next-single-property-change 0 prop string))) ;; long separator
(and pos (get-pos-property pos prop string)))))
(defun tab-line-auto-hscroll (strings hscroll)
(with-current-buffer tab-line-auto-hscroll-buffer
(let ((truncate-partial-width-windows nil)
(inhibit-modification-hooks t)
show-arrows)
(setq truncate-lines nil
word-wrap nil)
(erase-buffer)
(apply 'insert strings)
(goto-char (point-min))
(add-face-text-property (point-min) (point-max) 'tab-line t)
;; Continuation means tab-line doesn't fit completely,
;; thus scroll arrows are needed for scrolling.
(setq show-arrows (> (vertical-motion 1) 0))
;; Try to auto-hscroll only when scrolling is needed,
;; but no manual scrolling was performed before.
(when (and tab-line-auto-hscroll
show-arrows
;; Do nothing when scrolled manually
(not (integerp hscroll)))
(let ((selected (seq-position strings 'selected
(lambda (str prop)
(tab-line--get-tab-property prop str)))))
(cond
((null selected)
;; Do nothing if no tab is selected
)
((or (not (numberp hscroll)) (< selected (truncate hscroll)))
;; Selected is scrolled to the left, or no scrolling yet
(erase-buffer)
(apply 'insert (reverse (seq-subseq strings 0 (1+ selected))))
(goto-char (point-min))
(add-face-text-property (point-min) (point-max) 'tab-line)
(if (> (vertical-motion 1) 0)
(let* ((point (previous-single-property-change (point) 'tab))
(tab-prop (when point
(or (get-pos-property point 'tab)
(and (setq point (previous-single-property-change point 'tab))
(get-pos-property point 'tab)))))
(new-hscroll (when tab-prop
(seq-position strings tab-prop
(lambda (str tab)
(eq (tab-line--get-tab-property 'tab str) tab))))))
(when new-hscroll
(setq hscroll (float new-hscroll))
(set-window-parameter nil 'tab-line-hscroll hscroll)))
(setq hscroll nil)
(set-window-parameter nil 'tab-line-hscroll hscroll)))
(t
;; Check if the selected tab is already visible
(erase-buffer)
(apply 'insert (seq-subseq strings (truncate hscroll) (1+ selected)))
(goto-char (point-min))
(add-face-text-property (point-min) (point-max) 'tab-line)
(when (> (vertical-motion 1) 0)
;; Not visible already
(erase-buffer)
(apply 'insert (reverse (seq-subseq strings 0 (1+ selected))))
(goto-char (point-min))
(add-face-text-property (point-min) (point-max) 'tab-line)
(when (> (vertical-motion 1) 0)
(let* ((point (previous-single-property-change (point) 'tab))
(tab-prop (when point
(or (get-pos-property point 'tab)
(and (setq point (previous-single-property-change point 'tab))
(get-pos-property point 'tab)))))
(new-hscroll (when tab-prop
(seq-position strings tab-prop
(lambda (str tab)
(eq (tab-line--get-tab-property 'tab str) tab))))))
(when new-hscroll
(setq hscroll (float new-hscroll))
(set-window-parameter nil 'tab-line-hscroll hscroll)))))))))
(list show-arrows hscroll))))
(defun tab-line-hscroll (&optional arg window)
(let* ((hscroll (window-parameter window 'tab-line-hscroll))
(tabs (if window
(with-selected-window window (funcall tab-line-tabs-function))
(funcall tab-line-tabs-function))))
(set-window-parameter
window 'tab-line-hscroll
(max 0 (min (+ (if (numberp hscroll) (truncate hscroll) 0) (or arg 1))
(1- (length tabs)))))
(when window
(force-mode-line-update t))))
(defun tab-line-hscroll-right (&optional arg event)
"Scroll the tab line ARG positions to the right.
Interactively, ARG is the prefix numeric argument and defaults to 1."
(interactive (list current-prefix-arg last-nonmenu-event))
(when (tab-line-track-tap event)
(let ((window (and (listp event)
(posn-window (tab-line-event-start event)))))
(tab-line-hscroll arg window)
(force-mode-line-update window))))
(defun tab-line-hscroll-left (&optional arg event)
"Scroll the tab line ARG positions to the left.
Interactively, ARG is the prefix numeric argument and defaults to 1."
(interactive (list current-prefix-arg last-nonmenu-event))
(when (tab-line-track-tap event)
(let ((window (and (listp event)
(posn-window (tab-line-event-start event)))))
(tab-line-hscroll (- (or arg 1)) window)
(force-mode-line-update window))))
(defun tab-line-new-tab (&optional event)
"Add a new tab to the selected-window's tab line.
This command is usually invoked by clicking on the plus-shaped button
on the tab line. Switching to another buffer also adds a new tab
corresponding to the new buffer shown in the window."
(interactive (list last-nonmenu-event))
(when (tab-line-track-tap event)
(if (functionp tab-line-new-tab-choice)
(funcall tab-line-new-tab-choice)
(let ((tab-line-tabs-buffer-groups mouse-buffer-menu-mode-groups))
(if (and (listp event)
(display-popup-menus-p)
(not tty-menu-open-use-tmm))
(mouse-buffer-menu event) ; like (buffer-menu-open)
;; tty menu doesn't support mouse clicks, so use tmm
(tmm-prompt (mouse-buffer-menu-keymap)))))))
(defun tab-line-select-tab (&optional event)
"Switch to the buffer specified by the tab on which you click.
This command maintains the original order of prev/next buffers.
So, for example, switching to a previous tab is equivalent to
using the `previous-buffer' command."
(interactive "e")
(when (tab-line-track-tap event #'tab-line-tab-context-menu)
(let* ((posnp (tab-line-event-start event))
(tab (tab-line--get-tab-property 'tab (car (posn-string posnp))))
(buffer (if (bufferp tab) tab (cdr (assq 'buffer tab)))))
(if buffer
(tab-line-select-tab-buffer buffer (posn-window posnp))
(let ((select (cdr (assq 'select tab))))
(when (functionp select)
(with-selected-window (posn-window posnp)
(funcall select)
(force-mode-line-update))))))))
(defun tab-line-select-tab-buffer (buffer &optional window)
(let* ((window-buffer (window-buffer window))
(next-buffers (seq-remove (lambda (b) (eq b window-buffer))
(window-next-buffers window)))
(prev-buffers (seq-remove (lambda (b) (eq b window-buffer))
(mapcar #'car (window-prev-buffers window))))
;; Remove next-buffers from prev-buffers
(prev-buffers (seq-difference prev-buffers next-buffers)))
(cond
((and (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(memq buffer next-buffers))
(dotimes (_ (1+ (seq-position next-buffers buffer)))
(switch-to-next-buffer window)))
((and (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(memq buffer prev-buffers))
(dotimes (_ (1+ (seq-position prev-buffers buffer)))
(switch-to-prev-buffer window)))
(t
(with-selected-window window
(switch-to-buffer buffer))))))
(defcustom tab-line-switch-cycling nil
"Enable cycling tab switch.
If non-nil, `tab-line-switch-to-prev-tab' in the first tab
switches to the last tab and `tab-line-switch-to-next-tab' in the
last tab switches to the first tab. This variable is not consulted
when `tab-line-tabs-function' is `tab-line-tabs-window-buffers'."
:type 'boolean
:group 'tab-line
:version "28.1")
(defun tab-line-switch-to-prev-tab (&optional event)
"Switch to the previous tab's buffer.
Its effect is the same as using the `previous-buffer' command
(\\[previous-buffer])."
(interactive (list last-nonmenu-event))
(let ((window (and (listp event) (posn-window (event-start event)))))
(if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(switch-to-prev-buffer window)
(with-selected-window (or window (selected-window))
(let* ((tabs (seq-filter
(lambda (tab) (or (bufferp tab) (assq 'buffer tab)))
(funcall tab-line-tabs-function)))
(pos (seq-position
tabs (current-buffer)
(lambda (tab buffer)
(if (bufferp tab)
(eq buffer tab)
(eq buffer (cdr (assq 'buffer tab)))))))
(tab (if pos
(if (and tab-line-switch-cycling (<= pos 0))
(nth (1- (length tabs)) tabs)
(nth (1- pos) tabs))))
(buffer (if (bufferp tab) tab (cdr (assq 'buffer tab)))))
(when (bufferp buffer)
(switch-to-buffer buffer)))))))
(defun tab-line-switch-to-next-tab (&optional event)
"Switch to the next tab's buffer.
Its effect is the same as using the `next-buffer' command
(\\[next-buffer])."
(interactive (list last-nonmenu-event))
(let ((window (and (listp event) (posn-window (event-start event)))))
(if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(switch-to-next-buffer window)
(with-selected-window (or window (selected-window))
(let* ((tabs (seq-filter
(lambda (tab) (or (bufferp tab) (assq 'buffer tab)))
(funcall tab-line-tabs-function)))
(pos (seq-position
tabs (current-buffer)
(lambda (tab buffer)
(if (bufferp tab)
(eq buffer tab)
(eq buffer (cdr (assq 'buffer tab)))))))
(tab (if pos
(if (and tab-line-switch-cycling (<= (length tabs) (1+ pos)))
(car tabs)
(nth (1+ pos) tabs))))
(buffer (if (bufferp tab) tab (cdr (assq 'buffer tab)))))
(when (bufferp buffer)
(switch-to-buffer buffer)))))))
(defcustom tab-line-close-tab-function 'bury-buffer
"What to do upon closing a tab on the tab line.
If `bury-buffer', put the tab's buffer at the end of the list of all
buffers, which effectively hides the buffer's tab from the tab line.
If `kill-buffer', kills the tab's buffer.
When a function, it is called with the tab as its argument.
This option is useful when `tab-line-tabs-function' has the value
`tab-line-tabs-window-buffers'."
:type '(choice (const :tag "Bury buffer" bury-buffer)
(const :tag "Kill buffer" kill-buffer)
(function :tag "Function"))
:group 'tab-line
:version "27.1")
(defun tab-line-close-tab (&optional event)
"Close the selected tab.
This command is usually invoked by clicking on the close button on the
right side of the tab. This command buries the buffer, so it goes out of
sight of the tab line."
(interactive (list last-nonmenu-event))
(when (tab-line-track-tap event)
(let* ((posnp (and (listp event)
(tab-line-event-start event)))
(window (and posnp (posn-window posnp)))
(tab (tab-line--get-tab-property 'tab (car (posn-string posnp))))
(buffer (if (bufferp tab) tab (cdr (assq 'buffer tab))))
(close-function (unless (bufferp tab) (cdr (assq 'close tab)))))
(with-selected-window (or window (selected-window))
(cond
((functionp close-function)
(funcall close-function))
((eq tab-line-close-tab-function 'kill-buffer)
(kill-buffer buffer))
((eq tab-line-close-tab-function 'bury-buffer)
(if (eq buffer (current-buffer))
(bury-buffer)
(set-window-prev-buffers nil (assq-delete-all buffer (window-prev-buffers)))
(set-window-next-buffers nil (delq buffer (window-next-buffers)))))
((functionp tab-line-close-tab-function)
(funcall tab-line-close-tab-function tab)))
(force-mode-line-update)))))
(defun tab-line-tab-context-menu (&optional event)
"Pop up the context menu for a tab-line tab."
(interactive "e")
(let ((menu (make-sparse-keymap (propertize "Context Menu" 'hide t))))
(define-key-after menu [close]
'(menu-item "Close" tab-line-close-tab :help "Close the tab"))
(popup-menu menu event)))
(defun tab-line-context-menu (&optional event)
"Pop up the context menu for the tab line."
(interactive "e")
(let ((menu (make-sparse-keymap (propertize "Context Menu" 'hide t))))
(define-key-after menu [close]
'(menu-item "New tab" tab-line-new-tab :help "Create a new tab"))
(popup-menu menu event)))
;;;###autoload
(define-minor-mode tab-line-mode
"Toggle display of tab line in the windows displaying the current buffer."
:lighter nil
(let ((default-value '(:eval (tab-line-format))))
(if tab-line-mode
;; Preserve the existing tab-line set outside of this mode
(unless tab-line-format
(setq tab-line-format default-value))
;; Reset only values set by this mode
(when (equal tab-line-format default-value)
(setq tab-line-format nil)))))
(defcustom tab-line-exclude-modes
'(completion-list-mode)
"List of major modes for which the tab-line display is not enabled.
Buffers under any of these major modes will not show the tab line in
their windows, even if `global-tab-line-mode' is enabled."
:type '(repeat symbol)
:group 'tab-line
:version "27.1")
;;;###autoload
(defvar-local tab-line-exclude nil)
(defun tab-line-mode--turn-on ()
"Turn on `tab-line-mode' in all pertinent buffers.
Temporary buffers, buffers whose names begin with a space, buffers
under major modes that are either mentioned in `tab-line-exclude-mode'
or have a non-nil `tab-line-exclude' property on their symbol,
and buffers that have a non-nil buffer-local value
of `tab-line-exclude', are exempt from `tab-line-mode'."
(unless (or (minibufferp)
(string-match-p "\\` " (buffer-name))
(memq major-mode tab-line-exclude-modes)
(get major-mode 'tab-line-exclude)
(buffer-local-value 'tab-line-exclude (current-buffer)))
(tab-line-mode 1)))
;;;###autoload
(define-globalized-minor-mode global-tab-line-mode
tab-line-mode tab-line-mode--turn-on
:group 'tab-line
:version "27.1")
(global-set-key [tab-line down-mouse-3] 'tab-line-context-menu)
(global-set-key [tab-line mouse-4] 'tab-line-hscroll-left)
(global-set-key [tab-line mouse-5] 'tab-line-hscroll-right)
(global-set-key [tab-line wheel-up] 'tab-line-hscroll-left)
(global-set-key [tab-line wheel-down] 'tab-line-hscroll-right)
(global-set-key [tab-line wheel-left] 'tab-line-hscroll-left)
(global-set-key [tab-line wheel-right] 'tab-line-hscroll-right)
(global-set-key [tab-line S-mouse-4] 'tab-line-switch-to-prev-tab)
(global-set-key [tab-line S-mouse-5] 'tab-line-switch-to-next-tab)
(global-set-key [tab-line S-wheel-up] 'tab-line-switch-to-prev-tab)
(global-set-key [tab-line S-wheel-down] 'tab-line-switch-to-next-tab)
(global-set-key [tab-line S-wheel-left] 'tab-line-switch-to-prev-tab)
(global-set-key [tab-line S-wheel-right] 'tab-line-switch-to-next-tab)
(provide 'tab-line)
;;; tab-line.el ends here
Reference in New Issue View Git Blame Copy Permalink