From aab5bfd074e57d06a79e39d7c7c4760e1f385a06 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Mon, 17 Oct 2022 21:41:28 -0500 Subject: Bankruptcy 9 --- lisp/+tab-bar.el | 394 ------------------------------------------------------- 1 file changed, 394 deletions(-) delete mode 100644 lisp/+tab-bar.el (limited to 'lisp/+tab-bar.el') diff --git a/lisp/+tab-bar.el b/lisp/+tab-bar.el deleted file mode 100644 index 6c9debd..0000000 --- a/lisp/+tab-bar.el +++ /dev/null @@ -1,394 +0,0 @@ -;;; +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 format-mode-line-unescaping (construct) - "Return a mode-line construct as a string, but unescape `%'s." - (format-mode-line - (cond ((listp construct) - (cl-loop for item in construct - collect (cond ((stringp item) - (string-replace "%" "%%" item)) - ((and (listp item) (eq :propertize (car item))) - (format-mode-line-unescaping item)) - (t item)))) - ((stringp construct) (string-replace "%" "%%" construct)) - (t construct)))) - -(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-unescaping 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 -- cgit 1.4.1-21-gabe81