;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*- ;; Copyright (C) 2023 Free Software Foundation, Inc. ;; Author: David Leatherman ;; Andy Stewart ;; This file is part of GNU Emacs. ;; GNU Emacs 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. ;; GNU Emacs 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 GNU Emacs. If not, see . ;;; Commentary: ;; This file provides the `nicks' module for automatic nickname ;; highlighting. Add `nicks' to `erc-modules' to get started. ;; ;; To change the color of a nickname in a target buffer, click on it ;; and choose "Edit face" from the completion interface, and then ;; perform your adjustments in the resulting Customize menu. ;; Non-Customize users can persist their changes permanently by ;; clicking on the face's "location" hyperlink and copying the ;; generated code snippet (`defface' or `use-package') to their ;; init.el. Customize users need only click "Apply and Save", as ;; usual. ;;; History: ;; This module has enjoyed a number of contributors across several ;; variants over the years. To those not mentioned, your efforts are ;; no less appreciated. ;; 2023/05 - erc-nicks ;; Rewrite using internal API, and rebrand for ERC 5.6 ;; 2020/03 - erc-hl-nicks 1.3.4 ;; Final release, see [1] for intervening history ;; 2014/05 - erc-highlight-nicknames.el ;; Final release, see [2] for intervening history ;; 2011/08 - erc-hl-nicks 1.0 ;; Initial release forked from erc-highlight-nicknames.el ;; 2008/12 - erc-highlight-nicknames.el ;; First release from Andy Stewart ;; 2007/09 - erc-highlight-nicknames.el ;; Initial release by by André Riemann ;; [1] ;; [2] ;;; Code: (require 'erc-button) (require 'color) (defgroup erc-nicks nil "Colorize nicknames in ERC buffers." :package-version '(ERC . "5.6") ; FIXME sync on release :group 'erc) (defcustom erc-nicks-ignore-chars ",`'_-" "Trailing characters in a nick to ignore while highlighting. Value should be a string containing characters typically appended by IRC clients to secure a nickname after a rejection (see option `erc-nick-uniquifier'). A value of nil means don't trim anything." :type '(choice (string :tag "Chars to trim") (const :tag "Don't trim" nil))) (defcustom erc-nicks-skip-nicks nil "Nicks to avoid highlighting." :type '(repeat string)) (defcustom erc-nicks-skip-faces '( erc-notice-face erc-current-nick-face erc-my-nick-face erc-pal-face erc-fool-face) "Faces to avoid highlighting atop." :type '(repeat symbol)) (defcustom erc-nicks-nickname-face erc-button-nickname-face "Face to mix with generated one for emphasizing non-speakers." :type '(choice face (const nil))) (defcustom erc-nicks-bg-color (frame-parameter (selected-frame) 'background-color) "Background color for calculating contrast. Set this explicitly when the background color isn't discoverable, which may be the case in terminal Emacs." :type 'string) (defcustom erc-nicks-color-adjustments '(erc-nicks-invert erc-nicks-cap-contrast erc-nicks-ensaturate) "Treatments applied to improve aesthetics or visibility. For example, the function `erc-nicks-invert' inverts a nick when it's too close to the background, and `erc-nicks-add-contrast' attempts to find a decent contrast ratio by brightening or darkening. Note that ERC still applies adjustments when `erc-nicks-colors' is a user-defined list of colors. Specify a value of nil to prevent that." :type '(repeat (choice (function-item :tag "Invert" erc-nicks-invert) (function-item :tag "Add contrast" erc-nicks-add-contrast) (function-item :tag "Cap contrast" erc-nicks-cap-contrast) (function-item :tag "Bound saturation" erc-nicks-ensaturate) function))) (defcustom erc-nicks-contrast-range '(4.3 . 12.5) "Desired range of contrast as a cons of (MIN . MAX). When `erc-nicks-add-contrast' and/or `erc-nicks-invert' appear in `erc-nicks-color-adjustments', MIN specifies the minimum amount of contrast allowed between a buffer's background and its foreground colors. Depending on the background, nicks may appear tinted in pastels or shaded with muted grays. MAX works similarly for reducing contrast, but only when `erc-nicks-cap-contrast' is active. Users with lighter backgrounds may want to lower MAX significantly. Either value can range from 1.0 to 21.0(:1) but may produce unsatisfactory results toward either extreme." :type '(cons float float)) (defcustom erc-nicks-saturation-range '(0.2 . 0.8) "Desired range for constraining saturation. Expressed as a cons of decimal proportions. Only matters when `erc-nicks-ensaturate' appears in `erc-nicks-color-adjustments'." :type '(cons float float)) ;; Should we also accept a list of faces? (defcustom erc-nicks-colors 'all "Pool of colors. This can be a list of hexes or color names, such as those provided by `defined-colors', which can itself be used when the value is the symbol `defined'. With `all', use any 24-bit color." :type '(choice (const all) (const defined) (list string))) (defvar-local erc-nicks--face-table nil "Hash table containing unique nick faces.") ;; https://stackoverflow.com/questions/596216#answer-56678483 (defun erc-nicks--get-luminance (color) "Return relative luminance of COLOR. COLOR can be a list of normalized values or a name. This is the same as the Y component returned by `color-srgb-to-xyz'." (let ((out 0) (coefficients '(0.2126 0.7152 0.0722)) (chnls (if (stringp color) (color-name-to-rgb color) color))) (dolist (ch chnls out) (cl-incf out (* (pop coefficients) (if (<= ch 0.04045) (/ ch 12.92) (expt (/ (+ ch 0.055) 1.055) 2.4))))))) (defvar-local erc-nicks--bg-luminance nil) (defun erc-nicks--get-contrast (fg &optional bg) "Return a float between 1 and 21 for colors FG and BG. If FG or BG are floats, interpret them as luminance values." (let* ((lum-fg (if (numberp fg) fg (erc-nicks--get-luminance fg))) (lum-bg (if bg (if (numberp bg) bg (erc-nicks--get-luminance bg)) (or erc-nicks--bg-luminance (setq erc-nicks--bg-luminance (erc-nicks--get-luminance erc-nicks-bg-color)))))) (when (< lum-fg lum-bg) (cl-rotatef lum-fg lum-bg)) (/ (+ 0.05 lum-fg) (+ 0.05 lum-bg)))) (defvar-local erc-nicks--bg-mode-value nil) (defmacro erc-nicks--bg-mode () `(or erc-nicks--bg-mode-value (setq erc-nicks--bg-mode-value ,(cond ((fboundp 'frame--current-background-mode) '(frame--current-background-mode (selected-frame))) ((fboundp 'frame--current-backround-mode) '(frame--current-backround-mode (selected-frame))) (t '(frame-parameter (selected-frame) 'background-mode)))))) (defvar erc-nicks--grad-steps 9) ;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html ;; ;; TODO see implementation in https://elpa.gnu.org/packages/ement and ;; maybe copy that instead. (defun erc-nicks--adjust-contrast (color target &optional decrease) (let* ((lum-bg (or erc-nicks--bg-luminance (setq erc-nicks--bg-luminance (erc-nicks--get-luminance erc-nicks-bg-color)))) ;; Shouldn't this use the actual bg color instead of b+w? (stop (if (eq (if decrease 'light 'dark) (erc-nicks--bg-mode)) '(1.0 1.0 1.0) '(0.0 0.0 0.0))) ;; From `color-gradient' in color.el (r (nth 0 color)) (g (nth 1 color)) (b (nth 2 color)) (interval (float (1+ (expt 2 erc-nicks--grad-steps)))) (r-step (/ (- (nth 0 stop) r) interval)) (g-step (/ (- (nth 1 stop) g) interval)) (b-step (/ (- (nth 2 stop) b) interval)) (maxtries erc-nicks--grad-steps) started) ;; FIXME stop when sufficiently close instead of exhausting. (while (let* ((lum-fg (erc-nicks--get-luminance (list r g b))) (darker (if (< lum-bg lum-fg) lum-bg lum-fg)) (lighter (if (= darker lum-bg) lum-fg lum-bg)) (cur (/ (+ 0.05 lighter) (+ 0.05 darker))) (scale (expt 2 maxtries))) (cond ((if decrease (> cur target) (< cur target)) (setq r (+ r (* r-step scale)) g (+ g (* g-step scale)) b (+ b (* b-step scale)))) (started (setq r (- r (* r-step scale)) g (- g (* g-step scale)) b (- b (* b-step scale)))) (t (setq maxtries 1))) (unless started (setq started t)) (setq r (min 1.0 (max 0 r)) g (min 1.0 (max 0 g)) b (min 1.0 (max 0 b))) (not (zerop (cl-decf maxtries))))) (list r g b))) (defun erc-nicks-add-contrast (color) "Increase COLOR's contrast by blending it with white or black. Unless sufficient contrast exists between COLOR and the background, raise it to somewhere around the lower bound of `erc-nicks-contrast-range'." (erc-nicks--adjust-contrast color (car erc-nicks-contrast-range))) (defun erc-nicks-cap-contrast (color) "Reduce COLOR's contrast by blending it with white or black. If excessive contrast exists between COLOR and the background, lower it to the upper bound of `erc-nicks-contrast-range'." (erc-nicks--adjust-contrast color (cdr erc-nicks-contrast-range) 'remove)) (defun erc-nicks-invert (color) "Invert COLOR based on the CAR of `erc-nicks-contrast-range'. Don't bother if the inverted color has less contrast than the input." (if-let ((con-input (erc-nicks--get-contrast color)) ((< con-input (car erc-nicks-contrast-range))) (flipped (mapcar (lambda (c) (- 1.0 c)) color)) ((> (erc-nicks--get-contrast flipped) con-input))) flipped color)) (defun erc-nicks-ensaturate (color) "Ensure COLOR falls within `erc-nicks-saturation-range'." (pcase-let ((`(,min . ,max) erc-nicks-saturation-range) (`(,h ,s ,l) (apply #'color-rgb-to-hsl color))) (cond ((> s max) (setq color (color-hsl-to-rgb h max l))) ((< s min) (setq color (color-hsl-to-rgb h min l))))) color) ;; http://www.cse.yorku.ca/~oz/hash.html ;; See also gui_nick_hash_djb2_64 in weechat/src/gui/gui-nick.c, ;; which is originally from https://savannah.nongnu.org/patch/?8062. ;; ;; Short strings of the same length and those differing only in their ;; low order bits tend to land in neighboring buckets, which are often ;; similar in color. Padding on the right with at least nine added ;; chars seems to scramble things sufficiently enough for our needs. (defun erc-nicks--hash (s &optional nchoices) (let ((h 5381) ; seed and multiplier (33) hardcoded for now (p (or nchoices 281474976710656)) ; 48-bits (expt 2 48) (i 0) (n (length s))) (while (< (setq h (% (+ (* h 33) (aref s i)) p) i (1+ i)) n)) h)) ;; From https://elpa.gnu.org/packages/ement. The resolution has been ;; scaled up to try and avoid components being exactly 0.0, which our ;; contrast function doesn't seem to like. Hopefully, that's OK. (defun erc-nicks--gen-color-ement (string) "Generate normalized RGB color from STRING." (let* ((ratio (/ (float (abs (sxhash string))) (float most-positive-fixnum))) (color-num (round (* (* #xffff #xffff #xffff) ratio)))) (list (/ (float (logand color-num #xffff)) #xffff) (/ (float (ash (logand color-num #xffff0000) -16)) #xffff) (/ (float (ash (logand color-num #xffff00000000) -32)) #xffff)))) (defvar-local erc-nicks--colors-len nil) (defvar-local erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces)) (defun erc-nicks--revive (new-face old-face nick net) (put new-face 'erc-nicks--custom-nick (cons nick net)) (apply #'custom-declare-face new-face (face-user-default-spec old-face) (format "Persistent `erc-nicks' color for %s on %s." nick net) erc-nicks--custom-keywords)) (defun erc-nicks--create-defface-template (face) (pop-to-buffer (get-buffer-create (format "*New face %s*" face))) (erase-buffer) (lisp-interaction-mode) (insert ";; If you *don't* use Customize, put something like this in your\n" (substitute-command-keys ";; init.el and use \\[eval-last-sexp] to apply any edits.\n\n") (format "(defface %s\n '%S\n %S" face (face-user-default-spec face) (face-documentation face)) (cl-loop for (k v) on erc-nicks--custom-keywords by #'cddr concat (format "\n %s %S" k (list 'quote v))) ")\n\n;; Or, if you use use-package\n(use-package erc-nicks\n" " :custom-face\n" (format " (%s %S)" face (face-user-default-spec face)) ")\n")) (defun erc-nicks--redirect-face-widget-link (args) (pcase args (`(,widget face-link . ,plist) (when-let* ((face (widget-value widget)) ((get face 'erc-nicks--custom-nick))) (unless (symbol-file face) (setf (plist-get plist :action) (lambda (&rest _) (erc-nicks--create-defface-template face)))) (setf (plist-get plist :help-echo) "Create or edit `defface'." (cddr args) plist)))) args) (defun erc-nicks--reduce (color) "Fold contrast strategies over COLOR, a string or normalized triple. Return a hex string." (apply #'color-rgb-to-hex (seq-reduce (lambda (color strategy) (funcall strategy color)) erc-nicks-color-adjustments (if (stringp color) (color-name-to-rgb color) color)))) (defun erc-nicks--get-face (nick key) "Retrieve or create a face for NICK, stored locally under KEY. But favor a custom erc-nicks-NICK@NETWORK-face, when defined." (setq nick (erc-downcase nick)) (let ((table (buffer-local-value 'erc-nicks--face-table (erc-server-buffer)))) (or (gethash nick table) (and-let* ((face (intern-soft (concat "erc-nicks-" nick "@" (erc-network-name) "-face"))) ((or (and (facep face) face) (erc-nicks--revive face face nick (erc-network)))))) (let ((color (erc-nicks--reduce (pcase erc-nicks-colors ('all (erc-nicks--gen-color-ement key)) ((or 'defined v) (unless v (setq v (defined-colors (selected-frame)))) (unless erc-nicks--colors-len (setq erc-nicks--colors-len (length v))) (nth (erc-nicks--hash key erc-nicks--colors-len) v))))) (new-face (make-symbol (concat "erc-nicks-" nick "-face")))) (face-spec-set new-face `((t :foreground ,color)) 'face-defface-spec) (set-face-documentation new-face (format "Internal face for %s on %s." nick (erc-network))) (puthash nick new-face table))))) (define-inline erc-nicks--anon-face-p (face) (inline-quote (and (consp ,face) (pcase (car ,face) ((pred keywordp) t) ('foreground-color t) ('background-color t))))) (defvar erc-nicks--max-skip-search 3 ; make this an option? "Max number of faces to visit when testing `erc-nicks-skip-faces'.") (defun erc-nicks--skip-p (prop option limit) "Return non-nil if a face in PROP appears in OPTION. But abandon search after examining LIMIT faces." (setq prop (if (erc-nicks--anon-face-p prop) (list prop) (ensure-list prop))) (catch 'found (while-let (((> limit 0)) (elem (pop prop))) (while (and (consp elem) (not (erc-nicks--anon-face-p elem))) (when (cdr elem) (push (cdr elem) prop)) (setq elem (car elem))) (when elem (cl-decf limit) (when (if (symbolp elem) (memq elem option) (member elem option)) (throw 'found elem)))))) (defvar erc-nicks--phony-face nil "Face to pretend is propertizing the nick at point. Modules needing to colorize nicks outside of a buttonizing context can use this instead of setting fictitious bounds on the `erc-button--nick' object passed to `erc-nicks--highlight'.") (defun erc-nicks--highlight (nick-object) "Possibly highlight a single nick." (when-let* ((nick-object) (server-user (erc-button--nick-user nick-object)) (trimmed (if erc-nicks-ignore-chars (string-trim-right (erc-server-user-nickname server-user) (rx-to-string `(: (+ (any ,erc-nicks-ignore-chars)) eot))) (erc-server-user-nickname server-user))) ((not (member trimmed erc-nicks-skip-nicks))) (face (or erc-nicks--phony-face (get-text-property (car (erc-button--nick-bounds nick-object)) 'font-lock-face))) ((not (erc-nicks--skip-p face erc-nicks-skip-faces erc-nicks--max-skip-search))) ;; Ensure nicks are colored uniquely (per network) by padding ;; from the right, as mentioned above in `erc-nicks--hash'. (key (concat (erc-button--nick-downcased nick-object) (and-let* ((net (erc-network))) (format "%9s" net)))) (out (erc-nicks--get-face trimmed key))) ;; `font-lock-prepend-text-property' could also work if preserving ;; history isn't needed (in which case this var should be nil). (setf (erc-button--nick-erc-button-nickname-face nick-object) (if (or (not erc-nicks-nickname-face) (eq face erc-nicks-nickname-face)) out (cons out (erc-list erc-nicks-nickname-face))))) nick-object) (define-erc-module nicks nil "Uniquely colorize nicknames in target buffers." ((if erc--target (progn (add-function :filter-return (local 'erc-button--modify-nick-function) #'erc-nicks--highlight '((depth . 80))) (erc-button--phantom-users-mode +1)) (unless erc-button-mode (unless (memq 'button erc-modules) (erc--warn-once-before-connect 'erc-nicks-mode "Enabling default global module `button' needed by local" " module `nicks'. This will impact \C-]all\C-] ERC" " sessions. Add `nicks' to `erc-modules' to avoid this" " warning. See Info:\"(erc) Modules\" for more.")) (erc-button-mode +1)) (when (equal erc-nicks-bg-color "unspecified-bg") (let ((temp (if (eq (erc-nicks--bg-mode) 'light) "white" "black"))) (erc-button--display-error-notice-with-keys "Module `nicks' unable to determine background color. Setting to \"" temp "\" globally. Please see `erc-nicks-bg-color'.") (custom-set-variables (list 'erc-nicks-bg-color temp)))) (setq erc-nicks--face-table (make-hash-table :test #'equal))) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil nil #'equal) #'erc-nicks-customize-face) (advice-add 'widget-create-child-and-convert :filter-args #'erc-nicks--redirect-face-widget-link)) ((kill-local-variable 'erc-nicks--face-table) (kill-local-variable 'erc-nicks--bg-mode-value) (kill-local-variable 'erc-nicks--bg-luminance) (kill-local-variable 'erc-nicks--colors-len) (when (fboundp 'erc-button--phantom-users-mode) (erc-button--phantom-users-mode -1)) (remove-function (local 'erc-button--modify-nick-function) #'erc-nicks--highlight) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil 'remove #'equal) nil)) 'local) (defun erc-nicks-customize-face (nick) "Customize or create persistent face for NICK." (interactive (list (or (car (get-text-property (point) 'erc-data)) (completing-read "nick: " (or erc-channel-users erc-server-users))))) (setq nick (erc-downcase (substring-no-properties nick))) (let* ((net (erc-network)) (key (concat nick (and net (format "%9s" net)))) (old-face (erc-nicks--get-face nick key)) (new-face (intern (format "erc-nicks-%s@%s-face" nick net)))) (unless (eq new-face old-face) (erc-nicks--revive new-face old-face nick net) (set-face-attribute old-face nil :foreground 'unspecified) (set-face-attribute old-face nil :inherit new-face)) (customize-face new-face))) (provide 'erc-nicks) ;;; erc-nicks.el ends here