diff options
Diffstat (limited to 'bard-elisp')
| -rw-r--r-- | bard-elisp/bard-common.el | 416 | ||||
| -rw-r--r-- | bard-elisp/bard-modeline.el | 628 |
2 files changed, 1044 insertions, 0 deletions
diff --git a/bard-elisp/bard-common.el b/bard-elisp/bard-common.el new file mode 100644 index 0000000..4482bb4 --- /dev/null +++ b/bard-elisp/bard-common.el @@ -0,0 +1,416 @@ +;;; prot-common.el --- Common functions for my dotemacs -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2023 Protesilaos Stavrou + +;; Author: Protesilaos Stavrou <[email protected]> +;; URL: https://protesilaos.com/emacs/dotemacs +;; Version: 0.1.0 +;; Package-Requires: ((emacs "30.1")) + +;; This file is NOT part of GNU Emacs. + +;; 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: +;; +;; Common functions for my Emacs: <https://protesilaos.com/emacs/dotemacs/>. +;; +;; Remember that every piece of Elisp that I write is for my own +;; educational and recreational purposes. I am not a programmer and I +;; do not recommend that you copy any of this if you are not certain of +;; what it does. + +;;; Code: + +(eval-when-compile + (require 'subr-x) + (require 'cl-lib)) + +(defgroup prot-common () + "Auxiliary functions for my dotemacs." + :group 'editing) + +;;;###autoload +(defun prot-common-number-even-p (n) + "Test if N is an even number." + (if (numberp n) + (= (% n 2) 0) + (error "%s is not a number" n))) + +;;;###autoload +(defun prot-common-number-integer-p (n) + "Test if N is an integer." + (if (integerp n) + n + (error "%s is not an integer" n))) + +;;;###autoload +(defun prot-common-number-integer-positive-p (n) + "Test if N is a positive integer." + (if (prot-common-number-integer-p n) + (> n 0) + (error "%s is not a positive integer" n))) + +;; Thanks to Gabriel for providing a cleaner version of +;; `prot-common-number-negative': <https://github.com/gabriel376>. +;;;###autoload +(defun prot-common-number-negative (n) + "Make N negative." + (if (and (numberp n) (> n 0)) + (* -1 n) + (error "%s is not a valid positive number" n))) + +;;;###autoload +(defun prot-common-reverse-percentage (number percent change-p) + "Determine the original value of NUMBER given PERCENT. + +CHANGE-P should specify the increase or decrease. For simplicity, +nil means decrease while non-nil stands for an increase. + +NUMBER must satisfy `numberp', while PERCENT must be `natnump'." + (unless (numberp number) + (user-error "NUMBER must satisfy numberp")) + (unless (natnump percent) + (user-error "PERCENT must satisfy natnump")) + (let* ((pc (/ (float percent) 100)) + (pc-change (if change-p (+ 1 pc) pc)) + (n (if change-p pc-change (float (- 1 pc-change))))) + ;; FIXME 2021-12-21: If float, round to 4 decimal points. + (/ number n))) + +;;;###autoload +(defun prot-common-percentage-change (n-original n-final) + "Find percentage change between N-ORIGINAL and N-FINAL numbers. + +When the percentage is not an integer, it is rounded to 4 +floating points: 16.666666666666664 => 16.667." + (unless (numberp n-original) + (user-error "N-ORIGINAL must satisfy numberp")) + (unless (numberp n-final) + (user-error "N-FINAL must satisfy numberp")) + (let* ((difference (float (abs (- n-original n-final)))) + (n (* (/ difference n-original) 100)) + (round (floor n))) + ;; FIXME 2021-12-21: Any way to avoid the `string-to-number'? + (if (> n round) (string-to-number (format "%0.4f" n)) round))) + +;; REVIEW 2023-04-07 07:43 +0300: I just wrote the conversions from +;; seconds. Hopefully they are correct, but I need to double check. +(defun prot-common-seconds-to-minutes (seconds) + "Convert a number representing SECONDS to MM:SS notation." + (let ((minutes (/ seconds 60)) + (seconds (% seconds 60))) + (format "%.2d:%.2d" minutes seconds))) + +(defun prot-common-seconds-to-hours (seconds) + "Convert a number representing SECONDS to HH:MM:SS notation." + (let* ((hours (/ seconds 3600)) + (minutes (/ (% seconds 3600) 60)) + (seconds (% seconds 60))) + (format "%.2d:%.2d:%.2d" hours minutes seconds))) + +;;;###autoload +(defun prot-common-seconds-to-minutes-or-hours (seconds) + "Convert SECONDS to either minutes or hours, depending on the value." + (if (> seconds 3599) + (prot-common-seconds-to-hours seconds) + (prot-common-seconds-to-minutes seconds))) + +;;;###autoload +(defun prot-common-rotate-list-of-symbol (symbol) + "Rotate list value of SYMBOL by moving its car to the end. +Return the first element before performing the rotation. + +This means that if `sample-list' has an initial value of `(one +two three)', this function will first return `one' and update the +value of `sample-list' to `(two three one)'. Subsequent calls +will continue rotating accordingly." + (unless (symbolp symbol) + (user-error "%s is not a symbol" symbol)) + (when-let* ((value (symbol-value symbol)) + (list (and (listp value) value)) + (first (car list))) + (set symbol (append (cdr list) (list first))) + first)) + +;;;###autoload +(defun prot-common-empty-buffer-p () + "Test whether the buffer is empty." + (or (= (point-min) (point-max)) + (save-excursion + (goto-char (point-min)) + (while (and (looking-at "^\\([a-zA-Z]+: ?\\)?$") + (zerop (forward-line 1)))) + (eobp)))) + +;;;###autoload +(defun prot-common-minor-modes-active () + "Return list of active minor modes for the current buffer." + (let ((active-modes)) + (mapc (lambda (m) + (when (and (boundp m) (symbol-value m)) + (push m active-modes))) + minor-mode-list) + active-modes)) + +;;;###autoload +(defun prot-common-truncate-lines-silently () + "Toggle line truncation without printing messages." + (let ((inhibit-message t)) + (toggle-truncate-lines t))) + +;; NOTE 2023-08-12: I tried the `clear-message-function', but it did +;; not work. What I need is very simple and this gets the job done. +;;;###autoload +(defun prot-common-clear-minibuffer-message (&rest _) + "Print an empty message to clear the echo area. +Use this as advice :after a noisy function." + (message "")) + +;;;###autoload +(defun prot-common-disable-hl-line () + "Disable Hl-Line-Mode (for hooks)." + (hl-line-mode -1)) + +;;;###autoload +(defun prot-common-window-bounds () + "Return start and end points in the window as a cons cell." + (cons (window-start) (window-end))) + +;;;###autoload +(defun prot-common-page-p () + "Return non-nil if there is a `page-delimiter' in the buffer." + (or (save-excursion (re-search-forward page-delimiter nil t)) + (save-excursion (re-search-backward page-delimiter nil t)))) + +;;;###autoload +(defun prot-common-window-small-p () + "Return non-nil if window is small. +Check if the `window-width' or `window-height' is less than +`split-width-threshold' and `split-height-threshold', +respectively." + (or (and (numberp split-width-threshold) + (< (window-total-width) split-width-threshold)) + (and (numberp split-height-threshold) + (> (window-total-height) split-height-threshold)))) + +;;;###autoload +(defun prot-common-three-or-more-windows-p (&optional frame) + "Return non-nil if three or more windows occupy FRAME. +If FRAME is non-nil, inspect the current frame." + (>= (length (window-list frame :no-minibuffer)) 3)) + +;;;###autoload +(defun prot-common-read-data (file) + "Read Elisp data from FILE." + (with-temp-buffer + (insert-file-contents file) + (read (current-buffer)))) + +;;;###autoload +(defun prot-common-completion-category () + "Return completion category." + (when-let ((window (active-minibuffer-window))) + (with-current-buffer (window-buffer window) + (completion-metadata-get + (completion-metadata (buffer-substring-no-properties + (minibuffer-prompt-end) + (max (minibuffer-prompt-end) (point))) + minibuffer-completion-table + minibuffer-completion-predicate) + 'category)))) + +;; Thanks to Omar Antolín Camarena for providing this snippet! +;;;###autoload +(defun prot-common-completion-table (category candidates) + "Pass appropriate metadata CATEGORY to completion CANDIDATES. + +This is intended for bespoke functions that need to pass +completion metadata that can then be parsed by other +tools (e.g. `embark')." + (lambda (string pred action) + (if (eq action 'metadata) + `(metadata (category . ,category)) + (complete-with-action action candidates string pred)))) + +;;;###autoload +(defun prot-common-completion-table-no-sort (category candidates) + "Pass appropriate metadata CATEGORY to completion CANDIDATES. +Like `prot-common-completion-table' but also disable sorting." + (lambda (string pred action) + (if (eq action 'metadata) + `(metadata (category . ,category) + (display-sort-function . ,#'identity)) + (complete-with-action action candidates string pred)))) + +;; Thanks to Igor Lima for the `prot-common-crm-exclude-selected-p': +;; <https://github.com/0x462e41>. +;; This is used as a filter predicate in the relevant prompts. +(defvar crm-separator) + +;;;###autoload +(defun prot-common-crm-exclude-selected-p (input) + "Filter out INPUT from `completing-read-multiple'. +Hide non-destructively the selected entries from the completion +table, thus avoiding the risk of inputting the same match twice. + +To be used as the PREDICATE of `completing-read-multiple'." + (if-let* ((pos (string-match-p crm-separator input)) + (rev-input (reverse input)) + (element (reverse + (substring rev-input 0 + (string-match-p crm-separator rev-input)))) + (flag t)) + (progn + (while pos + (if (string= (substring input 0 pos) element) + (setq pos nil) + (setq input (substring input (1+ pos)) + pos (string-match-p crm-separator input) + flag (when pos t)))) + (not flag)) + t)) + +;; The `prot-common-line-regexp-p' and `prot-common--line-regexp-alist' +;; are contributed by Gabriel: <https://github.com/gabriel376>. They +;; provide a more elegant approach to using a macro, as shown further +;; below. +(defvar prot-common--line-regexp-alist + '((empty . "[\s\t]*$") + (indent . "^[\s\t]+") + (non-empty . "^.+$") + (list . "^\\([\s\t#*+]+\\|[0-9]+[^\s]?[).]+\\)") + (heading . "^[=-]+")) + "Alist of regexp types used by `prot-common-line-regexp-p'.") + +(defun prot-common-line-regexp-p (type &optional n) + "Test for TYPE on line. +TYPE is the car of a cons cell in +`prot-common--line-regexp-alist'. It matches a regular +expression. + +With optional N, search in the Nth line from point." + (save-excursion + (goto-char (line-beginning-position)) + (and (not (bobp)) + (or (beginning-of-line n) t) + (save-match-data + (looking-at + (alist-get type prot-common--line-regexp-alist)))))) + +;; The `prot-common-shell-command-with-exit-code-and-output' function is +;; courtesy of Harold Carr, who also sent a patch that improved +;; `prot-eww-download-html' (from the `prot-eww.el' library). +;; +;; More about Harold: <http://haroldcarr.com/about/>. +(defun prot-common-shell-command-with-exit-code-and-output (command &rest args) + "Run COMMAND with ARGS. +Return the exit code and output in a list." + (with-temp-buffer + (list (apply 'call-process command nil (current-buffer) nil args) + (buffer-string)))) + +(defvar prot-common-url-regexp + (concat + "~?\\<\\([-a-zA-Z0-9+&@#/%?=~_|!:,.;]*\\)" + "[.@]" + "\\([-a-zA-Z0-9+&@#/%?=~_|!:,.;]+\\)\\>/?") + "Regular expression to match (most?) URLs or email addresses.") + +(autoload 'auth-source-search "auth-source") + +;;;###autoload +(defun prot-common-auth-get-field (host prop) + "Find PROP in `auth-sources' for HOST entry." + (when-let ((source (auth-source-search :host host))) + (if (eq prop :secret) + (funcall (plist-get (car source) prop)) + (plist-get (flatten-list source) prop)))) + +;;;###autoload +(defun prot-common-parse-file-as-list (file) + "Return the contents of FILE as a list of strings. +Strings are split at newline characters and are then trimmed for +negative space. + +Use this function to provide a list of candidates for +completion (per `completing-read')." + (split-string + (with-temp-buffer + (insert-file-contents file) + (buffer-substring-no-properties (point-min) (point-max))) + "\n" :omit-nulls "[\s\f\t\n\r\v]+")) + +(defun prot-common-ignore (&rest _) + "Use this as override advice to make a function do nothing." + nil) + +;; NOTE 2023-06-02: The `prot-common-wcag-formula' and +;; `prot-common-contrast' are taken verbatim from my `modus-themes' +;; and renamed to have the prefix `prot-common-' instead of +;; `modus-themes-'. This is all my code, of course, but I do it this +;; way to ensure that this file is self-contained in case someone +;; copies it. + +;; This is the WCAG formula: <https://www.w3.org/TR/WCAG20-TECHS/G18.html>. +(defun prot-common-wcag-formula (hex) + "Get WCAG value of color value HEX. +The value is defined in hexadecimal RGB notation, such #123456." + (cl-loop for k in '(0.2126 0.7152 0.0722) + for x in (color-name-to-rgb hex) + sum (* k (if (<= x 0.03928) + (/ x 12.92) + (expt (/ (+ x 0.055) 1.055) 2.4))))) + +;;;###autoload +(defun prot-common-contrast (c1 c2) + "Measure WCAG contrast ratio between C1 and C2. +C1 and C2 are color values written in hexadecimal RGB." + (let ((ct (/ (+ (prot-common-wcag-formula c1) 0.05) + (+ (prot-common-wcag-formula c2) 0.05)))) + (max ct (/ ct)))) + +;;;; EXPERIMENTAL macros (not meant to be used anywhere) + +;; TODO 2023-09-30: Try the same with `cl-defmacro' and &key +(defmacro prot-common-if (condition &rest consequences) + "Separate the CONSEQUENCES of CONDITION semantically. +Like `if', `when', `unless' but done by using `:then' and `:else' +keywords. The forms under each keyword of `:then' and `:else' +belong to the given subset of CONSEQUENCES. + +- The absence of `:else' means: (if CONDITION (progn CONSEQUENCES)). +- The absence of `:then' means: (if CONDITION nil CONSEQUENCES). +- Otherwise: (if CONDITION (progn then-CONSEQUENCES) else-CONSEQUENCES)." + (declare (indent 1)) + (let (then-consequences else-consequences last-kw) + (dolist (elt consequences) + (let ((is-keyword (keywordp elt))) + (cond + ((and (not is-keyword) (eq last-kw :then)) + (push elt then-consequences)) + ((and (not is-keyword) (eq last-kw :else)) + (push elt else-consequences)) + ((and is-keyword (eq elt :then)) + (setq last-kw :then)) + ((and is-keyword (eq elt :else)) + (setq last-kw :else))))) + `(if ,condition + ,(if then-consequences + `(progn ,@(nreverse then-consequences)) + nil) + ,@(nreverse else-consequences)))) + +(provide 'prot-common) +;;; prot-common.el ends here diff --git a/bard-elisp/bard-modeline.el b/bard-elisp/bard-modeline.el new file mode 100644 index 0000000..851d063 --- /dev/null +++ b/bard-elisp/bard-modeline.el @@ -0,0 +1,628 @@ +;;; bard--modeline.el --- My customizations for the Emacs Modeline -*- lexical-binding: t -*- + +;; Author: BardofSprites +;; Maintainer: BardofSprites +;; Version: 0.1.0 +;; Package-Requires: ((Emacs 29.2)) +;; Homepage: https://github.com/BardofSprites/.emacs.d +;; Keywords: emacs modeline custom + + +;; This file is not part of GNU Emacs + +;; 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: + +;; Faces +(require 'prot-common) + +(defgroup prot-modeline nil + "Custom modeline that is stylistically close to the default." + :group 'mode-line) + +(defgroup prot-modeline-faces nil + "Faces for my custom modeline." + :group 'prot-modeline) + +(defcustom prot-modeline-string-truncate-length 9 + "String length after which truncation should be done in small windows." + :type 'natnum) + +;;;; Faces + +(defface prot-modeline-indicator-button nil + "Generic face used for indicators that have a background. +Modify this face to, for example, add a :box attribute to all +relevant indicators (combines nicely with my `spacious-padding' +package).") + +(defface prot-modeline-indicator-red + '((default :inherit bold) + (((class color) (min-colors 88) (background light)) + :foreground "#880000") + (((class color) (min-colors 88) (background dark)) + :foreground "#ff9f9f") + (t :foreground "red")) + "Face for modeline indicators (e.g. see my `notmuch-indicator')." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-red-bg + '((default :inherit (bold prot-modeline-indicator-button)) + (((class color) (min-colors 88) (background light)) + :background "#aa1111" :foreground "white") + (((class color) (min-colors 88) (background dark)) + :background "#ff9090" :foreground "black") + (t :background "red" :foreground "black")) + "Face for modeline indicators with a background." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-green + '((default :inherit bold) + (((class color) (min-colors 88) (background light)) + :foreground "#005f00") + (((class color) (min-colors 88) (background dark)) + :foreground "#73fa7f") + (t :foreground "green")) + "Face for modeline indicators (e.g. see my `notmuch-indicator')." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-green-bg + '((default :inherit (bold prot-modeline-indicator-button)) + (((class color) (min-colors 88) (background light)) + :background "#207b20" :foreground "white") + (((class color) (min-colors 88) (background dark)) + :background "#77d077" :foreground "black") + (t :background "green" :foreground "black")) + "Face for modeline indicators with a background." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-yellow + '((default :inherit bold) + (((class color) (min-colors 88) (background light)) + :foreground "#6f4000") + (((class color) (min-colors 88) (background dark)) + :foreground "#f0c526") + (t :foreground "yellow")) + "Face for modeline indicators (e.g. see my `notmuch-indicator')." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-yellow-bg + '((default :inherit (bold prot-modeline-indicator-button)) + (((class color) (min-colors 88) (background light)) + :background "#805000" :foreground "white") + (((class color) (min-colors 88) (background dark)) + :background "#ffc800" :foreground "black") + (t :background "yellow" :foreground "black")) + "Face for modeline indicators with a background." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-blue + '((default :inherit bold) + (((class color) (min-colors 88) (background light)) + :foreground "#00228a") + (((class color) (min-colors 88) (background dark)) + :foreground "#88bfff") + (t :foreground "blue")) + "Face for modeline indicators (e.g. see my `notmuch-indicator')." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-blue-bg + '((default :inherit (bold prot-modeline-indicator-button)) + (((class color) (min-colors 88) (background light)) + :background "#0000aa" :foreground "white") + (((class color) (min-colors 88) (background dark)) + :background "#77aaff" :foreground "black") + (t :background "blue" :foreground "black")) + "Face for modeline indicators with a background." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-magenta + '((default :inherit bold) + (((class color) (min-colors 88) (background light)) + :foreground "#6a1aaf") + (((class color) (min-colors 88) (background dark)) + :foreground "#e0a0ff") + (t :foreground "magenta")) + "Face for modeline indicators (e.g. see my `notmuch-indicator')." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-magenta-bg + '((default :inherit (bold prot-modeline-indicator-button)) + (((class color) (min-colors 88) (background light)) + :background "#6f0f9f" :foreground "white") + (((class color) (min-colors 88) (background dark)) + :background "#e3a2ff" :foreground "black") + (t :background "magenta" :foreground "black")) + "Face for modeline indicators with a background." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-cyan + '((default :inherit bold) + (((class color) (min-colors 88) (background light)) + :foreground "#004060") + (((class color) (min-colors 88) (background dark)) + :foreground "#30b7cc") + (t :foreground "cyan")) + "Face for modeline indicators (e.g. see my `notmuch-indicator')." + :group 'prot-modeline-faces) + +(defface prot-modeline-indicator-cyan-bg + '((default :inherit (bold prot-modeline-indicator-button)) + (((class color) (min-colors 88) (background light)) + :background "#006080" :foreground "white") + (((class color) (min-colors 88) (background dark)) + :background "#40c0e0" :foreground "black") + (t :background "cyan" :foreground "black")) + "Face for modeline indicators with a background." + :group 'prot-modeline-faces) + +;;;; Common helper functions + +(defun prot-modeline--string-truncate-p (str) + "Return non-nil if STR should be truncated." + (and (prot-common-window-small-p) + (> (length str) prot-modeline-string-truncate-length) + (not (one-window-p :no-minibuffer)))) + +(defun prot-modeline--truncate-p () + "Return non-nil if truncation should happen. +This is a more general and less stringent variant of +`prot-modeline--string-truncate-p'." + (and (prot-common-window-small-p) + (not (one-window-p :no-minibuffer)))) + +(defun prot-modeline-string-truncate (str) + "Return truncated STR, if appropriate, else return STR. +Truncation is done up to `prot-modeline-string-truncate-length'." + (if (prot-modeline--string-truncate-p str) + (concat (substring str 0 prot-modeline-string-truncate-length) "...") + str)) + +(defun prot-modeline-string-truncate-end (str) + "Like `prot-modeline-string-truncate' but truncate from STR beginning." + (if (prot-modeline--string-truncate-p str) + (concat "..." (substring str (- prot-modeline-string-truncate-length))) + str)) + +(defun prot-modeline--first-char (str) + "Return first character from STR." + (substring str 0 1)) + +(defun prot-modeline-string-abbreviate (str) + "Abbreviate STR individual hyphen or underscore separated words. +Also see `prot-modeline-string-abbreviate-but-last'." + (if (prot-modeline--string-truncate-p str) + (mapconcat #'prot-modeline--first-char (split-string str "[_-]") "-") + str)) + +(defun prot-modeline-string-abbreviate-but-last (str nthlast) + "Abbreviate STR, keeping NTHLAST words intact. +Also see `prot-modeline-string-abbreviate'." + (if (prot-modeline--string-truncate-p str) + (let* ((all-strings (split-string str "[_-]")) + (nbutlast-strings (nbutlast (copy-sequence all-strings) nthlast)) + (last-strings (nreverse (ntake nthlast (nreverse (copy-sequence all-strings))))) + (first-component (mapconcat #'prot-modeline--first-char nbutlast-strings "-")) + (last-component (mapconcat #'identity last-strings "-"))) + (if (string-empty-p first-component) + last-component + (concat first-component "-" last-component))) + str)) + +;;;; Keyboard macro indicator + +(defvar-local prot-modeline-kbd-macro + '(:eval + (when (and (mode-line-window-selected-p) defining-kbd-macro) + (propertize " KMacro " 'face 'prot-modeline-indicator-blue-bg))) + "Mode line construct displaying `mode-line-defining-kbd-macro'. +Specific to the current window's mode line.") + +;;;; Narrow indicator + +(defvar-local prot-modeline-narrow + '(:eval + (when (and (mode-line-window-selected-p) + (buffer-narrowed-p) + (not (derived-mode-p 'Info-mode 'help-mode 'special-mode 'message-mode))) + (propertize " Narrow " 'face 'prot-modeline-indicator-cyan-bg))) + "Mode line construct to report the multilingual environment.") + +;;;; Input method + +(defvar-local prot-modeline-input-method + '(:eval + (when current-input-method-title + (propertize (format " %s " current-input-method-title) + 'face 'prot-modeline-indicator-green-bg + 'mouse-face 'mode-line-highlight))) + "Mode line construct to report the multilingual environment.") + +;;;; Buffer status + +;; TODO 2023-07-05: What else is there beside remote files? If +;; nothing, this must be renamed accordingly. +(defvar-local prot-modeline-buffer-status + '(:eval + (when (file-remote-p default-directory) + (propertize " @ " + 'face 'prot-modeline-indicator-red-bg + 'mouse-face 'mode-line-highlight))) + "Mode line construct for showing remote file name.") + +;;;; Evil state + +(defvar evil-state) +(defvar evil-visual-selection) + +(defconst prot-modeline-evil-state-tags + '((normal :short "<N>" :long "NORMAL") + (insert :short "<I>" :long "INSERT") + (visual :short "<V>" :long "VISUAL") + (vblock :short "<Vb>" :long "VBLOCK") + (vline :short "<Vl>" :long "VLINE") + (vsline :short "<Vsl>" :long "VSLINE") + (motion :short "<M>" :long "MOTION") + (emacs :short "<E>" :long "EMACS") + (operator :short "<O>" :long "OPERATE") + (replace :short "<R>" :long "REPLACE") + (prot-basic :short "<B>" :long "BASIC")) + "Short and long tags for Evil states.") + +(defun prot-modeline--evil-get-tag (state variant) + "Get Evil STATE tag of VARIANT :short or :long. +VARIANT of the state tag is either :short or :long, as defined in +`prot-modeline-evil-state-tags'." + (let ((tags (alist-get state prot-modeline-evil-state-tags))) + (plist-get tags (or variant :short)))) + +(defun prot-modeline--evil-get-format-specifier (variant) + "Return a `format' specifier for VARIANT. +VARIANT of the state tag is either :short or :long, as defined in +`prot-modeline-evil-state-tags'." + (if (eq variant :short) + " %-5s" + " %-8s")) + +(defun prot-modeline--evil-propertize-tag (state variant &optional face) + "Propertize STATE tag of VARIANT with optional FACE. +VARIANT of the state tag is either :short or :long, as defined in +`prot-modeline-evil-state-tags'. If FACE is nil, fall back to +`default'." + (propertize + (format (prot-modeline--evil-get-format-specifier variant) (prot-modeline--evil-get-tag state variant)) + 'face (or face 'mode-line) + 'mouse-face 'mode-line-highlight + 'help-echo (format "Evil `%s' state" state))) + +(defun prot-modeline-evil-state-tag (variant) + "Return mode line tag VARIANT depending on the Evil state. +VARIANT of the state tag is either :short or :long, as defined in +`prot-modeline-evil-state-tags'." + (pcase evil-state + ('normal (prot-modeline--evil-propertize-tag 'normal variant 'prot-modeline-indicator-blue)) + ('insert (prot-modeline--evil-propertize-tag 'insert variant)) ; I don't actually use an "insert" state: it switches to "emacs" + ('visual (pcase evil-visual-selection + ('line (prot-modeline--evil-propertize-tag 'vline variant 'prot-modeline-indicator-yellow)) + ('screen-line (prot-modeline--evil-propertize-tag 'vsline variant 'prot-modeline-indicator-yellow)) + ('block (prot-modeline--evil-propertize-tag 'vblock variant 'prot-modeline-indicator-yellow)) + (_ (prot-modeline--evil-propertize-tag 'visual variant 'prot-modeline-indicator-yellow)))) + ('motion (prot-modeline--evil-propertize-tag 'motion variant 'prot-modeline-indicator-yellow)) + ('emacs (prot-modeline--evil-propertize-tag 'emacs variant 'prot-modeline-indicator-magenta)) + ('operator (prot-modeline--evil-propertize-tag 'operator variant 'prot-modeline-indicator-red)) + ('replace (prot-modeline--evil-propertize-tag 'replace variant 'prot-modeline-indicator-red)) + ('prot-basic (prot-modeline--evil-propertize-tag 'prot-basic variant 'prot-modeline-indicator-green)))) + +(defvar-local prot-modeline-evil + '(:eval + (if (and (mode-line-window-selected-p) (bound-and-true-p evil-mode)) + (let ((variant (if (prot-modeline--truncate-p) :short :long))) + (prot-modeline-evil-state-tag variant)) + " ")) + "Mode line construct to display the Evil state.") + +;;;; Buffer name and modified status + +(defun prot-modeline-buffer-identification-face () + "Return appropriate face or face list for `prot-modeline-buffer-identification'." + (let ((file (buffer-file-name))) + (cond + ((and (mode-line-window-selected-p) + file + (buffer-modified-p)) + '(italic mode-line-buffer-id)) + ((and file (buffer-modified-p)) + 'italic) + ((mode-line-window-selected-p) + 'mode-line-buffer-id)))) + +(defun prot-modeline--buffer-name () + "Return `buffer-name', truncating it if necessary. +See `prot-modeline-string-truncate'." + (when-let ((name (buffer-name))) + (prot-modeline-string-truncate name))) + +(defun prot-modeline-buffer-name () + "Return buffer name, with read-only indicator if relevant." + (let ((name (prot-modeline--buffer-name))) + (if buffer-read-only + (format "%s %s" (char-to-string #xE0A2) name) + name))) + +(defun prot-modeline-buffer-name-help-echo () + "Return `help-echo' value for `prot-modeline-buffer-identification'." + (concat + (propertize (buffer-name) 'face 'mode-line-buffer-id) + "\n" + (propertize + (or (buffer-file-name) + (format "No underlying file.\nDirectory is: %s" default-directory)) + 'face 'font-lock-doc-face))) + +(defvar-local prot-modeline-buffer-identification + '(:eval + (propertize (prot-modeline-buffer-name) + 'face (prot-modeline-buffer-identification-face) + 'mouse-face 'mode-line-highlight + 'help-echo (prot-modeline-buffer-name-help-echo))) + "Mode line construct for identifying the buffer being displayed. +Propertize the current buffer with the `mode-line-buffer-id' +face. Let other buffers have no face.") + +;;;; Major mode + +(defun prot-modeline-major-mode-indicator () + "Return appropriate propertized mode line indicator for the major mode." + (let ((indicator (cond + ((derived-mode-p 'text-mode) "§") + ((derived-mode-p 'prog-mode) "λ") + ((derived-mode-p 'comint-mode) ">_") + (t "◦")))) + (propertize indicator 'face 'shadow))) + +(defun prot-modeline-major-mode-name () + "Return capitalized `major-mode' without the -mode suffix." + (capitalize (string-replace "-mode" "" (symbol-name major-mode)))) + +(defun prot-modeline-major-mode-help-echo () + "Return `help-echo' value for `prot-modeline-major-mode'." + (if-let ((parent (get major-mode 'derived-mode-parent))) + (format "Symbol: `%s'. Derived from: `%s'" major-mode parent) + (format "Symbol: `%s'." major-mode))) + +(defvar-local prot-modeline-major-mode + (list + (propertize "%[" 'face 'prot-modeline-indicator-red) + '(:eval + (concat + (prot-modeline-major-mode-indicator) + " " + (propertize + (prot-modeline-string-abbreviate-but-last + (prot-modeline-major-mode-name) + 2) + 'mouse-face 'mode-line-highlight + 'help-echo (prot-modeline-major-mode-help-echo)))) + (propertize "%]" 'face 'prot-modeline-indicator-red)) + "Mode line construct for displaying major modes.") + +(defvar-local prot-modeline-process + (list '("" mode-line-process)) + "Mode line construct for the running process indicator.") + +;;;; Git branch and diffstat + +(declare-function vc-git--symbolic-ref "vc-git" (file)) + +(defun prot-modeline--vc-branch-name (file backend) + "Return capitalized VC branch name for FILE with BACKEND." + (when-let ((rev (vc-working-revision file backend)) + (branch (or (vc-git--symbolic-ref file) + (substring rev 0 7)))) + (capitalize branch))) + +;; NOTE 2023-07-27: This is a good idea, but it hardcodes Git, whereas +;; I want a generic VC method. Granted, I only use Git but I still +;; want it to work as a VC extension. + +;; (defun prot-modeline-diffstat (file) +;; "Return shortened Git diff numstat for FILE." +;; (when-let* ((output (shell-command-to-string (format "git diff --numstat %s" file))) +;; (stats (split-string output "[\s\t]" :omit-nulls "[\s\f\t\n\r\v]+")) +;; (added (nth 0 stats)) +;; (deleted (nth 1 stats))) +;; (cond +;; ((and (equal added "0") (equal deleted "0")) +;; "") +;; ((and (not (equal added "0")) (equal deleted "0")) +;; (propertize (format "+%s" added) 'face 'shadow)) +;; ((and (equal added "0") (not (equal deleted "0"))) +;; (propertize (format "-%s" deleted) 'face 'shadow)) +;; (t +;; (propertize (format "+%s -%s" added deleted) 'face 'shadow))))) + +(declare-function vc-git-working-revision "vc-git" (file)) + +(defvar prot-modeline-vc-map + (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] 'vc-diff) + (define-key map [mode-line down-mouse-3] 'vc-root-diff) + map) + "Keymap to display on VC indicator.") + +(defun prot-modeline--vc-help-echo (file) + "Return `help-echo' message for FILE tracked by VC." + (format "Revision: %s\nmouse-1: `vc-diff'\nmouse-3: `vc-root-diff'" + (vc-working-revision file))) + +(defun prot-modeline--vc-text (file branch &optional face) + "Prepare text for Git controlled FILE, given BRANCH. +With optional FACE, use it to propertize the BRANCH." + (concat + (propertize (char-to-string #xE0A0) 'face 'shadow) + " " + (propertize branch + 'face face + 'mouse-face 'mode-line-highlight + 'help-echo (prot-modeline--vc-help-echo file) + 'local-map prot-modeline-vc-map) + ;; " " + ;; (prot-modeline-diffstat file) + )) + +(defun prot-modeline--vc-details (file branch &optional face) + "Return Git BRANCH details for FILE, truncating it if necessary. +The string is truncated if the width of the window is smaller +than `split-width-threshold'." + (prot-modeline-string-truncate + (prot-modeline--vc-text file branch face))) + +(defvar prot-modeline--vc-faces + '((added . vc-locally-added-state) + (edited . vc-edited-state) + (removed . vc-removed-state) + (missing . vc-missing-state) + (conflict . vc-conflict-state) + (locked . vc-locked-state) + (up-to-date . vc-up-to-date-state)) + "VC state faces.") + +(defun prot-modeline--vc-get-face (key) + "Get face from KEY in `prot-modeline--vc-faces'." + (alist-get key prot-modeline--vc-faces 'up-to-date)) + +(defun prot-modeline--vc-face (file backend) + "Return VC state face for FILE with BACKEND." + (prot-modeline--vc-get-face (vc-state file backend))) + +(defvar-local prot-modeline-vc-branch + '(:eval + (when-let* (((mode-line-window-selected-p)) + (file (buffer-file-name)) + (backend (vc-backend file)) + ;; ((vc-git-registered file)) + (branch (prot-modeline--vc-branch-name file backend)) + (face (prot-modeline--vc-face file backend))) + (prot-modeline--vc-details file branch face))) + "Mode line construct to return propertized VC branch.") + +;;;; Flymake errors, warnings, notes + +(declare-function flymake--severity "flymake" (type)) +(declare-function flymake-diagnostic-type "flymake" (diag)) + +;; Based on `flymake--mode-line-counter'. +(defun prot-modeline-flymake-counter (type) + "Compute number of diagnostics in buffer with TYPE's severity. +TYPE is usually keyword `:error', `:warning' or `:note'." + (let ((count 0)) + (dolist (d (flymake-diagnostics)) + (when (= (flymake--severity type) + (flymake--severity (flymake-diagnostic-type d))) + (cl-incf count))) + (when (cl-plusp count) + (number-to-string count)))) + +(defvar prot-modeline-flymake-map + (let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] 'flymake-show-buffer-diagnostics) + (define-key map [mode-line down-mouse-3] 'flymake-show-project-diagnostics) + map) + "Keymap to display on Flymake indicator.") + +(defmacro prot-modeline-flymake-type (type indicator &optional face) + "Return function that handles Flymake TYPE with stylistic INDICATOR and FACE." + `(defun ,(intern (format "prot-modeline-flymake-%s" type)) () + (when-let ((count (prot-modeline-flymake-counter + ,(intern (format ":%s" type))))) + (concat + (propertize ,indicator 'face 'shadow) + (propertize count + 'face ',(or face type) + 'mouse-face 'mode-line-highlight + ;; FIXME 2023-07-03: Clicking on the text with + ;; this buffer and a single warning present, the + ;; diagnostics take up the entire frame. Why? + 'local-map prot-modeline-flymake-map + 'help-echo "mouse-1: buffer diagnostics\nmouse-3: project diagnostics"))))) + +(prot-modeline-flymake-type error "☣") +(prot-modeline-flymake-type warning "!") +(prot-modeline-flymake-type note "·" success) + +(defvar-local prot-modeline-flymake + `(:eval + (when (and (bound-and-true-p flymake-mode) + (mode-line-window-selected-p)) + (list + ;; See the calls to the macro `prot-modeline-flymake-type' + '(:eval (prot-modeline-flymake-error)) + '(:eval (prot-modeline-flymake-warning)) + '(:eval (prot-modeline-flymake-note))))) + "Mode line construct displaying `flymake-mode-line-format'. +Specific to the current window's mode line.") + +;;;; Eglot + +(with-eval-after-load 'eglot + (setq mode-line-misc-info + (delete '(eglot--managed-mode (" [" eglot--mode-line-format "] ")) mode-line-misc-info))) + +(defvar-local prot-modeline-eglot + `(:eval + (when (and (featurep 'eglot) (mode-line-window-selected-p)) + '(eglot--managed-mode eglot--mode-line-format))) + "Mode line construct displaying Eglot information. +Specific to the current window's mode line.") + +;;;; Miscellaneous + +(defvar-local prot-modeline-notmuch-indicator + '(notmuch-indicator-mode + (" " + (:eval (when (mode-line-window-selected-p) + notmuch-indicator--counters)))) + "The equivalent of `notmuch-indicator-mode-line-construct'. +Display the indicator only on the focused window's mode line.") + +(defvar-local prot-modeline-misc-info + '(:eval + (when (mode-line-window-selected-p) + mode-line-misc-info)) + "Mode line construct displaying `mode-line-misc-info'. +Specific to the current window's mode line.") + +;;;; Risky local variables + +;; NOTE 2023-04-28: The `risky-local-variable' is critical, as those +;; variables will not work without it. +(dolist (construct '(prot-modeline-kbd-macro + prot-modeline-narrow + prot-modeline-input-method + prot-modeline-buffer-status + prot-modeline-evil + prot-modeline-buffer-identification + prot-modeline-major-mode + prot-modeline-process + prot-modeline-vc-branch + prot-modeline-flymake + prot-modeline-eglot + ;; prot-modeline-align-right + prot-modeline-notmuch-indicator + prot-modeline-misc-info)) + (put construct 'risky-local-variable t)) + +(provide 'bard-modeline.el) |