From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: "J.P." Newsgroups: gmane.emacs.bugs Subject: bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC Date: Thu, 18 May 2023 07:37:26 -0700 Message-ID: <87ilcp1za1.fsf__10272.1162418433$1684420707$gmane$org@neverwas.me> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="7805"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: emacs-erc@gnu.org To: 63569@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Thu May 18 16:38:19 2023 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1pzeln-0001li-3T for geb-bug-gnu-emacs@m.gmane-mx.org; Thu, 18 May 2023 16:38:19 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1pzelX-00008a-HB; Thu, 18 May 2023 10:38:03 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1pzelW-00008J-Mk; Thu, 18 May 2023 10:38:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1pzelW-0001fE-FU; Thu, 18 May 2023 10:38:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1pzelV-000448-Uw; Thu, 18 May 2023 10:38:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: "J.P." Original-Sender: "Debbugs-submit" Resent-CC: emacs-erc@gnu.org, bug-gnu-emacs@gnu.org Resent-Date: Thu, 18 May 2023 14:38:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 63569 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-gnu-emacs@gnu.org X-Debbugs-Original-Xcc: emacs-erc@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.168442066715604 (code B ref -1); Thu, 18 May 2023 14:38:01 +0000 Original-Received: (at submit) by debbugs.gnu.org; 18 May 2023 14:37:47 +0000 Original-Received: from localhost ([127.0.0.1]:54037 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1pzelF-00043Z-MM for submit@debbugs.gnu.org; Thu, 18 May 2023 10:37:47 -0400 Original-Received: from lists.gnu.org ([209.51.188.17]:56570) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1pzelA-00043M-Mb for submit@debbugs.gnu.org; Thu, 18 May 2023 10:37:44 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1pzelA-0008VT-Cd for bug-gnu-emacs@gnu.org; Thu, 18 May 2023 10:37:40 -0400 Original-Received: from mail-108-mta25.mxroute.com ([136.175.108.25]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1pzel6-0001eF-7D for bug-gnu-emacs@gnu.org; Thu, 18 May 2023 10:37:40 -0400 Original-Received: from mail-111-mta2.mxroute.com ([136.175.111.2] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta25.mxroute.com (ZoneMTA) with ESMTPSA id 1882f4b62de00074ee.001 for (version=TLSv1/SSLv3 cipher=ECDHE-RSA-AES128-GCM-SHA256); Thu, 18 May 2023 14:37:29 +0000 X-Zone-Loop: f37be68fe428b6730ea45493ded37d53e5e6bdd45098 X-Originating-IP: [136.175.111.2] DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=neverwas.me ; s=x; h=Content-Type:MIME-Version:Message-ID:Date:Subject:To:From:Sender: Reply-To:Cc:Content-Transfer-Encoding:Content-ID:Content-Description: Resent-Date:Resent-From:Resent-Sender:Resent-To:Resent-Cc:Resent-Message-ID: In-Reply-To:References:List-Id:List-Help:List-Unsubscribe:List-Subscribe: List-Post:List-Owner:List-Archive; bh=pRUUsiB7Y7BLf2oFGPY4grhRNxF0gxFD2tyoJce5IAQ=; b=U2qFapbF7I/MoiNTCHpyQiT0dF BIeDMZA+/fETLsUpP73yzvjBnRsgLBs00Nnge82ew7/tn2q0rdr+xlB4qaRarNvQ2Z9e3Qh0EHAjg CgK0YL9Xb+M/7rlTm3aViKNkNAvRjogqFD0hHyNXzqxcexvmRYlTpa8EFs/Ubu0l4ZofnSG6xsPr8 PzZKJKBSy2Fsi/QVgMUxBZrsIriTuRyzvViRRVLQo/tqW2NV6cx7xm20h+2ZmhT81J6fDBvO3qwcg WlSaTw7+TUVXDFANVfVKbdK1a7BUXs26d/j+VMs36M4Fhi02OSNn2stq09fj1vJ+Px8H5BK3VHqHK Hr2KYpPw==; X-Authenticated-Id: masked@neverwas.me Received-SPF: pass client-ip=136.175.108.25; envelope-from=jp@neverwas.me; helo=mail-108-mta25.mxroute.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, SPF_HELO_NONE=0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.bugs:261936 Archived-At: --=-=-= Content-Type: text/plain 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)) --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: attachment; filename=0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch Content-Transfer-Encoding: quoted-printable >From 40297aca7eff54cfc6fc668098749e88c9de9fd0 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" 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 =20 +@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. =20 +** 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))) =20 +(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))))))) =20 ;;; 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 . + +;;; Commentary: + +;; This module is heavily influenced by the lovely and more featureful +;; +;; `erc-hl-nicks' by David Leatherman +;; +;; +;; which itself is based on +;; +;; `erc-highlight-nicknames' by Andr=C3=A9 Riemann, Andy Stewart, and +;; others +;; + +;;; 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, + + \\=3D'(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 (<=3D 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-contra= st.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 (=3D 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-fac= es)) + +(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 you= r\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 f= ace)) + (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-networ= k))) + (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-obj= ect)) + '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-func= tion) + #'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 t= o \"" + 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" nic= ks) (const :tag "noncommands: Don't display non-IRC commands after evaluat= ion" 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-tes= ts.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 . + +;;; 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 "whit= e"))) + (should (equal "#893a893a893a" + (erc-nicks-tests--show-contrast "#893a893a893a"))) + (should (equal "#000000000000" (erc-nicks-tests--show-contrast "blac= k"))) + (should (equal "#ffff00000000" (erc-nicks-tests--show-contrast "red"= ))) + (should (equal "#0000a12e0000" (erc-nicks-tests--show-contrast "gree= n"))) + (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 (=3D (erc-nicks--hash "00000000") #xe4deaa6df385)) + (should (=3D (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 (=3D (erc-nicks--hash "0Libera.Chat") #x32fdc0d63a92)) + (should (=3D (erc-nicks--hash "1Libera.Chat") #xc2c4f1c997f3)) + (erc-nicks-tests--show-contrast "#32fdc0d63a92") + (erc-nicks-tests--show-contrast "#c2c4f1c997f3") + + (should (=3D (erc-nicks--hash "0 OFTC") #x6805b7521261)) + (should (=3D (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 netsp= lit - 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)) =20 --=20 2.40.0 --=-=-=--