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