mirrored from git://git.sv.gnu.org/emacs.git
-
Notifications
You must be signed in to change notification settings - Fork 1.3k
/
Copy pathtab-line.el
1219 lines (1097 loc) · 51.4 KB
/
tab-line.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; tab-line.el --- window-local tabs with window buffers -*- lexical-binding: t; -*-
;; Copyright (C) 2019-2025 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 t))
: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.")
(defvar tab-line-new-button-functions
'(tab-line-tabs-window-buffers
tab-line-tabs-fixed-window-buffers)
"Functions of `tab-line-tabs-function' for which to show a new button.")
(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 t))
: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. The result of this function is cached
using `tab-line-cache-key-function'."
: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)
(tab-line-force-update t))
: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-fixed-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-fixed-window-buffers' that
returns a list of buffers associated with the selected window where
buffers always keep the original order after switching buffers.
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 by `tab-line-tabs-buffer-group-function'.
The result of this function is cached using
`tab-line-cache-key-function'."
:type '(choice (const :tag "Window buffers"
tab-line-tabs-window-buffers)
(const :tag "Window buffers with fixed order"
tab-line-tabs-fixed-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)
(tab-line-force-update t))
: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'.")
(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)))))
(defcustom tab-line-tabs-buffer-group-function
#'tab-line-tabs-buffer-group-by-mode
"Function to add a buffer to the appropriate group of tabs.
Takes a buffer as argument and should return a group name as a string.
If the return value is nil, the buffer has no group, so \"No group\"
is displayed instead of a group name and the buffer is not grouped
together with other buffers.
If the value is `tab-line-tabs-buffer-group-by-mode',
use mode-to-group mappings in `tab-line-tabs-buffer-groups'
to group by major mode. If the value is
`tab-line-tabs-buffer-group-by-project' use the project name
as a group name."
:type '(choice (const :tag "Group by mode"
tab-line-tabs-buffer-group-by-mode)
(const :tag "Group by project name"
tab-line-tabs-buffer-group-by-project)
(function :tag "Custom function"))
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(tab-line-force-update t))
:group 'tab-line
:version "30.1")
(defcustom tab-line-tabs-buffer-group-sort-function
#'tab-line-tabs-buffer-group-sort-by-name
"Function to sort buffers in a group."
:type '(choice (const :tag "Don't sort" nil)
(const :tag "Sort by name alphabetically"
tab-line-tabs-buffer-group-sort-by-name)
(function :tag "Custom function"))
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(tab-line-force-update t))
:group 'tab-line
:version "30.1")
(defun tab-line-tabs-buffer-group-sort-by-name (a b)
(string< (buffer-name a) (buffer-name b)))
(defcustom tab-line-tabs-buffer-groups-sort-function #'string<
"Function to sort group names."
:type '(choice (const :tag "Don't sort" nil)
(const :tag "Sort alphabetically" string<)
(function :tag "Custom function"))
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(tab-line-force-update t))
:group 'tab-line
:version "30.1")
(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-by-mode (&optional buffer)
"Group tab buffers by major mode."
(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)))
(declare-function project-name "project" (project))
(defun tab-line-tabs-buffer-group-by-project (&optional buffer)
"Group tab buffers by project name."
(with-current-buffer buffer
(if-let* ((project (project-current)))
(project-name project)
"No project")))
(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)
(tab-line-tabs-buffer-group-by-mode buffer)))
(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 (delq nil
(mapcar #'car
(seq-group-by #'tab-line-tabs-buffer-group-name
buffers))))
(sorted-groups (if (functionp tab-line-tabs-buffer-groups-sort-function)
(seq-sort tab-line-tabs-buffer-groups-sort-function
groups)
groups))
(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)))))
sorted-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 "No group")
(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)))
(defun tab-line-tabs-fixed-window-buffers ()
"Like `tab-line-tabs-window-buffers' but keep stable sorting order.
This means that switching to a buffer previously shown in the same
window will keep the same order of tabs that was before switching.
And newly displayed buffers are added to the end of the tab line."
(let* ((old-buffers (window-parameter nil 'tab-line-buffers))
(buffer-positions (let ((index-table (make-hash-table
:size (length old-buffers)
:test #'eq)))
(seq-do-indexed
(lambda (buf idx) (puthash buf idx index-table))
old-buffers)
index-table))
(new-buffers (sort (tab-line-tabs-window-buffers)
:in-place t
:key (lambda (buffer)
(gethash buffer buffer-positions
most-positive-fixnum)))))
(set-window-parameter nil 'tab-line-buffers new-buffers)
new-buffers))
(add-to-list 'window-persistent-parameters '(tab-line-buffers . t))
(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. The result of this function is cached
using `tab-line-cache-key-function'."
:type 'function
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
(tab-line-force-update t))
: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 (memq tab-line-tabs-function tab-line-new-button-functions)
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) (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-force-update (all)
"Force redisplay of the current buffer’s tab line.
This function also clears the tab-line cache. With optional non-nil ALL,
it clears the tab-line cache of all tab lines and forces their redisplay."
(if all
(walk-windows
(lambda (window)
(set-window-parameter window 'tab-line-cache nil))
'no-mini t)
(set-window-parameter nil 'tab-line-cache nil))
(force-mode-line-update all))
(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.
Also there is the function `tab-line-force-update' that clears the cache.")
(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)
(if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(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
((memq buffer next-buffers)
(dotimes (_ (1+ (seq-position next-buffers buffer)))
(switch-to-next-buffer window)))
((memq buffer prev-buffers)
(dotimes (_ (1+ (seq-position prev-buffers buffer)))
(switch-to-prev-buffer window)))))
(with-selected-window window
(let ((switch-to-buffer-obey-display-actions nil))
(switch-to-buffer buffer)))))
(defcustom tab-line-switch-cycling t
"Wrap tabs on tab switch while cycling.
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 arg)
"Switch to the ARGth previous tab's buffer.
When `tab-line-tabs-function' is `tab-line-tabs-window-buffers',
its effect is the same as using the `previous-buffer' command
\(\\[previous-buffer]).
For other values of `tab-line-tabs-function' this command
switches to the previous buffer in the sequence defined by
`tab-line-tabs-function'. To wrap buffer cycling in this case
is possible when `tab-line-switch-cycling' is non-nil."
(interactive (list last-nonmenu-event
(prefix-numeric-value current-prefix-arg)))
(let ((window (and (listp event) (posn-window (event-start event)))))
(with-selected-window (or window (selected-window))
(if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(previous-buffer arg t)
(let* ((buffers (seq-keep
(lambda (tab) (or (and (bufferp tab) tab)
(alist-get 'buffer tab)))
(funcall tab-line-tabs-function)))
(old-pos (seq-position buffers (current-buffer)))
(new-pos (when old-pos (- old-pos (or arg 1))))
(new-pos (when new-pos
(if tab-line-switch-cycling
(mod new-pos (length buffers))
(max new-pos 0))))
(buffer (when new-pos (nth new-pos buffers))))
(when (bufferp buffer)
(let ((switch-to-buffer-obey-display-actions nil))
(switch-to-buffer buffer))))))))
(defun tab-line-switch-to-next-tab (&optional event arg)
"Switch to the next ARGth tab's buffer.
When `tab-line-tabs-function' is `tab-line-tabs-window-buffers',
its effect is the same as using the `next-buffer' command
\(\\[next-buffer]).
For other values of `tab-line-tabs-function' this command
switches to the next buffer in the sequence defined by
`tab-line-tabs-function'. To wrap buffer cycling in this case
is possible when `tab-line-switch-cycling' is non-nil."
(interactive (list last-nonmenu-event
(prefix-numeric-value current-prefix-arg)))
(let ((window (and (listp event) (posn-window (event-start event)))))
(with-selected-window (or window (selected-window))
(if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers)
(next-buffer arg t)
(let* ((buffers (seq-keep
(lambda (tab) (or (and (bufferp tab) tab)
(alist-get 'buffer tab)))
(funcall tab-line-tabs-function)))
(old-pos (seq-position buffers (current-buffer)))
(new-pos (when old-pos (+ old-pos (or arg 1))))
(new-pos (when new-pos
(if tab-line-switch-cycling
(mod new-pos (length buffers))
(min new-pos (1- (length buffers))))))