emacs/lisp/+tab-bar.el

382 lines
20 KiB
EmacsLisp
Raw Permalink Normal View History

2022-01-11 05:44:45 +00:00
;;; +tab-bar.el -*- lexical-binding: t; -*-
;;; Commentary:
;; Emacs 28 comes with an easy-to-use `tab-bar-format' option, but I still use
;; Emacs 27 on my Windows machine. Thus, the code in this file.
;;; Code:
2022-05-27 18:26:19 +00:00
(require 'acdw)
2022-01-11 05:44:45 +00:00
(require 'tab-bar)
(defface +tab-bar-extra
'((t :inherit (tab-bar font-lock-comment-face)))
2022-06-08 22:59:53 +00:00
"Tab bar face for extra information, like the menu-bar and time."
:group 'basic-faces)
2022-01-11 05:44:45 +00:00
;; Common
2022-05-26 03:07:33 +00:00
(defun +tab-bar-space (&optional n)
"Display a space N characters long, or 1."
`((space menu-item ,(+string-repeat (or n 1) " ") ignore)))
2022-01-11 05:44:45 +00:00
(defun +tab-bar-misc-info ()
"Display `mode-line-misc-info', formatted for the tab-bar."
2022-02-07 04:17:34 +00:00
`((misc-info menu-item ,(string-trim-right
2022-02-17 05:06:05 +00:00
(format-mode-line mode-line-misc-info))
2022-02-07 04:17:34 +00:00
ignore)))
(defcustom +tracking-hide-when-org-clocking nil
"Hide the `tracking-mode' information when clocked in."
:type 'boolean)
2022-02-07 04:17:34 +00:00
(defun +tab-bar-tracking-mode ()
"Display `tracking-mode-line-buffers' in the tab-bar."
;; TODO: write something to convert a mode-line construct to a tab-bar
2022-06-08 22:59:53 +00:00
;; construct.
(when (and (bound-and-true-p tracking-mode)
(not (and +tracking-hide-when-org-clocking
(bound-and-true-p org-clock-current-task))))
(cons (when (> (length tracking-mode-line-buffers) 0)
'(track-mode-line-separator menu-item " " ignore))
(cl-loop for i from 0 below (length tracking-mode-line-buffers)
as item = (nth i tracking-mode-line-buffers)
collect (append (list (intern (format "tracking-mode-line-%s" i))
'menu-item
(string-trim (format-mode-line item)))
(if-let ((keymap (plist-get item 'keymap)))
(list (alist-get 'down-mouse-1 (cdadr keymap)))
(list #'ignore))
(when-let ((help (plist-get item 'help-echo)))
(list :help help)))))))
2022-02-07 04:17:34 +00:00
2022-05-13 03:37:16 +00:00
(defun +tab-bar-timer ()
"Display `+timer-string' in the tab-bar."
2022-06-08 22:59:53 +00:00
(when (> (length (bound-and-true-p +timer-string)) 0)
2022-05-13 03:37:16 +00:00
`((timer-string menu-item
,(concat " " +timer-string)
2022-06-08 22:59:53 +00:00
(lambda (ev)
(interactive "e")
(cond ((not +timer-timer) nil)
((equal +timer-string +timer-running-string)
(popup-menu
'("Running timer"
["Cancel timer" +timer-cancel t])
ev))
(t (setq +timer-string ""))))))))
2022-05-13 03:37:16 +00:00
2022-02-07 04:17:34 +00:00
(defun +tab-bar-date ()
"Display `display-time-string' in the tab-bar."
(when display-time-mode
`((date-time-string menu-item
2022-05-26 03:07:33 +00:00
,(substring-no-properties (concat " " (string-trim display-time-string)))
2022-06-08 22:59:53 +00:00
(lambda (ev)
(interactive "e")
(popup-menu
(append '("Timer")
(let (r)
(dolist (time '(3 5 10))
(push (vector (format "Timer for %d minutes" time)
`(lambda () (interactive)
(+timer ,time))
:active t)
r))
(nreverse r))
'(["Timer for ..." +timer t]))
ev))
:help (discord-date-string)))))
2022-01-11 05:44:45 +00:00
2022-02-17 05:06:05 +00:00
(defun +tab-bar-notmuch-count ()
"Display a notmuch count in the tab-bar."
(when (and (executable-find "notmuch")
(featurep 'notmuch))
(let* ((counts (ignore-errors (notmuch-hello-query-counts notmuch-saved-searches)))
2022-06-08 22:59:53 +00:00
(next (cl-find "inbox+unread" counts :key (lambda (l) (plist-get l :name)) :test 'equal))
2022-02-17 05:06:05 +00:00
(next-count (plist-get next :count)))
(when (and next-count (> next-count 0))
`((notmuch-count menu-item
,(format " |%s|" next-count)
2022-06-08 22:59:53 +00:00
ignore
:help ,(format "%s mails requiring attention." next-count)))))))
2022-02-17 05:06:05 +00:00
(defun +tab-bar-org-clock ()
"Display `org-mode-line-string' in the tab-bar."
2022-03-12 02:04:05 +00:00
(when (and (fboundp 'org-clocking-p)
(org-clocking-p))
2022-02-17 05:06:05 +00:00
;; org-mode-line-string
2022-06-08 22:59:53 +00:00
`((org-clocking menu-item
,org-mode-line-string
(lambda (ev)
(interactive "e")
(let ((menu (make-sparse-keymap
(or org-clock-current-task "Org-Clock"))))
(map-keymap (lambda (key binding)
(when (consp binding)
(define-key-after menu (vector key)
(copy-sequence binding))))
(org-clock-menu))
(message "%S" ev)
(popup-menu menu ev)))
:help ,(or (replace-regexp-in-string
(rx "[[" (group (* (not "]")))
"][" (group (* (not "]")))
"]]")
"\\2"
org-clock-current-task)
"Org-Clock")))))
2022-02-17 05:06:05 +00:00
2022-02-07 19:16:00 +00:00
(defcustom +tab-bar-emms-max-length 24
"Maximum length of `+tab-bar-emms'."
:type 'number)
(defun +tab-bar-emms ()
"Display EMMS now playing information."
(when (and (bound-and-true-p emms-mode-line-mode)
2022-02-07 19:16:00 +00:00
emms-player-playing-p)
(let ((now-playing (+string-truncate (emms-mode-line-playlist-current)
(- +tab-bar-emms-max-length 2))))
2022-04-20 15:44:51 +00:00
`(emms-now-playing menu-item
,(concat "{" now-playing "}" " ")
2022-06-08 22:59:53 +00:00
emms-pause
( :help ,(emms-mode-line-playlist-current))))))
2022-02-07 19:16:00 +00:00
(defun +tab-bar-bongo ()
"Display Bongo now playing information."
(when-let ((modep (bound-and-true-p bongo-mode-line-indicator-mode))
2022-02-07 23:09:32 +00:00
(buf (cl-some (lambda (b)
(with-current-buffer b
(when-let* ((modep (derived-mode-p 'bongo-playlist-mode))
(bongo-playlist-buffer b)
(playingp (bongo-playing-p)))
b)))
(buffer-list))))
2022-02-07 19:16:00 +00:00
`((bongo-now-playing menu-item
,(concat "{"
(let ((bongo-field-separator ""))
(+string-truncate (replace-regexp-in-string
"\\(.*\\)\\(.*\\)\\(.*\\)"
"\\1: \\3"
(bongo-formatted-infoset))
2022-02-22 03:02:08 +00:00
;; This isn't right
2022-06-08 22:59:53 +00:00
(- (min 50 (/ (frame-width) 3 )) 2)))
2022-02-07 19:16:00 +00:00
"}")
2022-06-08 22:59:53 +00:00
(lambda () (interactive)
(let ((bongo-playlist-buffer
;; XXX: I'm sure this is terribly inefficient
(cl-some (lambda (b)
(with-current-buffer b
(when-let* ((modep (derived-mode-p
'bongo-playlist-mode))
(bongo-playlist-buffer b)
(playingp (bongo-playing-p)))
b)))
(buffer-list))))
(with-bongo-playlist-buffer
(bongo-pause/resume))))
:help ,(funcall bongo-header-line-function)))))
2022-02-07 19:16:00 +00:00
2022-01-11 05:44:45 +00:00
(defvar +tab-bar-show-original nil
"Original value of `tab-bar-show'.")
2022-01-14 00:01:12 +00:00
(defun +tab-bar-basename ()
"Generate the tab name from the basename of the buffer of the
selected window."
2022-01-16 21:54:00 +00:00
(let* ((tab-file-name (buffer-file-name (window-buffer
(minibuffer-selected-window)))))
(concat " "
(if tab-file-name
(file-name-nondirectory tab-file-name)
(+tab-bar-tab-name-truncated-left)))))
2022-01-14 00:01:12 +00:00
;;; FIXME this doesn't work...
;; (defvar +tab-bar-tab-min-width 8
2022-06-08 22:59:53 +00:00
;; "Minimum width of a tab on the tab bar.")
;; (defvar +tab-bar-tab-max-width 24
2022-06-08 22:59:53 +00:00
;; "Maximum width of a tab on the tab bar.")
;; (defun +tab-bar-fluid-calculate-width ()
2022-06-08 22:59:53 +00:00
;; "Calculate the width of each tab in the tab-bar."
;; (let* ((tab-bar-list (cdr (tab-bar-make-keymap-1)))
;; (tab-bar-avail-width (frame-width))
;; (tab-bar-tab-count (length (tab-bar-tabs)))
;; (tab-bar-close-button-char-width 1)
;; (tab-bar-add-tab-button-char-width 1)
;; (tab-bar-total-width
;; (length (mapconcat
;; (lambda (el)
;; (when-let ((str (car-safe (cdr-safe (cdr-safe el)))))
;; (substring-no-properties (eval str))))
;; tab-bar-list)))
;; (tab-bar-total-tab-width
;; (+ (* tab-bar-tab-count tab-bar-close-button-char-width)
;; tab-bar-add-tab-button-char-width
;; (length (mapconcat
;; (lambda (el)
;; (substring-no-properties (alist-get 'name el)))
;; (tab-bar-tabs)))))
;; (tab-bar-total-nontab-width (- tab-bar-total-width
;; tab-bar-total-tab-width)))
;; (min +tab-bar-tab-max-width
;; (max +tab-bar-tab-min-width
;; (/ (- tab-bar-avail-width
;; tab-bar-total-tab-width
;; tab-bar-total-nontab-width)
;; tab-bar-tab-count)))))
;; (defun +tab-bar-fluid-width ()
2022-06-08 22:59:53 +00:00
;; "Generate the tab name to fluidly fit in the given space."
;; (let* ((tab-file-name (buffer-file-name (window-buffer
;; (minibuffer-selected-window)))))
;; (format (format " %%s%%%ds" (+tab-bar-fluid-calculate-width))
;; (if tab-file-name
;; (file-name-nondirectory tab-file-name)
;; (+tab-bar-tab-name-truncated-left))
;; " ")))
(defun +tab-bar-tab-name-truncated-left ()
"Generate the tab name from the buffer of the selected window.
This is just like `tab-bar-tab-name-truncated', but truncates the
name to the left."
(let* ((tab-name (buffer-name (window-buffer (minibuffer-selected-window))))
2022-02-17 05:06:05 +00:00
(ellipsis (cond
(tab-bar-tab-name-ellipsis)
((char-displayable-p ?…) "")
("...")))
(l-ell (length ellipsis))
(l-name (length tab-name)))
(if (< (length tab-name) tab-bar-tab-name-truncated-max)
tab-name
(propertize (concat
(when (> (+ l-name l-ell) tab-bar-tab-name-truncated-max)
ellipsis)
(truncate-string-to-width tab-name l-name
2022-05-13 03:37:16 +00:00
(max 0 (- l-name tab-bar-tab-name-truncated-max l-ell))))
'help-echo tab-name))))
2022-04-20 15:44:51 +00:00
(defun +tab-bar-format-align-right ()
"Align the rest of tab bar items to the right, pixel-wise."
;; XXX: ideally, wouldn't require `shr' here
2022-06-08 22:59:53 +00:00
(require 'shr) ; `shr-string-pixel-width'
(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 (shr-string-pixel-width rest))
(str (propertize " " 'display `(space :align-to (- right (,hpos))))))
`((align-right menu-item ,str ignore))))
2022-04-20 15:44:51 +00:00
2022-01-16 21:54:00 +00:00
;;; Menu bar
;; stole from https://github.com/emacs-mirror/emacs/blob/master/lisp/tab-bar.el
(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)))
2022-02-01 21:06:03 +00:00
(defcustom +tab-bar-menu-bar-icon " Emacs "
"The string to use for the tab-bar menu icon."
:type 'string)
2022-01-16 21:54:00 +00:00
(defun +tab-bar-format-menu-bar ()
"Produce the Menu button for the tab bar that shows the menu bar."
2022-02-01 21:06:03 +00:00
`((menu-bar menu-item (propertize +tab-bar-menu-bar-icon 'face '+tab-bar-extra)
2022-01-16 21:54:00 +00:00
+tab-bar-menu-bar :help "Menu Bar")))
;;; Tab bar format tabs
(require 'el-patch)
2022-01-18 23:18:06 +00:00
(el-patch-feature tab-bar)
(with-eval-after-load 'tab-bar
(el-patch-defun tab-bar--format-tab (tab i)
2022-05-13 03:37:16 +00:00
"Format TAB using its index I and return the result as a keymap."
(append
(el-patch-remove
`((,(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)
2022-06-08 22:59:53 +00:00
ignore
:help "Current tab")))
2022-05-13 03:37:16 +00:00
(t
`((,(intern (format "tab-%i" i))
2022-06-08 22:59:53 +00:00
menu-item
,(funcall tab-bar-tab-name-format-function tab i)
,(alist-get 'binding tab)
:help "Click to visit tab"))))
2022-05-13 03:37:16 +00:00
(when (alist-get 'close-binding tab)
`((,(if (eq (car tab) 'current-tab) 'C-current-tab (intern (format "C-tab-%i" i)))
2022-06-08 22:59:53 +00:00
menu-item ""
,(alist-get 'close-binding tab)))))))
2022-01-16 21:54:00 +00:00
2022-01-11 05:44:45 +00:00
;; Emacs 27
(defun +tab-bar-misc-info-27 (output &rest _)
"Display `mode-line-misc-info' in the `tab-bar' on Emacs 27.
This is :filter-return advice for `tab-bar-make-keymap-1'."
(let* ((reserve (length (format-mode-line mode-line-misc-info)))
(str (propertize " "
'display `(space :align-to (- right (- 0 right-margin)
,reserve)))))
(prog1 (append output
2022-05-13 03:37:16 +00:00
`((align-right menu-item ,str nil))
2022-06-08 22:59:53 +00:00
(+tab-bar-misc-info)))))
2022-01-11 05:44:45 +00:00
;; Emacs 28
(defvar +tab-bar-format-original nil
"Original value of `tab-bar-format'.")
(defun +tab-bar-misc-info-28 ()
"Display `mode-line-misc-info', right-aligned, on Emacs 28."
(append (unless (memq 'tab-bar-format-align-right tab-bar-format)
'(tab-bar-format-align-right))
'(+tab-bar-misc-info)))
(define-minor-mode +tab-bar-misc-info-mode
"Show the `mode-line-misc-info' in the `tab-bar'."
:lighter ""
2022-06-08 22:59:53 +00:00
:global t
(if +tab-bar-misc-info-mode
(progn ; Enable
(setq +tab-bar-show-original tab-bar-show)
(cond
((boundp 'tab-bar-format) ; Emacs 28
(setq +tab-bar-format-original tab-bar-format)
(unless (memq '+tab-bar-misc-info tab-bar-format)
(setq tab-bar-format
(append tab-bar-format (+tab-bar-misc-info-28)))))
((fboundp 'tab-bar-make-keymap-1) ; Emacs 27
(advice-add 'tab-bar-make-keymap-1 :filter-return
'+tab-bar-misc-info-27)))
(setq tab-bar-show t))
(progn ; Disable
(setq tab-bar-show +tab-bar-show-original)
(cond
((boundp 'tab-bar-format) ; Emacs 28
(setq tab-bar-format +tab-bar-format-original))
((fboundp 'tab-bar-make-keymap-1) ; Emacs 27
(advice-remove 'tab-bar-make-keymap-1 '+tab-bar-misc-info-27))))))
2022-01-11 05:44:45 +00:00
(provide '+tab-bar)
;;; +tab-bar.el ends here