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: Tue, 07 Nov 2023 08:28:07 -0800 Message-ID: <87r0l1frzc.fsf__3708.19733231968$1699374588$gmane$org@neverwas.me> References: <87ilcp1za1.fsf@neverwas.me> <87zg1yjeib.fsf@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="17685"; 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 Tue Nov 07 17:29:40 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 1r0OxQ-0004P1-2x for geb-bug-gnu-emacs@m.gmane-mx.org; Tue, 07 Nov 2023 17:29:40 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1r0OxD-0001Ya-BC; Tue, 07 Nov 2023 11:29:27 -0500 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 1r0OxB-0001YQ-3T for bug-gnu-emacs@gnu.org; Tue, 07 Nov 2023 11:29:25 -0500 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1r0OxA-0007nn-5x for bug-gnu-emacs@gnu.org; Tue, 07 Nov 2023 11:29:24 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1r0Oxl-0003lg-To for bug-gnu-emacs@gnu.org; Tue, 07 Nov 2023 11:30:01 -0500 X-Loop: help-debbugs@gnu.org Resent-From: "J.P." Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Tue, 07 Nov 2023 16:30:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 63569 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 63569-submit@debbugs.gnu.org id=B63569.169937456214408 (code B ref 63569); Tue, 07 Nov 2023 16:30:01 +0000 Original-Received: (at 63569) by debbugs.gnu.org; 7 Nov 2023 16:29:22 +0000 Original-Received: from localhost ([127.0.0.1]:43119 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1r0Ox6-0003kI-2v for submit@debbugs.gnu.org; Tue, 07 Nov 2023 11:29:21 -0500 Original-Received: from mail-108-mta246.mxroute.com ([136.175.108.246]:39539) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1r0Ox1-0003k7-Kk for 63569@debbugs.gnu.org; Tue, 07 Nov 2023 11:29:18 -0500 Original-Received: from filter006.mxroute.com ([136.175.111.2] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta246.mxroute.com (ZoneMTA) with ESMTPSA id 18baa9d3cfc000190b.001 for <63569@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Tue, 07 Nov 2023 16:28:33 +0000 X-Zone-Loop: ebc222531d4047c47c8c2bbd91e28f8440d7ae18f29a 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:References:In-Reply-To: Subject:Cc:To:From:Sender:Reply-To:Content-Transfer-Encoding:Content-ID: Content-Description:Resent-Date:Resent-From:Resent-Sender:Resent-To:Resent-Cc :Resent-Message-ID:List-Id:List-Help:List-Unsubscribe:List-Subscribe: List-Post:List-Owner:List-Archive; bh=d+gSvZC6ZfnWi9mxaG8ZuwVl7tfcd20RQOUTh+QFxM0=; b=djT0fHNjf0jaCBWyyPPidwQZeO zxVxjEe5d3m3PD/wHSUMnh5O6wU+dd2djdSkOHEhnmeW1Bq8Bp1wXfoDWVvMWBHdDR9WIaYkqirAD G1AK7I/jv43kJ1zzw3HhPPWtp5tttz7WbG+B1t2FNumXhj9OeTccFkg1dWrYLFRy+G91GlNQ1P2xu 1jol+BACR+Y+U8DZec+rOb0MihvvlK027krHY6h4duc5okErbnHrVCxdi9xHtBdFa38IMe3Qyrleo FuR8w3J6i7dgcXuEGiUOCZmt54wjw/88WLg0kLVnjsbAanok5rWEcPOwCi/KjPB5KbbGsBRuH3XfO CQQ6BK1A==; In-Reply-To: <87zg1yjeib.fsf@neverwas.me> (J. P.'s message of "Thu, 07 Sep 2023 06:31:56 -0700") X-Authenticated-Id: masked@neverwas.me 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:273936 Archived-At: --=-=-= Content-Type: text/plain "J.P." 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. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0000-v1-v2.diff >From 9aff22914d85d92ca2665c6fc5b3359217b5d766 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-5.6-Offer-alternate-pool-creation-strategies-in-erc-.patch >From 9aff22914d85d92ca2665c6fc5b3359217b5d766 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-POC-Offer-alternate-pool-creation-strategies-in-erc-.patch >From ef97b82a7d38e4a61a54cfb7be7444bc8293261b Mon Sep 17 00:00:00 2001 From: "F. Jason Park" 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 --=-=-=--