path: root/modeline.el

;;; modeline.el --- Configurations for the mode line.  -*- lexical-binding: t; -*-

;; Copyright (C) 2021  李俊緯

;; Author: 李俊緯 <mmemmew@gmail.com>
;; Keywords: emulations, tools

;; This program 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.

;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This configures my mode line.

;;; Code:

(defvar modeline-right-offset 6
  "An offset to adjust the modeline alignment.")

;;;###autoload
(defun modeline-format-main ()
  "The main mode line format."
  (let* ((left (modeline-format-left))
         (right (string-trim-right (modeline-format-right)))
         (left-len (string-pixel-width left))
         (right-len (string-pixel-width right))
         (middle (propertize
                  (string 32)
                  'display
                  (list
                   'space
                   :width
                   (list
                    (- (window-pixel-width) left-len right-len
                       (- modeline-right-offset)))))))
    (concat left middle right)))

(setq-default mode-line-format '("%e" (:eval (modeline-format-main))))

;;;###autoload
(defun modeline-format-dashboard ()
  "The mode line format for the dashboard."
  (let* ((left (modeline-dashboard-format-left))
         (right (string-trim-right (modeline-dashboard-format-right)))
         (left-len (string-pixel-width left))
         (right-len (string-pixel-width right))
         (middle (propertize
                  (string 32)
                  'display
                  (list
                   'space
                   :width
                   (list
                    (- (window-pixel-width) left-len right-len
                       (- modeline-right-offset)))))))
    (concat left middle right)))

;;;###autoload
(defun modeline-dashboard-format-left ()
  "The left / main part of the mode line for the dashboard."
  (concat
   (modeline-spc)
   (modeline-format-buffer-status)
   (modeline-spc)
   (modeline-format-buffer-name)
   (modeline-spc)
   (modeline-format-keycast)
   (modeline-spc)
   (modeline-format-minor-modes)))

;;;###autoload
(defun modeline-dashboard-format-right ()
  "The right part of the mode line for the dashboard."
  (declare (side-effect-free t) (pure t))
  (let ((face (cond ((modeline-active-window-p)
                     'durand-major-global-mode)
                    ('mode-line-inactive))))
    (concat
     (modeline-propertize
      (format-mode-line global-mode-string face)))))

;;;###autoload
(defun modeline-format-gnus ()
  "The mode line format for GNUS."
  (let* ((left (modeline-gnus-format-left))
         (right (string-trim-right (modeline-format-right)))
         (left-len (string-pixel-width left))
         (right-len (string-pixel-width right))
         (middle (propertize
                  (string 32)
                  'display
                  (list
                   'space
                   :width
                   (list
                    (- (window-pixel-width) left-len right-len
                       (- modeline-right-offset)))))))
    (concat left middle right)))

(defun modeline-gnus-format-left ()
  "The left part of the mode line for GNUS."
  (declare (side-effect-free t) (pure t))
  (concat
   (modeline-spc)
   (modeline-format-buffer-name)
   (modeline-spc)
   (modeline-format-keycast)
   (modeline-spc)
   (modeline-format-minor-modes)))

;;;###autoload
(defun modeline-format-left ()
  "The left mode line format."
  (concat
   (modeline-spc)
   (modeline-format-buffer-status)
   (modeline-spc)
   (modeline-format-buffer-name)
   (modeline-spc)
   (modeline-format-position)
   (modeline-spc)
   (modeline-format-buffer-size)
   (modeline-spc)
   (modeline-format-keycast)
   (modeline-spc)
   (modeline-format-minor-modes)))

;;;###autoload
(defun modeline-format-right ()
  "The right mode line format."
  (concat
   (modeline-format-input-method)
   (modeline-format-major-mode)
   (modeline-format-vc-mode)))

;;; Toggle modeline

(defvar-local modeline-alt-format nil
  "The variable to store the original mode line format, so that we
can toggle back the format later on.")

(defun modeline-toggle ()
  "Toggle the display of the mode line."
  (interactive)
  (cond
   ((null modeline-alt-format)
    (setq-local modeline-alt-format mode-line-format)
    (setq-local mode-line-format nil))
   (t
    (setq-local mode-line-format modeline-alt-format)
    (setq-local modeline-alt-format nil))))

(define-key global-map (vector 3 ?T) #'modeline-toggle)

;;; Calculate the correct lengths of characters

;;;###autoload
(defun modeline-length (str)
  "Return the length of STR.
Characters that take up more than one column will be counted with
1.7 columns."
  (declare (side-effect-free t) (pure t)
           (obsolete string-width "2021-12-19 13:51:30.332234"))
  (let ((len 0))
    (mapc (lambda (char)
            (let ((name (get-char-code-property char 'name))
                  (decomposition (get-char-code-property char 'decomposition)))
              (cond
               ((or (and
                     (stringp name)
                     (string-match (rx-to-string '(seq bos "CJK"))
                                   name))
                    (eq (car decomposition) 'wide))
                (setq len (+ len 1.7)))
               ((setq len (1+ len))))))
          str)
    (floor len)))

;;; Correct truncation

(defun modeline-truncate (str limit &optional ellipsis)
  "Truncate the string STR to no longer than LIMIT columns.
ELLIPSIS has the same meaning as for `truncate-string-to-width'.

This function calculates widths by `string-pixel-width.'"
  (setq ellipsis
        (cond ((or (null ellipsis) (stringp ellipsis)) ellipsis)
              ((truncate-string-ellipsis))))
  (let* ((substring-list (string-glyph-split str))
         (str-len (length str))
         (str-pixels (string-pixel-width str))
         (ellipsis-pixels
          (cond (ellipsis (string-pixel-width ellipsis)) (0)))
         (column 0)
         (idx 0)
         (space-width (string-pixel-width (string #x20)))
         (limit (* space-width limit))
         last-column last-idx temp-str)
    (with-current-buffer (get-buffer-create
                          " *modeline-truncate-to-pixels*")
      (when (bound-and-true-p display-line-numbers-mode)
        (display-line-numbers-mode -1))
      (delete-region (point-min) (point-max))
      (setq line-prefix nil)
      (setq wrap-prefix nil)
      (cond ((and (< limit str-pixels)
                  (< ellipsis-pixels str-pixels))
             (setq limit (- limit ellipsis-pixels)))
            ((setq ellipsis (string))))
      (condition-case nil
          (while (< column limit)
            (setq last-column column)
            (setq last-idx idx)
            (setq temp-str (nth idx substring-list))
            (insert (propertize
                     temp-str
                     'line-prefix nil 'wrap-prefix nil))
            (setq column (car (buffer-text-pixel-size nil nil t)))
            (setq idx (+ idx (length temp-str))))
        (t (setq idx str-len)))
      (cond
       ((> column limit)
        (setq column last-column)
        (setq idx last-idx)))
      (concat (substring str 0 idx) ellipsis))))

;;; Conveniently add text properties

;;;###autoload
(defmacro modeline-propertize (str &optional mouse-face help-echo map)
  "Give STR appropriate text properties.
MOUSE-FACE is used when the mouse is over the text.
HELP-ECHO is the additional information displayed when the mouse is over the text.
MAP is the local keymap of the text."
  (let ((mouse-face (or mouse-face 'mode-line-highlight))
        (help-echo-form (cond (help-echo (list (quote 'help-echo) help-echo))))
        (map-form (cond (map (list (quote 'local-map) map)))))
    (append
     `(propertize ,str
       'mouse-face ',mouse-face)
     help-echo-form
     map-form)))

;;; Determination of the active mode-line

;; NOTE: I tried to avoid this, but it turns out that this is the most
;; reliable way to do so.

;; NOTE: Emacs-29 adds the function `mode-line-window-selected-p'
;; which does what I manually implemented here.

;; ;;;###autoload
;; (defun modeline-get-active-window (&optional frame)
;;   "The active window excluding the child windows."
;;   (cond
;;    ((and (fboundp #'frame-parent) (frame-parent frame))
;;     (frame-selected-window (frame-parent frame)))
;;    ((frame-selected-window frame))))

;; ;;;###autoload
;; (defvar modeline-active-window (modeline-get-active-window)
;;   "The active window excluding the child windows.")

(defalias #'modeline-active-window-p #'mode-line-window-selected-p)

;; ;;;###autoload
;; (defun modeline-active-window-p ()
;;   "Whether we are in the active window."
;;   (and modeline-active-window
;;        (eq modeline-active-window (selected-window))))

;; ;;;###autoload
;; (defun modeline-set-active-window (&rest _)
;;   "Update `modeline-active-window'."
;;   (let ((active-wn (modeline-get-active-window)))
;;     (cond
;;      ((minibuffer-window-active-p active-wn))
;;      (t (setq modeline-active-window active-wn))))
;;   (force-mode-line-update t))

;; ;;;###autoload
;; (defsubst modeline-unset-active-window (&rest _)
;;   "Set `modeline-active-window' to `nil'."
;;   (setq modeline-active-window nil))

;; ;;;###autoload
;; (defun modeline-refresh-modeline ()
;;   "Refresh the focus state of the mode line."
;;   (setq modeline-active-window nil)
;;   (mapc (lambda (frame)
;;           (cond ((eq (frame-focus-state frame) t)
;;                  (setq modeline-active-window (modeline-get-active-window frame)))))
;;         (frame-list)))

;; (add-hook 'window-configuration-change-hook #'modeline-set-active-window)
;; (add-hook 'buffer-list-update-hook #'modeline-set-active-window)
;; (add-hook 'after-make-frame-functions #'modeline-set-active-window)
;; (add-hook 'delete-frame-functions #'modeline-set-active-window)
;; (advice-add #'handle-switch-frame :after #'modeline-set-active-window)
;; (add-function :after after-focus-change-function #'modeline-refresh-modeline)

;;; Faces

;; NOTE: These faces are not actually defined here.
;;       They are found here simply because they need to have a formal declaration to work.

;;;###autoload
(defface doom-modeline-buffer-modified nil
  "The face for mode line buffer identification.")

;;;###autoload
(defface doom-modeline-warning nil
  "The face for mode line warning.")

;;;###autoload
(defface doom-modeline-urgent nil
  "The face for mode line urgent.")

;;;###autoload
(defface doom-modeline-info nil
  "The face for mode line info.")

;;;###autoload
(defface doom-modeline-buffer-major-mode nil
  "The face for mode line major mode.")

;;;###autoload
(defface doom-modeline-input-method nil
  "The face for mode line input method.")

;;;###autoload
(defface doom-modeline-input-method-alt nil
  "The alternative face for mode line input method.")

;;; Various sections of the mode line

;;;; Directory

;;;###autoload
(defun modeline-format-directory ()
  "Display the default directory on the mode line."
  (modeline-propertize
   (propertize
    default-directory
    'face (cond ((modeline-active-window-p) 'mode-line)
                (t 'mode-line-inactive)))
   nil "The current directory\nmouse-1: Open that directory"
   (let ((map '(keymap)))
     (define-key map (vector 'mode-line 'down-mouse-1)
       (lambda () (interactive) (dired default-directory)))
     map)))

;;;; Space

;;;###autoload
(defun modeline-spc ()
  "A space with the appropriate face."
  (format-mode-line " "
                    (cond ((modeline-active-window-p)
                           'mode-line)
                          (t 'mode-line-inactive))))

;;;; Buffer status

;;;###autoload
(defun modeline-format-buffer-status ()
  "The status of the buffer displayed on the mode-line."
  (let ((active-p (modeline-active-window-p)))
    (concat
     ;; modified or not
     (cond ((and buffer-file-name (buffer-modified-p))
            (format-mode-line "M" (cond
                                   (active-p
                                    (modus-themes-with-colors
                                      `(:foreground
                                        ,magenta-intense))
                                    )
                                   (t 'mode-line-inactive)))))
     ;; read-only?
     (cond
      (buffer-read-only
       (format-mode-line "R" (cond
                              (active-p
                               (modus-themes-with-colors
                                 `(:foreground ,red-intense)))
                              (t 'mode-line-inactive)))))
     ;; narrow?
     (cond
      ((buffer-narrowed-p)
       (format-mode-line "N" (cond
                              (active-p 'warning)
                              (t 'mode-line-inactive))))))))

;;;; Buffer position

;;;###autoload
(defun modeline-format-position ()
  "The position of the cursor to be displayed in the mode line."
  (cond
   ((derived-mode-p 'pdf-view-mode)
    (concat
     (modeline-propertize
      (propertize
       (let* ((current (pdf-view-current-page))
              (total (pdf-info-number-of-pages)))
         (concat
          "P."
          (number-to-string current)
          "/"
          (number-to-string total)))
       'face (cond
              ((modeline-active-window-p) 'mode-line)
              (t 'mode-line-inactive)))
      nil "Current page / Total pages")))
   (t
    (modeline-propertize
     (propertize
      (let* ((lc (format-mode-line "%l:%C "))
	     (percent (format-mode-line "%p")))
        (concat
         lc
         (cond
	  ((eq (aref percent 0) 32)
	   (concat (substring percent 1) "%"))
	  ((memq (aref percent 0) (number-sequence 48 57))
	   (concat percent "%"))
	  ((> (length percent) 3)
	   (substring percent 0 3))
	  (t  percent))))
      'face (cond
	     ((modeline-active-window-p) 'mode-line)
	     (t 'mode-line-inactive)))
     nil
     "Buffer position\nmouse-1: Display Line and Column Mode Menu"
     mode-line-column-line-number-mode-map))))

;;;; Buffer size

;;;###autoload
(defun modeline-format-buffer-size ()
  "The size of the buffer to be displayed in the mode line."
  (modeline-propertize
   (format-mode-line
    (file-size-human-readable (string-to-number (format-mode-line "%i")))
    (cond
     ((modeline-active-window-p) 'mode-line)
     (t 'mode-line-inactive)))
   nil
   "Buffer size\nmouse-1: Display Line and Column Mode Menu"
   mode-line-column-line-number-mode-map))

;;;; Minor modes

;;;###autoload
(defvar modeline-minor-modes-name-len-max 150
  "The maximal length for the display of minor modes in the mode line.")

;;;###autoload
(defun modeline-format-minor-modes ()
  "Display some minor modes information."
  (declare (pure t) (side-effect-free t))
  (modeline-propertize
   (let* ((raw
           (format-mode-line
            minor-mode-alist
            (cond
             ((modeline-active-window-p) 'mode-line)
             ('mode-line-inactive))))
          (ellipsis
           (format-mode-line
            "..."
            (cond ((modeline-active-window-p) 'mode-line)
                  ('mode-line-inactive))))
          (orig (cond
                 ((and (not (string= raw ""))
                       (= (aref raw 0) 32))
                  (substring raw 1))
                 (raw))))
     (truncate-string-to-width
      orig modeline-minor-modes-name-len-max 0 nil ellipsis))
   nil
   "Minor mode
mouse-1: Display minor mode menu
mouse-2: Show help for minor mode
mouse-3: Toggle minor modes"
   mode-line-minor-mode-keymap))

;; NOTE: The minor mode menu does not work with my custom mode line.

;;;###autoload
(defun durand-mouse-minor-mode-menu (event)
  "Show minor-mode menu for EVENT on minor modes area of the mode line.
Modified for my custom mode line."
  (interactive "@e")
  (let* ((string-obj (nth 4 (car (cdr event))))
         (str (car string-obj))
         (str-pos (cdr string-obj))
         invalid indicator)
    (cond
     ((string= str "") (setq invalid t))
     ((= (aref str str-pos) 32) (setq str-pos (1+ str-pos))))
    (cond
     (invalid)
     ((= (aref str str-pos) 32))
     (t
      (let* ((orig str-pos)
             (start str-pos)
             (end str-pos))
        (while (and (>= start 0)
                   (/= (aref str start) 32))
          (setq start (1- start)))
        (while (and (< end (length str))
                   (/= (aref str end) 32))
          (setq end (1+ end)))
        (setq indicator (substring-no-properties str (1+ start) end))
        (minor-mode-menu-from-indicator indicator))))))

(advice-add 'mouse-minor-mode-menu :override #'durand-mouse-minor-mode-menu)

;;;; Keycast

(defun modeline-format-keycast ()
  "Format the keycast information."
  (declare (side-effect-free t))
  (cond
   ((bound-and-true-p durand-keycast-mode)
    (modeline-propertize
     (format-mode-line mode-line-keycast)
     nil
     "Minor mode
mouse-1: Display minor mode menu
mouse-2: Show help for minor mode
mouse-3: Toggle minor modes"
     mode-line-minor-mode-keymap))))

;;;; Buffer name 

;;;###autoload
(defvar modeline-buffer-name-len-max 40
  "The maximal length of the name of the buffer to be displayed in the mode line.")

(let ((map (make-sparse-keymap)))
  (define-key map [mode-line mouse-1] #'ibuffer)
  (setq mode-line-buffer-identification-keymap
        map))

;;;###autoload
(defun modeline-format-buffer-name ()
  "The name of the buffer truncated to `modeline-buffer-name-len-max'.
This will be displayed in the mode line."
  (declare (pure t) (side-effect-free t))
  (modeline-propertize
   (let* ((face (cond ((modeline-active-window-p) 'mode-line-buffer-id)
		      (t 'mode-line-inactive)))
          (name-max (min modeline-buffer-name-len-max
                         (floor (window-width) 2)))
          (ellipsis
           (format-mode-line
            "..."
            (cond ((modeline-active-window-p) 'mode-line)
                  ('mode-line-inactive))))
	  (orig (format-mode-line "%b" face)))
     (concat
      (format-mode-line "%[" face)
      (modeline-truncate orig name-max ellipsis)
      (format-mode-line "%]" face)))
   nil
   (concat (buffer-file-name)
           "\n"
           "mouse-1: ibuffer")
   mode-line-buffer-identification-keymap))

;;;; Major mode

(declare-function
 #'modus-themes-with-colors
 (expand-file-name
  "modus-themes.el"
  "/Users/durand/elisp_packages/protesilaos/modus-themes/")
 (&rest body) t)

(defface durand-major-global-mode
  (modus-themes-with-colors
    (list
     (list
      '((class color) (min-colors 256))
      :inherit 'mode-line-active)))
  "The face used for displaying the major mode and the global mode
string in the mode line.")

;;;###autoload
(defun modeline-format-major-mode ()
  "The major mode to display in the mode line."
  (declare (pure t) (side-effect-free t))
  (let ((face (cond ((modeline-active-window-p)
                     'durand-major-global-mode)
                    ('mode-line-inactive))))
    (concat
     (modeline-propertize
      (format-mode-line (list mode-name) face)
      nil
      "Major mode\nmouse-1: Display major mode menu\nmouse-2:\
 Show help for major mode\nmouse-3: Toggle minor modes"
      mode-line-major-mode-keymap)
     (modeline-spc)
     (modeline-propertize
      (format-mode-line global-mode-string face))
     (modeline-spc))))

;;;; VCS

;;;###autoload
(defvar-local modeline-vcs-str ""
  "Display the version control system information on the mode line.")
;;;###autoload
(defvar modeline-vcs-length-max 12
  "The maximum displayed length of the branch name of version control.")

;;;###autoload
(defun modeline-update-vcs-str (&rest _)
  "Update the version control system information to be displayed
on the mode line."
  (let ((bfn (buffer-file-name)))
    (setq
     modeline-vcs-str
     (cond
      ((and vc-mode bfn)
       (let* ((backend (vc-backend bfn))
              (state (vc-state bfn backend))
              (error-faces (list 'removed 'conflict 'unregistered))
              (face (cond
                     ((memq state '(added edited)) 'warning)
                     ((eq state 'needs-merge) 'compilation-info)
                     ((eq state 'needs-update) 'warning)
                     ((memq state error-faces) 'error)
                     ('success)))
              (indicator
               (cond
                ((memq state '(added edited))
                 (format-mode-line "* " face))
                ((eq state face)
                 (format-mode-line "? " face))
                ((eq state face)
                 (format-mode-line "! " face))
                ((memq state '(removed conflict unregistered))
                 (format-mode-line "! " face))
                (t (format-mode-line "@ " face))))
              (str (cond (vc-display-status
                          (substring vc-mode
                                     (+ (cond ((eq backend 'Hg) 2)
                                                      (t 3))
                                                2)))
                         (t ""))))
         (concat
          indicator
          (propertize
           (cond
            ((> (length str) modeline-vcs-length-max)
             (concat (substring str 0 (- modeline-vcs-length-max 3))
                     "..."))
            (t str))
           'face face))))
      (t "")))))

(add-hook 'find-file-hook #'modeline-update-vcs-str)
(add-hook 'after-save-hook #'modeline-update-vcs-str)
(advice-add #'vc-refresh-state :after #'modeline-update-vcs-str)

;;;###autoload
(defun modeline-format-vc-mode ()
  "Display version control system information on the mode line."
  (declare (pure t) (side-effect-free 'error-free))
  (cond
   ((and (stringp modeline-vcs-str)
         (not (string= modeline-vcs-str "")))
    (modeline-propertize
     (cond
      ((modeline-active-window-p) modeline-vcs-str)
      (t (propertize modeline-vcs-str 'face 'mode-line-inactive)))
     nil
     (get-text-property 1 'help-echo vc-mode)
     (get-text-property 1 'local-map vc-mode)))))

;;;; Input method

;;;###autoload
(defun modeline-format-input-method ()
  "Display the current input method on the mode line."
  (cond
   (current-input-method
    (concat
     (modeline-spc)
     (modeline-propertize
      (propertize
       current-input-method-title
       'face (cond ((modeline-active-window-p) 'compilation-info)
                   (t 'mode-line-inactive)))
      nil
      (format "Current input method: %s\nmouse-2: Disable input method\nmouse-3: Describe current input method"
              current-input-method)
      mode-line-input-method-map)
     (modeline-spc))
    )
   (t "")))

(provide 'modeline)
;;; modeline.el ends here