From 88fbd206ed296ddd99ce84696a5e45d3d4cf5ead Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 22 Jun 2023 05:51:15 -0700 Subject: [PATCH 0/1] *** NOT A PATCH *** *** BLURB HERE *** David Leatherman (1): [5.6] Add module for colorizing nicknames to ERC doc/misc/erc.texi | 4 + etc/ERC-NEWS | 8 + lisp/erc/erc-nicks.el | 554 +++++++++++++++++++++++++++++++ lisp/erc/erc.el | 1 + test/lisp/erc/erc-nicks-tests.el | 315 ++++++++++++++++++ test/lisp/erc/erc-tests.el | 2 +- 6 files changed, 883 insertions(+), 1 deletion(-) create mode 100644 lisp/erc/erc-nicks.el create mode 100644 test/lisp/erc/erc-nicks-tests.el Interdiff: diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index ad4fca523d2..cd78ac15e22 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -37,8 +37,13 @@ ;;; 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. +;; variants over the years, including: +;; +;; Thibault Polge , +;; Jay Kamat , +;; Alex Kost +;; +;; To those not mentioned, your efforts are no less appreciated. ;; 2023/05 - erc-nicks ;; Rewrite using internal API, and rebrand for ERC 5.6 @@ -53,7 +58,7 @@ ;; 2007/09 - erc-highlight-nicknames.el ;; Initial release by by André Riemann -;; [1] +;; [1] ;; [2] ;;; Code: @@ -76,7 +81,9 @@ erc-nicks-ignore-chars (const :tag "Don't trim" nil))) (defcustom erc-nicks-skip-nicks nil - "Nicks to avoid highlighting." + "Nicks to avoid highlighting. +ERC only considers this option during module activation, so users +should adjust it before connecting." :type '(repeat string)) (defcustom erc-nicks-skip-faces '( erc-notice-face erc-current-nick-face @@ -101,9 +108,15 @@ erc-nicks-color-adjustments 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." +darkening. When `erc-nicks-colors' is set to the symbol +`defined' or a user-provided list of colors, ERC uses this option +as a guide for culling any colors that don't fall within +`erc-nicks-contrast-range' or `erc-nicks-saturation-range', as +appropriate. For example, if `erc-nicks-cap-contrast' is present +in this option's value, and a color's contrast exceeds the CDR of +`erc-nicks-contrast-range', ERC will purge that color from its +rolls when initializing this module. Specify a value of nil to +inhibit this process." :type '(repeat (choice (function-item :tag "Invert" erc-nicks-invert) (function-item :tag "Add contrast" erc-nicks-add-contrast) @@ -131,16 +144,19 @@ erc-nicks-saturation-range `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." +List colors as strings (hex or named) or, alternatively, a single +symbol representing a set of colors, like that produced by the +function `defined-colors', which ERC associates with the symbol +`defined'. Similarly, `all' tells ERC to use any 24-bit color. +When specifying a list, users may want to set the option +`erc-nicks-color-adjustments' to nil to prevent unwanted culling." :type '(choice (const all) (const defined) (list string))) (defvar-local erc-nicks--face-table nil - "Hash table containing unique nick faces.") + "Hash table mapping nicks to unique, named faces. +Keys need not be valid nicks.") ;; https://stackoverflow.com/questions/596216#answer-56678483 (defun erc-nicks--get-luminance (color) @@ -261,25 +277,6 @@ erc-nicks-ensaturate ((< 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. @@ -291,11 +288,13 @@ erc-nicks--gen-color-ement (/ (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)) +;; This doesn't add an entry to the face table because "@" faces are +;; interned in the global `obarray' and thus easily accessible. (defun erc-nicks--revive (new-face old-face nick net) (put new-face 'erc-nicks--custom-nick (cons nick net)) + (put old-face 'erc-nicks--key nil) (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)) @@ -336,45 +335,88 @@ erc-nicks--reduce erc-nicks-color-adjustments (if (stringp color) (color-name-to-rgb color) color)))) +(defvar-local erc-nicks--colors-len nil) +(defvar-local erc-nicks--colors-pool nil) + +(defun erc-nicks--create-pool (adjustments colors &optional debug) + "Return COLORS that fall within parameters indicated by ADJUSTMENTS." + (let (addp capp satp pool rejects) + (dolist (adjustment adjustments) + (pcase adjustment + ((or 'erc-nicks-invert 'erc-nicks-add-contrast) (setq addp t)) + ('erc-nicks-cap-contrast (setq capp t)) + ('erc-nicks-ensaturate (setq satp t)))) + (dolist (color colors) + (let* ((rgb (color-name-to-rgb color)) + (contrast (and (or addp capp) (erc-nicks--get-contrast rgb)))) + (if (or (and addp (< contrast (car erc-nicks-contrast-range))) + (and capp (> contrast (cdr erc-nicks-contrast-range))) + (and-let* ((satp) + (s (cadr (apply #'color-rgb-to-hsl rgb)))) + (or (< s (car erc-nicks-saturation-range)) + (> s (cdr erc-nicks-saturation-range))))) + (when debug + (push color rejects)) + (push color pool)))) + (when-let + ((debug) + (cb (lambda (c) (message "contrast: %.3f :saturation: %.3f" + (erc-nicks--get-contrast c) + (cadr (apply #'color-rgb-to-hsl + (color-name-to-rgb c))))))) + (save-excursion + (when pool (list-colors-display pool "*erc-nicks-pool*" cb)) + (when rejects (list-colors-display rejects "*erc-nicks-rejects*" cb)))) + (nreverse pool))) + +(defun erc-nicks--init-pool (&optional debug) + (if (or (eq erc-nicks-colors 'all) (null erc-nicks-color-adjustments)) + (setq erc-nicks--colors-pool nil + erc-nicks--colors-len nil) + (let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors) + (defined-colors))) + (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors + debug))) + (setq erc-nicks--colors-pool pool + erc-nicks--colors-len (length pool))))) + +(defun erc-nicks--determine-color (key) + (if (eq erc-nicks-colors 'all) + (erc-nicks--reduce (erc-nicks--gen-color-ement key)) + (let ((pool (erc-with-server-buffer erc-nicks--colors-pool)) + (len (erc-with-server-buffer erc-nicks--colors-len))) + (nth (% (abs (sxhash key)) len) pool)))) + (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)))) + "Retrieve a face for trimmed and downcased NICK. +If NICK is new, use KEY to derive color, and store under NICK. +Favor a custom erc-nicks-NICK@NETWORK-face when defined." + (let ((table (erc-with-server-buffer erc-nicks--face-table))) (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))))) + (let ((color (erc-nicks--determine-color key)) (new-face (make-symbol (concat "erc-nicks-" nick "-face")))) + (put new-face 'erc-nicks--key key) (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))))) + (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." +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)) @@ -388,49 +430,59 @@ erc-nicks--skip-p (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." +(defvar-local erc-nicks--downcased-skip-nicks nil + "Case-mapped copy of `erc-nicks-skip-nicks'.") + +(defun erc-nicks--trim (nickname) + "Return downcased NICKNAME sans trailing `erc-nicks-ignore-chars'." + (erc-downcase + (if erc-nicks-ignore-chars + (string-trim-right nickname + (rx-to-string + `(: (+ (any ,erc-nicks-ignore-chars)) eot))) + nickname))) + +(defvar erc-nicks--key-function #'erc-nicks--gen-key-with-network + "Function for generating a key to determine nick color. +Called with a trimmed and case-mapped nickname.") + +(defun erc-nicks--gen-key-with-network (nickname) + "Generate key for NICKNAME with @network suffix." + (concat nickname (and erc-network "@") (and erc-network (erc-network-name)))) + +(defun erc-nicks--highlight (nickname &optional base-face) + "Return face for NICKNAME unless it or BASE-FACE is blacklisted." + (when-let* ((trimmed (erc-nicks--trim nickname)) + ((not (member trimmed erc-nicks--downcased-skip-nicks))) + ((not (and base-face + (erc-nicks--skip-p base-face erc-nicks-skip-faces + erc-nicks--max-skip-search)))) + (key (funcall erc-nicks--key-function trimmed)) + (out (erc-nicks--get-face trimmed key))) + (if (or (null erc-nicks-nickname-face) + (eq base-face erc-nicks-nickname-face)) + out + (cons out (erc-list erc-nicks-nickname-face))))) + +(defun erc-nicks--highlight-button (nick-object) + "Possibly add face to `erc-button--nick-user' NICK-OBJECT." (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))))) + (face (get-text-property (car (erc-button--nick-bounds nick-object)) + 'font-lock-face)) + (nick (erc-server-user-nickname (erc-button--nick-user nick-object))) + (out (erc-nicks--highlight nick face))) + (setf (erc-button--nick-erc-button-nickname-face nick-object) out)) nick-object) (define-erc-module nicks nil "Uniquely colorize nicknames in target buffers." ((if erc--target (progn + (setq erc-nicks--downcased-skip-nicks + (mapcar #'erc-downcase erc-nicks-skip-nicks)) (add-function :filter-return (local 'erc-button--modify-nick-function) - #'erc-nicks--highlight '((depth . 80))) + #'erc-nicks--highlight-button '((depth . 80))) (erc-button--phantom-users-mode +1)) (unless erc-button-mode (unless (memq 'button erc-modules) @@ -446,6 +498,7 @@ nicks "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)))) + (erc-nicks--init-pool) (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) @@ -455,10 +508,12 @@ nicks (kill-local-variable 'erc-nicks--bg-mode-value) (kill-local-variable 'erc-nicks--bg-luminance) (kill-local-variable 'erc-nicks--colors-len) + (kill-local-variable 'erc-nicks--colors-pool) + (kill-local-variable 'erc-nicks--downcased-skip-nicks) (when (fboundp 'erc-button--phantom-users-mode) (erc-button--phantom-users-mode -1)) (remove-function (local 'erc-button--modify-nick-function) - #'erc-nicks--highlight) + #'erc-nicks--highlight-button) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil 'remove #'equal) nil)) @@ -469,9 +524,9 @@ erc-nicks-customize-face (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))) + (setq nick (erc-nicks--trim (substring-no-properties nick))) (let* ((net (erc-network)) - (key (concat nick (and net (format "%9s" net)))) + (key (funcall erc-nicks--key-function nick)) (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) @@ -480,6 +535,20 @@ erc-nicks-customize-face (set-face-attribute old-face nil :inherit new-face)) (customize-face new-face))) +(defun erc-nicks-refresh (debug-pool) + "Recompute faces for all nicks on current network. +With DEBUG-POOL, list available colors and, in another buffer, +those culled (only applies when `erc-nicks-colors' is set to +something other than `all')." + (interactive "P") + (erc-with-server-buffer + (unless erc-nicks-mode (user-error "Module `nicks' disabled")) + (erc-nicks--init-pool debug-pool) + (dolist (nick (hash-table-keys erc-nicks--face-table)) + (when-let* ((face (gethash nick erc-nicks--face-table)) + (key (get face 'erc-nicks--key))) + (set-face-foreground face (erc-nicks--determine-color key)))))) + (provide 'erc-nicks) ;;; erc-nicks.el ends here diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index 0d640ad59c3..d8ddaef72e5 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -265,41 +265,6 @@ erc-nicks-cap-contrast (when noninteractive (kill-buffer))))) -;; Here is an example of how filters can steer us wrong (don't always -;; DTRT). Two keys with similar names hash to very different values: -;; -;; 1) "awbLibera.Chat" -> #x1e3b5ca4edbc ; deep blue -;; 2) "twbLibera.Chat" -> #xdeb4c26934af ; yellow/orange -;; -;; But on a dark bg, (1) falls below `erc-nicks-invert's min threshold -;; and thus gets treated, becoming #xe1c4a35b1243, which is quite -;; close to and thus easily confused with (2). - -(ert-deftest erc-nicks--hash () - (with-current-buffer (get-buffer-create "*erc-nicks--hash*") - ;; Here, we're just using `erc-nicks-tests--show-contrast' for show. - (let ((show (lambda (c) (erc-nicks-tests--print-contrast #'identity c)))) - - ;; Similar nicks yielding similar colors is likely undesirable. - (should (= (erc-nicks--hash "00000000") #xe4deaa6df385)) - (should (= (erc-nicks--hash "00000001") #xe4deaa6df386)) - (funcall show "#e4deaa6df385") - (funcall show "#e4deaa6df386") - - ;; So we currently pad from the right to avoid this. - (should (= (erc-nicks--hash "0Libera.Chat") #x32fdc0d63a92)) - (should (= (erc-nicks--hash "1Libera.Chat") #xc2c4f1c997f3)) - (funcall show "#32fdc0d63a92") - (funcall show "#c2c4f1c997f3") - - (should (= (erc-nicks--hash "0 OFTC") #x6805b7521261)) - (should (= (erc-nicks--hash "1 OFTC") #xf7cce8456fc2)) - (funcall show "#6805b7521261") - (funcall show "#f7cce8456fc2")) - - (when noninteractive - (kill-buffer)))) - (ert-deftest erc-nicks--skip-p () ;; Baseline (should-not (erc-nicks--skip-p 'bold nil 10000000)) @@ -337,4 +302,14 @@ erc-nicks--skip-p (should (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 3)) (should (erc-nicks--skip-p '(italic (default (bold shadow))) '(bold) 3))) +(ert-deftest erc-nicks--trim () + (should (equal (erc-nicks--trim "Bob`") "bob")) + (should (equal (erc-nicks--trim "Bob``") "bob")) + + ;; `erc--casemapping-rfc1459' + (let ((erc-nicks-ignore-chars "^")) + (should (equal (erc-nicks--trim "Bob~") "bob^")) + (should (equal (erc-nicks--trim "Bob^") "bob")))) + + ;;; erc-nicks-tests.el ends here -- 2.40.1