* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
@ 2023-05-18 14:37 J.P.
0 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-05-18 14:37 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 4776 bytes --]
Tags: patch
Severity: wishlist
Hi people,
Highlighting nicknames belonging to predetermined categories, like
"fools" or "pals," has long been part of ERC's repertoire. And doing the
same for any number of arbitrary buckets has long been on the wishlist.
Of the various third-party renditions floating around, the most
featureful is likely erc-hl-nicks by David Leatherman. I know I'm hardly
alone in feeling that folding this package or one like it into ERC
proper would be a welcome inclusion indeed, in part because the same
sentiment has been echoed widely in #emacs and beyond for years. To that
end, some months ago, Emacs' own Stefan K. reached out to David on
GitHub, entreating as much [1]. So far, that ticket has gone unanswered
(as has another, more recent effort by Corwin over email).
In any event, I'd like to find a way to move ahead with this, possibly
by replicating (most of) hl-nicks' functionality. Attached is a
quasi-"clean-roomed" (hopefully not too cynical) knockoff/POC for your
booing pleasure. Of course, if anyone has a problem with the degree of
perceived similitude, by all means, please say so. In general, this take
aims to be simpler and more tightly integrated with ERC's other
libraries, although both qualities would likely have manifested
naturally had we been able to officially procure the genuine article
(which of course I'd still be into).
Thanks,
J.P.
[1] https://github.com/leathekd/erc-hl-nicks/issues/15
In GNU Emacs 30.0.50 (build 2, x86_64-pc-linux-gnu, GTK+ Version
3.24.37, cairo version 1.17.6) of 2023-05-13 built on localhost
Repository revision: 867b104010760c4b7cd700078884cc774a01860a
Repository branch: master
Windowing system distributor 'The X.Org Foundation', version 11.0.12014000
System Description: Fedora Linux 37 (Workstation Edition)
Configured using:
'configure --enable-check-lisp-object-type --enable-checking=yes,glyphs
'CFLAGS=-O0 -g3'
PKG_CONFIG_PATH=:/usr/lib64/pkgconfig:/usr/share/pkgconfig'
Configured features:
ACL CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GPM GSETTINGS HARFBUZZ JPEG
JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 M17N_FLT MODULES NOTIFY
INOTIFY PDUMPER PNG RSVG SECCOMP SOUND SQLITE3 THREADS TIFF
TOOLKIT_SCROLL_BARS WEBP X11 XDBE XIM XINPUT2 XPM GTK3 ZLIB
Important settings:
value of $LANG: en_US.UTF-8
value of $XMODIFIERS: @im=ibus
locale-coding-system: utf-8-unix
Major mode: Lisp Interaction
Minor modes in effect:
tooltip-mode: t
global-eldoc-mode: t
eldoc-mode: t
show-paren-mode: t
electric-indent-mode: t
mouse-wheel-mode: t
tool-bar-mode: t
menu-bar-mode: t
file-name-shadow-mode: t
global-font-lock-mode: t
font-lock-mode: t
blink-cursor-mode: t
line-number-mode: t
indent-tabs-mode: t
transient-mark-mode: t
auto-composition-mode: t
auto-encryption-mode: t
auto-compression-mode: t
Load-path shadows:
None found.
Features:
(shadow sort mail-extr emacsbug message mailcap yank-media puny dired
dired-loaddefs rfc822 mml mml-sec epa derived epg rfc6068 epg-config
gnus-util text-property-search time-date mm-decode mm-bodies mm-encode
mail-parse rfc2231 mailabbrev gmm-utils mailheader sendmail rfc2047
rfc2045 ietf-drums mm-util mail-prsvr mail-utils erc auth-source cl-seq
eieio eieio-core cl-macs password-cache json subr-x map format-spec
cl-loaddefs cl-lib erc-backend erc-networks byte-opt gv bytecomp
byte-compile erc-common erc-compat erc-loaddefs rmc iso-transl tooltip
cconv eldoc paren electric uniquify ediff-hook vc-hooks lisp-float-type
elisp-mode mwheel term/x-win x-win term/common-win x-dnd tool-bar dnd
fontset image regexp-opt fringe tabulated-list replace newcomment
text-mode lisp-mode prog-mode register page tab-bar menu-bar rfn-eshadow
isearch easymenu timer select scroll-bar mouse jit-lock font-lock syntax
font-core term/tty-colors frame minibuffer nadvice seq simple cl-generic
indonesian philippine cham georgian utf-8-lang misc-lang vietnamese
tibetan thai tai-viet lao korean japanese eucjp-ms cp51932 hebrew greek
romanian slovak czech european ethiopic indian cyrillic chinese
composite emoji-zwj charscript charprop case-table epa-hook
jka-cmpr-hook help abbrev obarray oclosure cl-preloaded button loaddefs
theme-loaddefs faces cus-face macroexp files window text-properties
overlay sha1 md5 base64 format env code-pages mule custom widget keymap
hashtable-print-readable backquote threads dbusbind inotify lcms2
dynamic-setting system-font-setting font-render-setting cairo
move-toolbar gtk x-toolkit xinput2 x multi-tty make-network-process
emacs)
Memory information:
((conses 16 64236 9476)
(symbols 48 8573 0)
(strings 32 23246 1709)
(string-bytes 1 674076)
(vectors 16 15015)
(vector-slots 8 207266 8159)
(floats 8 24 33)
(intervals 56 229 0)
(buffers 976 10))
[-- Attachment #2: 0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch --]
[-- Type: text/x-patch, Size: 29213 bytes --]
From 40297aca7eff54cfc6fc668098749e88c9de9fd0 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH] [5.6] Add module for colorizing nicknames to ERC
* doc/misc/erc.texi: Add `nicks' to module lineup.
* etc/ERC-NEWS: Mention new module `nicks'.
* lisp/erc/erc-button.el (erc--nick-popup-alist, erc-nick-popup): New
variable to help the latter access special actions owned by modules.
* lisp/erc/erc-nicks.el: New file.
* lisp/erc/erc.el: (erc-modules): Add `nicks'.
* test/lisp/erc/erc-nicks-tests.el: New file.
* test/lisp/erc/erc-tests (erc-tests--modules): Add `nicks'.
---
doc/misc/erc.texi | 4 +
etc/ERC-NEWS | 8 +
lisp/erc/erc-button.el | 12 +-
lisp/erc/erc-nicks.el | 374 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 140 ++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
7 files changed, 537 insertions(+), 4 deletions(-)
create mode 100644 lisp/erc/erc-nicks.el
create mode 100644 test/lisp/erc/erc-nicks-tests.el
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index 1f343fc8529..f7036e57638 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -459,6 +459,10 @@ Modules
@item netsplit
Detect netsplits
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
@cindex modules, noncommands
@item noncommands
Don't display non-IRC commands after evaluation
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 1aa445c5b9c..41af8b88277 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of
buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get
started.
+** A new module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core. Users familiar with
+the excellent 'erc-hl-nicks' by David Leatherman, from which this new
+addition draws heavily, will already be familiar with its suite of
+handy options. By default, each nickname in an ERC session receives a
+unique face with a unique (or evenly dealt) foreground color. Add
+'nicks' to 'erc-modules' to get started.
+
** A unified interactive entry point.
New users are often dismayed to discover that M-x ERC doesn't connect
to its default network, Libera.Chat, over TLS. Though perhaps a
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index 4307dc3b860..b370fa4bf95 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -685,15 +685,21 @@ erc-nick-popup-alist
:type '(repeat (cons (string :tag "Op")
sexp)))
+(defvar-local erc--nick-popup-alist nil
+ "Internally controlled items for `erc-nick-popup-alist'.")
+
(defun erc-nick-popup (nick)
(let* ((completion-ignore-case t)
+ (alist (append erc-nick-popup-alist erc--nick-popup-alist))
(action (completing-read (format-message
"What action to take on `%s'? " nick)
- erc-nick-popup-alist))
- (code (cdr (assoc action erc-nick-popup-alist))))
+ alist))
+ (code (cdr (assoc action alist))))
(when code
(erc-set-active-buffer (current-buffer))
- (eval code `((nick . ,nick))))))
+ (if (functionp code)
+ (funcall code nick)
+ (eval code `((nick . ,nick)))))))
;;; Callback functions
(defun erc-button-describe-symbol (symbol-name)
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..53d1e0cc592
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,374 @@
+;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is heavily influenced by the lovely and more featureful
+;;
+;; `erc-hl-nicks' by David Leatherman
+;; <http://www.github.com/leathekd/erc-nicks>
+;;
+;; which itself is based on
+;;
+;; `erc-highlight-nicknames' by André Riemann, Andy Stewart, and
+;; others <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+;;
+
+;;; 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-regexp
+ (cons (rx bot (+ (any ",`'_-"))) (rx (+ (any ",`'_-")) eot))
+ "Characters surrounding a nick to ignore while highlighting.
+Regexps should be suitable for `string-trim'."
+ :type '(choice (cons string string) (const nil)))
+
+(defcustom erc-nicks-skip-nicks nil
+ "Nicks to not highlight."
+ :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-contrast-strategy
+ '(erc-nicks-invert erc-nicks-add-contrast)
+ "Treatments applied to colors for increasing visibility.
+A value of `erc-nicks-invert' inverts a nick when it's too close
+to the background. A value of `erc-nicks-add-contrast'
+attempts to find a decent contrast ratio by brightening or
+darkening. This option can also be a list, in which case,
+members will be applied in the order they appear. For example,
+
+ \\='(erc-nicks-invert erc-nicks-add-contrast)
+
+will invert as needed and likewise adjust the contrast. Note
+that anything specified by this option will still be applied when
+`erc-nicks-colors' is a user-defined list of colors."
+ :type '(choice (function-item :tag "Invert" erc-nicks-invert)
+ (function-item :tag "Contrast" erc-nicks-add-contrast)
+ (repeat function)
+ (const nil)
+ function))
+
+(defcustom erc-nicks-contrast-ratio 3.5
+ "Desired amount of contrast.
+For this to matter, `erc-nicks-add-contrast' must be present in
+the value of `erc-nicks-color-contrast-strategy'. When that's
+so, this specifies the amount of contrast between a buffer's
+background color and the foreground colors chosen. The closer
+the number is to the maximum, 21(:1), the greater the contrast.
+Depending on the background, nicks are either tinted in pastel or
+muted with dark gray. Somewhere between 3.0 and 4.5 seems ideal."
+ :type '(number :match (lambda (_ n) (and (floatp n) (< 0 n 21)))
+ :type-error "This should be a float between 0 and 21"))
+
+(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."
+ (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-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)
+(defvar-local erc-nicks--bg-luminance nil)
+
+;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html
+;;
+;; We could cache results, which may help when `erc-nicks-colors' is
+;; set to `defined'.
+
+(defun erc-nicks-add-contrast (color)
+ "Adjust COLOR by blending it with white or black.
+Unless sufficient contrast exists between COLOR and the
+background, bring the contrast up to `erc-nicks-contrast-ratio'."
+ (let* ((lum-bg (or erc-nicks--bg-luminance
+ (setq erc-nicks--bg-luminance
+ (erc-nicks--get-luminance erc-nicks-bg-color))))
+ (stop (if (eq 'dark (erc-nicks--bg-mode))
+ '(1.0 1.0 1.0)
+ '(0.0 0.0 0.0)))
+ (start (color-name-to-rgb color))
+ ;; From `color-gradient' in color.el
+ (r (nth 0 start))
+ (g (nth 1 start))
+ (b (nth 2 start))
+ (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)
+ (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 ((< cur erc-nicks-contrast-ratio)
+ (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)))))
+ (color-rgb-to-hex r g b)))
+
+;; Inversion thresholds for dark and light, respectively.
+(defvar erc-nicks--min-lum (/ 1 3.0))
+(defvar erc-nicks--max-lum (/ 2 3.0))
+
+(defun erc-nicks-invert (color)
+ "Invert COLOR based on luminance and background."
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) erc-nicks--min-lum))
+ ('light (> (erc-nicks--get-luminance color) erc-nicks--max-lum)))
+ (pcase-let ((`(,r ,g ,b) (color-values color)))
+ (format "#%04x%04x%04x" (- 65535 r) (- 65535 g) (- 65535 b)))
+ 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))
+
+(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"))
+
+(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--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 (seq-reduce
+ (lambda (color strategy) (funcall strategy color))
+ (erc-list erc-nicks-color-contrast-strategy)
+ (pcase erc-nicks-colors
+ ('all (format "#%012x" (erc-nicks--hash 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)))))
+
+(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-regexp
+ (string-trim (erc-server-user-nickname server-user)
+ (car erc-nicks-ignore-chars-regexp)
+ (cdr erc-nicks-ignore-chars-regexp))
+ (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 (seq-some (lambda (f) (memq f erc-nicks-skip-faces))
+ (erc-list face)))) ; cl-notany
+ ;; 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--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--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
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 495e25212ce..5a3b312b53b 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2026,6 +2026,7 @@ erc-modules
move-to-prompt)
(const :tag "netsplit: Detect netsplits" netsplit)
(const :tag "networks: Provide data about IRC networks" networks)
+ (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
(const :tag "noncommands: Don't display non-IRC commands after evaluation"
noncommands)
(const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..756260d718d
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,140 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;; in erc-fill-tests.el. (Should probably move helpers to a common
+;; library under ./resources.)
+
+;;; Code:
+
+(require 'ert)
+(require 'erc-nicks)
+
+(ert-deftest erc-nicks--get-luminance ()
+ (should (eql 0.0 (erc-nicks--get-luminance "black")))
+ (should (eql 1.0 (erc-nicks--get-luminance "white")))
+ (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+ ;; RGB floats from a `display-graphic-p' session.
+ (let ((a (erc-nicks--get-luminance ; #9439ad
+ '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+ (b (erc-nicks--get-luminance ; #ae54c7
+ '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+ (c (erc-nicks--get-luminance ; #d19ddf
+ '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+ (d (erc-nicks--get-luminance ; #f5e8f8
+ '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+ ;; Low, med, high contrast comparisons against known values from
+ ;; an external source.
+ (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+ (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+ (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert ()
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (erc-nicks-invert "white") "white"))
+ (should (equal (erc-nicks-invert "black") "#ffffffffffff"))
+ (should (equal (erc-nicks-invert "green") "green")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (erc-nicks-invert "white") "#000000000000"))
+ (should (equal (erc-nicks-invert "black") "black"))
+ (should (equal (erc-nicks-invert "green") "#ffff0000ffff"))))
+
+(defun erc-nicks-tests--show-contrast (color)
+ (let ((result (erc-nicks-add-contrast color))
+ (fg (if (eq 'dark erc-nicks--bg-mode-value) "white" "black"))
+ (start (point)))
+ (insert (format "%16s%-16s%16s%-16s\n"
+ (concat color "-")
+ (concat ">" result)
+ (concat color " ")
+ (concat " " result)))
+ (put-text-property start (+ start 32) 'face
+ (list :foreground fg))
+ (put-text-property (+ start 32) (+ start 48) 'face
+ (list :background color :foreground result))
+ (put-text-property (+ start 48) (+ start 64) 'face
+ (list :background result :foreground color))
+ result))
+
+(ert-deftest erc-nicks-add-contrast ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+ (should (equal "#893a893a893a" (erc-nicks-tests--show-contrast "white")))
+ (should (equal "#893a893a893a"
+ (erc-nicks-tests--show-contrast "#893a893a893a")))
+ (should (equal "#000000000000" (erc-nicks-tests--show-contrast "black")))
+ (should (equal "#ffff00000000" (erc-nicks-tests--show-contrast "red")))
+ (should (equal "#0000a12e0000" (erc-nicks-tests--show-contrast "green")))
+ (should (equal "#00000000ffff" (erc-nicks-tests--show-contrast "blue")))
+
+ ;; When the input is already near the desired ratio, the result
+ ;; may not be in bounds, only close. But the difference is
+ ;; usually imperceptible.
+ (unless noninteractive
+ (should (equal "#777788889999" ; well inside (light slate gray)
+ (erc-nicks-tests--show-contrast "#777788889999")))
+ (should (equal "#7c498bd39b5c" ; slightly outside -> just outside
+ (erc-nicks-tests--show-contrast "#88889999aaaa")))
+ (should (equal "#7bcc8b479ac0" ; just outside -> just inside
+ (erc-nicks-tests--show-contrast "#7c498bd39b5c")))
+ (should (equal "#7bcc8b479ac0" ; just inside
+ (erc-nicks-tests--show-contrast "#7bcc8b479ac0"))))
+
+ (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*")
+ ;; Similar nicks yielding similar colors is likely undesirable.
+ (should (= (erc-nicks--hash "00000000") #xe4deaa6df385))
+ (should (= (erc-nicks--hash "00000001") #xe4deaa6df386))
+ (erc-nicks-tests--show-contrast "#e4deaa6df385")
+ (erc-nicks-tests--show-contrast "#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))
+ (erc-nicks-tests--show-contrast "#32fdc0d63a92")
+ (erc-nicks-tests--show-contrast "#c2c4f1c997f3")
+
+ (should (= (erc-nicks--hash "0 OFTC") #x6805b7521261))
+ (should (= (erc-nicks--hash "1 OFTC") #xf7cce8456fc2))
+ (erc-nicks-tests--show-contrast "#6805b7521261")
+ (erc-nicks-tests--show-contrast "#f7cce8456fc2")
+ (when noninteractive
+ (kill-buffer))))
+
+;;; erc-nicks-tests.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index b624186d88d..991bfa3b082 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -1953,7 +1953,7 @@ erc-handle-irc-url
(defconst erc-tests--modules
'( autoaway autojoin button capab-identify completion dcc fill identd
imenu irccontrols keep-place list log match menu move-to-prompt netsplit
- networks noncommands notifications notify page readonly
+ networks nicks noncommands notifications notify page readonly
replace ring sasl scrolltobottom services smiley sound
spelling stamp track truncate unmorse xdcc))
--
2.40.0
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] <87ilcp1za1.fsf@neverwas.me>
@ 2023-05-23 13:37 ` J.P.
2023-05-30 14:24 ` J.P.
` (8 subsequent siblings)
9 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-05-23 13:37 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 248 bytes --]
v2. Generalize contrast function. Make option `erc-nicks-contrast-ratio'
a cons. Change default for `erc-nicks-color-contrast-strategy'. Generate
`use-package' snippet alongside standard `defface' (to help Customize
haters persist edited colors).
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0000-v1-v2.diff --]
[-- Type: text/x-patch, Size: 12931 bytes --]
From 8e16d161b6e9f3c67b4ccbe9e44fc73c43bb70f5 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Tue, 23 May 2023 06:31:04 -0700
Subject: [PATCH 0/1] *** NOT A PATCH ***
*** BLURB HERE ***
F. Jason Park (1):
[5.6] Add module for colorizing nicknames to ERC
doc/misc/erc.texi | 4 +
etc/ERC-NEWS | 8 +
lisp/erc/erc-button.el | 12 +-
lisp/erc/erc-nicks.el | 389 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 174 ++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
7 files changed, 586 insertions(+), 4 deletions(-)
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 53d1e0cc592..85d182f9a09 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -44,7 +44,7 @@ erc-nicks-ignore-chars-regexp
(cons (rx bot (+ (any ",`'_-"))) (rx (+ (any ",`'_-")) eot))
"Characters surrounding a nick to ignore while highlighting.
Regexps should be suitable for `string-trim'."
- :type '(choice (cons string string) (const nil)))
+ :type '(choice (cons regexp regexp) (const nil)))
(defcustom erc-nicks-skip-nicks nil
"Nicks to not highlight."
@@ -68,7 +68,7 @@ erc-nicks-bg-color
:type 'string)
(defcustom erc-nicks-color-contrast-strategy
- '(erc-nicks-invert erc-nicks-add-contrast)
+ '(erc-nicks-add-contrast erc-nicks-cap-contrast)
"Treatments applied to colors for increasing visibility.
A value of `erc-nicks-invert' inverts a nick when it's too close
to the background. A value of `erc-nicks-add-contrast'
@@ -82,22 +82,24 @@ erc-nicks-color-contrast-strategy
that anything specified by this option will still be applied when
`erc-nicks-colors' is a user-defined list of colors."
:type '(choice (function-item :tag "Invert" erc-nicks-invert)
- (function-item :tag "Contrast" erc-nicks-add-contrast)
+ (function-item :tag "Add contrast" erc-nicks-add-contrast)
+ (function-item :tag "Cap contrast" erc-nicks-cap-contrast)
(repeat function)
(const nil)
function))
-(defcustom erc-nicks-contrast-ratio 3.5
- "Desired amount of contrast.
-For this to matter, `erc-nicks-add-contrast' must be present in
-the value of `erc-nicks-color-contrast-strategy'. When that's
-so, this specifies the amount of contrast between a buffer's
-background color and the foreground colors chosen. The closer
-the number is to the maximum, 21(:1), the greater the contrast.
-Depending on the background, nicks are either tinted in pastel or
-muted with dark gray. Somewhere between 3.0 and 4.5 seems ideal."
- :type '(number :match (lambda (_ n) (and (floatp n) (< 0 n 21)))
- :type-error "This should be a float between 0 and 21"))
+(defcustom erc-nicks-contrast-ratio '(3.5 . 12.5)
+ "Desired range of contrast as a cons of (MIN . MAX).
+For this to matter, `erc-nicks-color-contrast-strategy' must be
+set to `erc-nicks-add-contrast' or `erc-nicks-cap-contrast' or
+contain at least one if that option is a list. If adding
+contrast, MIN specifies the minimum amount allowed between a
+buffer's background color and the foreground colors specified by
+`erc-nicks-colors'. The closer the number to the possible
+maximum of 21(:1), the greater the contrast. Depending on the
+background, nicks are either tinted in pastel or muted with dark
+gray. MAX works similarly for reducing contrast."
+ :type '(cons float float))
(defcustom erc-nicks-colors 'all
"Pool of colors.
@@ -142,14 +144,11 @@ erc-nicks--bg-luminance
;; We could cache results, which may help when `erc-nicks-colors' is
;; set to `defined'.
-(defun erc-nicks-add-contrast (color)
- "Adjust COLOR by blending it with white or black.
-Unless sufficient contrast exists between COLOR and the
-background, bring the contrast up to `erc-nicks-contrast-ratio'."
+(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))))
- (stop (if (eq 'dark (erc-nicks--bg-mode))
+ (stop (if (eq (if decrease 'light 'dark) (erc-nicks--bg-mode))
'(1.0 1.0 1.0)
'(0.0 0.0 0.0)))
(start (color-name-to-rgb color))
@@ -168,7 +167,7 @@ erc-nicks-add-contrast
(lighter (if (= darker lum-bg) lum-fg lum-bg))
(cur (/ (+ 0.05 lighter) (+ 0.05 darker)))
(scale (expt 2 maxtries)))
- (cond ((< cur erc-nicks-contrast-ratio)
+ (cond ((if decrease (> cur target) (< cur target))
(setq r (+ r (* r-step scale))
g (+ g (* g-step scale))
b (+ b (* b-step scale))))
@@ -185,6 +184,19 @@ erc-nicks-add-contrast
(not (zerop (cl-decf maxtries)))))
(color-rgb-to-hex 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-ratio'."
+ (erc-nicks--adjust-contrast color (car erc-nicks-contrast-ratio)))
+
+(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-ratio'."
+ (erc-nicks--adjust-contrast color (cdr erc-nicks-contrast-ratio) 'remove))
+
;; Inversion thresholds for dark and light, respectively.
(defvar erc-nicks--min-lum (/ 1 3.0))
(defvar erc-nicks--max-lum (/ 2 3.0))
@@ -237,6 +249,9 @@ erc-nicks--create-defface-template
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)
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
index 756260d718d..e0a5691b073 100644
--- a/test/lisp/erc/erc-nicks-tests.el
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -60,8 +60,8 @@ erc-nicks-invert
(should (equal (erc-nicks-invert "black") "black"))
(should (equal (erc-nicks-invert "green") "#ffff0000ffff"))))
-(defun erc-nicks-tests--show-contrast (color)
- (let ((result (erc-nicks-add-contrast color))
+(defun erc-nicks-tests--print-contrast (fn color)
+ (let ((result (funcall fn color))
(fg (if (eq 'dark erc-nicks--bg-mode-value) "white" "black"))
(start (point)))
(insert (format "%16s%-16s%16s%-16s\n"
@@ -79,29 +79,59 @@ erc-nicks-tests--show-contrast
(ert-deftest erc-nicks-add-contrast ()
(let ((erc-nicks--bg-luminance 1.0)
- (erc-nicks--bg-mode-value 'light))
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-add-contrast c))))
(with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
- (should (equal "#893a893a893a" (erc-nicks-tests--show-contrast "white")))
- (should (equal "#893a893a893a"
- (erc-nicks-tests--show-contrast "#893a893a893a")))
- (should (equal "#000000000000" (erc-nicks-tests--show-contrast "black")))
- (should (equal "#ffff00000000" (erc-nicks-tests--show-contrast "red")))
- (should (equal "#0000a12e0000" (erc-nicks-tests--show-contrast "green")))
- (should (equal "#00000000ffff" (erc-nicks-tests--show-contrast "blue")))
+ (should (equal "#893a893a893a" (funcall show "white")))
+ (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#0000a12e0000" (funcall show "green")))
+ (should (equal "#00000000ffff" (funcall show "blue")))
;; When the input is already near the desired ratio, the result
;; may not be in bounds, only close. But the difference is
;; usually imperceptible.
(unless noninteractive
- (should (equal "#777788889999" ; well inside (light slate gray)
- (erc-nicks-tests--show-contrast "#777788889999")))
- (should (equal "#7c498bd39b5c" ; slightly outside -> just outside
- (erc-nicks-tests--show-contrast "#88889999aaaa")))
- (should (equal "#7bcc8b479ac0" ; just outside -> just inside
- (erc-nicks-tests--show-contrast "#7c498bd39b5c")))
- (should (equal "#7bcc8b479ac0" ; just inside
- (erc-nicks-tests--show-contrast "#7bcc8b479ac0"))))
+ ;; Well inside (light slate gray)
+ (should (equal "#777788889999" (funcall show "#777788889999")))
+ ;; Slightly outside -> just outside
+ (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+ ;; Just outside -> just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+ ;; Just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+ (should (= 12.5 (cdr erc-nicks-contrast-ratio)))
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-cap-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+ (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+ (should ; 12.32 -> 12.32 (same)
+ (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+ (should (equal (funcall show "white") "#ffffffffffff"))
+
+ (unless noninteractive
+ (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+ (should (equal (funcall show "DarkGreen") "#000064640000"))
+ ;; 15.29 -> 12.38
+ (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+ ;; 12.50 -> 12.22
+ (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+ ;; 12.57 -> 12.28
+ (should (equal (funcall show "#338033803380") "#344c344c344c"))
+ ;; 12.67 -> 12.37
+ (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
(when noninteractive
(kill-buffer)))))
@@ -118,22 +148,26 @@ erc-nicks-add-contrast
(ert-deftest erc-nicks--hash ()
(with-current-buffer (get-buffer-create "*erc-nicks--hash*")
- ;; Similar nicks yielding similar colors is likely undesirable.
- (should (= (erc-nicks--hash "00000000") #xe4deaa6df385))
- (should (= (erc-nicks--hash "00000001") #xe4deaa6df386))
- (erc-nicks-tests--show-contrast "#e4deaa6df385")
- (erc-nicks-tests--show-contrast "#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))
- (erc-nicks-tests--show-contrast "#32fdc0d63a92")
- (erc-nicks-tests--show-contrast "#c2c4f1c997f3")
-
- (should (= (erc-nicks--hash "0 OFTC") #x6805b7521261))
- (should (= (erc-nicks--hash "1 OFTC") #xf7cce8456fc2))
- (erc-nicks-tests--show-contrast "#6805b7521261")
- (erc-nicks-tests--show-contrast "#f7cce8456fc2")
+ ;; 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))))
--
2.40.0
[-- Attachment #3: 0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch --]
[-- Type: text/x-patch, Size: 31255 bytes --]
From 8e16d161b6e9f3c67b4ccbe9e44fc73c43bb70f5 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH 1/1] [5.6] Add module for colorizing nicknames to ERC
* doc/misc/erc.texi: Add `nicks' to module lineup.
* etc/ERC-NEWS: Mention new module `nicks'.
* lisp/erc/erc-button.el (erc--nick-popup-alist, erc-nick-popup): New
variable to help the latter access special actions owned by modules.
* lisp/erc/erc-nicks.el: New file.
* lisp/erc/erc.el: (erc-modules): Add `nicks'.
* test/lisp/erc/erc-nicks-tests.el: New file.
* test/lisp/erc/erc-tests (erc-tests--modules): Add
`nicks'. (Bug#63569)
---
doc/misc/erc.texi | 4 +
etc/ERC-NEWS | 8 +
lisp/erc/erc-button.el | 12 +-
lisp/erc/erc-nicks.el | 389 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 174 ++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
7 files changed, 586 insertions(+), 4 deletions(-)
create mode 100644 lisp/erc/erc-nicks.el
create mode 100644 test/lisp/erc/erc-nicks-tests.el
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index 1f343fc8529..f7036e57638 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -459,6 +459,10 @@ Modules
@item netsplit
Detect netsplits
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
@cindex modules, noncommands
@item noncommands
Don't display non-IRC commands after evaluation
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index d257bdcbf51..2d3626e28b8 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of
buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get
started.
+** A new module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core. Users familiar with
+the excellent 'erc-hl-nicks' by David Leatherman, from which this new
+addition draws heavily, will already be familiar with its suite of
+handy options. By default, each nickname in an ERC session receives a
+unique face with a unique (or evenly dealt) foreground color. Add
+'nicks' to 'erc-modules' to get started.
+
** A unified interactive entry point.
New users are often dismayed to discover that M-x ERC doesn't connect
to its default network, Libera.Chat, over TLS. Though perhaps a
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index 4307dc3b860..b370fa4bf95 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -685,15 +685,21 @@ erc-nick-popup-alist
:type '(repeat (cons (string :tag "Op")
sexp)))
+(defvar-local erc--nick-popup-alist nil
+ "Internally controlled items for `erc-nick-popup-alist'.")
+
(defun erc-nick-popup (nick)
(let* ((completion-ignore-case t)
+ (alist (append erc-nick-popup-alist erc--nick-popup-alist))
(action (completing-read (format-message
"What action to take on `%s'? " nick)
- erc-nick-popup-alist))
- (code (cdr (assoc action erc-nick-popup-alist))))
+ alist))
+ (code (cdr (assoc action alist))))
(when code
(erc-set-active-buffer (current-buffer))
- (eval code `((nick . ,nick))))))
+ (if (functionp code)
+ (funcall code nick)
+ (eval code `((nick . ,nick)))))))
;;; Callback functions
(defun erc-button-describe-symbol (symbol-name)
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..85d182f9a09
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,389 @@
+;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is heavily influenced by the lovely and more featureful
+;;
+;; `erc-hl-nicks' by David Leatherman
+;; <http://www.github.com/leathekd/erc-nicks>
+;;
+;; which itself is based on
+;;
+;; `erc-highlight-nicknames' by André Riemann, Andy Stewart, and
+;; others <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+;;
+
+;;; 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-regexp
+ (cons (rx bot (+ (any ",`'_-"))) (rx (+ (any ",`'_-")) eot))
+ "Characters surrounding a nick to ignore while highlighting.
+Regexps should be suitable for `string-trim'."
+ :type '(choice (cons regexp regexp) (const nil)))
+
+(defcustom erc-nicks-skip-nicks nil
+ "Nicks to not highlight."
+ :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-contrast-strategy
+ '(erc-nicks-add-contrast erc-nicks-cap-contrast)
+ "Treatments applied to colors for increasing visibility.
+A value of `erc-nicks-invert' inverts a nick when it's too close
+to the background. A value of `erc-nicks-add-contrast'
+attempts to find a decent contrast ratio by brightening or
+darkening. This option can also be a list, in which case,
+members will be applied in the order they appear. For example,
+
+ \\='(erc-nicks-invert erc-nicks-add-contrast)
+
+will invert as needed and likewise adjust the contrast. Note
+that anything specified by this option will still be applied when
+`erc-nicks-colors' is a user-defined list of colors."
+ :type '(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)
+ (repeat function)
+ (const nil)
+ function))
+
+(defcustom erc-nicks-contrast-ratio '(3.5 . 12.5)
+ "Desired range of contrast as a cons of (MIN . MAX).
+For this to matter, `erc-nicks-color-contrast-strategy' must be
+set to `erc-nicks-add-contrast' or `erc-nicks-cap-contrast' or
+contain at least one if that option is a list. If adding
+contrast, MIN specifies the minimum amount allowed between a
+buffer's background color and the foreground colors specified by
+`erc-nicks-colors'. The closer the number to the possible
+maximum of 21(:1), the greater the contrast. Depending on the
+background, nicks are either tinted in pastel or muted with dark
+gray. MAX works similarly for reducing contrast."
+ :type '(cons float float))
+
+(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."
+ (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-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)
+(defvar-local erc-nicks--bg-luminance nil)
+
+;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html
+;;
+;; We could cache results, which may help when `erc-nicks-colors' is
+;; set to `defined'.
+
+(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))))
+ (stop (if (eq (if decrease 'light 'dark) (erc-nicks--bg-mode))
+ '(1.0 1.0 1.0)
+ '(0.0 0.0 0.0)))
+ (start (color-name-to-rgb color))
+ ;; From `color-gradient' in color.el
+ (r (nth 0 start))
+ (g (nth 1 start))
+ (b (nth 2 start))
+ (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)
+ (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)))))
+ (color-rgb-to-hex 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-ratio'."
+ (erc-nicks--adjust-contrast color (car erc-nicks-contrast-ratio)))
+
+(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-ratio'."
+ (erc-nicks--adjust-contrast color (cdr erc-nicks-contrast-ratio) 'remove))
+
+;; Inversion thresholds for dark and light, respectively.
+(defvar erc-nicks--min-lum (/ 1 3.0))
+(defvar erc-nicks--max-lum (/ 2 3.0))
+
+(defun erc-nicks-invert (color)
+ "Invert COLOR based on luminance and background."
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) erc-nicks--min-lum))
+ ('light (> (erc-nicks--get-luminance color) erc-nicks--max-lum)))
+ (pcase-let ((`(,r ,g ,b) (color-values color)))
+ (format "#%04x%04x%04x" (- 65535 r) (- 65535 g) (- 65535 b)))
+ 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))
+
+(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--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 (seq-reduce
+ (lambda (color strategy) (funcall strategy color))
+ (erc-list erc-nicks-color-contrast-strategy)
+ (pcase erc-nicks-colors
+ ('all (format "#%012x" (erc-nicks--hash 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)))))
+
+(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-regexp
+ (string-trim (erc-server-user-nickname server-user)
+ (car erc-nicks-ignore-chars-regexp)
+ (cdr erc-nicks-ignore-chars-regexp))
+ (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 (seq-some (lambda (f) (memq f erc-nicks-skip-faces))
+ (erc-list face)))) ; cl-notany
+ ;; 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--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--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
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 495e25212ce..5a3b312b53b 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2026,6 +2026,7 @@ erc-modules
move-to-prompt)
(const :tag "netsplit: Detect netsplits" netsplit)
(const :tag "networks: Provide data about IRC networks" networks)
+ (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
(const :tag "noncommands: Don't display non-IRC commands after evaluation"
noncommands)
(const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..e0a5691b073
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,174 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;; in erc-fill-tests.el. (Should probably move helpers to a common
+;; library under ./resources.)
+
+;;; Code:
+
+(require 'ert)
+(require 'erc-nicks)
+
+(ert-deftest erc-nicks--get-luminance ()
+ (should (eql 0.0 (erc-nicks--get-luminance "black")))
+ (should (eql 1.0 (erc-nicks--get-luminance "white")))
+ (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+ ;; RGB floats from a `display-graphic-p' session.
+ (let ((a (erc-nicks--get-luminance ; #9439ad
+ '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+ (b (erc-nicks--get-luminance ; #ae54c7
+ '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+ (c (erc-nicks--get-luminance ; #d19ddf
+ '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+ (d (erc-nicks--get-luminance ; #f5e8f8
+ '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+ ;; Low, med, high contrast comparisons against known values from
+ ;; an external source.
+ (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+ (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+ (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert ()
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (erc-nicks-invert "white") "white"))
+ (should (equal (erc-nicks-invert "black") "#ffffffffffff"))
+ (should (equal (erc-nicks-invert "green") "green")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (erc-nicks-invert "white") "#000000000000"))
+ (should (equal (erc-nicks-invert "black") "black"))
+ (should (equal (erc-nicks-invert "green") "#ffff0000ffff"))))
+
+(defun erc-nicks-tests--print-contrast (fn color)
+ (let ((result (funcall fn color))
+ (fg (if (eq 'dark erc-nicks--bg-mode-value) "white" "black"))
+ (start (point)))
+ (insert (format "%16s%-16s%16s%-16s\n"
+ (concat color "-")
+ (concat ">" result)
+ (concat color " ")
+ (concat " " result)))
+ (put-text-property start (+ start 32) 'face
+ (list :foreground fg))
+ (put-text-property (+ start 32) (+ start 48) 'face
+ (list :background color :foreground result))
+ (put-text-property (+ start 48) (+ start 64) 'face
+ (list :background result :foreground color))
+ result))
+
+(ert-deftest erc-nicks-add-contrast ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-add-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+ (should (equal "#893a893a893a" (funcall show "white")))
+ (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#0000a12e0000" (funcall show "green")))
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ ;; When the input is already near the desired ratio, the result
+ ;; may not be in bounds, only close. But the difference is
+ ;; usually imperceptible.
+ (unless noninteractive
+ ;; Well inside (light slate gray)
+ (should (equal "#777788889999" (funcall show "#777788889999")))
+ ;; Slightly outside -> just outside
+ (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+ ;; Just outside -> just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+ ;; Just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+ (should (= 12.5 (cdr erc-nicks-contrast-ratio)))
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-cap-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+ (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+ (should ; 12.32 -> 12.32 (same)
+ (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+ (should (equal (funcall show "white") "#ffffffffffff"))
+
+ (unless noninteractive
+ (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+ (should (equal (funcall show "DarkGreen") "#000064640000"))
+ ;; 15.29 -> 12.38
+ (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+ ;; 12.50 -> 12.22
+ (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+ ;; 12.57 -> 12.28
+ (should (equal (funcall show "#338033803380") "#344c344c344c"))
+ ;; 12.67 -> 12.37
+ (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
+
+ (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))))
+
+;;; erc-nicks-tests.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index b624186d88d..991bfa3b082 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -1953,7 +1953,7 @@ erc-handle-irc-url
(defconst erc-tests--modules
'( autoaway autojoin button capab-identify completion dcc fill identd
imenu irccontrols keep-place list log match menu move-to-prompt netsplit
- networks noncommands notifications notify page readonly
+ networks nicks noncommands notifications notify page readonly
replace ring sasl scrolltobottom services smiley sound
spelling stamp track truncate unmorse xdcc))
--
2.40.0
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] <87ilcp1za1.fsf@neverwas.me>
2023-05-23 13:37 ` bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC J.P.
@ 2023-05-30 14:24 ` J.P.
2023-06-13 4:07 ` J.P.
` (7 subsequent siblings)
9 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-05-30 14:24 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 805 bytes --]
v3. Spin off nick-popup business to separate patch. Fix existing bug
concerning truncated transmission of KICK "reason". Change "strategy"
function type from operating on strings to normalized RGB triplets. Fix
perceived bug in invert strategy and have it consult contrast knob. Add
new saturation strategy and knob. Redo front matter for anticipated
inclusion of other authors.
. . .
For anyone following this bug, there's been some movement regarding the
possible official incorporation (or adaptation) of erc-hl-nicks by David
Leatherman. How exactly that's to occur will be up for discussion in due
course. These developments do mean that this feature may not be ready in
time for ERC 5.6, so I may end up renaming this bug at some point (just
a heads up). Thanks.
[-- Attachment #2: 0000-v2-v3.diff --]
[-- Type: text/x-patch, Size: 32772 bytes --]
From a7d23ce4ca9f3b09c03b65d074ad0915d88a6da1 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Tue, 30 May 2023 07:01:48 -0700
Subject: [PATCH 0/2] *** NOT A PATCH ***
*** BLURB HERE ***
David Leatherman (1):
[5.6] Add module for colorizing nicknames to ERC
F. Jason Park (1):
[5.6] Allow ERC modules to extend erc-nick-popup-alist
doc/misc/erc.texi | 4 +
etc/ERC-NEWS | 26 +-
lisp/erc/erc-button.el | 64 +++--
lisp/erc/erc-nicks.el | 442 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 303 +++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
7 files changed, 818 insertions(+), 24 deletions(-)
create mode 100644 lisp/erc/erc-nicks.el
create mode 100644 test/lisp/erc/erc-nicks-tests.el
Interdiff:
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index a1279526015..e312ec38ca3 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -32,11 +32,11 @@ started.
** A new module for nickname highlighting has joined ERC.
Automatic nickname coloring has come to ERC core. Users familiar with
-the excellent 'erc-hl-nicks' by David Leatherman, from which this new
-addition draws heavily, will already be familiar with its suite of
-handy options. By default, each nickname in an ERC session receives a
-unique face with a unique (or evenly dealt) foreground color. Add
-'nicks' to 'erc-modules' to get started.
+'erc-hl-nicks', from which this module directly descends, will already
+be familiar with its suite of handy options. By default, each
+nickname in an ERC session receives a unique face with a unique (or
+evenly dealt) foreground color. Add 'nicks' to 'erc-modules' to get
+started.
** A unified interactive entry point.
New users are often dismayed to discover that M-x ERC doesn't connect
@@ -124,13 +124,19 @@ asking users who've customized this option to switch to
that some other solution, like automatic migration, is justified,
please make that known on the bug list.
-** The 'nicknames' entry in 'erc-button-alist' is officially exceptional.
+** 'erc-button-alist' and 'erc-nick-popup-alist' have evolved slightly.
It's no secret that the 'buttons' module treats potential nicknames
-specially. To simplify ERC's move to next-gen "rich UI" extensions,
-this special treatment is being canonized. From now on, all values
-other than the symbol 'erc-button-buttonize-nicks' appearing in the
-"FORM" field (third element) of this entry are considered deprecated
-and will incur a warning.
+specially. This is perhaps most evident in its treatment of the
+'nicknames' entry in 'erc-button-alist'. Indeed, to simplify ERC's
+move to next-gen "rich UI" extensions, this special treatment is being
+canonized. From now on, all values other than the symbol
+'erc-button-buttonize-nicks' appearing in the "FORM" field (third
+element) of this entry are considered deprecated and will incur a
+warning. Relatedly, the option 'erc-nick-popup-alist' now favors
+functions, which ERC calls non-interactively, over arbitrary
+s-expressions, which ERC will continue to honor. Although the default
+lineup remains functionally equivalent, its members have all been
+updated accordingly.
** Option 'erc-query-on-unjoined-chan-privmsg' restored and renamed.
This option was accidentally removed from the default client in ERC
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index c79b4e11f71..9c84de6720a 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -660,20 +660,20 @@ erc-browse-emacswiki-lisp
;;; Nickname buttons:
(defcustom erc-nick-popup-alist
- '(("DeOp" . (erc-cmd-DEOP nick))
- ("Kick" . (erc-cmd-KICK (concat nick " "
- (read-from-minibuffer
- (concat "Kick " nick ", reason: ")))))
- ("Msg" . (erc-cmd-MSG (concat nick " "
- (read-from-minibuffer
- (concat "Message to " nick ": ")))))
- ("Op" . (erc-cmd-OP nick))
- ("Query" . (erc-cmd-QUERY nick))
- ("Whois" . (erc-cmd-WHOIS nick))
- ("Lastlog" . (erc-cmd-LASTLOG nick)))
+ '(("DeOp" . erc-cmd-DEOP)
+ ("Kick" . erc-button-cmd-KICK)
+ ("Msg" . erc-button-cmd-MSG)
+ ("Op" . erc-cmd-OP)
+ ("Query" . erc-cmd-QUERY)
+ ("Whois" . erc-cmd-WHOIS)
+ ("Lastlog" . erc-cmd-LASTLOG))
"An alist of possible actions to take on a nickname.
-An entry looks like (\"Action\" . SEXP) where SEXP is evaluated with
-the variable `nick' bound to the nick in question.
+For all entries (ACTION . FUNC), ERC offers ACTION as a possible
+completion item and calls the selected entry's FUNC with the
+buttonized nickname at point as the only argument. For
+historical reasons, FUNC can also be an arbitrary sexp, in which
+case, ERC binds the nick in question to the variable `nick' and
+evaluates the expression.
Examples:
(\"DebianDB\" .
@@ -681,15 +681,39 @@ erc-nick-popup-alist
(format
\"ldapsearch -x -P 2 -h db.debian.org -b dc=debian,dc=org ircnick=%s\"
nick)))"
+ :package-version '(ERC . "5.6") ; FIXME sync on release
:type '(repeat (cons (string :tag "Op")
- sexp)))
-
-(defvar-local erc--nick-popup-alist nil
+ (choice function sexp))))
+
+(defun erc-button-cmd-KICK (nick)
+ "Prompt for a reason, then kick NICK via `erc-cmd-KICK'.
+In server buffers, also prompt for a channel."
+ (erc-cmd-KICK
+ (or (and erc--target (erc-default-target))
+ (let ((targets (mapcar (lambda (b)
+ (cons (erc--target-string
+ (buffer-local-value 'erc--target b))
+ b))
+ (erc-channel-list erc-server-process))))
+ (completing-read (format "Channel (%s): " (caar targets))
+ targets (pcase-lambda (`(,_ . ,buf))
+ (with-current-buffer buf
+ (erc-get-channel-user nick)))
+ t nil t (caar targets))))
+ nick
+ (read-from-minibuffer "Reason: ")))
+
+(defun erc-button-cmd-MSG (nick)
+ "Prompt for a message to NICK, and send it via `erc-cmd-MSG'."
+ (let ((msg (read-from-minibuffer (concat "Message to " nick ": "))))
+ (erc-cmd-MSG (concat nick " " msg))))
+
+(defvar-local erc-button--nick-popup-alist nil
"Internally controlled items for `erc-nick-popup-alist'.")
(defun erc-nick-popup (nick)
(let* ((completion-ignore-case t)
- (alist (append erc-nick-popup-alist erc--nick-popup-alist))
+ (alist (append erc-nick-popup-alist erc-button--nick-popup-alist))
(action (completing-read (format-message
"What action to take on `%s'? " nick)
alist))
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
index 85d182f9a09..0e0a481d453 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -2,6 +2,9 @@
;; Copyright (C) 2023 Free Software Foundation, Inc.
+;; Author: David Leatherman <leathekd@gmail.com>
+;; Andy Stewart <lazycat.manatee@gmail.com>
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -19,16 +22,39 @@
;;; Commentary:
-;; This module is heavily influenced by the lovely and more featureful
-;;
-;; `erc-hl-nicks' by David Leatherman
-;; <http://www.github.com/leathekd/erc-nicks>
-;;
-;; which itself is based on
-;;
-;; `erc-highlight-nicknames' by André Riemann, Andy Stewart, and
-;; others <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+;; 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] <http://www.github.com/leathekd/erc-nicks>
+;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
;;; Code:
@@ -40,19 +66,20 @@ erc-nicks
:package-version '(ERC . "5.6") ; FIXME sync on release
:group 'erc)
-(defcustom erc-nicks-ignore-chars-regexp
- (cons (rx bot (+ (any ",`'_-"))) (rx (+ (any ",`'_-")) eot))
- "Characters surrounding a nick to ignore while highlighting.
-Regexps should be suitable for `string-trim'."
- :type '(choice (cons regexp regexp) (const nil)))
+(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 a la `erc-nick-uniquifier' to secure a nickname
+after a rejection. 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 not highlight."
+ "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)
+(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))
@@ -67,40 +94,42 @@ erc-nicks-bg-color
which may be the case in terminal Emacs."
:type 'string)
-(defcustom erc-nicks-color-contrast-strategy
- '(erc-nicks-add-contrast erc-nicks-cap-contrast)
- "Treatments applied to colors for increasing visibility.
-A value of `erc-nicks-invert' inverts a nick when it's too close
-to the background. A value of `erc-nicks-add-contrast'
+(defcustom erc-nicks-color-adjustments
+ '(erc-nicks-add-contrast 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. This option can also be a list, in which case,
-members will be applied in the order they appear. For example,
-
- \\='(erc-nicks-invert erc-nicks-add-contrast)
-
-will invert as needed and likewise adjust the contrast. Note
-that anything specified by this option will still be applied when
-`erc-nicks-colors' is a user-defined list of colors."
- :type '(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)
- (repeat function)
- (const nil)
- function))
-
-(defcustom erc-nicks-contrast-ratio '(3.5 . 12.5)
+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.0 . 12.5)
"Desired range of contrast as a cons of (MIN . MAX).
-For this to matter, `erc-nicks-color-contrast-strategy' must be
-set to `erc-nicks-add-contrast' or `erc-nicks-cap-contrast' or
-contain at least one if that option is a list. If adding
-contrast, MIN specifies the minimum amount allowed between a
-buffer's background color and the foreground colors specified by
-`erc-nicks-colors'. The closer the number to the possible
-maximum of 21(:1), the greater the contrast. Depending on the
-background, nicks are either tinted in pastel or muted with dark
-gray. MAX works similarly for reducing contrast."
+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. Values 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
@@ -114,7 +143,8 @@ erc-nicks--face-table
;; 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."
+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)))
@@ -124,6 +154,20 @@ erc-nicks--get-luminance
(/ 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 ()
@@ -137,12 +181,8 @@ erc-nicks--bg-mode
'(frame-parameter (selected-frame) 'background-mode))))))
(defvar erc-nicks--grad-steps 9)
-(defvar-local erc-nicks--bg-luminance nil)
;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html
-;;
-;; We could cache results, which may help when `erc-nicks-colors' is
-;; set to `defined'.
(defun erc-nicks--adjust-contrast (color target &optional decrease)
(let* ((lum-bg (or erc-nicks--bg-luminance
@@ -151,17 +191,17 @@ erc-nicks--adjust-contrast
(stop (if (eq (if decrease 'light 'dark) (erc-nicks--bg-mode))
'(1.0 1.0 1.0)
'(0.0 0.0 0.0)))
- (start (color-name-to-rgb color))
;; From `color-gradient' in color.el
- (r (nth 0 start))
- (g (nth 1 start))
- (b (nth 2 start))
+ (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))
@@ -182,34 +222,40 @@ erc-nicks--adjust-contrast
g (min 1.0 (max 0 g))
b (min 1.0 (max 0 b)))
(not (zerop (cl-decf maxtries)))))
- (color-rgb-to-hex r g b)))
+ (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-ratio'."
- (erc-nicks--adjust-contrast color (car erc-nicks-contrast-ratio)))
+`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-ratio'."
- (erc-nicks--adjust-contrast color (cdr erc-nicks-contrast-ratio) 'remove))
-
-;; Inversion thresholds for dark and light, respectively.
-(defvar erc-nicks--min-lum (/ 1 3.0))
-(defvar erc-nicks--max-lum (/ 2 3.0))
+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 luminance and background."
- (if (pcase (erc-nicks--bg-mode)
- ('dark (< (erc-nicks--get-luminance color) erc-nicks--min-lum))
- ('light (> (erc-nicks--get-luminance color) erc-nicks--max-lum)))
- (pcase-let ((`(,r ,g ,b) (color-values color)))
- (format "#%04x%04x%04x" (- 65535 r) (- 65535 g) (- 65535 b)))
+ "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.
@@ -266,6 +312,13 @@ erc-nicks--redirect-face-widget-link
(cddr args) plist))))
args)
+(defun erc-nicks--reduce (color-string)
+ "Fold contrast strategies over COLOR-STRING."
+ (apply #'color-rgb-to-hex
+ (seq-reduce (lambda (color strategy) (funcall strategy color))
+ erc-nicks-color-adjustments
+ (color-name-to-rgb color-string))))
+
(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."
@@ -277,9 +330,7 @@ erc-nicks--get-face
(erc-network-name) "-face")))
((or (and (facep face) face)
(erc-nicks--revive face face nick (erc-network))))))
- (let ((color (seq-reduce
- (lambda (color strategy) (funcall strategy color))
- (erc-list erc-nicks-color-contrast-strategy)
+ (let ((color (erc-nicks--reduce
(pcase erc-nicks-colors
('all (format "#%012x" (erc-nicks--hash key)))
((or 'defined v)
@@ -305,10 +356,11 @@ erc-nicks--highlight
(when-let*
((nick-object)
(server-user (erc-button--nick-user nick-object))
- (trimmed (if erc-nicks-ignore-chars-regexp
- (string-trim (erc-server-user-nickname server-user)
- (car erc-nicks-ignore-chars-regexp)
- (cdr erc-nicks-ignore-chars-regexp))
+ (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
@@ -352,7 +404,7 @@ nicks
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--nick-popup-alist nil nil #'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))
@@ -364,7 +416,8 @@ nicks
(erc-button--phantom-users-mode -1))
(remove-function (local 'erc-button--modify-nick-function)
#'erc-nicks--highlight)
- (setf (alist-get "Edit face" erc--nick-popup-alist nil 'remove #'equal)
+ (setf (alist-get "Edit face"
+ erc-button--nick-popup-alist nil 'remove #'equal)
nil))
'local)
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
index e0a5691b073..e84a2fea6ce 100644
--- a/test/lisp/erc/erc-nicks-tests.el
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -19,6 +19,9 @@
;;; Commentary:
+;; Unlike most of ERC's tests, the ones in this file can be run
+;; interactively in the same session.
+
;; TODO:
;;
;; * Add mock session (or scenario) with buffer snapshots, like those
@@ -30,6 +33,19 @@
(require 'ert)
(require 'erc-nicks)
+;; This function replicates the behavior of older "invert" strategy
+;; implementations from EmacsWiki, etc. The values for the lower and
+;; upper bounds (0.33 and 0.66) are likewise inherited. See
+;; `erc-nicks--invert-classic--dark' below for one reason its results
+;; may not be plainly obvious.
+(defun erc-nicks-tests--invert-classic (color)
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0)))
+ ('light (> (erc-nicks--get-luminance color) (/ 2 3.0))))
+ (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color)))
+ color))
+
+
(ert-deftest erc-nicks--get-luminance ()
(should (eql 0.0 (erc-nicks--get-luminance "black")))
(should (eql 1.0 (erc-nicks--get-luminance "white")))
@@ -50,36 +66,149 @@ erc-nicks--get-luminance
(should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
(should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
-(ert-deftest erc-nicks-invert ()
- (let ((erc-nicks--bg-mode-value 'dark))
- (should (equal (erc-nicks-invert "white") "white"))
- (should (equal (erc-nicks-invert "black") "#ffffffffffff"))
- (should (equal (erc-nicks-invert "green") "green")))
- (let ((erc-nicks--bg-mode-value 'light))
- (should (equal (erc-nicks-invert "white") "#000000000000"))
- (should (equal (erc-nicks-invert "black") "black"))
- (should (equal (erc-nicks-invert "green") "#ffff0000ffff"))))
+(ert-deftest erc-nicks-invert--classic ()
+ (let ((convert (lambda (n) (apply #'color-rgb-to-hex
+ (erc-nicks-tests--invert-classic
+ (color-name-to-rgb n))))))
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (funcall convert "white") "#ffffffffffff"))
+ (should (equal (funcall convert "black") "#ffffffffffff"))
+ (should (equal (funcall convert "green") "#0000ffff0000")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (funcall convert "white") "#000000000000"))
+ (should (equal (funcall convert "black") "#000000000000"))
+ (should (equal (funcall convert "green") "#ffff0000ffff")))))
+
+(ert-deftest erc-nicks--get-contrast ()
+ (should (= 21.0 (erc-nicks--get-contrast "white" "black")))
+ (should (= 21.0 (erc-nicks--get-contrast "black" "white")))
+ (should (= 1.0 (erc-nicks--get-contrast "black" "black")))
+ (should (= 1.0 (erc-nicks--get-contrast "white" "white"))))
(defun erc-nicks-tests--print-contrast (fn color)
- (let ((result (funcall fn color))
- (fg (if (eq 'dark erc-nicks--bg-mode-value) "white" "black"))
- (start (point)))
+ (let* ((erc-nicks-color-adjustments (list fn))
+ (result (erc-nicks--reduce color))
+ (start (point)))
(insert (format "%16s%-16s%16s%-16s\n"
(concat color "-")
(concat ">" result)
(concat color " ")
(concat " " result)))
- (put-text-property start (+ start 32) 'face
- (list :foreground fg))
(put-text-property (+ start 32) (+ start 48) 'face
(list :background color :foreground result))
(put-text-property (+ start 48) (+ start 64) 'face
(list :background result :foreground color))
result))
+(ert-deftest erc-nicks--invert-classic--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; This shows that the output can be darker (have less contrast) than
+;; the input.
+(ert-deftest erc-nicks--invert-classic--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#777777777777" (funcall show "#888888888888")))
+ (should (equal "#666666666666" (funcall show "#999999999999")))
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; These are the same as the legacy version but work in terms of
+;; contrast ratios. Converting the original bounds to contrast ratios
+;; (assuming pure white and black backgrounds) gives:
+;;
+;; min-lum of 0.33 ~~> 1.465
+;; max-lum of 0.66 ~~> 7.666
+;;
+(ert-deftest erc-nicks-invert--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(1.465))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-invert--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (erc-nicks-contrast-range '(7.666))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#888888888888" (funcall show "#888888888888")))
+ (should (equal "#999999999999" (funcall show "#999999999999"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
(ert-deftest erc-nicks-add-contrast ()
(let ((erc-nicks--bg-luminance 1.0)
(erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(3.5))
(show (lambda (c) (erc-nicks-tests--print-contrast
#'erc-nicks-add-contrast c))))
@@ -108,7 +237,7 @@ erc-nicks-add-contrast
(kill-buffer)))))
(ert-deftest erc-nicks-cap-contrast ()
- (should (= 12.5 (cdr erc-nicks-contrast-ratio)))
+ (should (= 12.5 (cdr erc-nicks-contrast-range)))
(let ((erc-nicks--bg-luminance 1.0)
(erc-nicks--bg-mode-value 'light)
(show (lambda (c) (erc-nicks-tests--print-contrast
--
2.40.1
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0001-5.6-Allow-ERC-modules-to-extend-erc-nick-popup-alist.patch --]
[-- Type: text/x-patch, Size: 6777 bytes --]
From 1fc18ed7a18fecaa492a831150af0f27696c1c7a Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH 1/2] [5.6] Allow ERC modules to extend erc-nick-popup-alist
* etc/ERC-NEWS: Mention superficial changes to `erc-nick-popup-alist'.
* lisp/erc/erc-button.el (erc-nick-popup-alist): Accept alternate
shape for type with strings associated with functions instead of
arbitrary sexps.
(erc-button-cmd-KICK, erc-button-cmd-MSG): New functions to serve as
wrappers for `erc-cmd-KICK' and `erc-cmd-MSG', respectively. The
first also fixes a bug in which all but the first token of a given
"reason" would be omitted from the ":trailing" portion of an outgoing
KICK message.
(erc-button--nick-popup-alist): New variable to help built-in modules
expose special actions to `erc-nick-popup' without touching
`erc-nick-popup-alist'.
(erc-nick-popup): Present both `erc--nick-popup-alist' and
`erc-nick-popup-alist' to the invoking user. Accommodate functions as
well as arbitrary sexps. (bug#63569)
---
etc/ERC-NEWS | 18 ++++++++----
lisp/erc/erc-button.el | 64 +++++++++++++++++++++++++++++++-----------
2 files changed, 59 insertions(+), 23 deletions(-)
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index e9ec9e2caab..840ac64f963 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -116,13 +116,19 @@ asking users who've customized this option to switch to
that some other solution, like automatic migration, is justified,
please make that known on the bug list.
-** The 'nicknames' entry in 'erc-button-alist' is officially exceptional.
+** 'erc-button-alist' and 'erc-nick-popup-alist' have evolved slightly.
It's no secret that the 'buttons' module treats potential nicknames
-specially. To simplify ERC's move to next-gen "rich UI" extensions,
-this special treatment is being canonized. From now on, all values
-other than the symbol 'erc-button-buttonize-nicks' appearing in the
-"FORM" field (third element) of this entry are considered deprecated
-and will incur a warning.
+specially. This is perhaps most evident in its treatment of the
+'nicknames' entry in 'erc-button-alist'. Indeed, to simplify ERC's
+move to next-gen "rich UI" extensions, this special treatment is being
+canonized. From now on, all values other than the symbol
+'erc-button-buttonize-nicks' appearing in the "FORM" field (third
+element) of this entry are considered deprecated and will incur a
+warning. Relatedly, the option 'erc-nick-popup-alist' now favors
+functions, which ERC calls non-interactively, over arbitrary
+s-expressions, which ERC will continue to honor. Although the default
+lineup remains functionally equivalent, its members have all been
+updated accordingly.
** Option 'erc-query-on-unjoined-chan-privmsg' restored and renamed.
This option was accidentally removed from the default client in ERC
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index 33b93ff6744..9c84de6720a 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -660,20 +660,20 @@ erc-browse-emacswiki-lisp
;;; Nickname buttons:
(defcustom erc-nick-popup-alist
- '(("DeOp" . (erc-cmd-DEOP nick))
- ("Kick" . (erc-cmd-KICK (concat nick " "
- (read-from-minibuffer
- (concat "Kick " nick ", reason: ")))))
- ("Msg" . (erc-cmd-MSG (concat nick " "
- (read-from-minibuffer
- (concat "Message to " nick ": ")))))
- ("Op" . (erc-cmd-OP nick))
- ("Query" . (erc-cmd-QUERY nick))
- ("Whois" . (erc-cmd-WHOIS nick))
- ("Lastlog" . (erc-cmd-LASTLOG nick)))
+ '(("DeOp" . erc-cmd-DEOP)
+ ("Kick" . erc-button-cmd-KICK)
+ ("Msg" . erc-button-cmd-MSG)
+ ("Op" . erc-cmd-OP)
+ ("Query" . erc-cmd-QUERY)
+ ("Whois" . erc-cmd-WHOIS)
+ ("Lastlog" . erc-cmd-LASTLOG))
"An alist of possible actions to take on a nickname.
-An entry looks like (\"Action\" . SEXP) where SEXP is evaluated with
-the variable `nick' bound to the nick in question.
+For all entries (ACTION . FUNC), ERC offers ACTION as a possible
+completion item and calls the selected entry's FUNC with the
+buttonized nickname at point as the only argument. For
+historical reasons, FUNC can also be an arbitrary sexp, in which
+case, ERC binds the nick in question to the variable `nick' and
+evaluates the expression.
Examples:
(\"DebianDB\" .
@@ -681,18 +681,48 @@ erc-nick-popup-alist
(format
\"ldapsearch -x -P 2 -h db.debian.org -b dc=debian,dc=org ircnick=%s\"
nick)))"
+ :package-version '(ERC . "5.6") ; FIXME sync on release
:type '(repeat (cons (string :tag "Op")
- sexp)))
+ (choice function sexp))))
+
+(defun erc-button-cmd-KICK (nick)
+ "Prompt for a reason, then kick NICK via `erc-cmd-KICK'.
+In server buffers, also prompt for a channel."
+ (erc-cmd-KICK
+ (or (and erc--target (erc-default-target))
+ (let ((targets (mapcar (lambda (b)
+ (cons (erc--target-string
+ (buffer-local-value 'erc--target b))
+ b))
+ (erc-channel-list erc-server-process))))
+ (completing-read (format "Channel (%s): " (caar targets))
+ targets (pcase-lambda (`(,_ . ,buf))
+ (with-current-buffer buf
+ (erc-get-channel-user nick)))
+ t nil t (caar targets))))
+ nick
+ (read-from-minibuffer "Reason: ")))
+
+(defun erc-button-cmd-MSG (nick)
+ "Prompt for a message to NICK, and send it via `erc-cmd-MSG'."
+ (let ((msg (read-from-minibuffer (concat "Message to " nick ": "))))
+ (erc-cmd-MSG (concat nick " " msg))))
+
+(defvar-local erc-button--nick-popup-alist nil
+ "Internally controlled items for `erc-nick-popup-alist'.")
(defun erc-nick-popup (nick)
(let* ((completion-ignore-case t)
+ (alist (append erc-nick-popup-alist erc-button--nick-popup-alist))
(action (completing-read (format-message
"What action to take on `%s'? " nick)
- erc-nick-popup-alist))
- (code (cdr (assoc action erc-nick-popup-alist))))
+ alist))
+ (code (cdr (assoc action alist))))
(when code
(erc-set-active-buffer (current-buffer))
- (eval code `((nick . ,nick))))))
+ (if (functionp code)
+ (funcall code nick)
+ (eval code `((nick . ,nick)))))))
;;; Callback functions
(defun erc-button-describe-symbol (symbol-name)
--
2.40.1
[-- Attachment #4: 0002-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch --]
[-- Type: text/x-patch, Size: 38789 bytes --]
From a7d23ce4ca9f3b09c03b65d074ad0915d88a6da1 Mon Sep 17 00:00:00 2001
From: David Leatherman <leathekd@gmail.com>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH 2/2] [5.6] Add module for colorizing nicknames to ERC
* doc/misc/erc.texi: Add `nicks' to module lineup.
* etc/ERC-NEWS: Mention new module `nicks'.
* lisp/erc/erc-nicks.el: New file.
* lisp/erc/erc.el: (erc-modules): Add `nicks'.
* test/lisp/erc/erc-nicks-tests.el: New file.
* test/lisp/erc/erc-tests (erc-tests--modules): Add
`nicks'. (Bug#63569)
Co-authored-by: Andy Stewart <lazycat.manatee@gmail.com>
Co-authored-by: F. Jason Park <jp@neverwas.me>
---
doc/misc/erc.texi | 4 +
etc/ERC-NEWS | 8 +
lisp/erc/erc-nicks.el | 442 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 303 +++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
6 files changed, 759 insertions(+), 1 deletion(-)
create mode 100644 lisp/erc/erc-nicks.el
create mode 100644 test/lisp/erc/erc-nicks-tests.el
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index 14c6a457654..c18931b5f43 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -459,6 +459,10 @@ Modules
@item netsplit
Detect netsplits
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
@cindex modules, noncommands
@item noncommands
Don't display non-IRC commands after evaluation
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 840ac64f963..e312ec38ca3 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of
buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get
started.
+** A new module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core. Users familiar with
+'erc-hl-nicks', from which this module directly descends, will already
+be familiar with its suite of handy options. By default, each
+nickname in an ERC session receives a unique face with a unique (or
+evenly dealt) foreground color. Add 'nicks' to 'erc-modules' to get
+started.
+
** A unified interactive entry point.
New users are often dismayed to discover that M-x ERC doesn't connect
to its default network, Libera.Chat, over TLS. Though perhaps a
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..0e0a481d453
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,442 @@
+;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: David Leatherman <leathekd@gmail.com>
+;; Andy Stewart <lazycat.manatee@gmail.com>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; 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] <http://www.github.com/leathekd/erc-nicks>
+;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+
+;;; 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 a la `erc-nick-uniquifier' to secure a nickname
+after a rejection. 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-add-contrast 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.0 . 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. Values 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
+
+(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))))
+ (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))
+
+(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-string)
+ "Fold contrast strategies over COLOR-STRING."
+ (apply #'color-rgb-to-hex
+ (seq-reduce (lambda (color strategy) (funcall strategy color))
+ erc-nicks-color-adjustments
+ (color-name-to-rgb color-string))))
+
+(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 (format "#%012x" (erc-nicks--hash 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)))))
+
+(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 (seq-some (lambda (f) (memq f erc-nicks-skip-faces))
+ (erc-list face)))) ; cl-notany
+ ;; 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
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 5a91285c1d1..26e81c1ce69 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2028,6 +2028,7 @@ erc-modules
move-to-prompt)
(const :tag "netsplit: Detect netsplits" netsplit)
(const :tag "networks: Provide data about IRC networks" networks)
+ (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
(const :tag "noncommands: Don't display non-IRC commands after evaluation"
noncommands)
(const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..e84a2fea6ce
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,303 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unlike most of ERC's tests, the ones in this file can be run
+;; interactively in the same session.
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;; in erc-fill-tests.el. (Should probably move helpers to a common
+;; library under ./resources.)
+
+;;; Code:
+
+(require 'ert)
+(require 'erc-nicks)
+
+;; This function replicates the behavior of older "invert" strategy
+;; implementations from EmacsWiki, etc. The values for the lower and
+;; upper bounds (0.33 and 0.66) are likewise inherited. See
+;; `erc-nicks--invert-classic--dark' below for one reason its results
+;; may not be plainly obvious.
+(defun erc-nicks-tests--invert-classic (color)
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0)))
+ ('light (> (erc-nicks--get-luminance color) (/ 2 3.0))))
+ (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color)))
+ color))
+
+
+(ert-deftest erc-nicks--get-luminance ()
+ (should (eql 0.0 (erc-nicks--get-luminance "black")))
+ (should (eql 1.0 (erc-nicks--get-luminance "white")))
+ (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+ ;; RGB floats from a `display-graphic-p' session.
+ (let ((a (erc-nicks--get-luminance ; #9439ad
+ '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+ (b (erc-nicks--get-luminance ; #ae54c7
+ '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+ (c (erc-nicks--get-luminance ; #d19ddf
+ '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+ (d (erc-nicks--get-luminance ; #f5e8f8
+ '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+ ;; Low, med, high contrast comparisons against known values from
+ ;; an external source.
+ (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+ (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+ (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert--classic ()
+ (let ((convert (lambda (n) (apply #'color-rgb-to-hex
+ (erc-nicks-tests--invert-classic
+ (color-name-to-rgb n))))))
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (funcall convert "white") "#ffffffffffff"))
+ (should (equal (funcall convert "black") "#ffffffffffff"))
+ (should (equal (funcall convert "green") "#0000ffff0000")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (funcall convert "white") "#000000000000"))
+ (should (equal (funcall convert "black") "#000000000000"))
+ (should (equal (funcall convert "green") "#ffff0000ffff")))))
+
+(ert-deftest erc-nicks--get-contrast ()
+ (should (= 21.0 (erc-nicks--get-contrast "white" "black")))
+ (should (= 21.0 (erc-nicks--get-contrast "black" "white")))
+ (should (= 1.0 (erc-nicks--get-contrast "black" "black")))
+ (should (= 1.0 (erc-nicks--get-contrast "white" "white"))))
+
+(defun erc-nicks-tests--print-contrast (fn color)
+ (let* ((erc-nicks-color-adjustments (list fn))
+ (result (erc-nicks--reduce color))
+ (start (point)))
+ (insert (format "%16s%-16s%16s%-16s\n"
+ (concat color "-")
+ (concat ">" result)
+ (concat color " ")
+ (concat " " result)))
+ (put-text-property (+ start 32) (+ start 48) 'face
+ (list :background color :foreground result))
+ (put-text-property (+ start 48) (+ start 64) 'face
+ (list :background result :foreground color))
+ result))
+
+(ert-deftest erc-nicks--invert-classic--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; This shows that the output can be darker (have less contrast) than
+;; the input.
+(ert-deftest erc-nicks--invert-classic--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#777777777777" (funcall show "#888888888888")))
+ (should (equal "#666666666666" (funcall show "#999999999999")))
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; These are the same as the legacy version but work in terms of
+;; contrast ratios. Converting the original bounds to contrast ratios
+;; (assuming pure white and black backgrounds) gives:
+;;
+;; min-lum of 0.33 ~~> 1.465
+;; max-lum of 0.66 ~~> 7.666
+;;
+(ert-deftest erc-nicks-invert--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(1.465))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-invert--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (erc-nicks-contrast-range '(7.666))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#888888888888" (funcall show "#888888888888")))
+ (should (equal "#999999999999" (funcall show "#999999999999"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-add-contrast ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(3.5))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-add-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+ (should (equal "#893a893a893a" (funcall show "white")))
+ (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#0000a12e0000" (funcall show "green")))
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ ;; When the input is already near the desired ratio, the result
+ ;; may not be in bounds, only close. But the difference is
+ ;; usually imperceptible.
+ (unless noninteractive
+ ;; Well inside (light slate gray)
+ (should (equal "#777788889999" (funcall show "#777788889999")))
+ ;; Slightly outside -> just outside
+ (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+ ;; Just outside -> just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+ ;; Just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+ (should (= 12.5 (cdr erc-nicks-contrast-range)))
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-cap-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+ (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+ (should ; 12.32 -> 12.32 (same)
+ (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+ (should (equal (funcall show "white") "#ffffffffffff"))
+
+ (unless noninteractive
+ (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+ (should (equal (funcall show "DarkGreen") "#000064640000"))
+ ;; 15.29 -> 12.38
+ (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+ ;; 12.50 -> 12.22
+ (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+ ;; 12.57 -> 12.28
+ (should (equal (funcall show "#338033803380") "#344c344c344c"))
+ ;; 12.67 -> 12.37
+ (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
+
+ (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))))
+
+;;; erc-nicks-tests.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index 1c75f35e1b5..38b0e16db86 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -2052,7 +2052,7 @@ erc-handle-irc-url
(defconst erc-tests--modules
'( autoaway autojoin button capab-identify completion dcc fill identd
imenu irccontrols keep-place list log match menu move-to-prompt netsplit
- networks noncommands notifications notify page readonly
+ networks nicks noncommands notifications notify page readonly
replace ring sasl scrolltobottom services smiley sound
spelling stamp track truncate unmorse xdcc))
--
2.40.1
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] <87ilcp1za1.fsf@neverwas.me>
2023-05-23 13:37 ` bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC J.P.
2023-05-30 14:24 ` J.P.
@ 2023-06-13 4:07 ` J.P.
[not found] ` <87r0qgknt1.fsf@neverwas.me>
` (6 subsequent siblings)
9 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-06-13 4:07 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 302 bytes --]
v4. Drop erc-buttons patch. Be smarter when looking for faces to skip.
Just a minor update. As noted, I've dropped the first patch
0001-5.6-Allow-ERC-modules-to-extend-erc-nick-popup-alist.patch
which has been installed on HEAD as
e560f9af8e8 Allow ERC modules to extend erc-nick-popup-alist
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0000-v3-v4.diff --]
[-- Type: text/x-patch, Size: 10417 bytes --]
From 5100a10672355255a80549acde1ca939f61e465d Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Mon, 12 Jun 2023 21:00:28 -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 | 485 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 340 ++++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
6 files changed, 839 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 0e0a481d453..ad4fca523d2 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -34,7 +34,7 @@
;; init.el. Customize users need only click "Apply and Save", as
;; usual.
-;; History:
+;;; History:
;; This module has enjoyed a number of contributors across several
;; variants over the years. To those not mentioned, your efforts are
@@ -69,8 +69,9 @@ erc-nicks
(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 a la `erc-nick-uniquifier' to secure a nickname
-after a rejection. A value of nil means don't trim anything."
+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)))
@@ -95,7 +96,7 @@ erc-nicks-bg-color
:type 'string)
(defcustom erc-nicks-color-adjustments
- '(erc-nicks-add-contrast erc-nicks-cap-contrast erc-nicks-ensaturate)
+ '(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'
@@ -110,7 +111,7 @@ erc-nicks-color-adjustments
(function-item :tag "Bound saturation" erc-nicks-ensaturate)
function)))
-(defcustom erc-nicks-contrast-range '(4.0 . 12.5)
+(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
@@ -118,9 +119,10 @@ erc-nicks-contrast-range
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. Values can range from 1.0 to
-21.0(:1) but may produce unsatisfactory results toward either
-extreme."
+`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)
@@ -183,11 +185,14 @@ erc-nicks--bg-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)))
@@ -275,6 +280,17 @@ erc-nicks--hash
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))
@@ -312,12 +328,13 @@ erc-nicks--redirect-face-widget-link
(cddr args) plist))))
args)
-(defun erc-nicks--reduce (color-string)
- "Fold contrast strategies over COLOR-STRING."
+(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
- (color-name-to-rgb color-string))))
+ (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.
@@ -332,7 +349,7 @@ erc-nicks--get-face
(erc-nicks--revive face face nick (erc-network))))))
(let ((color (erc-nicks--reduce
(pcase erc-nicks-colors
- ('all (format "#%012x" (erc-nicks--hash key)))
+ ('all (erc-nicks--gen-color-ement key))
((or 'defined v)
(unless v (setq v (defined-colors (selected-frame))))
(unless erc-nicks--colors-len
@@ -345,6 +362,32 @@ erc-nicks--get-face
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
@@ -366,8 +409,8 @@ erc-nicks--highlight
(face (or erc-nicks--phony-face
(get-text-property (car (erc-button--nick-bounds nick-object))
'font-lock-face)))
- ((not (seq-some (lambda (f) (memq f erc-nicks-skip-faces))
- (erc-list face)))) ; cl-notany
+ ((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)
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
index e84a2fea6ce..0d640ad59c3 100644
--- a/test/lisp/erc/erc-nicks-tests.el
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -300,4 +300,41 @@ erc-nicks--hash
(when noninteractive
(kill-buffer))))
+(ert-deftest erc-nicks--skip-p ()
+ ;; Baseline
+ (should-not (erc-nicks--skip-p 'bold nil 10000000))
+ (should-not (erc-nicks--skip-p '(bold) nil 10000000))
+ (should-not (erc-nicks--skip-p nil '(bold) 10000000))
+ (should-not (erc-nicks--skip-p 'bold '(bold) 0))
+ (should-not (erc-nicks--skip-p '(bold) '(bold) 0))
+ (should-not (erc-nicks--skip-p 'bold '(foo bold) 0))
+ (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(fake bold) 1))
+ (should (erc-nicks--skip-p 'bold '(foo bar bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(bold) 1))
+ (should (erc-nicks--skip-p '((bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '((((bold)))) '(bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(foo bold) 1))
+ (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1))
+
+ ;; Composed
+ (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '(italic bold) '(bold) 2))
+ (should (erc-nicks--skip-p '((italic) bold) '(bold) 2))
+ (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2))
+
+ (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2))
+ (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3))
+ (should (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default (bold shadow))) '(bold) 3)))
+
;;; erc-nicks-tests.el ends here
--
2.40.1
[-- Attachment #3: 0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch --]
[-- Type: text/x-patch, Size: 42805 bytes --]
From 5100a10672355255a80549acde1ca939f61e465d Mon Sep 17 00:00:00 2001
From: David Leatherman <leathekd@gmail.com>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH 1/1] [5.6] Add module for colorizing nicknames to ERC
* doc/misc/erc.texi: Add `nicks' to module lineup.
* etc/ERC-NEWS: Mention new module `nicks'.
* lisp/erc/erc-nicks.el: New file.
* lisp/erc/erc.el: (erc-modules): Add `nicks'.
* test/lisp/erc/erc-nicks-tests.el: New file.
* test/lisp/erc/erc-tests (erc-tests--modules): Add
`nicks'. (Bug#63569)
Co-authored-by: Andy Stewart <lazycat.manatee@gmail.com>
---
doc/misc/erc.texi | 4 +
etc/ERC-NEWS | 8 +
lisp/erc/erc-nicks.el | 485 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 340 ++++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
6 files changed, 839 insertions(+), 1 deletion(-)
create mode 100644 lisp/erc/erc-nicks.el
create mode 100644 test/lisp/erc/erc-nicks-tests.el
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index e848ed21a50..07484122e4b 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -459,6 +459,10 @@ Modules
@item netsplit
Detect netsplits
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
@cindex modules, noncommands
@item noncommands
Don't display non-IRC commands after evaluation
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 68f1083621c..d6383b72557 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of
buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get
started.
+** A new module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core. Users familiar with
+'erc-hl-nicks', from which this module directly descends, will already
+be familiar with its suite of handy options. By default, each
+nickname in an ERC session receives a unique face with a unique (or
+evenly dealt) foreground color. Add 'nicks' to 'erc-modules' to get
+started.
+
** A unified interactive entry point.
New users are often dismayed to discover that M-x ERC doesn't connect
to its default network, Libera.Chat, over TLS. Though perhaps a
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..ad4fca523d2
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,485 @@
+;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: David Leatherman <leathekd@gmail.com>
+;; Andy Stewart <lazycat.manatee@gmail.com>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; 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] <http://www.github.com/leathekd/erc-nicks>
+;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+
+;;; 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
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index a1538962602..7b54b5db276 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2017,6 +2017,7 @@ erc-modules
move-to-prompt)
(const :tag "netsplit: Detect netsplits" netsplit)
(const :tag "networks: Provide data about IRC networks" networks)
+ (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
(const :tag "noncommands: Don't display non-IRC commands after evaluation"
noncommands)
(const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..0d640ad59c3
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,340 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unlike most of ERC's tests, the ones in this file can be run
+;; interactively in the same session.
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;; in erc-fill-tests.el. (Should probably move helpers to a common
+;; library under ./resources.)
+
+;;; Code:
+
+(require 'ert)
+(require 'erc-nicks)
+
+;; This function replicates the behavior of older "invert" strategy
+;; implementations from EmacsWiki, etc. The values for the lower and
+;; upper bounds (0.33 and 0.66) are likewise inherited. See
+;; `erc-nicks--invert-classic--dark' below for one reason its results
+;; may not be plainly obvious.
+(defun erc-nicks-tests--invert-classic (color)
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0)))
+ ('light (> (erc-nicks--get-luminance color) (/ 2 3.0))))
+ (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color)))
+ color))
+
+
+(ert-deftest erc-nicks--get-luminance ()
+ (should (eql 0.0 (erc-nicks--get-luminance "black")))
+ (should (eql 1.0 (erc-nicks--get-luminance "white")))
+ (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+ ;; RGB floats from a `display-graphic-p' session.
+ (let ((a (erc-nicks--get-luminance ; #9439ad
+ '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+ (b (erc-nicks--get-luminance ; #ae54c7
+ '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+ (c (erc-nicks--get-luminance ; #d19ddf
+ '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+ (d (erc-nicks--get-luminance ; #f5e8f8
+ '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+ ;; Low, med, high contrast comparisons against known values from
+ ;; an external source.
+ (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+ (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+ (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert--classic ()
+ (let ((convert (lambda (n) (apply #'color-rgb-to-hex
+ (erc-nicks-tests--invert-classic
+ (color-name-to-rgb n))))))
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (funcall convert "white") "#ffffffffffff"))
+ (should (equal (funcall convert "black") "#ffffffffffff"))
+ (should (equal (funcall convert "green") "#0000ffff0000")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (funcall convert "white") "#000000000000"))
+ (should (equal (funcall convert "black") "#000000000000"))
+ (should (equal (funcall convert "green") "#ffff0000ffff")))))
+
+(ert-deftest erc-nicks--get-contrast ()
+ (should (= 21.0 (erc-nicks--get-contrast "white" "black")))
+ (should (= 21.0 (erc-nicks--get-contrast "black" "white")))
+ (should (= 1.0 (erc-nicks--get-contrast "black" "black")))
+ (should (= 1.0 (erc-nicks--get-contrast "white" "white"))))
+
+(defun erc-nicks-tests--print-contrast (fn color)
+ (let* ((erc-nicks-color-adjustments (list fn))
+ (result (erc-nicks--reduce color))
+ (start (point)))
+ (insert (format "%16s%-16s%16s%-16s\n"
+ (concat color "-")
+ (concat ">" result)
+ (concat color " ")
+ (concat " " result)))
+ (put-text-property (+ start 32) (+ start 48) 'face
+ (list :background color :foreground result))
+ (put-text-property (+ start 48) (+ start 64) 'face
+ (list :background result :foreground color))
+ result))
+
+(ert-deftest erc-nicks--invert-classic--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; This shows that the output can be darker (have less contrast) than
+;; the input.
+(ert-deftest erc-nicks--invert-classic--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#777777777777" (funcall show "#888888888888")))
+ (should (equal "#666666666666" (funcall show "#999999999999")))
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; These are the same as the legacy version but work in terms of
+;; contrast ratios. Converting the original bounds to contrast ratios
+;; (assuming pure white and black backgrounds) gives:
+;;
+;; min-lum of 0.33 ~~> 1.465
+;; max-lum of 0.66 ~~> 7.666
+;;
+(ert-deftest erc-nicks-invert--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(1.465))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-invert--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (erc-nicks-contrast-range '(7.666))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#888888888888" (funcall show "#888888888888")))
+ (should (equal "#999999999999" (funcall show "#999999999999"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-add-contrast ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(3.5))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-add-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+ (should (equal "#893a893a893a" (funcall show "white")))
+ (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#0000a12e0000" (funcall show "green")))
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ ;; When the input is already near the desired ratio, the result
+ ;; may not be in bounds, only close. But the difference is
+ ;; usually imperceptible.
+ (unless noninteractive
+ ;; Well inside (light slate gray)
+ (should (equal "#777788889999" (funcall show "#777788889999")))
+ ;; Slightly outside -> just outside
+ (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+ ;; Just outside -> just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+ ;; Just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+ (should (= 12.5 (cdr erc-nicks-contrast-range)))
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-cap-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+ (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+ (should ; 12.32 -> 12.32 (same)
+ (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+ (should (equal (funcall show "white") "#ffffffffffff"))
+
+ (unless noninteractive
+ (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+ (should (equal (funcall show "DarkGreen") "#000064640000"))
+ ;; 15.29 -> 12.38
+ (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+ ;; 12.50 -> 12.22
+ (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+ ;; 12.57 -> 12.28
+ (should (equal (funcall show "#338033803380") "#344c344c344c"))
+ ;; 12.67 -> 12.37
+ (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
+
+ (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))
+ (should-not (erc-nicks--skip-p '(bold) nil 10000000))
+ (should-not (erc-nicks--skip-p nil '(bold) 10000000))
+ (should-not (erc-nicks--skip-p 'bold '(bold) 0))
+ (should-not (erc-nicks--skip-p '(bold) '(bold) 0))
+ (should-not (erc-nicks--skip-p 'bold '(foo bold) 0))
+ (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(fake bold) 1))
+ (should (erc-nicks--skip-p 'bold '(foo bar bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(bold) 1))
+ (should (erc-nicks--skip-p '((bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '((((bold)))) '(bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(foo bold) 1))
+ (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1))
+
+ ;; Composed
+ (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '(italic bold) '(bold) 2))
+ (should (erc-nicks--skip-p '((italic) bold) '(bold) 2))
+ (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2))
+
+ (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2))
+ (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3))
+ (should (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default (bold shadow))) '(bold) 3)))
+
+;;; erc-nicks-tests.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index f3489a16386..ebe49bcece2 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -2057,7 +2057,7 @@ erc-handle-irc-url
(defconst erc-tests--modules
'( autoaway autojoin button capab-identify completion dcc fill identd
imenu irccontrols keep-place list log match menu move-to-prompt netsplit
- networks noncommands notifications notify page readonly
+ networks nicks noncommands notifications notify page readonly
replace ring sasl scrolltobottom services smiley sound
spelling stamp track truncate unmorse xdcc))
--
2.40.1
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] ` <87r0qgknt1.fsf@neverwas.me>
@ 2023-06-16 3:07 ` Richard Stallman
[not found] ` <E1q9zoC-0003PO-Jf@fencepost.gnu.org>
1 sibling, 0 replies; 15+ messages in thread
From: Richard Stallman @ 2023-06-16 3:07 UTC (permalink / raw)
To: J.P.; +Cc: 63569, emacs-erc
[[[ To any NSA and FBI agents reading my email: please consider ]]]
[[[ whether defending the US Constitution against all enemies, ]]]
[[[ foreign or domestic, requires you to follow Snowden's example. ]]]
> v4. Drop erc-buttons patch.
I am puzzled by the word "drop". What does it mean to "drop" a patch?
To cancel plans to install it?
--
Dr Richard Stallman (https://stallman.org)
Chief GNUisance of the GNU Project (https://gnu.org)
Founder, Free Software Foundation (https://fsf.org)
Internet Hall-of-Famer (https://internethalloffame.org)
^ permalink raw reply [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] ` <E1q9zoC-0003PO-Jf@fencepost.gnu.org>
@ 2023-06-16 5:12 ` J.P.
[not found] ` <87h6r8j8ie.fsf@neverwas.me>
1 sibling, 0 replies; 15+ messages in thread
From: J.P. @ 2023-06-16 5:12 UTC (permalink / raw)
To: Richard Stallman; +Cc: 63569, emacs-erc
Richard Stallman <rms@gnu.org> writes:
> [[[ To any NSA and FBI agents reading my email: please consider ]]]
> [[[ whether defending the US Constitution against all enemies, ]]]
> [[[ foreign or domestic, requires you to follow Snowden's example. ]]]
>
> > v4. Drop erc-buttons patch.
>
> I am puzzled by the word "drop". What does it mean to "drop" a patch?
> To cancel plans to install it?
Yes, sorry, "drop" as in "cancel." I've removed the patch from the
proposed change set because it's already been installed.
^ permalink raw reply [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] ` <87h6r8j8ie.fsf@neverwas.me>
@ 2023-06-18 2:13 ` Richard Stallman
0 siblings, 0 replies; 15+ messages in thread
From: Richard Stallman @ 2023-06-18 2:13 UTC (permalink / raw)
To: J.P.; +Cc: 63569, emacs-erc
[[[ To any NSA and FBI agents reading my email: please consider ]]]
[[[ whether defending the US Constitution against all enemies, ]]]
[[[ foreign or domestic, requires you to follow Snowden's example. ]]]
> Yes, sorry, "drop" as in "cancel." I've removed the patch from the
> proposed change set because it's already been installed.
Now I understand.
I suggest saying "cancel" in the future, to avoid possible
uncertainty.
Thanks for helping with this feature.
--
Dr Richard Stallman (https://stallman.org)
Chief GNUisance of the GNU Project (https://gnu.org)
Founder, Free Software Foundation (https://fsf.org)
Internet Hall-of-Famer (https://internethalloffame.org)
^ permalink raw reply [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] <87ilcp1za1.fsf@neverwas.me>
` (3 preceding siblings ...)
[not found] ` <87r0qgknt1.fsf@neverwas.me>
@ 2023-06-22 13:47 ` J.P.
[not found] ` <871qi3boca.fsf@neverwas.me>
` (4 subsequent siblings)
9 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-06-22 13:47 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 359 bytes --]
v5. Simplify integration with internal buttons API. Factor out common
utilities for nick trimming, key generation, etc. Improve user
experience in dealing with predefined color palettes.
Note that these changes break those currently on offer in bug#63595. But
since things are still pretty fluid, I'm going to hold off on updating
those for a bit. Thanks.
[-- Attachment #2: 0000-v4-v5.diff --]
[-- Type: text/x-patch, Size: 21919 bytes --]
From 88fbd206ed296ddd99ce84696a5e45d3d4cf5ead Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
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 <thibault@thb.lt>,
+;; Jay Kamat <jaygkamat@gmail.com>,
+;; Alex Kost <alezost@gmail.com>
+;;
+;; 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] <http://www.github.com/leathekd/erc-nicks>
+;; [1] <http://www.github.com/leathekd/erc-hl-nicks>
;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
;;; 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
[-- Attachment #3: 0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch --]
[-- Type: text/x-patch, Size: 44856 bytes --]
From 88fbd206ed296ddd99ce84696a5e45d3d4cf5ead Mon Sep 17 00:00:00 2001
From: David Leatherman <leathekd@gmail.com>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH 1/1] [5.6] Add module for colorizing nicknames to ERC
* doc/misc/erc.texi: Add `nicks' to module lineup.
* etc/ERC-NEWS: Mention new module `nicks'.
* lisp/erc/erc-nicks.el: New file.
* lisp/erc/erc.el: (erc-modules): Add `nicks'.
* test/lisp/erc/erc-nicks-tests.el: New file.
* test/lisp/erc/erc-tests (erc-tests--modules): Add
`nicks'. (Bug#63569)
Co-authored-by: Andy Stewart <lazycat.manatee@gmail.com>
---
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
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index e848ed21a50..07484122e4b 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -459,6 +459,10 @@ Modules
@item netsplit
Detect netsplits
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
@cindex modules, noncommands
@item noncommands
Don't display non-IRC commands after evaluation
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 68f1083621c..d6383b72557 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of
buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get
started.
+** A new module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core. Users familiar with
+'erc-hl-nicks', from which this module directly descends, will already
+be familiar with its suite of handy options. By default, each
+nickname in an ERC session receives a unique face with a unique (or
+evenly dealt) foreground color. Add 'nicks' to 'erc-modules' to get
+started.
+
** A unified interactive entry point.
New users are often dismayed to discover that M-x ERC doesn't connect
to its default network, Libera.Chat, over TLS. Though perhaps a
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..cd78ac15e22
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,554 @@
+;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: David Leatherman <leathekd@gmail.com>
+;; Andy Stewart <lazycat.manatee@gmail.com>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; 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, including:
+;;
+;; Thibault Polge <thibault@thb.lt>,
+;; Jay Kamat <jaygkamat@gmail.com>,
+;; Alex Kost <alezost@gmail.com>
+;;
+;; 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] <http://www.github.com/leathekd/erc-hl-nicks>
+;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+
+;;; 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.
+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
+ 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. 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)
+ (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))
+
+(defcustom erc-nicks-colors 'all
+ "Pool of colors.
+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 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)
+ "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)
+
+;; 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--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))
+
+(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))))
+
+(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 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--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)))))
+
+(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.
+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-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)
+ (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-button '((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))))
+ (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)
+ (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)
+ (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-button)
+ (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-nicks--trim (substring-no-properties nick)))
+ (let* ((net (erc-network))
+ (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)
+ (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)))
+
+(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/lisp/erc/erc.el b/lisp/erc/erc.el
index a1538962602..7b54b5db276 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2017,6 +2017,7 @@ erc-modules
move-to-prompt)
(const :tag "netsplit: Detect netsplits" netsplit)
(const :tag "networks: Provide data about IRC networks" networks)
+ (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
(const :tag "noncommands: Don't display non-IRC commands after evaluation"
noncommands)
(const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..d8ddaef72e5
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,315 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unlike most of ERC's tests, the ones in this file can be run
+;; interactively in the same session.
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;; in erc-fill-tests.el. (Should probably move helpers to a common
+;; library under ./resources.)
+
+;;; Code:
+
+(require 'ert)
+(require 'erc-nicks)
+
+;; This function replicates the behavior of older "invert" strategy
+;; implementations from EmacsWiki, etc. The values for the lower and
+;; upper bounds (0.33 and 0.66) are likewise inherited. See
+;; `erc-nicks--invert-classic--dark' below for one reason its results
+;; may not be plainly obvious.
+(defun erc-nicks-tests--invert-classic (color)
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0)))
+ ('light (> (erc-nicks--get-luminance color) (/ 2 3.0))))
+ (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color)))
+ color))
+
+
+(ert-deftest erc-nicks--get-luminance ()
+ (should (eql 0.0 (erc-nicks--get-luminance "black")))
+ (should (eql 1.0 (erc-nicks--get-luminance "white")))
+ (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+ ;; RGB floats from a `display-graphic-p' session.
+ (let ((a (erc-nicks--get-luminance ; #9439ad
+ '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+ (b (erc-nicks--get-luminance ; #ae54c7
+ '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+ (c (erc-nicks--get-luminance ; #d19ddf
+ '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+ (d (erc-nicks--get-luminance ; #f5e8f8
+ '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+ ;; Low, med, high contrast comparisons against known values from
+ ;; an external source.
+ (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+ (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+ (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert--classic ()
+ (let ((convert (lambda (n) (apply #'color-rgb-to-hex
+ (erc-nicks-tests--invert-classic
+ (color-name-to-rgb n))))))
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (funcall convert "white") "#ffffffffffff"))
+ (should (equal (funcall convert "black") "#ffffffffffff"))
+ (should (equal (funcall convert "green") "#0000ffff0000")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (funcall convert "white") "#000000000000"))
+ (should (equal (funcall convert "black") "#000000000000"))
+ (should (equal (funcall convert "green") "#ffff0000ffff")))))
+
+(ert-deftest erc-nicks--get-contrast ()
+ (should (= 21.0 (erc-nicks--get-contrast "white" "black")))
+ (should (= 21.0 (erc-nicks--get-contrast "black" "white")))
+ (should (= 1.0 (erc-nicks--get-contrast "black" "black")))
+ (should (= 1.0 (erc-nicks--get-contrast "white" "white"))))
+
+(defun erc-nicks-tests--print-contrast (fn color)
+ (let* ((erc-nicks-color-adjustments (list fn))
+ (result (erc-nicks--reduce color))
+ (start (point)))
+ (insert (format "%16s%-16s%16s%-16s\n"
+ (concat color "-")
+ (concat ">" result)
+ (concat color " ")
+ (concat " " result)))
+ (put-text-property (+ start 32) (+ start 48) 'face
+ (list :background color :foreground result))
+ (put-text-property (+ start 48) (+ start 64) 'face
+ (list :background result :foreground color))
+ result))
+
+(ert-deftest erc-nicks--invert-classic--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; This shows that the output can be darker (have less contrast) than
+;; the input.
+(ert-deftest erc-nicks--invert-classic--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#777777777777" (funcall show "#888888888888")))
+ (should (equal "#666666666666" (funcall show "#999999999999")))
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; These are the same as the legacy version but work in terms of
+;; contrast ratios. Converting the original bounds to contrast ratios
+;; (assuming pure white and black backgrounds) gives:
+;;
+;; min-lum of 0.33 ~~> 1.465
+;; max-lum of 0.66 ~~> 7.666
+;;
+(ert-deftest erc-nicks-invert--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(1.465))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-invert--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (erc-nicks-contrast-range '(7.666))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#888888888888" (funcall show "#888888888888")))
+ (should (equal "#999999999999" (funcall show "#999999999999"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-add-contrast ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(3.5))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-add-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+ (should (equal "#893a893a893a" (funcall show "white")))
+ (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#0000a12e0000" (funcall show "green")))
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ ;; When the input is already near the desired ratio, the result
+ ;; may not be in bounds, only close. But the difference is
+ ;; usually imperceptible.
+ (unless noninteractive
+ ;; Well inside (light slate gray)
+ (should (equal "#777788889999" (funcall show "#777788889999")))
+ ;; Slightly outside -> just outside
+ (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+ ;; Just outside -> just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+ ;; Just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+ (should (= 12.5 (cdr erc-nicks-contrast-range)))
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-cap-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+ (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+ (should ; 12.32 -> 12.32 (same)
+ (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+ (should (equal (funcall show "white") "#ffffffffffff"))
+
+ (unless noninteractive
+ (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+ (should (equal (funcall show "DarkGreen") "#000064640000"))
+ ;; 15.29 -> 12.38
+ (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+ ;; 12.50 -> 12.22
+ (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+ ;; 12.57 -> 12.28
+ (should (equal (funcall show "#338033803380") "#344c344c344c"))
+ ;; 12.67 -> 12.37
+ (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks--skip-p ()
+ ;; Baseline
+ (should-not (erc-nicks--skip-p 'bold nil 10000000))
+ (should-not (erc-nicks--skip-p '(bold) nil 10000000))
+ (should-not (erc-nicks--skip-p nil '(bold) 10000000))
+ (should-not (erc-nicks--skip-p 'bold '(bold) 0))
+ (should-not (erc-nicks--skip-p '(bold) '(bold) 0))
+ (should-not (erc-nicks--skip-p 'bold '(foo bold) 0))
+ (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(fake bold) 1))
+ (should (erc-nicks--skip-p 'bold '(foo bar bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(bold) 1))
+ (should (erc-nicks--skip-p '((bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '((((bold)))) '(bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(foo bold) 1))
+ (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1))
+
+ ;; Composed
+ (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '(italic bold) '(bold) 2))
+ (should (erc-nicks--skip-p '((italic) bold) '(bold) 2))
+ (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2))
+
+ (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2))
+ (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3))
+ (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
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index f3489a16386..ebe49bcece2 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -2057,7 +2057,7 @@ erc-handle-irc-url
(defconst erc-tests--modules
'( autoaway autojoin button capab-identify completion dcc fill identd
imenu irccontrols keep-place list log match menu move-to-prompt netsplit
- networks noncommands notifications notify page readonly
+ networks nicks noncommands notifications notify page readonly
replace ring sasl scrolltobottom services smiley sound
spelling stamp track truncate unmorse xdcc))
--
2.40.1
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] ` <871qi3boca.fsf@neverwas.me>
@ 2023-06-23 13:38 ` J.P.
[not found] ` <87wmzu8fjg.fsf@neverwas.me>
1 sibling, 0 replies; 15+ messages in thread
From: J.P. @ 2023-06-23 13:38 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 520 bytes --]
v6. Add command for reviewing and editing managed faces. Rework
properties applied to face symbols.
Previously, tuning this module's options to arrive at a satisfactory
palette was a bit inconvenient because you had to scroll around in
different target buffers afterward to get a sense of the result, which
was often only subtly different from a previous incarnation. Editing
persistent faces was also somewhat unpleasant for similar reasons. This
adds a single dashboard based on `list-faces-display' for doing both.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0000-v5-v6.diff --]
[-- Type: text/x-patch, Size: 13820 bytes --]
From 9cb0138ef3e56533538c2d402d8ad7b2e282ce6c Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Fri, 23 Jun 2023 06:17:55 -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 | 612 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 416 +++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
6 files changed, 1042 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 cd78ac15e22..2977235b3a8 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -25,14 +25,15 @@
;; 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.
+;; Use the command `erc-nicks-refresh' to review changes after
+;; adjusting an option, like `erc-nicks-contrast-range'. 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 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:
@@ -91,7 +92,7 @@ erc-nicks-skip-faces
"Faces to avoid highlighting atop."
:type '(repeat symbol))
-(defcustom erc-nicks-nickname-face erc-button-nickname-face
+(defcustom erc-nicks-backing-face erc-button-nickname-face
"Face to mix with generated one for emphasizing non-speakers."
:type '(choice face (const nil)))
@@ -103,7 +104,7 @@ erc-nicks-bg-color
:type 'string)
(defcustom erc-nicks-color-adjustments
- '(erc-nicks-invert erc-nicks-cap-contrast erc-nicks-ensaturate)
+ '(erc-nicks-add-contrast 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'
@@ -293,7 +294,9 @@ erc-nicks--custom-keywords
;; 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 new-face 'erc-nicks--custom-face t)
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
(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)
@@ -319,7 +322,7 @@ erc-nicks--redirect-face-widget-link
(pcase args
(`(,widget face-link . ,plist)
(when-let* ((face (widget-value widget))
- ((get face 'erc-nicks--custom-nick)))
+ ((get face 'erc-nicks--custom-face)))
(unless (symbol-file face)
(setf (plist-get plist :action)
(lambda (&rest _) (erc-nicks--create-defface-template face))))
@@ -371,8 +374,10 @@ erc-nicks--create-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)
+ (progn (setq erc-nicks--colors-pool nil
+ erc-nicks--colors-len nil)
+ (when debug
+ (erc-nicks-list-faces)))
(let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors)
(defined-colors)))
(pool (erc-nicks--create-pool erc-nicks-color-adjustments colors
@@ -399,6 +404,8 @@ erc-nicks--get-face
(erc-nicks--revive face face nick (erc-network))))))
(let ((color (erc-nicks--determine-color key))
(new-face (make-symbol (concat "erc-nicks-" nick "-face"))))
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
(put new-face 'erc-nicks--key key)
(face-spec-set new-face `((t :foreground ,color)) 'face-defface-spec)
(set-face-documentation
@@ -459,10 +466,10 @@ erc-nicks--highlight
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))
+ (if (or (null erc-nicks-backing-face)
+ (eq base-face erc-nicks-backing-face))
out
- (cons out (erc-list erc-nicks-nickname-face)))))
+ (cons out (erc-list erc-nicks-backing-face)))))
(defun erc-nicks--highlight-button (nick-object)
"Possibly add face to `erc-button--nick-user' NICK-OBJECT."
@@ -535,16 +542,67 @@ erc-nicks-customize-face
(set-face-attribute old-face nil :inherit new-face))
(customize-face new-face)))
-(defun erc-nicks-refresh (debug-pool)
+(defun erc-nicks--list-faces-help-button-action (face)
+ (when-let (((or (get face 'erc-nicks--custom-face)
+ (y-or-n-p (format "Create new persistent face for %s?"
+ (get face 'erc-nicks--key)))))
+ (nid (get face 'erc-nicks--netid))
+ (foundp (lambda ()
+ (erc-networks--id-equal-p nid erc-networks--id)))
+ (server-buffer (car (erc-buffer-filter foundp))))
+ (with-current-buffer server-buffer
+ (erc-nicks-customize-face (get face 'erc-nicks--nick)))))
+
+(defvar help-xref-stack)
+(defvar help-xref-stack-item)
+
+(defun erc-nicks-list-faces ()
+ "Show faces owned by ERC-nicks in a help buffer."
+ (interactive)
+ (save-excursion
+ (list-faces-display (rx bot "erc-nicks-"))
+ (with-current-buffer "*Faces*"
+ (setq help-xref-stack nil
+ help-xref-stack-item '(erc-nicks-list-faces))
+ (with-silent-modifications
+ (goto-char (point-min))
+ (while (zerop (forward-line))
+ (when (and (get-text-property (point) 'button)
+ (facep (car (button-get (point) 'help-args))))
+ (button-put (point) 'help-function
+ #'erc-nicks--list-faces-help-button-action)
+ (if-let* ((face (car (button-get (point) 'help-args)))
+ ((not (get face 'erc-nicks--custom-face)))
+ ((not (get face 'erc-nicks--key))))
+ (progn (delete-region (pos-bol) (1+ (pos-eol)))
+ (forward-line -1))
+ (when-let* ((nid (get face 'erc-nicks--netid))
+ (net (symbol-name (erc-networks--id-symbol nid))))
+ (goto-char (button-end (point)))
+ (skip-syntax-forward "-")
+ (put-text-property (point) (1+ (point)) 'rear-nonsticky nil)
+ (forward-char)
+ (when (stringp (face-foreground face))
+ (setq net (format "%-13.13s %s" (substring-no-properties
+ (face-foreground face))
+ net)))
+ (insert-and-inherit net)
+ (delete-region (button-start (point))
+ (1+ (button-start (point))))
+ (delete-region (point) (pos-eol))))))))))
+
+(defun erc-nicks-refresh (debug)
"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')."
+With DEBUG, review affected faces or colors. Which one depends
+on the value of `erc-nicks-colors'."
(interactive "P")
+ (unless (derived-mode-p 'erc-mode)
+ (user-error "Not an ERC buffer"))
(erc-with-server-buffer
(unless erc-nicks-mode (user-error "Module `nicks' disabled"))
- (erc-nicks--init-pool debug-pool)
+ (erc-nicks--init-pool debug)
(dolist (nick (hash-table-keys erc-nicks--face-table))
+ ;; User-tuned faces do not have an `erc-nicks--key' property.
(when-let* ((face (gethash nick erc-nicks--face-table))
(key (get face 'erc-nicks--key)))
(set-face-foreground face (erc-nicks--determine-color key))))))
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
index d8ddaef72e5..052a4c6df70 100644
--- a/test/lisp/erc/erc-nicks-tests.el
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -311,5 +311,106 @@ erc-nicks--trim
(should (equal (erc-nicks--trim "Bob~") "bob^"))
(should (equal (erc-nicks--trim "Bob^") "bob"))))
+(defun erc-nicks-tests--create-session (test)
+ (should-not (memq 'nicks erc-modules))
+ (let ((erc-modules (cons 'nicks erc-modules))
+ (inhibit-message noninteractive)
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+
+ (with-current-buffer
+ (cl-letf
+ (((symbol-function 'erc-server-connect)
+ (lambda (&rest _)
+ (setq erc-server-process
+ (start-process "sleep" (current-buffer) "sleep" "1"))
+ (set-process-query-on-exit-flag erc-server-process nil))))
+
+ (erc-open "localhost" 6667 "tester" "Tester" 'connect
+ nil nil nil nil nil "tester"))
+
+ (let ((inhibit-message noninteractive))
+ (dolist (line (split-string "\
+:irc.foonet.org 004 tester irc.foonet.org irc.d abc 123 456
+:irc.foonet.org 005 tester NETWORK=foonet :are supported
+:irc.foonet.org 376 tester :End of /MOTD command."
+ "\n"))
+ (erc-parse-server-response erc-server-process line)))
+
+ (with-current-buffer (erc--open-target "#chan")
+ (erc-update-channel-member
+ "#chan" "Alice" "Alice" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-update-channel-member
+ "#chan" "Bob" "Bob" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-display-message
+ nil 'notice (current-buffer)
+ (concat "This server is in debug mode and is logging all user I/O. "
+ "Blah Alice (1) Bob (2) blah."))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "Bob" "Hi Alice" nil t))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "Alice" "Hi Bob" nil t)))
+
+ (funcall test)
+
+ (when noninteractive
+ (kill-buffer "#chan")
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-list-faces ()
+ (erc-nicks-tests--create-session
+ (lambda ()
+ (erc-nicks-list-faces)
+ (let ((table (buffer-local-value 'erc-nicks--face-table
+ (get-buffer "foonet")))
+ calls)
+ (cl-letf (((symbol-function 'erc-nicks--list-faces-help-button-action)
+ (lambda (&rest r) (push r calls))))
+ (with-current-buffer "*Faces*"
+ (set-window-buffer (selected-window) (current-buffer))
+ (goto-char (point-min))
+
+ (ert-info ("Clicking on face link runs action function")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-alice-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "alice" table))))
+
+ (ert-info ("Clicking on sample text describes face")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (push-button)
+ (should (search-forward-regexp
+ (rx "Foreground: #" (group (+ xdigit)) eol)))
+ (forward-button 1)
+ (push-button))
+
+ (ert-info ("First entry's sample is rendered correctly")
+ (let ((hex (match-string 1)))
+ (should (looking-at (concat "#" hex)))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls)))
+
+ (ert-info ("Clicking on another entry's face link runs action")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-bob-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "bob" table))))
+
+ (ert-info ("Second entry's sample is rendered correctly")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls))
+
+ (when noninteractive
+ (kill-buffer))))))))
;;; erc-nicks-tests.el ends here
--
2.40.1
[-- Attachment #3: 0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch --]
[-- Type: text/x-patch, Size: 52079 bytes --]
From 9cb0138ef3e56533538c2d402d8ad7b2e282ce6c Mon Sep 17 00:00:00 2001
From: David Leatherman <leathekd@gmail.com>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH 1/1] [5.6] Add module for colorizing nicknames to ERC
* doc/misc/erc.texi: Add `nicks' to module lineup.
* etc/ERC-NEWS: Mention new module `nicks'.
* lisp/erc/erc-nicks.el: New file.
* lisp/erc/erc.el: (erc-modules): Add `nicks'.
* test/lisp/erc/erc-nicks-tests.el: New file.
* test/lisp/erc/erc-tests (erc-tests--modules): Add
`nicks'. (Bug#63569)
Co-authored-by: Andy Stewart <lazycat.manatee@gmail.com>
---
doc/misc/erc.texi | 4 +
etc/ERC-NEWS | 8 +
lisp/erc/erc-nicks.el | 612 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 416 +++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
6 files changed, 1042 insertions(+), 1 deletion(-)
create mode 100644 lisp/erc/erc-nicks.el
create mode 100644 test/lisp/erc/erc-nicks-tests.el
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index e848ed21a50..07484122e4b 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -459,6 +459,10 @@ Modules
@item netsplit
Detect netsplits
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
@cindex modules, noncommands
@item noncommands
Don't display non-IRC commands after evaluation
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 68f1083621c..d6383b72557 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of
buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get
started.
+** A new module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core. Users familiar with
+'erc-hl-nicks', from which this module directly descends, will already
+be familiar with its suite of handy options. By default, each
+nickname in an ERC session receives a unique face with a unique (or
+evenly dealt) foreground color. Add 'nicks' to 'erc-modules' to get
+started.
+
** A unified interactive entry point.
New users are often dismayed to discover that M-x ERC doesn't connect
to its default network, Libera.Chat, over TLS. Though perhaps a
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..2977235b3a8
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,612 @@
+;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: David Leatherman <leathekd@gmail.com>
+;; Andy Stewart <lazycat.manatee@gmail.com>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides the `nicks' module for automatic nickname
+;; highlighting. Add `nicks' to `erc-modules' to get started.
+;;
+;; Use the command `erc-nicks-refresh' to review changes after
+;; adjusting an option, like `erc-nicks-contrast-range'. 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 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, including:
+;;
+;; Thibault Polge <thibault@thb.lt>,
+;; Jay Kamat <jaygkamat@gmail.com>,
+;; Alex Kost <alezost@gmail.com>
+;;
+;; 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] <http://www.github.com/leathekd/erc-hl-nicks>
+;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+
+;;; 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.
+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
+ erc-my-nick-face erc-pal-face erc-fool-face)
+ "Faces to avoid highlighting atop."
+ :type '(repeat symbol))
+
+(defcustom erc-nicks-backing-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-add-contrast 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. 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)
+ (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))
+
+(defcustom erc-nicks-colors 'all
+ "Pool of colors.
+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 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)
+ "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)
+
+;; 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--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-face t)
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
+ (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))
+
+(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-face)))
+ (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))))
+
+(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))
+ (progn (setq erc-nicks--colors-pool nil
+ erc-nicks--colors-len nil)
+ (when debug
+ (erc-nicks-list-faces)))
+ (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 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--determine-color key))
+ (new-face (make-symbol (concat "erc-nicks-" nick "-face"))))
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
+ (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)))))
+
+(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.
+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-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-backing-face)
+ (eq base-face erc-nicks-backing-face))
+ out
+ (cons out (erc-list erc-nicks-backing-face)))))
+
+(defun erc-nicks--highlight-button (nick-object)
+ "Possibly add face to `erc-button--nick-user' NICK-OBJECT."
+ (when-let*
+ ((nick-object)
+ (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-button '((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))))
+ (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)
+ (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)
+ (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-button)
+ (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-nicks--trim (substring-no-properties nick)))
+ (let* ((net (erc-network))
+ (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)
+ (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)))
+
+(defun erc-nicks--list-faces-help-button-action (face)
+ (when-let (((or (get face 'erc-nicks--custom-face)
+ (y-or-n-p (format "Create new persistent face for %s?"
+ (get face 'erc-nicks--key)))))
+ (nid (get face 'erc-nicks--netid))
+ (foundp (lambda ()
+ (erc-networks--id-equal-p nid erc-networks--id)))
+ (server-buffer (car (erc-buffer-filter foundp))))
+ (with-current-buffer server-buffer
+ (erc-nicks-customize-face (get face 'erc-nicks--nick)))))
+
+(defvar help-xref-stack)
+(defvar help-xref-stack-item)
+
+(defun erc-nicks-list-faces ()
+ "Show faces owned by ERC-nicks in a help buffer."
+ (interactive)
+ (save-excursion
+ (list-faces-display (rx bot "erc-nicks-"))
+ (with-current-buffer "*Faces*"
+ (setq help-xref-stack nil
+ help-xref-stack-item '(erc-nicks-list-faces))
+ (with-silent-modifications
+ (goto-char (point-min))
+ (while (zerop (forward-line))
+ (when (and (get-text-property (point) 'button)
+ (facep (car (button-get (point) 'help-args))))
+ (button-put (point) 'help-function
+ #'erc-nicks--list-faces-help-button-action)
+ (if-let* ((face (car (button-get (point) 'help-args)))
+ ((not (get face 'erc-nicks--custom-face)))
+ ((not (get face 'erc-nicks--key))))
+ (progn (delete-region (pos-bol) (1+ (pos-eol)))
+ (forward-line -1))
+ (when-let* ((nid (get face 'erc-nicks--netid))
+ (net (symbol-name (erc-networks--id-symbol nid))))
+ (goto-char (button-end (point)))
+ (skip-syntax-forward "-")
+ (put-text-property (point) (1+ (point)) 'rear-nonsticky nil)
+ (forward-char)
+ (when (stringp (face-foreground face))
+ (setq net (format "%-13.13s %s" (substring-no-properties
+ (face-foreground face))
+ net)))
+ (insert-and-inherit net)
+ (delete-region (button-start (point))
+ (1+ (button-start (point))))
+ (delete-region (point) (pos-eol))))))))))
+
+(defun erc-nicks-refresh (debug)
+ "Recompute faces for all nicks on current network.
+With DEBUG, review affected faces or colors. Which one depends
+on the value of `erc-nicks-colors'."
+ (interactive "P")
+ (unless (derived-mode-p 'erc-mode)
+ (user-error "Not an ERC buffer"))
+ (erc-with-server-buffer
+ (unless erc-nicks-mode (user-error "Module `nicks' disabled"))
+ (erc-nicks--init-pool debug)
+ (dolist (nick (hash-table-keys erc-nicks--face-table))
+ ;; User-tuned faces do not have an `erc-nicks--key' property.
+ (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/lisp/erc/erc.el b/lisp/erc/erc.el
index a1538962602..7b54b5db276 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2017,6 +2017,7 @@ erc-modules
move-to-prompt)
(const :tag "netsplit: Detect netsplits" netsplit)
(const :tag "networks: Provide data about IRC networks" networks)
+ (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
(const :tag "noncommands: Don't display non-IRC commands after evaluation"
noncommands)
(const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..052a4c6df70
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,416 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unlike most of ERC's tests, the ones in this file can be run
+;; interactively in the same session.
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;; in erc-fill-tests.el. (Should probably move helpers to a common
+;; library under ./resources.)
+
+;;; Code:
+
+(require 'ert)
+(require 'erc-nicks)
+
+;; This function replicates the behavior of older "invert" strategy
+;; implementations from EmacsWiki, etc. The values for the lower and
+;; upper bounds (0.33 and 0.66) are likewise inherited. See
+;; `erc-nicks--invert-classic--dark' below for one reason its results
+;; may not be plainly obvious.
+(defun erc-nicks-tests--invert-classic (color)
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0)))
+ ('light (> (erc-nicks--get-luminance color) (/ 2 3.0))))
+ (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color)))
+ color))
+
+
+(ert-deftest erc-nicks--get-luminance ()
+ (should (eql 0.0 (erc-nicks--get-luminance "black")))
+ (should (eql 1.0 (erc-nicks--get-luminance "white")))
+ (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+ ;; RGB floats from a `display-graphic-p' session.
+ (let ((a (erc-nicks--get-luminance ; #9439ad
+ '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+ (b (erc-nicks--get-luminance ; #ae54c7
+ '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+ (c (erc-nicks--get-luminance ; #d19ddf
+ '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+ (d (erc-nicks--get-luminance ; #f5e8f8
+ '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+ ;; Low, med, high contrast comparisons against known values from
+ ;; an external source.
+ (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+ (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+ (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert--classic ()
+ (let ((convert (lambda (n) (apply #'color-rgb-to-hex
+ (erc-nicks-tests--invert-classic
+ (color-name-to-rgb n))))))
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (funcall convert "white") "#ffffffffffff"))
+ (should (equal (funcall convert "black") "#ffffffffffff"))
+ (should (equal (funcall convert "green") "#0000ffff0000")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (funcall convert "white") "#000000000000"))
+ (should (equal (funcall convert "black") "#000000000000"))
+ (should (equal (funcall convert "green") "#ffff0000ffff")))))
+
+(ert-deftest erc-nicks--get-contrast ()
+ (should (= 21.0 (erc-nicks--get-contrast "white" "black")))
+ (should (= 21.0 (erc-nicks--get-contrast "black" "white")))
+ (should (= 1.0 (erc-nicks--get-contrast "black" "black")))
+ (should (= 1.0 (erc-nicks--get-contrast "white" "white"))))
+
+(defun erc-nicks-tests--print-contrast (fn color)
+ (let* ((erc-nicks-color-adjustments (list fn))
+ (result (erc-nicks--reduce color))
+ (start (point)))
+ (insert (format "%16s%-16s%16s%-16s\n"
+ (concat color "-")
+ (concat ">" result)
+ (concat color " ")
+ (concat " " result)))
+ (put-text-property (+ start 32) (+ start 48) 'face
+ (list :background color :foreground result))
+ (put-text-property (+ start 48) (+ start 64) 'face
+ (list :background result :foreground color))
+ result))
+
+(ert-deftest erc-nicks--invert-classic--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; This shows that the output can be darker (have less contrast) than
+;; the input.
+(ert-deftest erc-nicks--invert-classic--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#777777777777" (funcall show "#888888888888")))
+ (should (equal "#666666666666" (funcall show "#999999999999")))
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; These are the same as the legacy version but work in terms of
+;; contrast ratios. Converting the original bounds to contrast ratios
+;; (assuming pure white and black backgrounds) gives:
+;;
+;; min-lum of 0.33 ~~> 1.465
+;; max-lum of 0.66 ~~> 7.666
+;;
+(ert-deftest erc-nicks-invert--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(1.465))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-invert--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (erc-nicks-contrast-range '(7.666))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#888888888888" (funcall show "#888888888888")))
+ (should (equal "#999999999999" (funcall show "#999999999999"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-add-contrast ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(3.5))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-add-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+ (should (equal "#893a893a893a" (funcall show "white")))
+ (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#0000a12e0000" (funcall show "green")))
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ ;; When the input is already near the desired ratio, the result
+ ;; may not be in bounds, only close. But the difference is
+ ;; usually imperceptible.
+ (unless noninteractive
+ ;; Well inside (light slate gray)
+ (should (equal "#777788889999" (funcall show "#777788889999")))
+ ;; Slightly outside -> just outside
+ (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+ ;; Just outside -> just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+ ;; Just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+ (should (= 12.5 (cdr erc-nicks-contrast-range)))
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-cap-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+ (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+ (should ; 12.32 -> 12.32 (same)
+ (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+ (should (equal (funcall show "white") "#ffffffffffff"))
+
+ (unless noninteractive
+ (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+ (should (equal (funcall show "DarkGreen") "#000064640000"))
+ ;; 15.29 -> 12.38
+ (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+ ;; 12.50 -> 12.22
+ (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+ ;; 12.57 -> 12.28
+ (should (equal (funcall show "#338033803380") "#344c344c344c"))
+ ;; 12.67 -> 12.37
+ (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks--skip-p ()
+ ;; Baseline
+ (should-not (erc-nicks--skip-p 'bold nil 10000000))
+ (should-not (erc-nicks--skip-p '(bold) nil 10000000))
+ (should-not (erc-nicks--skip-p nil '(bold) 10000000))
+ (should-not (erc-nicks--skip-p 'bold '(bold) 0))
+ (should-not (erc-nicks--skip-p '(bold) '(bold) 0))
+ (should-not (erc-nicks--skip-p 'bold '(foo bold) 0))
+ (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(fake bold) 1))
+ (should (erc-nicks--skip-p 'bold '(foo bar bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(bold) 1))
+ (should (erc-nicks--skip-p '((bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '((((bold)))) '(bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(foo bold) 1))
+ (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1))
+
+ ;; Composed
+ (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '(italic bold) '(bold) 2))
+ (should (erc-nicks--skip-p '((italic) bold) '(bold) 2))
+ (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2))
+
+ (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2))
+ (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3))
+ (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"))))
+
+(defun erc-nicks-tests--create-session (test)
+ (should-not (memq 'nicks erc-modules))
+ (let ((erc-modules (cons 'nicks erc-modules))
+ (inhibit-message noninteractive)
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+
+ (with-current-buffer
+ (cl-letf
+ (((symbol-function 'erc-server-connect)
+ (lambda (&rest _)
+ (setq erc-server-process
+ (start-process "sleep" (current-buffer) "sleep" "1"))
+ (set-process-query-on-exit-flag erc-server-process nil))))
+
+ (erc-open "localhost" 6667 "tester" "Tester" 'connect
+ nil nil nil nil nil "tester"))
+
+ (let ((inhibit-message noninteractive))
+ (dolist (line (split-string "\
+:irc.foonet.org 004 tester irc.foonet.org irc.d abc 123 456
+:irc.foonet.org 005 tester NETWORK=foonet :are supported
+:irc.foonet.org 376 tester :End of /MOTD command."
+ "\n"))
+ (erc-parse-server-response erc-server-process line)))
+
+ (with-current-buffer (erc--open-target "#chan")
+ (erc-update-channel-member
+ "#chan" "Alice" "Alice" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-update-channel-member
+ "#chan" "Bob" "Bob" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-display-message
+ nil 'notice (current-buffer)
+ (concat "This server is in debug mode and is logging all user I/O. "
+ "Blah Alice (1) Bob (2) blah."))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "Bob" "Hi Alice" nil t))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "Alice" "Hi Bob" nil t)))
+
+ (funcall test)
+
+ (when noninteractive
+ (kill-buffer "#chan")
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-list-faces ()
+ (erc-nicks-tests--create-session
+ (lambda ()
+ (erc-nicks-list-faces)
+ (let ((table (buffer-local-value 'erc-nicks--face-table
+ (get-buffer "foonet")))
+ calls)
+ (cl-letf (((symbol-function 'erc-nicks--list-faces-help-button-action)
+ (lambda (&rest r) (push r calls))))
+ (with-current-buffer "*Faces*"
+ (set-window-buffer (selected-window) (current-buffer))
+ (goto-char (point-min))
+
+ (ert-info ("Clicking on face link runs action function")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-alice-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "alice" table))))
+
+ (ert-info ("Clicking on sample text describes face")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (push-button)
+ (should (search-forward-regexp
+ (rx "Foreground: #" (group (+ xdigit)) eol)))
+ (forward-button 1)
+ (push-button))
+
+ (ert-info ("First entry's sample is rendered correctly")
+ (let ((hex (match-string 1)))
+ (should (looking-at (concat "#" hex)))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls)))
+
+ (ert-info ("Clicking on another entry's face link runs action")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-bob-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "bob" table))))
+
+ (ert-info ("Second entry's sample is rendered correctly")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls))
+
+ (when noninteractive
+ (kill-buffer))))))))
+
+;;; erc-nicks-tests.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index f3489a16386..ebe49bcece2 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -2057,7 +2057,7 @@ erc-handle-irc-url
(defconst erc-tests--modules
'( autoaway autojoin button capab-identify completion dcc fill identd
imenu irccontrols keep-place list log match menu move-to-prompt netsplit
- networks noncommands notifications notify page readonly
+ networks nicks noncommands notifications notify page readonly
replace ring sasl scrolltobottom services smiley sound
spelling stamp track truncate unmorse xdcc))
--
2.40.1
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] ` <87wmzu8fjg.fsf@neverwas.me>
@ 2023-06-26 13:44 ` J.P.
0 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-06-26 13:44 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 222 bytes --]
v7. Adapt to change in `buttons' interface. Rework refresh command's
"debug" feature for user-provided color pools. Use `random' instead of
`sxhash' for generating colors. Add option for controlling suffix of
color keys.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0000-v6-v7.diff --]
[-- Type: text/x-patch, Size: 9977 bytes --]
From 1527bdbbc70c27adce3fa57e7226dffc62da7853 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Mon, 26 Jun 2023 06:18:50 -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 | 632 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 435 +++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
6 files changed, 1081 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 2977235b3a8..dd936af3835 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -155,6 +155,15 @@ erc-nicks-colors
`erc-nicks-color-adjustments' to nil to prevent unwanted culling."
:type '(choice (const all) (const defined) (list string)))
+(defcustom erc-nicks-key-suffix-format "@%n"
+ "Template for latter portion of keys to generate colors from.
+ERC passes this to `format-spec' with the following specifiers:
+%n for the current network and %m for your nickname (not the one
+being colorized). If you don't like the generated palette, try
+adding extra characters or padding, for example, with something
+like \"@%-012n\"."
+ :type 'string)
+
(defvar-local erc-nicks--face-table nil
"Hash table mapping nicks to unique, named faces.
Keys need not be valid nicks.")
@@ -278,13 +287,13 @@ erc-nicks-ensaturate
((< s min) (setq color (color-hsl-to-rgb h min l)))))
color)
-;; From https://elpa.gnu.org/packages/ement. The resolution has been
+;; From https://elpa.gnu.org/packages/ement. The bit depth 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)
+;; contrast function doesn't seem to like.
+(defun erc-nicks--gen-color (string)
"Generate normalized RGB color from STRING."
- (let* ((ratio (/ (float (abs (sxhash string))) (float most-positive-fixnum)))
- (color-num (round (* (* #xffff #xffff #xffff) ratio))))
+ (let* ((ratio (/ (float (abs (random string))) (float most-positive-fixnum)))
+ (color-num (round (* #xffffffffffff ratio))))
(list (/ (float (logand color-num #xffff)) #xffff)
(/ (float (ash (logand color-num #xffff0000) -16)) #xffff)
(/ (float (ash (logand color-num #xffff00000000) -32)) #xffff))))
@@ -340,10 +349,11 @@ erc-nicks--reduce
(defvar-local erc-nicks--colors-len nil)
(defvar-local erc-nicks--colors-pool nil)
+(defvar erc-nicks--colors-rejects nil)
-(defun erc-nicks--create-pool (adjustments colors &optional debug)
+(defun erc-nicks--create-pool (adjustments colors)
"Return COLORS that fall within parameters indicated by ADJUSTMENTS."
- (let (addp capp satp pool rejects)
+ (let (addp capp satp pool)
(dolist (adjustment adjustments)
(pcase adjustment
((or 'erc-nicks-invert 'erc-nicks-add-contrast) (setq addp t))
@@ -358,39 +368,26 @@ erc-nicks--create-pool
(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))
+ (when erc-nicks--colors-rejects
+ (push color erc-nicks--colors-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))
- (progn (setq erc-nicks--colors-pool nil
- erc-nicks--colors-len nil)
- (when debug
- (erc-nicks-list-faces)))
+(defun erc-nicks--init-pool ()
+ "Initialize colors and optionally display faces or color palette."
+ (unless (eq erc-nicks-colors 'all)
(let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors)
(defined-colors)))
- (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors
- debug)))
+ (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors)))
(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))
+ (erc-nicks--reduce (erc-nicks--gen-color 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))))
+ (nth (% (abs (random key)) len) pool))))
(defun erc-nicks--get-face (nick key)
"Retrieve a face for trimmed and downcased NICK.
@@ -449,13 +446,15 @@ erc-nicks--trim
`(: (+ (any ,erc-nicks-ignore-chars)) eot)))
nickname)))
-(defvar erc-nicks--key-function #'erc-nicks--gen-key-with-network
+(defvar erc-nicks--key-function #'erc-nicks--gen-key-from-format-spec
"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--gen-key-from-format-spec (nickname)
+ "Generate key for NICKNAME according to `erc-nicks-key-suffix-format'."
+ (concat nickname (format-spec erc-nicks-key-suffix-format
+ `((?n . ,(erc-network))
+ (?m . ,(erc-current-nick))))))
(defun erc-nicks--highlight (nickname &optional base-face)
"Return face for NICKNAME unless it or BASE-FACE is blacklisted."
@@ -479,7 +478,7 @@ erc-nicks--highlight-button
'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))
+ (setf (erc-button--nick-nickname-face nick-object) out))
nick-object)
(define-erc-module nicks nil
@@ -600,12 +599,33 @@ erc-nicks-refresh
(user-error "Not an ERC buffer"))
(erc-with-server-buffer
(unless erc-nicks-mode (user-error "Module `nicks' disabled"))
- (erc-nicks--init-pool debug)
- (dolist (nick (hash-table-keys erc-nicks--face-table))
- ;; User-tuned faces do not have an `erc-nicks--key' property.
- (when-let* ((face (gethash nick erc-nicks--face-table))
- (key (get face 'erc-nicks--key)))
- (set-face-foreground face (erc-nicks--determine-color key))))))
+ (let ((erc-nicks--colors-rejects (and debug (list t))))
+ (erc-nicks--init-pool)
+ (dolist (nick (hash-table-keys erc-nicks--face-table))
+ ;; User-tuned faces do not have an `erc-nicks--key' property.
+ (when-let* ((face (gethash nick erc-nicks--face-table))
+ (key (get face 'erc-nicks--key)))
+ (setq key (funcall erc-nicks--key-function nick))
+ (put face 'erc-nicks--key key)
+ (set-face-foreground face (erc-nicks--determine-color key))))
+ (when debug
+ (if (eq erc-nicks-colors 'all)
+ (erc-nicks-list-faces)
+ (pcase-dolist (`(,name ,pool)
+ `(("*erc-nicks-pool*" ,erc-nicks--colors-pool)
+ ("*erc-nicks-rejects*"
+ ,(cdr (nreverse erc-nicks--colors-rejects)))))
+ (when (buffer-live-p (get-buffer name))
+ (kill-buffer name))
+ (when pool
+ (save-excursion
+ (list-colors-display
+ pool name
+ (lambda (c)
+ (message "contrast: %.3f :saturation: %.3f"
+ (erc-nicks--get-contrast c)
+ (cadr (apply #'color-rgb-to-hsl
+ (color-name-to-rgb c))))))))))))))
(provide 'erc-nicks)
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
index 052a4c6df70..ec6b351a2e7 100644
--- a/test/lisp/erc/erc-nicks-tests.el
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -413,4 +413,23 @@ erc-nicks-list-faces
(when noninteractive
(kill-buffer))))))))
+(ert-deftest erc-nicks--gen-key-from-format-spec ()
+ (let ((erc-network 'OFTC)
+ (erc-nicks-key-suffix-format "@%-012n")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@OFTC00000000")))
+
+ (let ((erc-network 'Libera.Chat)
+ (erc-nicks-key-suffix-format "@%-012n")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@Libera.Chat0")))
+
+ (let* ((erc-network 'Libera.Chat)
+ (erc-nicks-key-suffix-format "@%n/%m")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@Libera.Chat/tester"))))
+
;;; erc-nicks-tests.el ends here
--
2.40.1
[-- Attachment #3: 0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch --]
[-- Type: text/x-patch, Size: 53758 bytes --]
From 1527bdbbc70c27adce3fa57e7226dffc62da7853 Mon Sep 17 00:00:00 2001
From: David Leatherman <leathekd@gmail.com>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH 1/1] [5.6] Add module for colorizing nicknames to ERC
* doc/misc/erc.texi: Add `nicks' to module lineup.
* etc/ERC-NEWS: Mention new module `nicks'.
* lisp/erc/erc-nicks.el: New file.
* lisp/erc/erc.el: (erc-modules): Add `nicks'.
* test/lisp/erc/erc-nicks-tests.el: New file.
* test/lisp/erc/erc-tests (erc-tests--modules): Add
`nicks'. (Bug#63569)
Co-authored-by: Andy Stewart <lazycat.manatee@gmail.com>
---
doc/misc/erc.texi | 4 +
etc/ERC-NEWS | 8 +
lisp/erc/erc-nicks.el | 632 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 435 +++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
6 files changed, 1081 insertions(+), 1 deletion(-)
create mode 100644 lisp/erc/erc-nicks.el
create mode 100644 test/lisp/erc/erc-nicks-tests.el
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index ddfdb2e2b64..a67dcb3da7c 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -459,6 +459,10 @@ Modules
@item netsplit
Detect netsplits
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
@cindex modules, noncommands
@item noncommands
Don't display non-IRC commands after evaluation
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 68cf0e2d6ca..658665f9d86 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of
buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get
started.
+** A new module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core. Users familiar with
+'erc-hl-nicks', from which this module directly descends, will already
+be familiar with its suite of handy options. By default, each
+nickname in an ERC session receives a unique face with a unique (or
+evenly dealt) foreground color. Add 'nicks' to 'erc-modules' to get
+started.
+
** A unified interactive entry point.
New users are often dismayed to discover that M-x ERC doesn't connect
to its default network, Libera.Chat, over TLS. Though perhaps a
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..dd936af3835
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,632 @@
+;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: David Leatherman <leathekd@gmail.com>
+;; Andy Stewart <lazycat.manatee@gmail.com>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides the `nicks' module for automatic nickname
+;; highlighting. Add `nicks' to `erc-modules' to get started.
+;;
+;; Use the command `erc-nicks-refresh' to review changes after
+;; adjusting an option, like `erc-nicks-contrast-range'. 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 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, including:
+;;
+;; Thibault Polge <thibault@thb.lt>,
+;; Jay Kamat <jaygkamat@gmail.com>,
+;; Alex Kost <alezost@gmail.com>
+;;
+;; 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] <http://www.github.com/leathekd/erc-hl-nicks>
+;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+
+;;; 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.
+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
+ erc-my-nick-face erc-pal-face erc-fool-face)
+ "Faces to avoid highlighting atop."
+ :type '(repeat symbol))
+
+(defcustom erc-nicks-backing-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-add-contrast 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. 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)
+ (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))
+
+(defcustom erc-nicks-colors 'all
+ "Pool of colors.
+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)))
+
+(defcustom erc-nicks-key-suffix-format "@%n"
+ "Template for latter portion of keys to generate colors from.
+ERC passes this to `format-spec' with the following specifiers:
+%n for the current network and %m for your nickname (not the one
+being colorized). If you don't like the generated palette, try
+adding extra characters or padding, for example, with something
+like \"@%-012n\"."
+ :type 'string)
+
+(defvar-local erc-nicks--face-table nil
+ "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)
+ "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)
+
+;; From https://elpa.gnu.org/packages/ement. The bit depth has been
+;; scaled up to try and avoid components being exactly 0.0, which our
+;; contrast function doesn't seem to like.
+(defun erc-nicks--gen-color (string)
+ "Generate normalized RGB color from STRING."
+ (let* ((ratio (/ (float (abs (random string))) (float most-positive-fixnum)))
+ (color-num (round (* #xffffffffffff 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--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-face t)
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
+ (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))
+
+(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-face)))
+ (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))))
+
+(defvar-local erc-nicks--colors-len nil)
+(defvar-local erc-nicks--colors-pool nil)
+(defvar erc-nicks--colors-rejects nil)
+
+(defun erc-nicks--create-pool (adjustments colors)
+ "Return COLORS that fall within parameters indicated by ADJUSTMENTS."
+ (let (addp capp satp pool)
+ (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 erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (push color pool))))
+ (nreverse pool)))
+
+(defun erc-nicks--init-pool ()
+ "Initialize colors and optionally display faces or color palette."
+ (unless (eq erc-nicks-colors 'all)
+ (let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors)
+ (defined-colors)))
+ (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors)))
+ (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 key))
+ (let ((pool (erc-with-server-buffer erc-nicks--colors-pool))
+ (len (erc-with-server-buffer erc-nicks--colors-len)))
+ (nth (% (abs (random key)) len) pool))))
+
+(defun erc-nicks--get-face (nick key)
+ "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--determine-color key))
+ (new-face (make-symbol (concat "erc-nicks-" nick "-face"))))
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
+ (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)))))
+
+(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.
+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-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-from-format-spec
+ "Function for generating a key to determine nick color.
+Called with a trimmed and case-mapped nickname.")
+
+(defun erc-nicks--gen-key-from-format-spec (nickname)
+ "Generate key for NICKNAME according to `erc-nicks-key-suffix-format'."
+ (concat nickname (format-spec erc-nicks-key-suffix-format
+ `((?n . ,(erc-network))
+ (?m . ,(erc-current-nick))))))
+
+(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-backing-face)
+ (eq base-face erc-nicks-backing-face))
+ out
+ (cons out (erc-list erc-nicks-backing-face)))))
+
+(defun erc-nicks--highlight-button (nick-object)
+ "Possibly add face to `erc-button--nick-user' NICK-OBJECT."
+ (when-let*
+ ((nick-object)
+ (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-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-button '((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))))
+ (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)
+ (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)
+ (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-button)
+ (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-nicks--trim (substring-no-properties nick)))
+ (let* ((net (erc-network))
+ (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)
+ (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)))
+
+(defun erc-nicks--list-faces-help-button-action (face)
+ (when-let (((or (get face 'erc-nicks--custom-face)
+ (y-or-n-p (format "Create new persistent face for %s?"
+ (get face 'erc-nicks--key)))))
+ (nid (get face 'erc-nicks--netid))
+ (foundp (lambda ()
+ (erc-networks--id-equal-p nid erc-networks--id)))
+ (server-buffer (car (erc-buffer-filter foundp))))
+ (with-current-buffer server-buffer
+ (erc-nicks-customize-face (get face 'erc-nicks--nick)))))
+
+(defvar help-xref-stack)
+(defvar help-xref-stack-item)
+
+(defun erc-nicks-list-faces ()
+ "Show faces owned by ERC-nicks in a help buffer."
+ (interactive)
+ (save-excursion
+ (list-faces-display (rx bot "erc-nicks-"))
+ (with-current-buffer "*Faces*"
+ (setq help-xref-stack nil
+ help-xref-stack-item '(erc-nicks-list-faces))
+ (with-silent-modifications
+ (goto-char (point-min))
+ (while (zerop (forward-line))
+ (when (and (get-text-property (point) 'button)
+ (facep (car (button-get (point) 'help-args))))
+ (button-put (point) 'help-function
+ #'erc-nicks--list-faces-help-button-action)
+ (if-let* ((face (car (button-get (point) 'help-args)))
+ ((not (get face 'erc-nicks--custom-face)))
+ ((not (get face 'erc-nicks--key))))
+ (progn (delete-region (pos-bol) (1+ (pos-eol)))
+ (forward-line -1))
+ (when-let* ((nid (get face 'erc-nicks--netid))
+ (net (symbol-name (erc-networks--id-symbol nid))))
+ (goto-char (button-end (point)))
+ (skip-syntax-forward "-")
+ (put-text-property (point) (1+ (point)) 'rear-nonsticky nil)
+ (forward-char)
+ (when (stringp (face-foreground face))
+ (setq net (format "%-13.13s %s" (substring-no-properties
+ (face-foreground face))
+ net)))
+ (insert-and-inherit net)
+ (delete-region (button-start (point))
+ (1+ (button-start (point))))
+ (delete-region (point) (pos-eol))))))))))
+
+(defun erc-nicks-refresh (debug)
+ "Recompute faces for all nicks on current network.
+With DEBUG, review affected faces or colors. Which one depends
+on the value of `erc-nicks-colors'."
+ (interactive "P")
+ (unless (derived-mode-p 'erc-mode)
+ (user-error "Not an ERC buffer"))
+ (erc-with-server-buffer
+ (unless erc-nicks-mode (user-error "Module `nicks' disabled"))
+ (let ((erc-nicks--colors-rejects (and debug (list t))))
+ (erc-nicks--init-pool)
+ (dolist (nick (hash-table-keys erc-nicks--face-table))
+ ;; User-tuned faces do not have an `erc-nicks--key' property.
+ (when-let* ((face (gethash nick erc-nicks--face-table))
+ (key (get face 'erc-nicks--key)))
+ (setq key (funcall erc-nicks--key-function nick))
+ (put face 'erc-nicks--key key)
+ (set-face-foreground face (erc-nicks--determine-color key))))
+ (when debug
+ (if (eq erc-nicks-colors 'all)
+ (erc-nicks-list-faces)
+ (pcase-dolist (`(,name ,pool)
+ `(("*erc-nicks-pool*" ,erc-nicks--colors-pool)
+ ("*erc-nicks-rejects*"
+ ,(cdr (nreverse erc-nicks--colors-rejects)))))
+ (when (buffer-live-p (get-buffer name))
+ (kill-buffer name))
+ (when pool
+ (save-excursion
+ (list-colors-display
+ pool name
+ (lambda (c)
+ (message "contrast: %.3f :saturation: %.3f"
+ (erc-nicks--get-contrast c)
+ (cadr (apply #'color-rgb-to-hsl
+ (color-name-to-rgb c))))))))))))))
+
+(provide 'erc-nicks)
+
+;;; erc-nicks.el ends here
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 70adbb15b5f..a269d10dc51 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2008,6 +2008,7 @@ erc-modules
move-to-prompt)
(const :tag "netsplit: Detect netsplits" netsplit)
(const :tag "networks: Provide data about IRC networks" networks)
+ (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
(const :tag "noncommands: Don't display non-IRC commands after evaluation"
noncommands)
(const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..ec6b351a2e7
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,435 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unlike most of ERC's tests, the ones in this file can be run
+;; interactively in the same session.
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;; in erc-fill-tests.el. (Should probably move helpers to a common
+;; library under ./resources.)
+
+;;; Code:
+
+(require 'ert)
+(require 'erc-nicks)
+
+;; This function replicates the behavior of older "invert" strategy
+;; implementations from EmacsWiki, etc. The values for the lower and
+;; upper bounds (0.33 and 0.66) are likewise inherited. See
+;; `erc-nicks--invert-classic--dark' below for one reason its results
+;; may not be plainly obvious.
+(defun erc-nicks-tests--invert-classic (color)
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0)))
+ ('light (> (erc-nicks--get-luminance color) (/ 2 3.0))))
+ (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color)))
+ color))
+
+
+(ert-deftest erc-nicks--get-luminance ()
+ (should (eql 0.0 (erc-nicks--get-luminance "black")))
+ (should (eql 1.0 (erc-nicks--get-luminance "white")))
+ (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+ ;; RGB floats from a `display-graphic-p' session.
+ (let ((a (erc-nicks--get-luminance ; #9439ad
+ '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+ (b (erc-nicks--get-luminance ; #ae54c7
+ '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+ (c (erc-nicks--get-luminance ; #d19ddf
+ '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+ (d (erc-nicks--get-luminance ; #f5e8f8
+ '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+ ;; Low, med, high contrast comparisons against known values from
+ ;; an external source.
+ (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+ (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+ (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert--classic ()
+ (let ((convert (lambda (n) (apply #'color-rgb-to-hex
+ (erc-nicks-tests--invert-classic
+ (color-name-to-rgb n))))))
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (funcall convert "white") "#ffffffffffff"))
+ (should (equal (funcall convert "black") "#ffffffffffff"))
+ (should (equal (funcall convert "green") "#0000ffff0000")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (funcall convert "white") "#000000000000"))
+ (should (equal (funcall convert "black") "#000000000000"))
+ (should (equal (funcall convert "green") "#ffff0000ffff")))))
+
+(ert-deftest erc-nicks--get-contrast ()
+ (should (= 21.0 (erc-nicks--get-contrast "white" "black")))
+ (should (= 21.0 (erc-nicks--get-contrast "black" "white")))
+ (should (= 1.0 (erc-nicks--get-contrast "black" "black")))
+ (should (= 1.0 (erc-nicks--get-contrast "white" "white"))))
+
+(defun erc-nicks-tests--print-contrast (fn color)
+ (let* ((erc-nicks-color-adjustments (list fn))
+ (result (erc-nicks--reduce color))
+ (start (point)))
+ (insert (format "%16s%-16s%16s%-16s\n"
+ (concat color "-")
+ (concat ">" result)
+ (concat color " ")
+ (concat " " result)))
+ (put-text-property (+ start 32) (+ start 48) 'face
+ (list :background color :foreground result))
+ (put-text-property (+ start 48) (+ start 64) 'face
+ (list :background result :foreground color))
+ result))
+
+(ert-deftest erc-nicks--invert-classic--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; This shows that the output can be darker (have less contrast) than
+;; the input.
+(ert-deftest erc-nicks--invert-classic--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#777777777777" (funcall show "#888888888888")))
+ (should (equal "#666666666666" (funcall show "#999999999999")))
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; These are the same as the legacy version but work in terms of
+;; contrast ratios. Converting the original bounds to contrast ratios
+;; (assuming pure white and black backgrounds) gives:
+;;
+;; min-lum of 0.33 ~~> 1.465
+;; max-lum of 0.66 ~~> 7.666
+;;
+(ert-deftest erc-nicks-invert--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(1.465))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-invert--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (erc-nicks-contrast-range '(7.666))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#888888888888" (funcall show "#888888888888")))
+ (should (equal "#999999999999" (funcall show "#999999999999"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-add-contrast ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(3.5))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-add-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+ (should (equal "#893a893a893a" (funcall show "white")))
+ (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#0000a12e0000" (funcall show "green")))
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ ;; When the input is already near the desired ratio, the result
+ ;; may not be in bounds, only close. But the difference is
+ ;; usually imperceptible.
+ (unless noninteractive
+ ;; Well inside (light slate gray)
+ (should (equal "#777788889999" (funcall show "#777788889999")))
+ ;; Slightly outside -> just outside
+ (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+ ;; Just outside -> just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+ ;; Just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+ (should (= 12.5 (cdr erc-nicks-contrast-range)))
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-cap-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+ (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+ (should ; 12.32 -> 12.32 (same)
+ (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+ (should (equal (funcall show "white") "#ffffffffffff"))
+
+ (unless noninteractive
+ (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+ (should (equal (funcall show "DarkGreen") "#000064640000"))
+ ;; 15.29 -> 12.38
+ (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+ ;; 12.50 -> 12.22
+ (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+ ;; 12.57 -> 12.28
+ (should (equal (funcall show "#338033803380") "#344c344c344c"))
+ ;; 12.67 -> 12.37
+ (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks--skip-p ()
+ ;; Baseline
+ (should-not (erc-nicks--skip-p 'bold nil 10000000))
+ (should-not (erc-nicks--skip-p '(bold) nil 10000000))
+ (should-not (erc-nicks--skip-p nil '(bold) 10000000))
+ (should-not (erc-nicks--skip-p 'bold '(bold) 0))
+ (should-not (erc-nicks--skip-p '(bold) '(bold) 0))
+ (should-not (erc-nicks--skip-p 'bold '(foo bold) 0))
+ (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(fake bold) 1))
+ (should (erc-nicks--skip-p 'bold '(foo bar bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(bold) 1))
+ (should (erc-nicks--skip-p '((bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '((((bold)))) '(bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(foo bold) 1))
+ (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1))
+
+ ;; Composed
+ (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '(italic bold) '(bold) 2))
+ (should (erc-nicks--skip-p '((italic) bold) '(bold) 2))
+ (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2))
+
+ (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2))
+ (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3))
+ (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"))))
+
+(defun erc-nicks-tests--create-session (test)
+ (should-not (memq 'nicks erc-modules))
+ (let ((erc-modules (cons 'nicks erc-modules))
+ (inhibit-message noninteractive)
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+
+ (with-current-buffer
+ (cl-letf
+ (((symbol-function 'erc-server-connect)
+ (lambda (&rest _)
+ (setq erc-server-process
+ (start-process "sleep" (current-buffer) "sleep" "1"))
+ (set-process-query-on-exit-flag erc-server-process nil))))
+
+ (erc-open "localhost" 6667 "tester" "Tester" 'connect
+ nil nil nil nil nil "tester"))
+
+ (let ((inhibit-message noninteractive))
+ (dolist (line (split-string "\
+:irc.foonet.org 004 tester irc.foonet.org irc.d abc 123 456
+:irc.foonet.org 005 tester NETWORK=foonet :are supported
+:irc.foonet.org 376 tester :End of /MOTD command."
+ "\n"))
+ (erc-parse-server-response erc-server-process line)))
+
+ (with-current-buffer (erc--open-target "#chan")
+ (erc-update-channel-member
+ "#chan" "Alice" "Alice" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-update-channel-member
+ "#chan" "Bob" "Bob" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-display-message
+ nil 'notice (current-buffer)
+ (concat "This server is in debug mode and is logging all user I/O. "
+ "Blah Alice (1) Bob (2) blah."))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "Bob" "Hi Alice" nil t))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "Alice" "Hi Bob" nil t)))
+
+ (funcall test)
+
+ (when noninteractive
+ (kill-buffer "#chan")
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-list-faces ()
+ (erc-nicks-tests--create-session
+ (lambda ()
+ (erc-nicks-list-faces)
+ (let ((table (buffer-local-value 'erc-nicks--face-table
+ (get-buffer "foonet")))
+ calls)
+ (cl-letf (((symbol-function 'erc-nicks--list-faces-help-button-action)
+ (lambda (&rest r) (push r calls))))
+ (with-current-buffer "*Faces*"
+ (set-window-buffer (selected-window) (current-buffer))
+ (goto-char (point-min))
+
+ (ert-info ("Clicking on face link runs action function")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-alice-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "alice" table))))
+
+ (ert-info ("Clicking on sample text describes face")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (push-button)
+ (should (search-forward-regexp
+ (rx "Foreground: #" (group (+ xdigit)) eol)))
+ (forward-button 1)
+ (push-button))
+
+ (ert-info ("First entry's sample is rendered correctly")
+ (let ((hex (match-string 1)))
+ (should (looking-at (concat "#" hex)))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls)))
+
+ (ert-info ("Clicking on another entry's face link runs action")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-bob-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "bob" table))))
+
+ (ert-info ("Second entry's sample is rendered correctly")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls))
+
+ (when noninteractive
+ (kill-buffer))))))))
+
+(ert-deftest erc-nicks--gen-key-from-format-spec ()
+ (let ((erc-network 'OFTC)
+ (erc-nicks-key-suffix-format "@%-012n")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@OFTC00000000")))
+
+ (let ((erc-network 'Libera.Chat)
+ (erc-nicks-key-suffix-format "@%-012n")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@Libera.Chat0")))
+
+ (let* ((erc-network 'Libera.Chat)
+ (erc-nicks-key-suffix-format "@%n/%m")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@Libera.Chat/tester"))))
+
+;;; erc-nicks-tests.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index b751ef50520..a154b81db30 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -1754,7 +1754,7 @@ erc-handle-irc-url
(defconst erc-tests--modules
'( autoaway autojoin button capab-identify completion dcc fill identd
imenu irccontrols keep-place list log match menu move-to-prompt netsplit
- networks noncommands notifications notify page readonly
+ networks nicks noncommands notifications notify page readonly
replace ring sasl scrolltobottom services smiley sound
spelling stamp track truncate unmorse xdcc))
--
2.40.1
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] <87ilcp1za1.fsf@neverwas.me>
` (5 preceding siblings ...)
[not found] ` <871qi3boca.fsf@neverwas.me>
@ 2023-07-01 3:31 ` J.P.
2023-07-14 2:37 ` J.P.
` (2 subsequent siblings)
9 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-07-01 3:31 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 113 bytes --]
v8. Use foreground and background colors when adjusting contrast. Fix
memory leak affecting continued sessions.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0000-v7-v8.diff --]
[-- Type: text/x-patch, Size: 9059 bytes --]
From 7318662ad47e9f7b0da1a72f158690bbd4504724 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Fri, 30 Jun 2023 19:38: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 | 635 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 439 +++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
6 files changed, 1088 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 dd936af3835..42bbdc1c59d 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -40,9 +40,11 @@
;; This module has enjoyed a number of contributors across several
;; variants over the years, including:
;;
-;; Thibault Polge <thibault@thb.lt>,
-;; Jay Kamat <jaygkamat@gmail.com>,
+;; Thibault Polge <thibault@thb.lt>
+;; Jay Kamat <jaygkamat@gmail.com>
;; Alex Kost <alezost@gmail.com>
+;; Antoine Levitt <antoine dot levitt at gmail>
+;; Adam Porter <adam@alphapapa.net>
;;
;; To those not mentioned, your efforts are no less appreciated.
@@ -164,9 +166,32 @@ erc-nicks-key-suffix-format
like \"@%-012n\"."
:type 'string)
+(defvar erc-nicks--max-skip-search 3 ; make this an option?
+ "Max number of faces to visit when testing `erc-nicks-skip-faces'.")
+
+(defvar erc-nicks--key-function #'erc-nicks--gen-key-from-format-spec
+ "Function for generating a key to determine nick color.
+Called with a trimmed and case-mapped nickname.")
+
+(defvar erc-nicks--colors-rejects nil)
+(defvar erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces))
+(defvar erc-nicks--grad-steps 9)
+
(defvar-local erc-nicks--face-table nil
"Hash table mapping nicks to unique, named faces.
-Keys need not be valid nicks.")
+Keys are nonempty strings but need not be valid nicks.")
+
+(defvar-local erc-nicks--downcased-skip-nicks nil
+ "Case-mapped copy of `erc-nicks-skip-nicks'.")
+
+(defvar-local erc-nicks--bg-luminance nil)
+(defvar-local erc-nicks--bg-mode-value nil)
+(defvar-local erc-nicks--colors-len nil)
+(defvar-local erc-nicks--colors-pool nil)
+(defvar-local erc-nicks--fg-rgb nil)
+
+(defvar help-xref-stack)
+(defvar help-xref-stack-item)
;; https://stackoverflow.com/questions/596216#answer-56678483
(defun erc-nicks--get-luminance (color)
@@ -182,8 +207,6 @@ erc-nicks--get-luminance
(/ 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."
@@ -196,8 +219,6 @@ erc-nicks--get-contrast
(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
@@ -208,20 +229,14 @@ erc-nicks--bg-mode
(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)))
+ (stop (if decrease
+ (color-name-to-rgb erc-nicks-bg-color)
+ erc-nicks--fg-rgb))
;; From `color-gradient' in color.el
(r (nth 0 color))
(g (nth 1 color))
@@ -298,8 +313,6 @@ erc-nicks--gen-color
(/ (float (ash (logand color-num #xffff0000) -16)) #xffff)
(/ (float (ash (logand color-num #xffff00000000) -32)) #xffff))))
-(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)
@@ -347,10 +360,6 @@ 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)
-(defvar erc-nicks--colors-rejects nil)
-
(defun erc-nicks--create-pool (adjustments colors)
"Return COLORS that fall within parameters indicated by ADJUSTMENTS."
(let (addp capp satp pool)
@@ -415,9 +424,6 @@ erc-nicks--anon-face-p
('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.
Abandon search after examining LIMIT faces."
@@ -434,9 +440,6 @@ erc-nicks--skip-p
(when (if (symbolp elem) (memq elem option) (member elem option))
(throw 'found elem))))))
-(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
@@ -446,10 +449,6 @@ erc-nicks--trim
`(: (+ (any ,erc-nicks-ignore-chars)) eot)))
nickname)))
-(defvar erc-nicks--key-function #'erc-nicks--gen-key-from-format-spec
- "Function for generating a key to determine nick color.
-Called with a trimmed and case-mapped nickname.")
-
(defun erc-nicks--gen-key-from-format-spec (nickname)
"Generate key for NICKNAME according to `erc-nicks-key-suffix-format'."
(concat nickname (format-spec erc-nicks-key-suffix-format
@@ -505,7 +504,13 @@ nicks
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)))
+ (erc--restore-initialize-priors erc-nicks-mode
+ erc-nicks--face-table (make-hash-table :test #'equal)))
+ (setq erc-nicks--fg-rgb
+ (or (color-name-to-rgb
+ (face-foreground 'erc-default-face nil 'default))
+ (color-name-to-rgb
+ (readable-foreground-color erc-nicks-bg-color))))
(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
@@ -513,6 +518,7 @@ nicks
((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--fg-rgb)
(kill-local-variable 'erc-nicks--colors-len)
(kill-local-variable 'erc-nicks--colors-pool)
(kill-local-variable 'erc-nicks--downcased-skip-nicks)
@@ -552,9 +558,6 @@ erc-nicks--list-faces-help-button-action
(with-current-buffer server-buffer
(erc-nicks-customize-face (get face 'erc-nicks--nick)))))
-(defvar help-xref-stack)
-(defvar help-xref-stack-item)
-
(defun erc-nicks-list-faces ()
"Show faces owned by ERC-nicks in a help buffer."
(interactive)
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
index ec6b351a2e7..08e423bf6b3 100644
--- a/test/lisp/erc/erc-nicks-tests.el
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -208,6 +208,8 @@ erc-nicks-invert--dark
(ert-deftest erc-nicks-add-contrast ()
(let ((erc-nicks--bg-luminance 1.0)
(erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
(erc-nicks-contrast-range '(3.5))
(show (lambda (c) (erc-nicks-tests--print-contrast
#'erc-nicks-add-contrast c))))
@@ -240,6 +242,8 @@ erc-nicks-cap-contrast
(should (= 12.5 (cdr erc-nicks-contrast-range)))
(let ((erc-nicks--bg-luminance 1.0)
(erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
(show (lambda (c) (erc-nicks-tests--print-contrast
#'erc-nicks-cap-contrast c))))
--
2.41.0
[-- Attachment #3: 0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch --]
[-- Type: text/x-patch, Size: 54197 bytes --]
From 7318662ad47e9f7b0da1a72f158690bbd4504724 Mon Sep 17 00:00:00 2001
From: David Leatherman <leathekd@gmail.com>
Date: Sun, 18 Dec 2022 19:01:40 -0800
Subject: [PATCH 1/1] [5.6] Add module for colorizing nicknames to ERC
* doc/misc/erc.texi: Add `nicks' to module lineup.
* etc/ERC-NEWS: Mention new module `nicks'.
* lisp/erc/erc-nicks.el: New file.
* lisp/erc/erc.el: (erc-modules): Add `nicks'.
* test/lisp/erc/erc-nicks-tests.el: New file.
* test/lisp/erc/erc-tests (erc-tests--modules): Add
`nicks'. (Bug#63569)
Co-authored-by: Andy Stewart <lazycat.manatee@gmail.com>
---
doc/misc/erc.texi | 4 +
etc/ERC-NEWS | 8 +
lisp/erc/erc-nicks.el | 635 +++++++++++++++++++++++++++++++
lisp/erc/erc.el | 1 +
test/lisp/erc/erc-nicks-tests.el | 439 +++++++++++++++++++++
test/lisp/erc/erc-tests.el | 2 +-
6 files changed, 1088 insertions(+), 1 deletion(-)
create mode 100644 lisp/erc/erc-nicks.el
create mode 100644 test/lisp/erc/erc-nicks-tests.el
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index ddfdb2e2b64..a67dcb3da7c 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -459,6 +459,10 @@ Modules
@item netsplit
Detect netsplits
+@cindex modules, nicks
+@item nicks
+Automatically colorize nicks
+
@cindex modules, noncommands
@item noncommands
Don't display non-IRC commands after evaluation
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 68cf0e2d6ca..658665f9d86 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of
buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get
started.
+** A new module for nickname highlighting has joined ERC.
+Automatic nickname coloring has come to ERC core. Users familiar with
+'erc-hl-nicks', from which this module directly descends, will already
+be familiar with its suite of handy options. By default, each
+nickname in an ERC session receives a unique face with a unique (or
+evenly dealt) foreground color. Add 'nicks' to 'erc-modules' to get
+started.
+
** A unified interactive entry point.
New users are often dismayed to discover that M-x ERC doesn't connect
to its default network, Libera.Chat, over TLS. Though perhaps a
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
new file mode 100644
index 00000000000..42bbdc1c59d
--- /dev/null
+++ b/lisp/erc/erc-nicks.el
@@ -0,0 +1,635 @@
+;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: David Leatherman <leathekd@gmail.com>
+;; Andy Stewart <lazycat.manatee@gmail.com>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides the `nicks' module for automatic nickname
+;; highlighting. Add `nicks' to `erc-modules' to get started.
+;;
+;; Use the command `erc-nicks-refresh' to review changes after
+;; adjusting an option, like `erc-nicks-contrast-range'. 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 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, including:
+;;
+;; Thibault Polge <thibault@thb.lt>
+;; Jay Kamat <jaygkamat@gmail.com>
+;; Alex Kost <alezost@gmail.com>
+;; Antoine Levitt <antoine dot levitt at gmail>
+;; Adam Porter <adam@alphapapa.net>
+;;
+;; 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] <http://www.github.com/leathekd/erc-hl-nicks>
+;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames>
+
+;;; 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.
+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
+ erc-my-nick-face erc-pal-face erc-fool-face)
+ "Faces to avoid highlighting atop."
+ :type '(repeat symbol))
+
+(defcustom erc-nicks-backing-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-add-contrast 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. 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)
+ (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))
+
+(defcustom erc-nicks-colors 'all
+ "Pool of colors.
+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)))
+
+(defcustom erc-nicks-key-suffix-format "@%n"
+ "Template for latter portion of keys to generate colors from.
+ERC passes this to `format-spec' with the following specifiers:
+%n for the current network and %m for your nickname (not the one
+being colorized). If you don't like the generated palette, try
+adding extra characters or padding, for example, with something
+like \"@%-012n\"."
+ :type 'string)
+
+(defvar erc-nicks--max-skip-search 3 ; make this an option?
+ "Max number of faces to visit when testing `erc-nicks-skip-faces'.")
+
+(defvar erc-nicks--key-function #'erc-nicks--gen-key-from-format-spec
+ "Function for generating a key to determine nick color.
+Called with a trimmed and case-mapped nickname.")
+
+(defvar erc-nicks--colors-rejects nil)
+(defvar erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces))
+(defvar erc-nicks--grad-steps 9)
+
+(defvar-local erc-nicks--face-table nil
+ "Hash table mapping nicks to unique, named faces.
+Keys are nonempty strings but need not be valid nicks.")
+
+(defvar-local erc-nicks--downcased-skip-nicks nil
+ "Case-mapped copy of `erc-nicks-skip-nicks'.")
+
+(defvar-local erc-nicks--bg-luminance nil)
+(defvar-local erc-nicks--bg-mode-value nil)
+(defvar-local erc-nicks--colors-len nil)
+(defvar-local erc-nicks--colors-pool nil)
+(defvar-local erc-nicks--fg-rgb nil)
+
+(defvar help-xref-stack)
+(defvar help-xref-stack-item)
+
+;; 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)))))))
+
+(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))))
+
+(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))))))
+
+;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html
+(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))))
+ (stop (if decrease
+ (color-name-to-rgb erc-nicks-bg-color)
+ erc-nicks--fg-rgb))
+ ;; 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)
+
+;; From https://elpa.gnu.org/packages/ement. The bit depth has been
+;; scaled up to try and avoid components being exactly 0.0, which our
+;; contrast function doesn't seem to like.
+(defun erc-nicks--gen-color (string)
+ "Generate normalized RGB color from STRING."
+ (let* ((ratio (/ (float (abs (random string))) (float most-positive-fixnum)))
+ (color-num (round (* #xffffffffffff ratio))))
+ (list (/ (float (logand color-num #xffff)) #xffff)
+ (/ (float (ash (logand color-num #xffff0000) -16)) #xffff)
+ (/ (float (ash (logand color-num #xffff00000000) -32)) #xffff))))
+
+;; 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-face t)
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
+ (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))
+
+(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-face)))
+ (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--create-pool (adjustments colors)
+ "Return COLORS that fall within parameters indicated by ADJUSTMENTS."
+ (let (addp capp satp pool)
+ (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 erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (push color pool))))
+ (nreverse pool)))
+
+(defun erc-nicks--init-pool ()
+ "Initialize colors and optionally display faces or color palette."
+ (unless (eq erc-nicks-colors 'all)
+ (let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors)
+ (defined-colors)))
+ (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors)))
+ (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 key))
+ (let ((pool (erc-with-server-buffer erc-nicks--colors-pool))
+ (len (erc-with-server-buffer erc-nicks--colors-len)))
+ (nth (% (abs (random key)) len) pool))))
+
+(defun erc-nicks--get-face (nick key)
+ "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--determine-color key))
+ (new-face (make-symbol (concat "erc-nicks-" nick "-face"))))
+ (put new-face 'erc-nicks--nick nick)
+ (put new-face 'erc-nicks--netid erc-networks--id)
+ (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)))))
+
+(defun erc-nicks--skip-p (prop option limit)
+ "Return non-nil if a face in PROP appears in OPTION.
+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))))))
+
+(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)))
+
+(defun erc-nicks--gen-key-from-format-spec (nickname)
+ "Generate key for NICKNAME according to `erc-nicks-key-suffix-format'."
+ (concat nickname (format-spec erc-nicks-key-suffix-format
+ `((?n . ,(erc-network))
+ (?m . ,(erc-current-nick))))))
+
+(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-backing-face)
+ (eq base-face erc-nicks-backing-face))
+ out
+ (cons out (erc-list erc-nicks-backing-face)))))
+
+(defun erc-nicks--highlight-button (nick-object)
+ "Possibly add face to `erc-button--nick-user' NICK-OBJECT."
+ (when-let*
+ ((nick-object)
+ (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-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-button '((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))))
+ (erc-nicks--init-pool)
+ (erc--restore-initialize-priors erc-nicks-mode
+ erc-nicks--face-table (make-hash-table :test #'equal)))
+ (setq erc-nicks--fg-rgb
+ (or (color-name-to-rgb
+ (face-foreground 'erc-default-face nil 'default))
+ (color-name-to-rgb
+ (readable-foreground-color erc-nicks-bg-color))))
+ (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--fg-rgb)
+ (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-button)
+ (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-nicks--trim (substring-no-properties nick)))
+ (let* ((net (erc-network))
+ (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)
+ (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)))
+
+(defun erc-nicks--list-faces-help-button-action (face)
+ (when-let (((or (get face 'erc-nicks--custom-face)
+ (y-or-n-p (format "Create new persistent face for %s?"
+ (get face 'erc-nicks--key)))))
+ (nid (get face 'erc-nicks--netid))
+ (foundp (lambda ()
+ (erc-networks--id-equal-p nid erc-networks--id)))
+ (server-buffer (car (erc-buffer-filter foundp))))
+ (with-current-buffer server-buffer
+ (erc-nicks-customize-face (get face 'erc-nicks--nick)))))
+
+(defun erc-nicks-list-faces ()
+ "Show faces owned by ERC-nicks in a help buffer."
+ (interactive)
+ (save-excursion
+ (list-faces-display (rx bot "erc-nicks-"))
+ (with-current-buffer "*Faces*"
+ (setq help-xref-stack nil
+ help-xref-stack-item '(erc-nicks-list-faces))
+ (with-silent-modifications
+ (goto-char (point-min))
+ (while (zerop (forward-line))
+ (when (and (get-text-property (point) 'button)
+ (facep (car (button-get (point) 'help-args))))
+ (button-put (point) 'help-function
+ #'erc-nicks--list-faces-help-button-action)
+ (if-let* ((face (car (button-get (point) 'help-args)))
+ ((not (get face 'erc-nicks--custom-face)))
+ ((not (get face 'erc-nicks--key))))
+ (progn (delete-region (pos-bol) (1+ (pos-eol)))
+ (forward-line -1))
+ (when-let* ((nid (get face 'erc-nicks--netid))
+ (net (symbol-name (erc-networks--id-symbol nid))))
+ (goto-char (button-end (point)))
+ (skip-syntax-forward "-")
+ (put-text-property (point) (1+ (point)) 'rear-nonsticky nil)
+ (forward-char)
+ (when (stringp (face-foreground face))
+ (setq net (format "%-13.13s %s" (substring-no-properties
+ (face-foreground face))
+ net)))
+ (insert-and-inherit net)
+ (delete-region (button-start (point))
+ (1+ (button-start (point))))
+ (delete-region (point) (pos-eol))))))))))
+
+(defun erc-nicks-refresh (debug)
+ "Recompute faces for all nicks on current network.
+With DEBUG, review affected faces or colors. Which one depends
+on the value of `erc-nicks-colors'."
+ (interactive "P")
+ (unless (derived-mode-p 'erc-mode)
+ (user-error "Not an ERC buffer"))
+ (erc-with-server-buffer
+ (unless erc-nicks-mode (user-error "Module `nicks' disabled"))
+ (let ((erc-nicks--colors-rejects (and debug (list t))))
+ (erc-nicks--init-pool)
+ (dolist (nick (hash-table-keys erc-nicks--face-table))
+ ;; User-tuned faces do not have an `erc-nicks--key' property.
+ (when-let* ((face (gethash nick erc-nicks--face-table))
+ (key (get face 'erc-nicks--key)))
+ (setq key (funcall erc-nicks--key-function nick))
+ (put face 'erc-nicks--key key)
+ (set-face-foreground face (erc-nicks--determine-color key))))
+ (when debug
+ (if (eq erc-nicks-colors 'all)
+ (erc-nicks-list-faces)
+ (pcase-dolist (`(,name ,pool)
+ `(("*erc-nicks-pool*" ,erc-nicks--colors-pool)
+ ("*erc-nicks-rejects*"
+ ,(cdr (nreverse erc-nicks--colors-rejects)))))
+ (when (buffer-live-p (get-buffer name))
+ (kill-buffer name))
+ (when pool
+ (save-excursion
+ (list-colors-display
+ pool name
+ (lambda (c)
+ (message "contrast: %.3f :saturation: %.3f"
+ (erc-nicks--get-contrast c)
+ (cadr (apply #'color-rgb-to-hsl
+ (color-name-to-rgb c))))))))))))))
+
+(provide 'erc-nicks)
+
+;;; erc-nicks.el ends here
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 70adbb15b5f..a269d10dc51 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2008,6 +2008,7 @@ erc-modules
move-to-prompt)
(const :tag "netsplit: Detect netsplits" netsplit)
(const :tag "networks: Provide data about IRC networks" networks)
+ (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks)
(const :tag "noncommands: Don't display non-IRC commands after evaluation"
noncommands)
(const :tag "notifications: Desktop alerts on PRIVMSG or mentions"
diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el
new file mode 100644
index 00000000000..08e423bf6b3
--- /dev/null
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -0,0 +1,439 @@
+;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unlike most of ERC's tests, the ones in this file can be run
+;; interactively in the same session.
+
+;; TODO:
+;;
+;; * Add mock session (or scenario) with buffer snapshots, like those
+;; in erc-fill-tests.el. (Should probably move helpers to a common
+;; library under ./resources.)
+
+;;; Code:
+
+(require 'ert)
+(require 'erc-nicks)
+
+;; This function replicates the behavior of older "invert" strategy
+;; implementations from EmacsWiki, etc. The values for the lower and
+;; upper bounds (0.33 and 0.66) are likewise inherited. See
+;; `erc-nicks--invert-classic--dark' below for one reason its results
+;; may not be plainly obvious.
+(defun erc-nicks-tests--invert-classic (color)
+ (if (pcase (erc-nicks--bg-mode)
+ ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0)))
+ ('light (> (erc-nicks--get-luminance color) (/ 2 3.0))))
+ (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color)))
+ color))
+
+
+(ert-deftest erc-nicks--get-luminance ()
+ (should (eql 0.0 (erc-nicks--get-luminance "black")))
+ (should (eql 1.0 (erc-nicks--get-luminance "white")))
+ (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0))))
+
+ ;; RGB floats from a `display-graphic-p' session.
+ (let ((a (erc-nicks--get-luminance ; #9439ad
+ '(0.5803921568627451 0.2235294117647059 0.6784313725490196)))
+ (b (erc-nicks--get-luminance ; #ae54c7
+ '(0.6823529411764706 0.32941176470588235 0.7803921568627451)))
+ (c (erc-nicks--get-luminance ; #d19ddf
+ '(0.8196078431372549 0.615686274509804 0.8745098039215686)))
+ (d (erc-nicks--get-luminance ; #f5e8f8
+ '(0.9607843137254902 0.9098039215686274 0.9725490196078431))))
+ ;; Low, med, high contrast comparisons against known values from
+ ;; an external source.
+ (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0)))
+ (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0)))
+ (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0)))))
+
+(ert-deftest erc-nicks-invert--classic ()
+ (let ((convert (lambda (n) (apply #'color-rgb-to-hex
+ (erc-nicks-tests--invert-classic
+ (color-name-to-rgb n))))))
+ (let ((erc-nicks--bg-mode-value 'dark))
+ (should (equal (funcall convert "white") "#ffffffffffff"))
+ (should (equal (funcall convert "black") "#ffffffffffff"))
+ (should (equal (funcall convert "green") "#0000ffff0000")))
+ (let ((erc-nicks--bg-mode-value 'light))
+ (should (equal (funcall convert "white") "#000000000000"))
+ (should (equal (funcall convert "black") "#000000000000"))
+ (should (equal (funcall convert "green") "#ffff0000ffff")))))
+
+(ert-deftest erc-nicks--get-contrast ()
+ (should (= 21.0 (erc-nicks--get-contrast "white" "black")))
+ (should (= 21.0 (erc-nicks--get-contrast "black" "white")))
+ (should (= 1.0 (erc-nicks--get-contrast "black" "black")))
+ (should (= 1.0 (erc-nicks--get-contrast "white" "white"))))
+
+(defun erc-nicks-tests--print-contrast (fn color)
+ (let* ((erc-nicks-color-adjustments (list fn))
+ (result (erc-nicks--reduce color))
+ (start (point)))
+ (insert (format "%16s%-16s%16s%-16s\n"
+ (concat color "-")
+ (concat ">" result)
+ (concat color " ")
+ (concat " " result)))
+ (put-text-property (+ start 32) (+ start 48) 'face
+ (list :background color :foreground result))
+ (put-text-property (+ start 48) (+ start 64) 'face
+ (list :background result :foreground color))
+ result))
+
+(ert-deftest erc-nicks--invert-classic--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; This shows that the output can be darker (have less contrast) than
+;; the input.
+(ert-deftest erc-nicks--invert-classic--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-tests--invert-classic c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#777777777777" (funcall show "#888888888888")))
+ (should (equal "#666666666666" (funcall show "#999999999999")))
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+;; These are the same as the legacy version but work in terms of
+;; contrast ratios. Converting the original bounds to contrast ratios
+;; (assuming pure white and black backgrounds) gives:
+;;
+;; min-lum of 0.33 ~~> 1.465
+;; max-lum of 0.66 ~~> 7.666
+;;
+(ert-deftest erc-nicks-invert--light ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks-contrast-range '(1.465))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create
+ "*erc-nicks--invert-classic--light*")
+ (should (equal "#000000000000" (funcall show "white")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ (unless noninteractive
+ (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb")))
+ (should (equal "#cccccccccccc" (funcall show "#cccccccccccc")))
+ (should (equal "#222122212221" (funcall show "#dddddddddddd")))
+ (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-invert--dark ()
+ (let ((erc-nicks--bg-luminance 0.0)
+ (erc-nicks--bg-mode-value 'dark)
+ (erc-nicks-contrast-range '(7.666))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-invert c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*")
+ (should (equal "#ffffffffffff" (funcall show "white")))
+ (should (equal "#ffffffffffff" (funcall show "black")))
+ (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan
+ (should (equal "#0000ffff0000" (funcall show "green")))
+ (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow
+
+ (unless noninteractive
+ (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555")))
+ (should (equal "#999999999999" (funcall show "#666666666666")))
+ (should (equal "#888888888888" (funcall show "#777777777777")))
+ (should (equal "#888888888888" (funcall show "#888888888888")))
+ (should (equal "#999999999999" (funcall show "#999999999999"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-add-contrast ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
+ (erc-nicks-contrast-range '(3.5))
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-add-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*")
+ (should (equal "#893a893a893a" (funcall show "white")))
+ (should (equal "#893a893a893a" (funcall show "#893a893a893a")))
+ (should (equal "#000000000000" (funcall show "black")))
+ (should (equal "#ffff00000000" (funcall show "red")))
+ (should (equal "#0000a12e0000" (funcall show "green")))
+ (should (equal "#00000000ffff" (funcall show "blue")))
+
+ ;; When the input is already near the desired ratio, the result
+ ;; may not be in bounds, only close. But the difference is
+ ;; usually imperceptible.
+ (unless noninteractive
+ ;; Well inside (light slate gray)
+ (should (equal "#777788889999" (funcall show "#777788889999")))
+ ;; Slightly outside -> just outside
+ (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa")))
+ ;; Just outside -> just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c")))
+ ;; Just inside
+ (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0"))))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-cap-contrast ()
+ (should (= 12.5 (cdr erc-nicks-contrast-range)))
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
+ (show (lambda (c) (erc-nicks-tests--print-contrast
+ #'erc-nicks-cap-contrast c))))
+
+ (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*")
+ (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14
+ (should ; 12.32 -> 12.32 (same)
+ (equal (funcall show "#34e534e534e5") "#34e534e534e5"))
+ (should (equal (funcall show "white") "#ffffffffffff"))
+
+ (unless noninteractive
+ (should (equal (funcall show "DarkRed") "#8b8b00000000"))
+ (should (equal (funcall show "DarkGreen") "#000064640000"))
+ ;; 15.29 -> 12.38
+ (should (equal (funcall show "DarkBlue") "#1cf11cf198b5"))
+
+ ;; 12.50 -> 12.22
+ (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab"))
+ ;; 12.57 -> 12.28
+ (should (equal (funcall show "#338033803380") "#344c344c344c"))
+ ;; 12.67 -> 12.37
+ (should (equal (funcall show "#330033003300") "#33cc33cc33cc")))
+
+ (when noninteractive
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks--skip-p ()
+ ;; Baseline
+ (should-not (erc-nicks--skip-p 'bold nil 10000000))
+ (should-not (erc-nicks--skip-p '(bold) nil 10000000))
+ (should-not (erc-nicks--skip-p nil '(bold) 10000000))
+ (should-not (erc-nicks--skip-p 'bold '(bold) 0))
+ (should-not (erc-nicks--skip-p '(bold) '(bold) 0))
+ (should-not (erc-nicks--skip-p 'bold '(foo bold) 0))
+ (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(bold) 1))
+ (should (erc-nicks--skip-p 'bold '(fake bold) 1))
+ (should (erc-nicks--skip-p 'bold '(foo bar bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(bold) 1))
+ (should (erc-nicks--skip-p '((bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '((((bold)))) '(bold) 1))
+ (should (erc-nicks--skip-p '(bold) '(foo bold) 1))
+ (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1))
+ (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1))
+
+ ;; Composed
+ (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1))
+ (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1))
+ (should (erc-nicks--skip-p '(italic bold) '(bold) 2))
+ (should (erc-nicks--skip-p '((italic) bold) '(bold) 2))
+ (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2))
+
+ (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2))
+ (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2))
+ (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2))
+ (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3))
+ (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3))
+ (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"))))
+
+(defun erc-nicks-tests--create-session (test)
+ (should-not (memq 'nicks erc-modules))
+ (let ((erc-modules (cons 'nicks erc-modules))
+ (inhibit-message noninteractive)
+ erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+
+ (with-current-buffer
+ (cl-letf
+ (((symbol-function 'erc-server-connect)
+ (lambda (&rest _)
+ (setq erc-server-process
+ (start-process "sleep" (current-buffer) "sleep" "1"))
+ (set-process-query-on-exit-flag erc-server-process nil))))
+
+ (erc-open "localhost" 6667 "tester" "Tester" 'connect
+ nil nil nil nil nil "tester"))
+
+ (let ((inhibit-message noninteractive))
+ (dolist (line (split-string "\
+:irc.foonet.org 004 tester irc.foonet.org irc.d abc 123 456
+:irc.foonet.org 005 tester NETWORK=foonet :are supported
+:irc.foonet.org 376 tester :End of /MOTD command."
+ "\n"))
+ (erc-parse-server-response erc-server-process line)))
+
+ (with-current-buffer (erc--open-target "#chan")
+ (erc-update-channel-member
+ "#chan" "Alice" "Alice" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-update-channel-member
+ "#chan" "Bob" "Bob" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+ (erc-display-message
+ nil 'notice (current-buffer)
+ (concat "This server is in debug mode and is logging all user I/O. "
+ "Blah Alice (1) Bob (2) blah."))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "Bob" "Hi Alice" nil t))
+
+ (erc-display-message nil nil (current-buffer)
+ (erc-format-privmessage "Alice" "Hi Bob" nil t)))
+
+ (funcall test)
+
+ (when noninteractive
+ (kill-buffer "#chan")
+ (kill-buffer)))))
+
+(ert-deftest erc-nicks-list-faces ()
+ (erc-nicks-tests--create-session
+ (lambda ()
+ (erc-nicks-list-faces)
+ (let ((table (buffer-local-value 'erc-nicks--face-table
+ (get-buffer "foonet")))
+ calls)
+ (cl-letf (((symbol-function 'erc-nicks--list-faces-help-button-action)
+ (lambda (&rest r) (push r calls))))
+ (with-current-buffer "*Faces*"
+ (set-window-buffer (selected-window) (current-buffer))
+ (goto-char (point-min))
+
+ (ert-info ("Clicking on face link runs action function")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-alice-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "alice" table))))
+
+ (ert-info ("Clicking on sample text describes face")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (push-button)
+ (should (search-forward-regexp
+ (rx "Foreground: #" (group (+ xdigit)) eol)))
+ (forward-button 1)
+ (push-button))
+
+ (ert-info ("First entry's sample is rendered correctly")
+ (let ((hex (match-string 1)))
+ (should (looking-at (concat "#" hex)))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls)))
+
+ (ert-info ("Clicking on another entry's face link runs action")
+ (forward-button 1)
+ (should (looking-at "erc-nicks-bob-face"))
+ (push-button)
+ (should (eq (car (car calls)) (gethash "bob" table))))
+
+ (ert-info ("Second entry's sample is rendered correctly")
+ (forward-button 1)
+ (should (looking-at (rx "#" (+ xdigit))))
+ (goto-char (button-end (point)))
+ (should (looking-back " foonet"))
+ (should (eq (button-get (1- (point)) 'face) (car (pop calls))))
+ (should-not calls))
+
+ (when noninteractive
+ (kill-buffer))))))))
+
+(ert-deftest erc-nicks--gen-key-from-format-spec ()
+ (let ((erc-network 'OFTC)
+ (erc-nicks-key-suffix-format "@%-012n")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@OFTC00000000")))
+
+ (let ((erc-network 'Libera.Chat)
+ (erc-nicks-key-suffix-format "@%-012n")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@Libera.Chat0")))
+
+ (let* ((erc-network 'Libera.Chat)
+ (erc-nicks-key-suffix-format "@%n/%m")
+ (erc-server-current-nick "tester"))
+ (should (equal (erc-nicks--gen-key-from-format-spec "bob")
+ "bob@Libera.Chat/tester"))))
+
+;;; erc-nicks-tests.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index b751ef50520..a154b81db30 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -1754,7 +1754,7 @@ erc-handle-irc-url
(defconst erc-tests--modules
'( autoaway autojoin button capab-identify completion dcc fill identd
imenu irccontrols keep-place list log match menu move-to-prompt netsplit
- networks noncommands notifications notify page readonly
+ networks nicks noncommands notifications notify page readonly
replace ring sasl scrolltobottom services smiley sound
spelling stamp track truncate unmorse xdcc))
--
2.41.0
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] <87ilcp1za1.fsf@neverwas.me>
` (6 preceding siblings ...)
2023-07-01 3:31 ` J.P.
@ 2023-07-14 2:37 ` J.P.
2023-09-07 13:31 ` J.P.
[not found] ` <87zg1yjeib.fsf@neverwas.me>
9 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-07-14 2:37 UTC (permalink / raw)
To: 63569-done; +Cc: emacs-erc, leathekd
I'm happy to report that this feature has landed [1]. Aside from small
fixes, the version installed was endorsed [2] by the author of hl-nicks
(which, you'll recall, is the most direct and significant ancestor of
what's now sitting on HEAD). Thanks to Corwin and the FSF for helping
make this initiative happen.
Closing.
[1] https://git.savannah.gnu.org/cgit/emacs.git/commit/?id=9bdc5c62
[2] https://lists.gnu.org/archive/html/emacs-erc/2023-07/msg00010.html
^ permalink raw reply [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] <87ilcp1za1.fsf@neverwas.me>
` (7 preceding siblings ...)
2023-07-14 2:37 ` J.P.
@ 2023-09-07 13:31 ` J.P.
[not found] ` <87zg1yjeib.fsf@neverwas.me>
9 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-09-07 13:31 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 1661 bytes --]
Currently, users on a non-graphical, non 24-bit Emacs who provide their
own `erc-nicks-colors' pool must ensure those colors fall within
`erc-nicks-contrast-range' and `erc-nicks-saturation-range' (assuming a
non-nil `erc-nicks-color-adjustments', the default). Otherwise, their
pool is subject to culling without warning on module init, which they
may find frustrating even though this behavior is documented. If people
believe this to be a grave enough annoyance, we can do something like
the attached, which offers a couple alternate pool-prep approaches that
"pre-treat" candidates with `erc-nicks-color-adjustments' and coerce
them to predefined system palette members, thus effectively culling by
way of deduping.
If actually doing this, we'd likely have to add a public-facing knob
for selecting between various fixed-pool filtering styles, such as:
- cull (current)
- treat, coerce, and cull
- treat and coerce
The latter two differ in that the first rechecks if the remapped
"defined" value still falls within specified tolerances, and drops it if
it doesn't, while the last approach turns a blind eye. IMO, the first is
of limited value unless we were to make it try repeatedly to find a
satisfactory match. Although these only run on init, folks may find them
too sluggish (both are already quadratic). We could instead make them
interactive commands (or `custom-set' functions) that users can use to
populate `erc-nicks-colors' while configuring.
Personally, I'm not affected by the current behavior because I use
graphical Emacs or a 24-bit terminal emulator with ERC. However, I'm
open to doing this if others think it worthwhile. Thanks.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-POC-Offer-alternate-pool-creation-strategies-in-erc-.patch --]
[-- Type: text/x-patch, Size: 5197 bytes --]
From ef97b82a7d38e4a61a54cfb7be7444bc8293261b Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 3 Sep 2023 16:05:59 -0700
Subject: [PATCH] [POC] Offer alternate pool-creation strategies in erc-nicks
(erc-nicks--create-pool-function): New function-valued variable to
allow for changing fixed-pool creation strategy.
(erc-nicks--create-adjusted-pool,
erc-nicks--create-coerced-pool): New functions for filtering
user-provided `erc-nicks-color' values.
(erc-nicks--init-pool): Call `erc-nicks--create-pool-function'.
(erc-nicks-refresh): Provide helpful user error instead of letting
`arith-error' propagate due to an empty pool. (Bug#63569)
---
lisp/erc/erc-nicks.el | 63 ++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 62 insertions(+), 1 deletion(-)
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
index a7d0b0769f2..3e5bf2b8d3f 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -356,6 +356,64 @@ erc-nicks--reduce
erc-nicks-color-adjustments
(if (stringp color) (color-name-to-rgb color) color))))
+(defvar erc-nicks--create-pool-function #'erc-nicks--create-adjusted-pool)
+
+(defun erc-nicks--create-adjusted-pool (adjustments colors)
+ "Return COLORS that fall within parameters indicated by ADJUSTMENTS.
+Apply adjustments before replacing COLORS with the nearest
+defined, and then cull those that still don't meet the grade.
+Expect to operate on user-provided lists of `erc-nicks-colors'
+rather than all those `defined' by the system."
+ (let* ((seen (make-hash-table :test #'equal))
+ (valmax (float (car (color-values "#ffffffffffff"))))
+ (erc-nicks-color-adjustments adjustments)
+ addp capp satp pool)
+ (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)
+ (pcase-let ((`(,quantized ,_ . ,vals)
+ (tty-color-approximate (color-values
+ (erc-nicks--reduce color)))))
+ (if (gethash quantized seen)
+ (when erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (let* ((rgb (mapcar (lambda (x) (/ x valmax)) vals))
+ (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 erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (push quantized pool)
+ (puthash quantized color seen))))))
+ (nreverse pool)))
+
+(defun erc-nicks--create-coerced-pool (adjustments colors)
+ "Return COLORS that fall within parameters indicated by ADJUSTMENTS.
+Rather than culling, apply adjustments and then dedupe after
+first replacing adjusted values with the nearest defined. Unlike
+`erc-nicks--create-adjusted-pool', don't recheck after adjusting.
+Rather, tolerate values that may fall slightly outside desired
+parameters, thus yielding a larger pool."
+ (let* ((seen (make-hash-table :test #'equal))
+ (erc-nicks-color-adjustments adjustments)
+ pool)
+ (dolist (color colors)
+ (let ((quantized (car (tty-color-approximate
+ (color-values (erc-nicks--reduce color))))))
+ (if (gethash quantized seen)
+ (when erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (push quantized pool)
+ (puthash quantized color seen))))
+ (nreverse pool)))
+
(defun erc-nicks--create-pool (adjustments colors)
"Return COLORS that fall within parameters indicated by ADJUSTMENTS."
(let (addp capp satp pool)
@@ -383,7 +441,8 @@ erc-nicks--init-pool
(unless (eq erc-nicks-colors 'all)
(let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors)
(defined-colors)))
- (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors)))
+ (pool (funcall erc-nicks--create-pool-function
+ erc-nicks-color-adjustments colors)))
(setq erc-nicks--colors-pool pool
erc-nicks--colors-len (length pool)))))
@@ -608,6 +667,8 @@ erc-nicks-refresh
(unless erc-nicks-mode (user-error "Module `nicks' disabled"))
(let ((erc-nicks--colors-rejects (and debug (list t))))
(erc-nicks--init-pool)
+ (unless erc-nicks--colors-pool
+ (user-error "Pool empty: all colors rejected"))
(dolist (nick (hash-table-keys erc-nicks--face-table))
;; User-tuned faces do not have an `erc-nicks--key' property.
(when-let ((face (gethash nick erc-nicks--face-table))
--
2.41.0
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] ` <87zg1yjeib.fsf@neverwas.me>
@ 2023-11-07 16:28 ` J.P.
[not found] ` <87r0l1frzc.fsf@neverwas.me>
1 sibling, 0 replies; 15+ messages in thread
From: J.P. @ 2023-11-07 16:28 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
[-- Attachment #1: Type: text/plain, Size: 2547 bytes --]
"J.P." <jp@neverwas.me> writes:
> Currently, users on a non-graphical, non 24-bit Emacs who provide their
> own `erc-nicks-colors' pool must ensure those colors fall within
> `erc-nicks-contrast-range' and `erc-nicks-saturation-range' (assuming a
> non-nil `erc-nicks-color-adjustments', the default). Otherwise, their
> pool is subject to culling without warning on module init, which they
> may find frustrating even though this behavior is documented. If people
> believe this to be a grave enough annoyance, we can do something like
> the attached, which offers a couple alternate pool-prep approaches that
> "pre-treat" candidates with `erc-nicks-color-adjustments' and coerce
> them to predefined system palette members, thus effectively culling by
> way of deduping.
>
> If actually doing this, we'd likely have to add a public-facing knob
> for selecting between various fixed-pool filtering styles, such as:
>
> - cull (current)
> - treat, coerce, and cull
> - treat and coerce
>
> The latter two differ in that the first rechecks if the remapped
> "defined" value still falls within specified tolerances, and drops it if
> it doesn't, while the last approach turns a blind eye. IMO, the first is
> of limited value unless we were to make it try repeatedly to find a
> satisfactory match. Although these only run on init, folks may find them
> too sluggish (both are already quadratic). We could instead make them
> interactive commands (or `custom-set' functions) that users can use to
> populate `erc-nicks-colors' while configuring.
>
> Personally, I'm not affected by the current behavior because I use
> graphical Emacs or a 24-bit terminal emulator with ERC. However, I'm
> open to doing this if others think it worthwhile. Thanks.
A user on Libera requested some time ago that pool-creation facilities
like the ones mentioned above be added to erc-nicks. The attached patch
does this but in a simplified manner that avoids adding additional user
options. Instead, it defaults to the "blind eye" approach mentioned
above since (IMO) it's likeliest to meet user expectations.
The patch also adds two ready-made Custom choice variants to the option
`erc-nick-colors': `font-lock' and `ansi-color'. These are predefined
sets of candidates for the (repeat string) :type variant. As may be
obvious, ERC interprets these symbols as palettes to be populated from
the :foreground colors of whatever font-lock- and ansi-color-related
faces exist for the current theme.
There's also a minor bug fix involving initialization ordering.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0000-v1-v2.diff --]
[-- Type: text/x-patch, Size: 15007 bytes --]
From 9aff22914d85d92ca2665c6fc5b3359217b5d766 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Tue, 7 Nov 2023 02:03:27 -0800
Subject: [PATCH 0/1] *** NOT A PATCH ***
*** BLURB HERE ***
F. Jason Park (1):
[5.6] Offer alternate pool-creation strategies in erc-nicks
lisp/erc/erc-nicks.el | 87 +++++++++++++++++++++++++++-----
test/lisp/erc/erc-nicks-tests.el | 79 ++++++++++++++++++++---------
2 files changed, 129 insertions(+), 37 deletions(-)
Interdiff:
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
index 3e5bf2b8d3f..d512455090b 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -102,7 +102,10 @@ 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."
+which may be the case in terminal Emacs. Even when automatically
+initialized, this value may need adjustment mid-session, such as
+after loading a new theme. Remember to run \\[erc-nicks-refresh]
+after doing so."
:type 'string)
(defcustom erc-nicks-color-adjustments
@@ -153,9 +156,13 @@ erc-nicks-colors
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) (repeat string)))
+color. To change the value mid-session, try
+\\[erc-nicks-refresh]."
+ :type `(choice (const :tag "All 24-bit colors" all)
+ (const :tag "Defined terminal colors" defined)
+ (const :tag "Font Lock faces" font-lock)
+ (const :tag "ANSI color faces" ansi-color)
+ (repeat :tag "User-provided list" string)))
(defcustom erc-nicks-key-suffix-format "@%n"
"Template for latter portion of keys to generate colors from.
@@ -227,6 +234,7 @@ erc-nicks--bg-mode
;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html
(defun erc-nicks--adjust-contrast (color target &optional decrease)
+ (cl-assert erc-nicks--fg-rgb)
(let* ((lum-bg (or erc-nicks--bg-luminance
(setq erc-nicks--bg-luminance
(erc-nicks--get-luminance erc-nicks-bg-color))))
@@ -356,51 +364,26 @@ erc-nicks--reduce
erc-nicks-color-adjustments
(if (stringp color) (color-name-to-rgb color) color))))
-(defvar erc-nicks--create-pool-function #'erc-nicks--create-adjusted-pool)
-
-(defun erc-nicks--create-adjusted-pool (adjustments colors)
- "Return COLORS that fall within parameters indicated by ADJUSTMENTS.
-Apply adjustments before replacing COLORS with the nearest
-defined, and then cull those that still don't meet the grade.
-Expect to operate on user-provided lists of `erc-nicks-colors'
-rather than all those `defined' by the system."
- (let* ((seen (make-hash-table :test #'equal))
- (valmax (float (car (color-values "#ffffffffffff"))))
- (erc-nicks-color-adjustments adjustments)
- addp capp satp pool)
- (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)
- (pcase-let ((`(,quantized ,_ . ,vals)
- (tty-color-approximate (color-values
- (erc-nicks--reduce color)))))
- (if (gethash quantized seen)
- (when erc-nicks--colors-rejects
- (push color erc-nicks--colors-rejects))
- (let* ((rgb (mapcar (lambda (x) (/ x valmax)) vals))
- (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 erc-nicks--colors-rejects
- (push color erc-nicks--colors-rejects))
- (push quantized pool)
- (puthash quantized color seen))))))
- (nreverse pool)))
+(defvar erc-nicks--create-pool-function #'erc-nicks--create-coerced-pool
+ "Filter function for initializing the pool of colors.
+Takes a list of adjustment functions, such as those named in
+`erc-nicks-color-adjustments', and a list of colors. Returns
+another list whose members need not be among the original
+candidates. Users should note that this variable, along with its
+predefined function values, `erc-nicks--create-coerced-pool' and
+`erc-nicks--create-culled-pool', can be made public in a future
+version of this module, perhaps as a single user option, given
+sufficient demand.")
(defun erc-nicks--create-coerced-pool (adjustments colors)
- "Return COLORS that fall within parameters indicated by ADJUSTMENTS.
-Rather than culling, apply adjustments and then dedupe after
-first replacing adjusted values with the nearest defined. Unlike
-`erc-nicks--create-adjusted-pool', don't recheck after adjusting.
-Rather, tolerate values that may fall slightly outside desired
-parameters, thus yielding a larger pool."
+ "Return COLORS that fall within parameters heeded by ADJUSTMENTS.
+Apply ADJUSTMENTS and dedupe after replacing adjusted values with
+those nearest defined for the terminal. Only perform one pass.
+That is, accept the nearest initially found as \"close enough,\"
+knowing that values may fall outside desired parameters and thus
+yield a larger pool than simple culling might produce. When
+debugging, add candidates to `erc-nicks--colors-rejects' that map
+to the same output color as some prior candidate."
(let* ((seen (make-hash-table :test #'equal))
(erc-nicks-color-adjustments adjustments)
pool)
@@ -414,7 +397,7 @@ erc-nicks--create-coerced-pool
(puthash quantized color seen))))
(nreverse pool)))
-(defun erc-nicks--create-pool (adjustments colors)
+(defun erc-nicks--create-culled-pool (adjustments colors)
"Return COLORS that fall within parameters indicated by ADJUSTMENTS."
(let (addp capp satp pool)
(dolist (adjustment adjustments)
@@ -440,6 +423,9 @@ erc-nicks--init-pool
"Initialize colors and optionally display faces or color palette."
(unless (eq erc-nicks-colors 'all)
(let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors)
+ (and (memq erc-nicks-colors '(font-lock ansi-color))
+ (erc-nicks--colors-from-faces
+ (format "%s-" erc-nicks-colors)))
(defined-colors)))
(pool (funcall erc-nicks--create-pool-function
erc-nicks-color-adjustments colors)))
@@ -546,7 +532,8 @@ nicks
" Toggling it in individual target buffers is unsupported.")
(erc-nicks-mode +1))) ; but do it anyway
(setq erc-nicks--downcased-skip-nicks
- (mapcar #'erc-downcase erc-nicks-skip-nicks))
+ (mapcar #'erc-downcase erc-nicks-skip-nicks)
+ erc-nicks--fg-rgb (erc-with-server-buffer erc-nicks--fg-rgb))
(add-function :filter-return (local 'erc-button--modify-nick-function)
#'erc-nicks--highlight-button '((depth . 80)))
(erc-button--phantom-users-mode +1))
@@ -564,14 +551,14 @@ 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))))
+ (setq erc-nicks--fg-rgb
+ (or (color-name-to-rgb
+ (face-foreground 'erc-default-face nil 'default))
+ (color-name-to-rgb
+ (readable-foreground-color erc-nicks-bg-color))))
(erc-nicks--init-pool)
(erc--restore-initialize-priors erc-nicks-mode
erc-nicks--face-table (make-hash-table :test #'equal)))
- (setq erc-nicks--fg-rgb
- (or (color-name-to-rgb
- (face-foreground 'erc-default-face nil 'default))
- (color-name-to-rgb
- (readable-foreground-color erc-nicks-bg-color))))
(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
@@ -658,8 +645,10 @@ erc-nicks-list-faces
(defun erc-nicks-refresh (debug)
"Recompute faces for all nicks on current network.
-With DEBUG, review affected faces or colors. Which one depends
-on the value of `erc-nicks-colors'."
+With DEBUG, review affected faces or colors. Exactly which of
+the two depends on the value of `erc-nicks-colors'. Note that
+the list of rejected faces may include duplicates of accepted
+ones."
(interactive "P")
(unless (derived-mode-p 'erc-mode)
(user-error "Not an ERC buffer"))
@@ -695,6 +684,15 @@ erc-nicks-refresh
(cadr (apply #'color-rgb-to-hsl
(color-name-to-rgb c))))))))))))))
+(defun erc-nicks--colors-from-faces (prefix)
+ "Extract foregrounds from faces with PREFIX
+Expect PREFIX to be something like \"ansi-color-\" or \"font-lock-\"."
+ (let (out)
+ (dolist (face (face-list) (nreverse out))
+ (when-let (((string-prefix-p prefix (symbol-name face)))
+ (color (face-foreground face)))
+ (push color out)))))
+
(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 3e5804734ec..35264a23caa 100644
--- a/test/lisp/erc/erc-nicks-tests.el
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -493,7 +493,7 @@ erc-nicks--gen-key-from-format-spec
(should (equal (erc-nicks--gen-key-from-format-spec "bob")
"bob@Libera.Chat/tester"))))
-(ert-deftest erc-nicks--create-pool ()
+(ert-deftest erc-nicks--create-culled-pool ()
(let ((erc-nicks--bg-luminance 1.0)
(erc-nicks--bg-mode-value 'light)
(erc-nicks--fg-rgb '(0.0 0.0 0.0))
@@ -502,37 +502,70 @@ erc-nicks--create-pool
(erc-nicks--colors-rejects '(t)))
;; Reject
- (should-not (erc-nicks--create-pool '(erc-nicks-invert) '("white")))
+ (should-not (erc-nicks--create-culled-pool '(erc-nicks-invert) '("white")))
(should (equal (pop erc-nicks--colors-rejects) "white")) ; too close
- (should-not (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("black")))
+ (should-not
+ (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast) '("black")))
(should (equal (pop erc-nicks--colors-rejects) "black")) ; too far
- (should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("white")))
+ (should-not
+ (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("white")))
(should (equal (pop erc-nicks--colors-rejects) "white")) ; lacks color
- (should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("red")))
+ (should-not
+ (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("red")))
(should (equal (pop erc-nicks--colors-rejects) "red")) ; too much color
;; Safe
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-invert) '("black"))
- '("black")))
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-add-contrast) '("black"))
- '("black")))
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("white"))
- '("white")))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-invert)
+ '("black"))
+ '("black")))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-add-contrast)
+ '("black"))
+ '("black")))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast)
+ '("white"))
+ '("white")))
(let ((erc-nicks-saturation-range '(0.5 . 1.0)))
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("green"))
- '("green"))))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate)
+ '("green"))
+ '("green"))))
(let ((erc-nicks-saturation-range '(0.0 . 0.5)))
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("gray"))
- '("gray"))))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate)
+ '("gray"))
+ '("gray"))))
(unless noninteractive
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("firebrick"))
- '("firebrick"))))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate)
+ '("firebrick"))
+ '("firebrick"))))
+ (should (equal erc-nicks--colors-rejects '(t)))))
+
+(ert-deftest erc-nicks--create-coerced-pool ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
+ (num-colors (length (defined-colors)))
+ ;;
+ (erc-nicks--colors-rejects '(t)))
+
+ ;; Deduplication.
+ (when (= 8 num-colors)
+ (should (equal (erc-nicks--create-coerced-pool '(erc-nicks-ensaturate)
+ '("#ee0000" "#f80000"))
+ '("red")))
+ (should (equal (pop erc-nicks--colors-rejects) "#f80000")))
+
+ ;; "Coercion" in Xterm.
+ (unless noninteractive
+ (when (= 665 num-colors)
+ (pcase-dolist (`(,adjustments ,candidates ,result)
+ '(((erc-nicks-invert) ("white") ("gray10"))
+ ((erc-nicks-cap-contrast) ("black") ("gray20"))
+ ((erc-nicks-ensaturate) ("white") ("lavenderblush2"))
+ ((erc-nicks-ensaturate) ("red") ("firebrick"))))
+ (should (equal (erc-nicks--create-coerced-pool adjustments
+ candidates)
+ result)))))
+
(should (equal erc-nicks--colors-rejects '(t)))))
;;; erc-nicks-tests.el ends here
--
2.41.0
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0001-5.6-Offer-alternate-pool-creation-strategies-in-erc-.patch --]
[-- Type: text/x-patch, Size: 14748 bytes --]
From 9aff22914d85d92ca2665c6fc5b3359217b5d766 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 3 Sep 2023 16:05:59 -0700
Subject: [PATCH 1/1] [5.6] Offer alternate pool-creation strategies in
erc-nicks
* lisp/erc/erc-nicks.el (erc-nicks-bg-color): Expand doc string.
(erc-nicks-colors): Add new choices `font-lock' and `ansi-color'.
(erc-nicks--adjust-contrast): Add
assertion.
(erc-nicks--create-pool-function): New function-valued variable to
specify a pool creation strategy. Note in doc string that this could
form the basis for a possible user option should the need arise.
(erc-nicks--create-coerced-pool): New function for filtering
user-provided `erc-nicks-color' values.
(erc-nicks--create-pool, erc-nicks--create-culled-pool): Rename former
to latter.
(erc-nicks--init-pool): Call `erc-nicks--create-pool-function' to
actually create pool. Account for new `erc-nicks-colors' values.
(erc-nicks-enable, erc-nicks-mode): Set `erc-nicks--fg-rgb' before
`erc-nicks--init-pool' to prevent type error in filters that depend on
that variable being initialized. This is a bug fix.
(erc-nicks-refresh): Provide helpful user error instead of letting
`arith-error' propagate due to an empty pool.
(erc-nicks--colors-from-faces): New function.
* test/lisp/erc/erc-nicks-tests.el (erc-nicks--create-pool,
erc-nicks--create-culled-pool): Rename test from former to latter.
(erc-nicks--create-coerced-pool): New test. (Bug#63569)
---
lisp/erc/erc-nicks.el | 87 +++++++++++++++++++++++++++-----
test/lisp/erc/erc-nicks-tests.el | 79 ++++++++++++++++++++---------
2 files changed, 129 insertions(+), 37 deletions(-)
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
index a7d0b0769f2..d512455090b 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -102,7 +102,10 @@ 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."
+which may be the case in terminal Emacs. Even when automatically
+initialized, this value may need adjustment mid-session, such as
+after loading a new theme. Remember to run \\[erc-nicks-refresh]
+after doing so."
:type 'string)
(defcustom erc-nicks-color-adjustments
@@ -153,9 +156,13 @@ erc-nicks-colors
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) (repeat string)))
+color. To change the value mid-session, try
+\\[erc-nicks-refresh]."
+ :type `(choice (const :tag "All 24-bit colors" all)
+ (const :tag "Defined terminal colors" defined)
+ (const :tag "Font Lock faces" font-lock)
+ (const :tag "ANSI color faces" ansi-color)
+ (repeat :tag "User-provided list" string)))
(defcustom erc-nicks-key-suffix-format "@%n"
"Template for latter portion of keys to generate colors from.
@@ -227,6 +234,7 @@ erc-nicks--bg-mode
;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html
(defun erc-nicks--adjust-contrast (color target &optional decrease)
+ (cl-assert erc-nicks--fg-rgb)
(let* ((lum-bg (or erc-nicks--bg-luminance
(setq erc-nicks--bg-luminance
(erc-nicks--get-luminance erc-nicks-bg-color))))
@@ -356,7 +364,40 @@ erc-nicks--reduce
erc-nicks-color-adjustments
(if (stringp color) (color-name-to-rgb color) color))))
-(defun erc-nicks--create-pool (adjustments colors)
+(defvar erc-nicks--create-pool-function #'erc-nicks--create-coerced-pool
+ "Filter function for initializing the pool of colors.
+Takes a list of adjustment functions, such as those named in
+`erc-nicks-color-adjustments', and a list of colors. Returns
+another list whose members need not be among the original
+candidates. Users should note that this variable, along with its
+predefined function values, `erc-nicks--create-coerced-pool' and
+`erc-nicks--create-culled-pool', can be made public in a future
+version of this module, perhaps as a single user option, given
+sufficient demand.")
+
+(defun erc-nicks--create-coerced-pool (adjustments colors)
+ "Return COLORS that fall within parameters heeded by ADJUSTMENTS.
+Apply ADJUSTMENTS and dedupe after replacing adjusted values with
+those nearest defined for the terminal. Only perform one pass.
+That is, accept the nearest initially found as \"close enough,\"
+knowing that values may fall outside desired parameters and thus
+yield a larger pool than simple culling might produce. When
+debugging, add candidates to `erc-nicks--colors-rejects' that map
+to the same output color as some prior candidate."
+ (let* ((seen (make-hash-table :test #'equal))
+ (erc-nicks-color-adjustments adjustments)
+ pool)
+ (dolist (color colors)
+ (let ((quantized (car (tty-color-approximate
+ (color-values (erc-nicks--reduce color))))))
+ (if (gethash quantized seen)
+ (when erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (push quantized pool)
+ (puthash quantized color seen))))
+ (nreverse pool)))
+
+(defun erc-nicks--create-culled-pool (adjustments colors)
"Return COLORS that fall within parameters indicated by ADJUSTMENTS."
(let (addp capp satp pool)
(dolist (adjustment adjustments)
@@ -382,8 +423,12 @@ erc-nicks--init-pool
"Initialize colors and optionally display faces or color palette."
(unless (eq erc-nicks-colors 'all)
(let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors)
+ (and (memq erc-nicks-colors '(font-lock ansi-color))
+ (erc-nicks--colors-from-faces
+ (format "%s-" erc-nicks-colors)))
(defined-colors)))
- (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors)))
+ (pool (funcall erc-nicks--create-pool-function
+ erc-nicks-color-adjustments colors)))
(setq erc-nicks--colors-pool pool
erc-nicks--colors-len (length pool)))))
@@ -487,7 +532,8 @@ nicks
" Toggling it in individual target buffers is unsupported.")
(erc-nicks-mode +1))) ; but do it anyway
(setq erc-nicks--downcased-skip-nicks
- (mapcar #'erc-downcase erc-nicks-skip-nicks))
+ (mapcar #'erc-downcase erc-nicks-skip-nicks)
+ erc-nicks--fg-rgb (erc-with-server-buffer erc-nicks--fg-rgb))
(add-function :filter-return (local 'erc-button--modify-nick-function)
#'erc-nicks--highlight-button '((depth . 80)))
(erc-button--phantom-users-mode +1))
@@ -505,14 +551,14 @@ 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))))
+ (setq erc-nicks--fg-rgb
+ (or (color-name-to-rgb
+ (face-foreground 'erc-default-face nil 'default))
+ (color-name-to-rgb
+ (readable-foreground-color erc-nicks-bg-color))))
(erc-nicks--init-pool)
(erc--restore-initialize-priors erc-nicks-mode
erc-nicks--face-table (make-hash-table :test #'equal)))
- (setq erc-nicks--fg-rgb
- (or (color-name-to-rgb
- (face-foreground 'erc-default-face nil 'default))
- (color-name-to-rgb
- (readable-foreground-color erc-nicks-bg-color))))
(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
@@ -599,8 +645,10 @@ erc-nicks-list-faces
(defun erc-nicks-refresh (debug)
"Recompute faces for all nicks on current network.
-With DEBUG, review affected faces or colors. Which one depends
-on the value of `erc-nicks-colors'."
+With DEBUG, review affected faces or colors. Exactly which of
+the two depends on the value of `erc-nicks-colors'. Note that
+the list of rejected faces may include duplicates of accepted
+ones."
(interactive "P")
(unless (derived-mode-p 'erc-mode)
(user-error "Not an ERC buffer"))
@@ -608,6 +656,8 @@ erc-nicks-refresh
(unless erc-nicks-mode (user-error "Module `nicks' disabled"))
(let ((erc-nicks--colors-rejects (and debug (list t))))
(erc-nicks--init-pool)
+ (unless erc-nicks--colors-pool
+ (user-error "Pool empty: all colors rejected"))
(dolist (nick (hash-table-keys erc-nicks--face-table))
;; User-tuned faces do not have an `erc-nicks--key' property.
(when-let ((face (gethash nick erc-nicks--face-table))
@@ -634,6 +684,15 @@ erc-nicks-refresh
(cadr (apply #'color-rgb-to-hsl
(color-name-to-rgb c))))))))))))))
+(defun erc-nicks--colors-from-faces (prefix)
+ "Extract foregrounds from faces with PREFIX
+Expect PREFIX to be something like \"ansi-color-\" or \"font-lock-\"."
+ (let (out)
+ (dolist (face (face-list) (nreverse out))
+ (when-let (((string-prefix-p prefix (symbol-name face)))
+ (color (face-foreground face)))
+ (push color out)))))
+
(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 3e5804734ec..35264a23caa 100644
--- a/test/lisp/erc/erc-nicks-tests.el
+++ b/test/lisp/erc/erc-nicks-tests.el
@@ -493,7 +493,7 @@ erc-nicks--gen-key-from-format-spec
(should (equal (erc-nicks--gen-key-from-format-spec "bob")
"bob@Libera.Chat/tester"))))
-(ert-deftest erc-nicks--create-pool ()
+(ert-deftest erc-nicks--create-culled-pool ()
(let ((erc-nicks--bg-luminance 1.0)
(erc-nicks--bg-mode-value 'light)
(erc-nicks--fg-rgb '(0.0 0.0 0.0))
@@ -502,37 +502,70 @@ erc-nicks--create-pool
(erc-nicks--colors-rejects '(t)))
;; Reject
- (should-not (erc-nicks--create-pool '(erc-nicks-invert) '("white")))
+ (should-not (erc-nicks--create-culled-pool '(erc-nicks-invert) '("white")))
(should (equal (pop erc-nicks--colors-rejects) "white")) ; too close
- (should-not (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("black")))
+ (should-not
+ (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast) '("black")))
(should (equal (pop erc-nicks--colors-rejects) "black")) ; too far
- (should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("white")))
+ (should-not
+ (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("white")))
(should (equal (pop erc-nicks--colors-rejects) "white")) ; lacks color
- (should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("red")))
+ (should-not
+ (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("red")))
(should (equal (pop erc-nicks--colors-rejects) "red")) ; too much color
;; Safe
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-invert) '("black"))
- '("black")))
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-add-contrast) '("black"))
- '("black")))
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("white"))
- '("white")))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-invert)
+ '("black"))
+ '("black")))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-add-contrast)
+ '("black"))
+ '("black")))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast)
+ '("white"))
+ '("white")))
(let ((erc-nicks-saturation-range '(0.5 . 1.0)))
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("green"))
- '("green"))))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate)
+ '("green"))
+ '("green"))))
(let ((erc-nicks-saturation-range '(0.0 . 0.5)))
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("gray"))
- '("gray"))))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate)
+ '("gray"))
+ '("gray"))))
(unless noninteractive
- (should
- (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("firebrick"))
- '("firebrick"))))
+ (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate)
+ '("firebrick"))
+ '("firebrick"))))
+ (should (equal erc-nicks--colors-rejects '(t)))))
+
+(ert-deftest erc-nicks--create-coerced-pool ()
+ (let ((erc-nicks--bg-luminance 1.0)
+ (erc-nicks--bg-mode-value 'light)
+ (erc-nicks--fg-rgb '(0.0 0.0 0.0))
+ (erc-nicks-bg-color "white")
+ (num-colors (length (defined-colors)))
+ ;;
+ (erc-nicks--colors-rejects '(t)))
+
+ ;; Deduplication.
+ (when (= 8 num-colors)
+ (should (equal (erc-nicks--create-coerced-pool '(erc-nicks-ensaturate)
+ '("#ee0000" "#f80000"))
+ '("red")))
+ (should (equal (pop erc-nicks--colors-rejects) "#f80000")))
+
+ ;; "Coercion" in Xterm.
+ (unless noninteractive
+ (when (= 665 num-colors)
+ (pcase-dolist (`(,adjustments ,candidates ,result)
+ '(((erc-nicks-invert) ("white") ("gray10"))
+ ((erc-nicks-cap-contrast) ("black") ("gray20"))
+ ((erc-nicks-ensaturate) ("white") ("lavenderblush2"))
+ ((erc-nicks-ensaturate) ("red") ("firebrick"))))
+ (should (equal (erc-nicks--create-coerced-pool adjustments
+ candidates)
+ result)))))
+
(should (equal erc-nicks--colors-rejects '(t)))))
;;; erc-nicks-tests.el ends here
--
2.41.0
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0001-POC-Offer-alternate-pool-creation-strategies-in-erc-.patch --]
[-- Type: text/x-patch, Size: 5197 bytes --]
From ef97b82a7d38e4a61a54cfb7be7444bc8293261b Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Sun, 3 Sep 2023 16:05:59 -0700
Subject: [PATCH] [POC] Offer alternate pool-creation strategies in erc-nicks
(erc-nicks--create-pool-function): New function-valued variable to
allow for changing fixed-pool creation strategy.
(erc-nicks--create-adjusted-pool,
erc-nicks--create-coerced-pool): New functions for filtering
user-provided `erc-nicks-color' values.
(erc-nicks--init-pool): Call `erc-nicks--create-pool-function'.
(erc-nicks-refresh): Provide helpful user error instead of letting
`arith-error' propagate due to an empty pool. (Bug#63569)
---
lisp/erc/erc-nicks.el | 63 ++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 62 insertions(+), 1 deletion(-)
diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el
index a7d0b0769f2..3e5bf2b8d3f 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -356,6 +356,64 @@ erc-nicks--reduce
erc-nicks-color-adjustments
(if (stringp color) (color-name-to-rgb color) color))))
+(defvar erc-nicks--create-pool-function #'erc-nicks--create-adjusted-pool)
+
+(defun erc-nicks--create-adjusted-pool (adjustments colors)
+ "Return COLORS that fall within parameters indicated by ADJUSTMENTS.
+Apply adjustments before replacing COLORS with the nearest
+defined, and then cull those that still don't meet the grade.
+Expect to operate on user-provided lists of `erc-nicks-colors'
+rather than all those `defined' by the system."
+ (let* ((seen (make-hash-table :test #'equal))
+ (valmax (float (car (color-values "#ffffffffffff"))))
+ (erc-nicks-color-adjustments adjustments)
+ addp capp satp pool)
+ (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)
+ (pcase-let ((`(,quantized ,_ . ,vals)
+ (tty-color-approximate (color-values
+ (erc-nicks--reduce color)))))
+ (if (gethash quantized seen)
+ (when erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (let* ((rgb (mapcar (lambda (x) (/ x valmax)) vals))
+ (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 erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (push quantized pool)
+ (puthash quantized color seen))))))
+ (nreverse pool)))
+
+(defun erc-nicks--create-coerced-pool (adjustments colors)
+ "Return COLORS that fall within parameters indicated by ADJUSTMENTS.
+Rather than culling, apply adjustments and then dedupe after
+first replacing adjusted values with the nearest defined. Unlike
+`erc-nicks--create-adjusted-pool', don't recheck after adjusting.
+Rather, tolerate values that may fall slightly outside desired
+parameters, thus yielding a larger pool."
+ (let* ((seen (make-hash-table :test #'equal))
+ (erc-nicks-color-adjustments adjustments)
+ pool)
+ (dolist (color colors)
+ (let ((quantized (car (tty-color-approximate
+ (color-values (erc-nicks--reduce color))))))
+ (if (gethash quantized seen)
+ (when erc-nicks--colors-rejects
+ (push color erc-nicks--colors-rejects))
+ (push quantized pool)
+ (puthash quantized color seen))))
+ (nreverse pool)))
+
(defun erc-nicks--create-pool (adjustments colors)
"Return COLORS that fall within parameters indicated by ADJUSTMENTS."
(let (addp capp satp pool)
@@ -383,7 +441,8 @@ erc-nicks--init-pool
(unless (eq erc-nicks-colors 'all)
(let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors)
(defined-colors)))
- (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors)))
+ (pool (funcall erc-nicks--create-pool-function
+ erc-nicks-color-adjustments colors)))
(setq erc-nicks--colors-pool pool
erc-nicks--colors-len (length pool)))))
@@ -608,6 +667,8 @@ erc-nicks-refresh
(unless erc-nicks-mode (user-error "Module `nicks' disabled"))
(let ((erc-nicks--colors-rejects (and debug (list t))))
(erc-nicks--init-pool)
+ (unless erc-nicks--colors-pool
+ (user-error "Pool empty: all colors rejected"))
(dolist (nick (hash-table-keys erc-nicks--face-table))
;; User-tuned faces do not have an `erc-nicks--key' property.
(when-let ((face (gethash nick erc-nicks--face-table))
--
2.41.0
^ permalink raw reply related [flat|nested] 15+ messages in thread
* bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
[not found] ` <87r0l1frzc.fsf@neverwas.me>
@ 2023-11-13 20:06 ` J.P.
0 siblings, 0 replies; 15+ messages in thread
From: J.P. @ 2023-11-13 20:06 UTC (permalink / raw)
To: 63569; +Cc: emacs-erc
"J.P." <jp@neverwas.me> writes:
> A user on Libera requested some time ago that pool-creation facilities
> like the ones mentioned above be added to erc-nicks. The attached patch
> does this but in a simplified manner that avoids adding additional user
> options. Instead, it defaults to the "blind eye" approach mentioned
> above since (IMO) it's likeliest to meet user expectations.
>
> The patch also adds two ready-made Custom choice variants to the option
> `erc-nick-colors': `font-lock' and `ansi-color'. These are predefined
> sets of candidates for the (repeat string) :type variant. As may be
> obvious, ERC interprets these symbols as palettes to be populated from
> the :foreground colors of whatever font-lock- and ansi-color-related
> faces exist for the current theme.
>
> There's also a minor bug fix involving initialization ordering.
This has been installed as
5baa0f61f8d * Offer alternate pool-creation strategies in erc-nicks
^ permalink raw reply [flat|nested] 15+ messages in thread
end of thread, other threads:[~2023-11-13 20:06 UTC | newest]
Thread overview: 15+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
[not found] <87ilcp1za1.fsf@neverwas.me>
2023-05-23 13:37 ` bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC J.P.
2023-05-30 14:24 ` J.P.
2023-06-13 4:07 ` J.P.
[not found] ` <87r0qgknt1.fsf@neverwas.me>
2023-06-16 3:07 ` Richard Stallman
[not found] ` <E1q9zoC-0003PO-Jf@fencepost.gnu.org>
2023-06-16 5:12 ` J.P.
[not found] ` <87h6r8j8ie.fsf@neverwas.me>
2023-06-18 2:13 ` Richard Stallman
2023-06-22 13:47 ` J.P.
[not found] ` <871qi3boca.fsf@neverwas.me>
2023-06-23 13:38 ` J.P.
[not found] ` <87wmzu8fjg.fsf@neverwas.me>
2023-06-26 13:44 ` J.P.
2023-07-01 3:31 ` J.P.
2023-07-14 2:37 ` J.P.
2023-09-07 13:31 ` J.P.
[not found] ` <87zg1yjeib.fsf@neverwas.me>
2023-11-07 16:28 ` J.P.
[not found] ` <87r0l1frzc.fsf@neverwas.me>
2023-11-13 20:06 ` J.P.
2023-05-18 14:37 J.P.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).