;;; +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 '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-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 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-date ()
  "Display `display-time-string' in the tab-bar."
  (when display-time-mode
    `((date-time-string menu-item
                        ,(propertize (concat " " display-time-string))
                        ignore
                        :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" 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
