all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
* 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

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 external index

	https://git.savannah.gnu.org/cgit/emacs.git
	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.