>From e14973511bf0c845ceaac2121c95cc47c6b17ae5 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Wed, 13 Dec 2023 00:00:42 -0800 Subject: [PATCH 0/5] *** NOT A PATCH *** *** BLURB HERE *** F. Jason Park (5): [5.6] Include rather than combine erc-nicks-backing-face [5.6] Fix Custom :type of erc-track-faces-normal-list [5.7] Promote "normal" faces in erc-track [5.7] Cache shortened channel names in erc-track [5.7] Add erc-track integration to erc-nicks etc/ERC-NEWS | 39 +++++ lisp/erc/erc-button.el | 49 +++--- lisp/erc/erc-nicks.el | 95 ++++++++++- lisp/erc/erc-track.el | 270 +++++++++++++++++++++++++++---- lisp/erc/erc.el | 8 +- test/lisp/erc/erc-nicks-tests.el | 2 +- test/lisp/erc/erc-track-tests.el | 166 +++++++++++++++++++ 7 files changed, 570 insertions(+), 59 deletions(-) Interdiff: diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index 92dd03912e6..0b1e5e0c050 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -173,9 +173,19 @@ erc-nicks-key-suffix-format like \"@%-012n\"." :type 'string) -(defcustom erc-nicks-track-faces t - "Show nick faces in the `track' module's portion of the mode line." - :type 'boolean) +(defcustom erc-nicks-track-faces 'prioritize + "Show nick faces in the `track' module's portion of the mode line. +A value of nil means don't show nick faces at all. A value of +`defer' means have `track' consider nick faces only after those +ranked faces in `erc-track-faces-normal-list'. This has the +effect of \"alternating\" between a ranked \"normal\" and a nick. +The value `prioritize' means have `track' consider nick faces to +be \"normal\" unless the current speaker is the same as the +previous one, in which case pretend the value is `defer'. Like +most options in this module, updating the value mid-session is +not officially supported, although cycling \\[erc-nicks-mode] may +be worth a shot." + :type '(choice (const nil) (const defer) (const prioritize))) (defvar erc-nicks--max-skip-search 3 ; make this an option? "Max number of faces to visit when testing `erc-nicks-skip-faces'.") @@ -568,9 +578,8 @@ nicks erc-nicks--face-table (make-hash-table :test #'equal))) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil nil #'equal) #'erc-nicks-customize-face) - (unless erc-nicks-track-faces - (erc-nicks--setup-track-integration) - (add-hook 'erc-track-mode #'erc-nicks--setup-track-integration 50 t)) + (erc-nicks--setup-track-integration) + (add-hook 'erc-track-mode #'erc-nicks--setup-track-integration 50 t) (advice-add 'widget-create-child-and-convert :filter-args #'erc-nicks--redirect-face-widget-link)) ((kill-local-variable 'erc-nicks--face-table) @@ -586,6 +595,8 @@ nicks #'erc-nicks--reject-uninterned-faces) (remove-function (local 'erc-button--modify-nick-function) #'erc-nicks--highlight-button) + (remove-function (local 'erc-track--alt-normals-function) + #'erc-nicks--check-normals) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil 'remove #'equal) nil) @@ -713,12 +724,42 @@ erc-nicks--reject-uninterned-faces (setq candidate (cdr candidate))) (if (and (consp candidate) (not (cdr candidate))) (car candidate) candidate)) +(define-inline erc-nicks--oursp (face) + (inline-quote + (and-let* ((sym (car-safe ,face)) + ((symbolp sym)) + ((get sym 'erc-nicks--key))) + sym))) + +(defun erc-nicks--check-normals (current contender contenders normals) + "Return a viable `nicks'-owned face from NORMALS in CONTENDERS. +But only do so if the CURRENT face is also one of ours and in +NORMALS and if the highest ranked CONTENDER among new faces is +`erc-default-face', the lowest ranking default priority face." + (defvar erc-track--normal-faces) + (cl-assert erc-track--normal-faces) + (and-let* (((eq contender 'erc-default-face)) + ((gethash current normals)) + (spkr (erc-nicks--oursp current))) + (catch 'contender + (dolist (candidate (cdr contenders) contender) + (when-let (((not (equal candidate current))) + ((gethash candidate normals)) + (s (erc-nicks--oursp candidate)) + ((not (eq s spkr)))) + (throw 'contender candidate)))))) + (defun erc-nicks--setup-track-integration () "Restore traditional \"alternating normal\" face functionality to mode-line." - (cl-assert (not erc-nicks-track-faces)) (when (bound-and-true-p erc-track-mode) - (add-function :override (local 'erc-track--face-reject-function) - #'erc-nicks--reject-uninterned-faces))) + (pcase erc-nicks-track-faces + ;; Variant `defer' is handled elsewhere. + ('prioritize + (add-function :override (local 'erc-track--alt-normals-function) + #'erc-nicks--check-normals)) + ('nil + (add-function :override (local 'erc-track--face-reject-function) + #'erc-nicks--reject-uninterned-faces))))) (defun erc-nicks--remember-face-for-track (face) "Add FACE to local hash table maintained by `track' module." diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 4c3c7ca49a5..a6a1539b044 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -166,20 +166,25 @@ erc-track-use-faces ;; (erc-nick-default-face erc-pal-face). However, since at least ;; Emacs 27, `match' has done its damage after `button' in ;; `erc-insert-modify-hook', meaning such permutations cannot exist. -(defvar erc-track--old-nick-button-faces - '((erc-nick-default-face erc-default-face)) - "List of obsolete nick button faces.") - -(defun erc-track--massage-nick-button-faces (val) - "Update members of face list VAL to have the default nick button face. -In ERC 5.7, it changed from `erc-current-nick-face' to -`erc-button-nick-default-face'." - (mapcar (lambda (f) - (if (and (eq (car-safe f) 'erc-nick-default-face) - (member f erc-track--old-nick-button-faces)) - (cons 'erc-button-nick-default-face (cdr f)) - f)) - val)) +(defun erc-track--massage-nick-button-faces (sym val &optional set-fn) + "Transform VAL of face-list option SYM to have new defaults. +Use `set'-compatible SET-FN when given. If an update was +performed, stash a copy of the replaced VAL member in the symbol +property `erc-track--obsolete-faces' of SYM." + (let* ((changedp nil) + (new (mapcar + (lambda (f) + (if (and (eq (car-safe f) 'erc-nick-default-face) + (equal f '(erc-nick-default-face erc-default-face))) + (progn + (setq changedp t) + (put sym 'erc-track--obsolete-faces t) + (cons 'erc-button-nick-default-face (cdr f))) + f)) + val))) + (if set-fn + (funcall set-fn sym (if changedp new val)) + (set-default sym (if changedp new val))))) (defcustom erc-track-faces-priority-list '(erc-error-face @@ -205,8 +210,7 @@ erc-track-faces-priority-list Note that ERC prioritizes certain faces reserved for critical messages regardless of this option's value." :package-version '(ERC . "5.7") ; FIXME sync on release - :set (lambda (sym val) - (set-default sym (erc-track--massage-nick-button-faces val))) + :set #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) erc-button)) @@ -248,10 +252,10 @@ erc-track-faces-normal-list The effect may be disabled by setting this variable to nil." :package-version '(ERC . "5.7") ; FIXME sync on release - :set (lambda (sym val) - (set-default sym (erc-track--massage-nick-button-faces val))) - :type '(repeat (choice face - (repeat :tag "Combination" face)))) + :set #'erc-track--massage-nick-button-faces + :type (erc--with-dependent-type-match + (repeat (choice face (repeat :tag "Combination" face))) + erc-button)) (defvar erc-track-ignore-normal-contenders-p nil "Compatibility flag to promote only exclusively new \"normal\" faces. @@ -649,30 +653,29 @@ erc-track--setup (let ((existing (erc-with-server-buffer erc-track--normal-faces)) (localp (and erc--target (local-variable-p 'erc-track-faces-normal-list))) + (opts '(erc-track-faces-normal-list erc-track-faces-priority-list)) warnp table) + ;; Don't bother warning users who've disabled `button'. (unless (or erc--target (not (or (bound-and-true-p erc-button-mode) (memq 'button erc-modules)))) - (dolist (opt '(erc-track-faces-normal-list - erc-track-faces-priority-list)) - (when (seq-some - (lambda (f) - (and (eq (car-safe f) 'erc-nick-default-face) - (member f erc-track--old-nick-button-faces))) - (symbol-value opt)) + (when (or localp (local-variable-p 'erc-track-faces-priority-list)) + (dolist (opt opts) + (erc-track--massage-nick-button-faces opt (symbol-value opt) + #'set))) + (dolist (opt opts) + (when (get opt 'erc-track--obsolete-faces) (push opt warnp) - (set opt (erc-track--massage-nick-button-faces - (symbol-value opt))))) + (put opt 'erc-track--obsolete-faces nil))) (when warnp (erc--warn-once-before-connect 'erc-track-mode (if (cdr warnp) "Options " "Option ") (mapconcat (lambda (o) (format "`%S'" o)) warnp " and ") (if (cdr warnp) " contain" " contains") - " obsolete list-style faces intended to match buttonized" - " nicknames. To silence this warning, please update members" - " with `%S' at their head, like %S, by converting them to %S." - " ERC has done this for you for this session." - 'erc-nick-default-face '(erc-nick-default-face foo) - '(erc-button-nick-default-face foo)))) + " an obsolete item, %S, intended to match buttonized nicknames." + " ERC has changed it to %S for the current session." + " Please save the current value to silence this message." + '(erc-nick-default-face erc-default-face) + '(erc-button-nick-default-face erc-default-face)))) (when (or (null existing) localp) (setq table (map-into (mapcar (lambda (f) (cons f f)) erc-track-faces-normal-list) @@ -913,12 +916,12 @@ erc-track-select-mode-line-face choice)) choice)))) -(define-inline erc-track--gett (table-or-function key) - "Look up KEY via TABLE-OR-FUNCTION." - (inline-quote - (if (functionp ,table-or-function) - (funcall ,table-or-function ,key) - (gethash ,key ,table-or-function)))) +(defvar erc-track--alt-normals-function nil + "A function to possibly elect a \"normal\" face. +Called with the current incumbent and the worthiest new contender +followed by all new contending faces and so-called \"normal\" +faces. See `erc-track--select-mode-line-face' for their meanings +and expected types. This function should return a face or nil.") (defun erc-track--select-mode-line-face (cur-face new-faces ranks normals) "Return CUR-FACE or a replacement for displaying in the mode-line, or nil. @@ -929,12 +932,12 @@ erc-track--select-mode-line-face If NEW-FACES has a cdr, expect it to be its car's contents ordered from most recently seen (later in the buffer) to earliest. In general, act like `erc-track-select-mode-line-face' -except reconsider NEW-FACES when CUR-FACE outranks all its -members. That is, choose the highest RANKS among NEW-FACES not -equal to CUR-FACE. Failing that, choose the first face in -NORMALS to appear anywhere in NEW-FACES, but only if NEW-FACES -has a cdr. If NORMALS is a function, call it with the name of a -face to query membership." +except appeal to `erc-track--alt-normals-function' if it's +non-nil, falling back on reconsidering NEW-FACES when CUR-FACE +outranks all its members. That is, choose the first among RANKS +in NEW-FACES not equal to CUR-FACE. Failing that, choose the +first face in NEW-FACES that's also in NORMALS, assuming +NEW-FACES has a cdr." (cl-check-type erc-track-ignore-normal-contenders-p null) (cl-check-type new-faces cons) (when-let ((choice (catch 'face @@ -942,21 +945,23 @@ erc-track--select-mode-line-face (when (or (equal candidate cur-face) (gethash candidate (car new-faces))) (throw 'face candidate)))))) - (when-let (((equal choice cur-face)) - ((erc-track--gett normals choice)) - (contender (catch 'face - (progn - (dolist (candidate ranks) - (when (and (not (equal candidate choice)) - (gethash candidate (car new-faces)) - (erc-track--gett normals candidate)) - (throw 'face candidate))) - (dolist (f (cdr new-faces)) - (when (and (not (equal f choice)) - (erc-track--gett normals f)) - (throw 'face f))))))) - (setq choice contender)) - choice)) + (or (and erc-track--alt-normals-function + (funcall erc-track--alt-normals-function + cur-face choice new-faces normals)) + (and (equal choice cur-face) + (gethash choice normals) + (catch 'face + (progn + (dolist (candidate ranks) + (when (and (not (equal candidate choice)) + (gethash candidate (car new-faces)) + (gethash choice normals)) + (throw 'face candidate))) + (dolist (candidate (cdr new-faces)) + (when (and (not (equal candidate choice)) + (gethash candidate normals)) + (throw 'face candidate)))))) + choice))) (defvar erc-track--skipped-msgs '(datestamp) "Values of `erc-msg' text prop to ignore.") -- 2.42.0