;;; +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: (require 'acdw) (require 'tab-bar) (defface +tab-bar-extra '((t :inherit (tab-bar font-lock-comment-face))) "Tab bar face for extra information, like the menu-bar and time." :group 'basic-faces) ;; Common (defun +tab-bar-space (&optional n) "Display a space N characters long, or 1." `((space menu-item ,(+string-repeat (or n 1) " ") ignore))) (defun +tab-bar-misc-info () "Display `mode-line-misc-info', formatted for the tab-bar." `((misc-info menu-item ,(string-trim-right (format-mode-line mode-line-misc-info)) ignore))) (defcustom +tracking-hide-when-org-clocking nil "Hide the `tracking-mode' information when clocked in." :type 'boolean) (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 ;; 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))))))) (defun +tab-bar-timer () "Display `+timer-string' in the tab-bar." (when (> (length (bound-and-true-p +timer-string)) 0) `((timer-string menu-item ,(concat " " +timer-string) (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 "")))))))) (defun +tab-bar-date () "Display `display-time-string' in the tab-bar." (when display-time-mode `((date-time-string menu-item ,(substring-no-properties (concat " " (string-trim display-time-string))) (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))))) (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))) (next (cl-find "inbox+unread" counts :key (lambda (l) (plist-get l :name)) :test 'equal)) (next-count (plist-get next :count))) (when (and next-count (> next-count 0)) `((notmuch-count menu-item ,(format " |%s|" next-count) ignore :help ,(format "%s mails requiring attention." next-count))))))) (defun +tab-bar-org-clock () "Display `org-mode-line-string' in the tab-bar." (when (and (fboundp 'org-clocking-p) (org-clocking-p)) ;; org-mode-line-string `((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"))))) (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) emms-player-playing-p) (let ((now-playing (+string-truncate (emms-mode-line-playlist-current) (- +tab-bar-emms-max-length 2)))) `(emms-now-playing menu-item ,(concat "{" now-playing "}" " ") emms-pause ( :help ,(emms-mode-line-playlist-current)))))) (defun +tab-bar-bongo () "Display Bongo now playing information." (when-let ((modep (bound-and-true-p bongo-mode-line-indicator-mode)) (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)))) `((bongo-now-playing menu-item ,(concat "{" (let ((bongo-field-separator "")) (+string-truncate (replace-regexp-in-string "\\(.*\\)\\(.*\\)\\(.*\\)" "\\1: \\3" (bongo-formatted-infoset)) ;; This isn't right (- (min 50 (/ (frame-width) 3 )) 2))) "}") (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))))) (defvar +tab-bar-show-original nil "Original value of `tab-bar-show'.") (defun +tab-bar-basename () "Generate the tab name from the basename of the buffer of the selected window." (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))))) ;;; FIXME this doesn't work... ;; (defvar +tab-bar-tab-min-width 8 ;; "Minimum width of a tab on the tab bar.") ;; (defvar +tab-bar-tab-max-width 24 ;; "Maximum width of a tab on the tab bar.") ;; (defun +tab-bar-fluid-calculate-width () ;; "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 () ;; "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)))) (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 (max 0 (- l-name tab-bar-tab-name-truncated-max l-ell)))) 'help-echo tab-name)))) (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 (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)))) ;;; 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))) (defcustom +tab-bar-menu-bar-icon " Emacs " "The string to use for the tab-bar menu icon." :type 'string) (defun +tab-bar-format-menu-bar () "Produce the Menu button for the tab bar that shows the menu bar." `((menu-bar menu-item (propertize +tab-bar-menu-bar-icon 'face '+tab-bar-extra) +tab-bar-menu-bar :help "Menu Bar"))) ;;; Tab bar format tabs (require 'el-patch) (el-patch-feature tab-bar) (with-eval-after-load 'tab-bar (el-patch-defun tab-bar--format-tab (tab i) "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) 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))))))) ;; 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 `((align-right menu-item ,str nil)) (+tab-bar-misc-info))))) ;; 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 "" :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)))))) (provide '+tab-bar) ;;; +tab-bar.el ends here