path: root/lisp/+modeline.el

;;; +modeline.el --- my modeline customizations -*- lexical-binding: t; -*-

;;; Commentary:

;; `+modeline.el' is kind of a dumping ground for various
;; modeline-related functions.  I probably don't use everything in
;; here.  Credit given where possible.

;;; Code:

(require '+util)
(require 'simple-modeline)
(require 'minions)

(defgroup +modeline nil
  "Various customization options for my modeline things."
  :prefix "+modeline-"
  :group 'simple-modeline)

(defcustom +modeline-default-spacer " "
  "Default spacer to use for modeline elements.
All modeline elements take an optional argument, `spacer', which
will default to this string.")

;;; Combinators

(defun +modeline-concat (segments &optional separator)
  "Concatenate multiple functional modeline SEGMENTS.
Each segment in SEGMENTS is a function returning a mode-line
construct.

Segments are separated using SEPARATOR, which defaults to
`+modeline-default-spacer'.  Only segments that evaluate to a
non-zero-length string will be separated, for a cleaner look.

This function returns a lambda that should be `:eval'd or
`funcall'd in a mode-line context."
  (let ((separator (or separator +modeline-default-spacer)))
    (lambda ()
      (let (this-sep result)
        (dolist (segment segments)
          (let ((segstr (funcall segment this-sep)))
            (when (and segstr
                       (not (equal segstr "")))
              (push segstr result)
              (setq this-sep separator))))
        (apply #'concat
               (nreverse result))))))

(defun +modeline-spacer (&optional n spacer &rest strings)
  "Make an N-length SPACER, or prepend SPACER to STRINGS.
When called with no arguments, insert `+modeline-default-spacer'.
N will repeat SPACER N times, and defaults to 1.  SPACER defaults
to `+modeline-default-spacer', but can be any string.  STRINGS
should form a mode-line construct when `concat'ed."
  (declare (indent 2))
  (let ((spacer (or spacer +modeline-default-spacer))
        (n (or n 1))
        (strings (cond((null strings) '(""))
                      ((equal strings '("")) nil)
                      ((atom strings) (list strings))
                      (t strings)))
        r)
    (when strings (dotimes (_ n) (push spacer r)))
    (apply #'concat (apply #'concat r) strings)))

;;; Modeline segments

(defun +modeline-sanitize-string (string)
  "Sanitize a string for `format-mode-line'."
  (when string
    (string-replace "%" "%%" string)))

(defcustom +modeline-buffer-name-max-length 0
  "Maximum length of `+modeline-buffer-name'.
If > 0 and < 1, use that portion of the window's width.  If > 1,
use that many characters.  If anything else, don't limit.  If the
buffer name is longer than the max length, it will be shortened
and appended with `truncate-string-ellipsis'."
  :type '(choice (const :tag "No maximum length" 0)
                 (natnum :tag "Number of characters")
                 (float :tag "Fraction of window's width")))

(defcustom +modeline-buffer-position nil
  "What to put in the `+modeline-buffer-name' position."
  :type 'function
  :local t)

(defun +modeline-buffer-name (&optional spacer)         ; gonsie
  "Display the buffer name."
  (let ((bufname (string-trim (string-replace "%" "" (buffer-name)))))
    (+modeline-spacer nil spacer
      (if (and +modeline-buffer-position (fboundp +modeline-buffer-position))
          (funcall +modeline-buffer-position)
        (propertize (cond
                     ((ignore-errors
                        (and (> +modeline-buffer-name-max-length 0)
                             (< +modeline-buffer-name-max-length 1)))
                      (truncate-string-to-width bufname
                                                (* (window-total-width)
                                                   +modeline-buffer-name-max-length)
                                                nil nil t))
                     ((ignore-errors
                        (> +modeline-buffer-name-max-length 1))
                      (truncate-string-to-width bufname
                                                +modeline-buffer-name-max-length
                                                nil nil t))
                     (t bufname))
                    'help-echo (or (buffer-file-name)
                                   (buffer-name))
                    'mouse-face 'mode-line-highlight)))))

(defcustom +modeline-minions-icon "&"
  "The \"icon\" for `+modeline-minions' button."
  :type 'string)

(defun +modeline-minions (&optional spacer)
  "Display a button for `minions-minor-modes-menu'."
  (+modeline-spacer nil spacer
    (propertize
     +modeline-minions-icon
     'help-echo "Minor modes menu\nmouse-1: show menu."
     'local-map (purecopy (simple-modeline-make-mouse-map
                           'mouse-1
                           (lambda (event)
                             (interactive "e")
                             (with-selected-window
                                 (posn-window (event-start event))
                               (minions-minor-modes-menu)))))
     'mouse-face 'mode-line-highlight)))

(defcustom +modeline-major-mode-faces '((text-mode . font-lock-string-face)
                                        (prog-mode . font-lock-keyword-face)
                                        (t . font-lock-warning-face))
  "Mode->face mapping for `+modeline-major-mode'.
If the current mode is derived from the car of a cell, the face
in the cdr will be applied to the major-mode in the mode line."
  :type '(alist :key-type function
                :value-type face))

(defun +modeline-major-mode (&optional spacer)
  "Display the current `major-mode'."
  (+modeline-spacer nil spacer
    "("
    (propertize ;; (+string-truncate (format-mode-line mode-name) 16)
     (format-mode-line mode-name)
     'face (when (actually-selected-window-p)
               ;; XXX: This is probably really inefficient.  I need to
               ;; simply detect which mode it's in when I change major
               ;; modes (`change-major-mode-hook') and change the face
               ;; there, probably.
               (catch :done (dolist (cel +modeline-major-mode-faces)
                              (when (derived-mode-p (car cel))
                                (throw :done (cdr cel))))
                      (alist-get t +modeline-major-mode-faces)))
     'keymap (let ((map (make-sparse-keymap)))
               (bindings--define-key map [mode-line down-mouse-1]
                 `(menu-item "Menu Bar" ignore
                             :filter ,(lambda (_) (mouse-menu-major-mode-map))))
               (define-key map [mode-line mouse-2] 'describe-mode)
               (bindings--define-key map [mode-line down-mouse-3]
                 `(menu-item "Minions" minions-minor-modes-menu))
               map)
     'help-echo (+concat (list (format-mode-line mode-name) " mode")
                         "mouse-1: show menu"
                         "mouse-2: describe mode"
                         "mouse-3: display minor modes")
     'mouse-face 'mode-line-highlight)
    ")"))

(defcustom +modeline-modified-icon-alist '((ephemeral . "*")
                                           (readonly . "=")
                                           (modified  . "+")
                                           (special . "~")
                                           (t . "-"))
  "\"Icons\" to display depending on buffer status in modeline.
The CAR of each field is one of `readonly', `modified',
`special', `ephemeral', or t, and the CDR is a string to display
in that mode.

`readonly' is true if the buffer is read-only and visiting a file.
`modified' is true if the buffer is modified.
`special' is true if the buffer is a special-mode or derived buffer.
`ephemeral' is true if the buffer is not visiting a file.
t is the fall-back, shown when nothing else in the alist applies.

The order of elements matters: whichever one matches first is applied."
  :type '(alist :key-type symbol
                :value-type string)
  :options '("readonly" "modified" "special" "t"))

(defcustom +modeline-modified-icon-special-modes '(special-mode)
  "Modes to apply the `special-mode' icon to in the
`+modeline-modified'."
  :type '(repeat function))

(defun +modeline-modified (&optional spacer) ; modified from `simple-modeline-status-modified'
  "Display a color-coded \"icon\" indicator for the buffer's status."
  (let* ((icon (catch :icon
                 (dolist (cell +modeline-modified-icon-alist)
                   (when (pcase (car cell)
                           ('ephemeral (not (buffer-file-name)))
                           ('readonly buffer-read-only)
                           ('modified (buffer-modified-p))
                           ('special
                            (apply 'derived-mode-p
                                   +modeline-modified-icon-special-modes))
                           ('t t)
                           (_ nil))
                     (throw :icon cell))))))
    (+modeline-spacer nil spacer
      (propertize (or (cdr-safe icon) "")
                  'help-echo (format "Buffer \"%s\" is %s."
                                     (buffer-name)
                                     (pcase (car-safe icon)
                                       ('t "unmodified")
                                       ('nil "unknown")
                                       (_ (car-safe icon))))))))

(defun +modeline-narrowed (&optional spacer)
  "Display an indication that the buffer is narrowed."
  (when (buffer-narrowed-p)
    (+modeline-spacer nil spacer
      (propertize "N"
                  'help-echo (format "%s\n%s"
                                     "Buffer is narrowed."
                                     "mouse-2: widen buffer.")
                  'local-map (purecopy (simple-modeline-make-mouse-map
                                        'mouse-2 'mode-line-widen))
                  'face 'font-lock-doc-face
                  'mouse-face 'mode-line-highlight))))

(defun +modeline-reading-mode (&optional spacer)
  "Display an indication that the buffer is in `reading-mode'."
  (when reading-mode
    (+modeline-spacer nil spacer
      (propertize
       (concat "R" (when (bound-and-true-p +eww-readable-p) "w"))
       'help-echo (format "%s\n%s"
                          "Buffer is in reading-mode."
                          "mouse-2: disable reading-mode.")
       'local-map (purecopy
                   (simple-modeline-make-mouse-map
                    'mouse-2 (lambda (ev)
                               (interactive "e")
                               (with-selected-window
                                   (posn-window
                                    (event-start ev))
                                 (reading-mode -1)
                                 (force-mode-line-update)))))
       'face 'font-lock-doc-face
       'mouse-face 'mode-line-highlight))))

(define-minor-mode file-percentage-mode
  "Toggle the percentage display in the mode line (File Percentage Mode)."
  :init-value t :global t :group 'mode-line)

(defun +modeline--percentage ()
  "Return point's progress through current file as a percentage."
  (let ((tot (count-screen-lines (point-min) (point-max) :ignore-invisible)))
    (floor (* 100 (/ (float (line-number-at-pos)) tot)))))

(defun +modeline--buffer-contained-in-window-p ()
  "Whether the buffer is totally contained within its window."
  (let ((window-min (save-excursion (move-to-window-line 0) (point)))
        (window-max (save-excursion (move-to-window-line -1) (point))))
    (and (<= window-min (point-min))
         (>= window-max (point-max)))))

(defun +modeline-file-percentage (&optional spacer)
  "Display the position in the current file."
  (when file-percentage-mode
    ;; (let ((perc (+modeline--percentage)))
    ;;   (propertize (+modeline-spacer nil spacer
    ;;                       (cond
    ;;                        ((+modeline--buffer-contained-in-window-p) "All")
    ;;                        ((= (line-number-at-pos) (line-number-at-pos (point-min))) "Top")
    ;;                        ((= (line-number-at-pos) (line-number-at-pos (point-max))) "Bot")
    ;;                        ;; Why the 10 %s?  Not sure.  `format' knocks them
    ;;                        ;; down to 5, then `format-mode-line' kills all but
    ;;                        ;; two.  If I use only 8, the margin is much too
    ;;                        ;; large.  Something else is obviously going on, but
    ;;                        ;; I'm at a loss as to what it could be.
    ;;                        (t (format "%d%%%%%%%%%%" perc))))
    ;;               ;; TODO: add scroll-up and scroll-down bindings.
    ;;               ))
    (let ((perc (format-mode-line '(-2 "%p"))))
      (+modeline-spacer nil spacer
        "/"
        (pcase perc
          ("To" "Top")
          ("Bo" "Bot")
          ("Al" "All")
          (_ (format ".%02d" (string-to-number perc))))))))

(defun +modeline-file-percentage-ascii-icon (&optional spacer)
  (when file-percentage-mode
    (+modeline-spacer nil spacer
      (let ((perc (format-mode-line '(-2 "%p"))))
       (pcase perc
         ("To" "/\\")
         ("Bo" "\\/")
         ("Al" "[]")
         (_ (let ((vec (vector "/|" "//" "||" "\\\\" "\\|" "\\|"))
                  (perc (string-to-number perc)))
              (aref vec (floor (/ perc 17))))))))))

(defun +modeline-file-percentage-icon (&optional spacer)
  "Display the position in the current file as an icon."
  (when file-percentage-mode
    (let ((perc (+modeline--percentage)))
      (propertize (+modeline-spacer nil spacer
                    (cond
                     ((+modeline--buffer-contained-in-window-p) "111")
                     ((= perc 0)   "000")
                     ((< perc 20)  "001")
                     ((< perc 40)  "010")
                     ((< perc 60)  "011")
                     ((< perc 80)  "100")
                     ((< perc 100) "101")
                     ((>= perc 100) "110")))
                  'help-echo (format "Point is %d%% through the buffer."
                                     perc)))))

(define-minor-mode region-indicator-mode
  "Toggle the region indicator in the mode line."
  :init-value t :global t :group 'mode-line)

(defun +modeline-region (&optional spacer)
  "Display an indicator if the region is active."
  (when (and region-indicator-mode
             (region-active-p))
    (+modeline-spacer nil spacer
      (propertize (format "%d%s"
                          (apply '+ (mapcar (lambda (pos)
                                              (- (cdr pos)
                                                 (car pos)))
                                            (region-bounds)))
                          (if (and (< (point) (mark))) "-" "+"))
                  'font-lock-face 'font-lock-variable-name-face))))

(defun +modeline-line (&optional spacer)
  (when line-number-mode
    (+modeline-spacer nil spacer
      "%l")))

(defun +modeline-column (&optional spacer)
  (when column-number-mode
    (+modeline-spacer nil spacer
      "|"
      (if column-number-indicator-zero-based "%2c" "%2C"))))

(defcustom +modeline-position-function nil
  "Function to use instead of `+modeline-position' in modeline."
  :type '(choice (const :tag "Default" nil)
                 function)
  :local t)

(defun +modeline-position (&optional spacer)
  "Display the current cursor position.
See `line-number-mode', `column-number-mode', and
`file-percentage-mode'.  If `+modeline-position-function' is set
to a function in the current buffer, call that function instead."
  (cond ((functionp +modeline-position-function)
         (+modeline-spacer nil spacer
           (funcall +modeline-position-function)))
        (t (funcall (+modeline-concat '(+modeline-region
                                        +modeline-line
                                        +modeline-column
                                        +modeline-file-percentage)
                                      "")))))

(defun +modeline-vc (&optional spacer)
  "Display the version control branch of the current buffer in the modeline."
  ;; from https://www.gonsie.com/blorg/modeline.html, from Doom
  (if-let ((backend (vc-backend buffer-file-name)))
      (+modeline-spacer nil spacer
        (substring vc-mode (+ (if (eq backend 'Hg) 2 3) 2)))
    ""))

(defun +modeline-track (&optional spacer)
  "Display `tracking-mode' information."
  (when tracking-mode
    tracking-mode-line-buffers))

(defun +modeline-anzu (&optional spacer)
  "Display `anzu--update-mode-line'."
  (+modeline-spacer nil spacer
    (anzu--update-mode-line)))

(defun +modeline-text-scale (&optional spacer)
  "Display text scaling level."
  ;; adapted from https://github.com/seagle0128/doom-modeline
  (when (and (boundp 'text-scale-mode-amount)
             (/= text-scale-mode-amount 0))
    (format (if (> text-scale-mode-amount 0) "%s(%+d)" "%s(%-d)")
            (or spacer +modeline-default-spacer)
            text-scale-mode-amount)))

(defun +modeline-ace-window-display (&optional spacer)
  "Display `ace-window-display-mode' information in the modeline."
  (when (and +ace-window-display-mode
             ace-window-mode)
    (+modeline-spacer nil spacer
      (window-parameter (selected-window) 'ace-window-path))))

(defun +modeline-god-mode (&optional spacer)
  "Display an icon when `god-mode' is active."
  (when (and (boundp 'god-local-mode) god-local-mode)
    (+modeline-spacer nil spacer
      (propertize "Ω"
                  'help-echo (concat "God mode is active."
                                     "\nmouse-1: exit God mode.")
                  'local-map (purecopy
                              (simple-modeline-make-mouse-map
                               'mouse-1 (lambda (e)
                                          (interactive "e")
                                          (with-selected-window
                                              (posn-window
                                               (event-start e))
                                            (god-local-mode -1)
                                            (force-mode-line-update)))))
                  'mouse-face 'mode-line-highlight))))

(defun +modeline-input-method (&optional spacer)
  "Display which input method is active."
  (when current-input-method
    (+modeline-spacer nil spacer
      (propertize current-input-method-title
                  'help-echo (format
                              (concat "Current input method: %s\n"
                                      "mouse-1: Describe current input method\n"
                                      "mouse-3: Toggle input method")
                              current-input-method)
                  'local-map (purecopy
                              (let ((map (make-sparse-keymap)))
                                (define-key map [mode-line mouse-1]
                                  (lambda (e)
                                    (interactive "e")
                                    (with-selected-window (posn-window (event-start e))
                                      (describe-current-input-method))))
                                (define-key map [mode-line mouse-3]
                                  (lambda (e)
                                    (interactive "e")
                                    (with-selected-window (posn-window (event-start e))
                                      (toggle-input-method nil :interactive))))
                                map))
                  'mouse-face 'mode-line-highlight))))

(defface +modeline-kmacro-indicator '((t :foreground "Firebrick"))
  "Face for the kmacro indicator in the modeline.")

(defun +modeline-kmacro-indicator (&optional spacer)
  "Display an indicator when recording a kmacro."
  (when defining-kbd-macro
    (+modeline-spacer nil spacer
      (propertize "●"
                  'face '+modeline-kmacro-indicator
                  'help-echo (format (concat "Defining a macro\n"
                                             "Current step: %d\n"
                                             "mouse-1: Stop recording")
                                     kmacro-counter)
                  'local-map (purecopy (simple-modeline-make-mouse-map
                                        'mouse-1 (lambda (e)
                                                   (interactive "e")
                                                   (with-selected-window
                                                       (posn-window (event-start e))
                                                     (kmacro-end-macro nil)))))
                  'mouse-face 'mode-line-highlight))))

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