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 `simple-modeline'-style SEGMENTS.
SEGMENTS is a list of either modeline segment-functions (see
`simple-modeline' functions for an example of types of
functions), though it can also contain cons cells of the
form (SEGMENT . PREDICATE).

Segments are separated from each other using SEPARATOR, which
defaults to a \" \".  Only segments that evaluate to a
non-trivial string (that is, a string not equal to \"\") will be
separated, for a cleaner look.

This function makes a lambda, so you can throw it straight into
`simple-modeline-segments'."
  (setq separator (or separator +modeline-default-spacer))
  (lambda ()
    (apply #'concat
           (let (this-sep result-list)
             (dolist (segment segments)
               (push (funcall (or (car-safe segment) segment)
                              this-sep)
                     result-list)
               (if (or (cdr-safe segment)
                       (and (car result-list)
                            (not (equal (car result-list) ""))))
                   (setq this-sep separator)
                 (setq this-sep nil)))
             (unless (seq-some #'null result-list)
               (push +modeline-default-spacer result-list))
             (nreverse result-list)))))

(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) '(""))
                       ((atom strings) (list strings))
                       (t strings)))
        r)
    (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 nil
      (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 nil
    (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 nil
          "("
          (propertize ;; (+string-truncate (format-mode-line mode-name) 16)
           (format-mode-line mode-name)
           'face (if (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))
                   'mode-line-inactive)
           '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 nil
            (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 nil
            (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 nil
            (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 nil
    ;;                       (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 '(-3 "%p"))))
      (+modeline-spacer nil nil
        (pcase perc
          ((or "Top" "Bot" "All") perc)
          (_ (format ".%02d" (string-to-number (substring perc 0 2)))))))))

(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 nil
                          (cond
                           ((+modeline--buffer-contained-in-window-p) "⏹")
                           ((= perc 0)   "▇")
                           ((< perc 20)  "▆")
                           ((< perc 40)  "▅")
                           ((< perc 60)  "▄")
                           ((< perc 80)  "▃")
                           ((< perc 100) "▂")
                           ((>= perc 100) "▁")))
                  '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."
  (if (and region-indicator-mode
           (region-active-p))
      (format "%s%s"
              (or spacer +modeline-default-spacer)
              (propertize (format "%s%d"
                                  (if (and (< (point) (mark))) "-" "+")
                                  (apply '+ (mapcar (lambda (pos)
                                                      (- (cdr pos)
                                                         (car pos)))
                                                    (region-bounds))))
                          'font-lock-face 'font-lock-variable-name-face))
    ""))

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

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

(defun +modeline-line-column (&optional spacer) ; adapted from `simple-modeline'
  "Display the current cursor line and column depending on modes."
  (+modeline-spacer nil nil
          (+modeline-line "")
          "|"
          (+modeline-column "")))

(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."
  (+modeline-spacer nil nil
          (cond ((functionp +modeline-position-function)
                 (funcall +modeline-position-function))
                (t (concat (+modeline-region)
                           (+modeline-line-column))))))

(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 nil
              (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 nil
          (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 nil
            (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 nil
            (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 nil
            (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 nil
            (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