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#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module Date: Wed, 13 Dec 2023 06:06:05 -0800 Message-ID: <8734w6yz76.fsf__21128.0150966317$1702476446$gmane$org@neverwas.me> References: <87edfs3gj4.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="24556"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: emacs-erc@gnu.org To: 67767@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Wed Dec 13 15:07: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 1rDPtM-00067j-MW for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 13 Dec 2023 15:07:17 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rDPsz-0001v3-EZ; Wed, 13 Dec 2023 09:06:57 -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 1rDPst-0001tr-DR for bug-gnu-emacs@gnu.org; Wed, 13 Dec 2023 09:06:47 -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 1rDPss-0002qN-7k for bug-gnu-emacs@gnu.org; Wed, 13 Dec 2023 09:06:46 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rDPt7-0007Ed-Vn for bug-gnu-emacs@gnu.org; Wed, 13 Dec 2023 09:07:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: "J.P." Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Wed, 13 Dec 2023 14:07:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 67767 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 67767-submit@debbugs.gnu.org id=B67767.170247639827767 (code B ref 67767); Wed, 13 Dec 2023 14:07:01 +0000 Original-Received: (at 67767) by debbugs.gnu.org; 13 Dec 2023 14:06:38 +0000 Original-Received: from localhost ([127.0.0.1]:58451 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rDPsh-0007Dk-H8 for submit@debbugs.gnu.org; Wed, 13 Dec 2023 09:06:38 -0500 Original-Received: from mail-108-mta249.mxroute.com ([136.175.108.249]:39019) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rDPsc-0007DP-7F for 67767@debbugs.gnu.org; Wed, 13 Dec 2023 09:06:33 -0500 Original-Received: from filter006.mxroute.com ([136.175.111.2] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta249.mxroute.com (ZoneMTA) with ESMTPSA id 18c637fcdac00065b4.001 for <67767@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Wed, 13 Dec 2023 14:06:09 +0000 X-Zone-Loop: c45cfc2baed6ca72458ab9fecb8050d4bd5b60f04b96 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=EouPusQUIPVVrI9GRlfviArUOFagx58/jAzDbXN2cWU=; b=KhQYao2VL2suvDbN/eSRMRkSIb g8/QFDod/kSvoeEs9wwtMpjWAAVsiFZ00v31/x6RLzU8u79l25z/UVlr8ZX95sIZs8GmE4Omm6VPm TmWH4cKkqnU/WWp7njvo5U+cFnzG1Zlp6fYoN9O+2Z0R8HxZmVeosjY7GWb2UoOzL70inKj3We/2+ dpEMfbNjrKWgbcuCMcHSQ1jIaQ4/rIRz2dd2AhVvPAtgjbaRr3j7WphyFa5FD07V9LDv62WH8WGxX LDRZsx3oUJGCgTcqt5MQPfKSk/YUiM82MCyW649Zz/5bz+df1GLA+6mK7iFClOVJjNwq+OzJwrKaM jqdibzUA==; In-Reply-To: <87edfs3gj4.fsf@neverwas.me> (J. P.'s message of "Mon, 11 Dec 2023 07:28:15 -0800") 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:276132 Archived-At: --=-=-= Content-Type: text/plain v3. Make default behavior of `erc-nicks-track-faces' more intuitive. Fix issue with detection of obsolete button face in `track' options. Make `erc-track--select-mode-line-face' more convenient to modify. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0000-v2-v3.diff >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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-5.6-Include-rather-than-combine-erc-nicks-backing-fa.patch >From 8f3926d0dd13a430bf4d8492e0e418e9677c8091 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 11 Dec 2023 20:24:17 -0800 Subject: [PATCH 1/5] [5.6] Include rather than combine erc-nicks-backing-face * lisp/erc/erc-nicks.el (erc-nicks--get-face): Make generated face :inherit from `erc-nicks-backing-face'. (erc-nicks--highlight): Just return the generated face instead of combining it with `erc-nicks-backing-face' or the existing face in the buffer. * test/lisp/erc/erc-nicks-tests.el (erc-nicks-list-faces): Skip "Inherit: " button. --- lisp/erc/erc-nicks.el | 12 +++++------- test/lisp/erc/erc-nicks-tests.el | 2 +- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index fcd3afdbbc4..2f0c3261266 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -454,7 +454,9 @@ erc-nicks--get-face (put new-face 'erc-nicks--nick nick) (put new-face 'erc-nicks--netid erc-networks--id) (put new-face 'erc-nicks--key key) - (face-spec-set new-face `((t :foreground ,color)) 'face-defface-spec) + (face-spec-set new-face `((t :foreground ,color + :inherit ,erc-nicks-backing-face)) + 'face-defface-spec) (set-face-documentation new-face (format "Internal face for %s on %s." nick (erc-network))) (puthash nick new-face table))))) @@ -503,12 +505,8 @@ erc-nicks--highlight ((not (and base-face (erc-nicks--skip-p base-face erc-nicks-skip-faces erc-nicks--max-skip-search)))) - (key (erc-nicks--gen-key-from-format-spec trimmed)) - (out (erc-nicks--get-face trimmed key))) - (if (or (null erc-nicks-backing-face) - (eq base-face erc-nicks-backing-face)) - out - (cons out (erc-list erc-nicks-backing-face))))) + (key (erc-nicks--gen-key-from-format-spec trimmed))) + (erc-nicks--get-face trimmed key))) (defun erc-nicks--highlight-button (nick-object) "Possibly add face to `erc-button--nick-user' NICK-OBJECT." diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index 35264a23caa..54882278139 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -409,7 +409,7 @@ erc-nicks-list-faces (push-button) (should (search-forward-regexp (rx "Foreground: #" (group (+ xdigit)) eol))) - (forward-button 1) + (forward-button 2) ; skip Inherit:... (push-button)) (ert-info ("First entry's sample is rendered correctly") -- 2.42.0 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0002-5.6-Fix-Custom-type-of-erc-track-faces-normal-list.patch >From be105b8d876c4e0bace6049726302bde1cae7cdd Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Tue, 12 Dec 2023 19:04:12 -0800 Subject: [PATCH 2/5] [5.6] Fix Custom :type of erc-track-faces-normal-list * lisp/erc/erc-track.el (erc-modified-channels-object): Load `erc-button' during validation so that Customize chooses the correct UI instead of a generic field with "(mismatch)" printed alongside the "STATE" button. --- lisp/erc/erc-track.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index a36b781e04d..db10063cafe 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -225,8 +225,9 @@ erc-track-faces-normal-list are occurring in these channels. The effect may be disabled by setting this variable to nil." - :type '(repeat (choice face - (repeat :tag "Combination" face)))) + :type (erc--with-dependent-type-match + (repeat (choice face (repeat :tag "Combination" face))) + erc-button)) (defcustom erc-track-position-in-mode-line 'before-modes "Where to show modified channel information in the mode-line. -- 2.42.0 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0003-5.7-Promote-normal-faces-in-erc-track.patch >From 60e297cf14c873bd55a73e80bb77c71a78f6a5e3 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sun, 10 Dec 2023 05:33:48 -0800 Subject: [PATCH 3/5] [5.7] Promote "normal" faces in erc-track * etc/ERC-NEWS: Add entry for new behavior involving the option `erc-track-faces-normal-list'. * lisp/erc/erc-button.el (erc-button-nick-default-face): New face to serve as default for `erc-button-nickname-face'. (erc-button-nickname-face): Change default value to `erc-button-nick-default-face'. * lisp/erc/erc-track.el (erc-track--massage-nick-button-faces): New function to serve as Custom :set function for priority and "normal" face-list options. (erc-track-faces-priority-list, erc-track-faces-normal-list): Change values for `match' module faces to feature `erc-button-nick-default-face' instead of `erc-nick-default-face'. Use :set function to massage saved user values. (erc-track-ignore-normal-contenders-p): New compatibility switch to access pre-5.6 behavior, in which faces in `erc-track-faces-normal-list' were only considered for promotion to the mode line if the current face occupying that pole position wasn't present. (erc-track-mode, erc-track-enable, erc-track-disable): Add FIXME comments regarding perceived futility of `erc-server-001-functions and likely unneeded hook removal. Run common buffer-local setup and teardown. (erc-track--normal-faces): New local variable, a snapshot of `erc-track-faces-normal-list'. (erc-track--setup): New function to stash `erc-track-faces-normal-list' on init. (erc-track-select-mode-line-face): Offer alternate explanation of certain particulars in doc string. (erc-track--alt-normals-function): New function-valued variable to allow other modules to intervene in deciding whether to pursue and promote a "normal" contending face. (erc-track--select-mode-line-face): New function similar to its public namesake except that it considers other viable candidates among the "normal" alternatives. (erc-track-modified-channels): Only run face selection portion when faces are actually found. Use `erc-track--select-mode-line-face' instead of `erc-track-select-mode-line-face'. * test/lisp/erc/erc-track-tests.el (erc-track-select-mode-line-face): New test. (erc-track-tests--select-mode-line-face): New function. (erc-track--select-mode-line-face): New test. (Bug#67767) --- etc/ERC-NEWS | 39 ++++++ lisp/erc/erc-button.el | 8 +- lisp/erc/erc-track.el | 223 ++++++++++++++++++++++++++++--- test/lisp/erc/erc-track-tests.el | 130 ++++++++++++++++++ 4 files changed, 377 insertions(+), 23 deletions(-) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 4642c742b0f..40e3d5d5638 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -170,6 +170,19 @@ options, like 'erc-command-indicator', have moved to the 'erc-goodies' library, although their Custom groups remain the same. Add 'command-indicator' to 'erc-modules' to get started. +** Option 'erc-track-faces-normal-list' slightly more influential. +This option has always been a source of confusion for users, mainly +because its influence rode heavily on the makeup of faces in a given +message. Historically, when a buffer's current mode-line face was a +member of this option's value, ERC would only swap it out for a fellow +"normal" if it was absent from message being processed. Beginning +with this release, ERC now looks to other ranked and (if necessary) +unranked "normals" instead of sustaining the same face between +messages. This was done to better honor the stated purpose of the +option, which is to provide consistent visual feedback when buffer +activity occurs. If you experience problems with this development, +see the compatibility flag 'erc-track-ignore-normal-contenders-p'. + ** 'erc-button-alist' and 'erc-nick-popup-alist' have evolved slightly. It's no secret that the 'buttons' module treats potential nicknames specially. This is perhaps most evident in its treatment of the @@ -184,6 +197,23 @@ s-expressions, which ERC will continue to honor. Although the default lineup remains functionally equivalent, its members have all been updated accordingly. +** 'erc-track-faces-priority-list' and 'erc-track-faces-normal-list' slimmed. +These options have been purged of certain 'button'-related face +combinations. Originally added in ERC 5.3, these combinations +described the effect of "buttonizing" atop faces added by the 'match' +module, like '(erc-nick-default-face erc-pal-face)'. However, since +at least Emacs 27, 'match' has run before 'button' in +'erc-insert-modify-hook', meaning such permutations aren't possible. + +More importantly, users who've customized either of these options +should update them with the new default value of the option +'erc-button-nickname-face'. Like 'erc-nick-default-face', which it +replaces, the new 'erc-button-nick-default-face' is also a "real" +face. Its sole reason for existing is to make it easier for users and +modules to distinguish between basic buttonized faces and +'erc-nick-default-face', which is now reserved to mean the base +"speaker" face. + ** Option 'erc-query-on-unjoined-chan-privmsg' restored and renamed. This option was accidentally removed from the default client in ERC 5.5 and was thus prevented from influencing PRIVMSG routing. It's now @@ -306,6 +336,15 @@ from 't' to the more useful 'erc-prompt', although the property of the same name has been retained and now has a value of 'hidden' when disconnected. +*** Lists of faces in buttonized text are no longer nested. +Previously, when "buttonizing" a new region, ERC would combine faces +by blindly consing the new onto the existing. In theory, this kept a +nice record of all modifications to a given region. However, it also +complicated life for other modules wanting to analyze and operate on +these regions. Beginning with this release, ERC now merges combined +faces together when creating buttons, although the odd nested list may +still crop up here and there. + *** Members of insert- and send-related hooks have been reordered. As anyone reading this is no doubt aware, both built-in and third-party modules rely on certain hooks for adjusting incoming and diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index e1c10be53f6..f10d7a2fce7 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -70,6 +70,11 @@ erc-button "ERC button face." :group 'erc-faces) +(defface erc-button-nick-default-face '((t :inherit erc-nick-default-face)) + "Default face for a buttonized nickname." + :package-version '(ERC . "5.7") ; FIXME sync on release + :group 'erc-faces) + (defcustom erc-button-face 'erc-button "Face used for highlighting buttons in ERC buffers. @@ -78,8 +83,9 @@ erc-button-face :type 'face :group 'erc-faces) -(defcustom erc-button-nickname-face 'erc-nick-default-face +(defcustom erc-button-nickname-face 'erc-button-nick-default-face "Face used for ERC nickname buttons." + :package-version '(ERC . "5.7") ; FIXME sync on release :type 'face :group 'erc-faces) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index db10063cafe..490fc52d42c 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -161,23 +161,44 @@ erc-track-use-faces \(e.g. `erc-pal-face' is used if a pal sent a message to that channel.)" :type 'boolean) +;; Historically, `erc-track-faces-priority-list' had members +;; describing the effect of buttonizing atop faces from `match', e.g., +;; (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. +(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 - (erc-nick-default-face erc-current-nick-face) erc-current-nick-face erc-keyword-face - (erc-nick-default-face erc-pal-face) erc-pal-face erc-nick-msg-face erc-direct-msg-face (erc-button erc-default-face) - (erc-nick-default-face erc-dangerous-host-face) erc-dangerous-host-face erc-nick-default-face - (erc-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-default-face) erc-default-face erc-action-face - (erc-nick-default-face erc-fool-face) erc-fool-face erc-notice-face erc-input-face @@ -188,6 +209,8 @@ 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 #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) erc-button)) @@ -209,10 +232,9 @@ erc-track-priority-faces-only (defcustom erc-track-faces-normal-list '((erc-button erc-default-face) - (erc-nick-default-face erc-dangerous-host-face) erc-dangerous-host-face erc-nick-default-face - (erc-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-default-face) erc-default-face erc-action-face) "A list of faces considered to be part of normal conversations. @@ -224,11 +246,26 @@ erc-track-faces-normal-list message. This gives a rough indication that active conversations are occurring in these channels. +Note that ERC makes a copy of this option when initializing the +module. To see your changes reflected mid-session, cycle +\\[erc-track-mode]. + The effect may be disabled by setting this variable to nil." + :package-version '(ERC . "5.7") ; FIXME sync on release + :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. +When non-nil, revert to pre-5.6 behavior in which a current +mode-line face that both outranks and is absent from the current +message is eligible for replacement with a fellow face from +`erc-track-faces-normal-list' that does appear in the message. +By extension, when enabled, never replace the current, reigning +mode-line face if it's present in the current message.") + (defcustom erc-track-position-in-mode-line 'before-modes "Where to show modified channel information in the mode-line. @@ -519,6 +556,9 @@ track (progn (add-hook 'window-configuration-change-hook #'erc-user-is-active) (add-hook 'erc-send-completed-hook #'erc-user-is-active) + ;; FIXME find out why this uses `erc-server-001-functions'. + ;; `erc-user-is-active' runs when `erc-server-connected' is + ;; non-nil. But this hook usually only runs when it's nil. (add-hook 'erc-server-001-functions #'erc-user-is-active)) (erc-track-add-to-mode-line erc-track-position-in-mode-line) (erc-update-mode-line) @@ -529,6 +569,8 @@ track ;; enable the tracking keybindings (add-hook 'erc-connect-pre-hook #'erc-track-minor-mode-maybe) (erc-track-minor-mode-maybe)) + (add-hook 'erc-mode-hook #'erc-track--setup) + (unless erc--updating-modules-p (erc-buffer-do #'erc-track--setup)) (add-hook 'erc-networks--copy-server-buffer-functions #'erc-track--replace-killed-buffer)) ;; Disable: @@ -540,6 +582,7 @@ track #'erc-user-is-active) (remove-hook 'erc-send-completed-hook #'erc-user-is-active) (remove-hook 'erc-server-001-functions #'erc-user-is-active) + ;; FIXME remove this if unused. (remove-hook 'erc-timer-hook #'erc-user-is-active)) (remove-hook 'window-configuration-change-hook #'erc-window-configuration-change) @@ -549,9 +592,12 @@ track (remove-hook 'erc-connect-pre-hook #'erc-track-minor-mode-maybe) (when erc-track-minor-mode (erc-track-minor-mode -1))) + (remove-hook 'erc-mode-hook #'erc-track--setup) + (erc-buffer-do #'erc-track--setup) (remove-hook 'erc-networks--copy-server-buffer-functions #'erc-track--replace-killed-buffer))) +;; FIXME move this above the module definition. (defcustom erc-track-when-inactive nil "Enable channel tracking even for visible buffers, if you are inactive." :type 'boolean @@ -563,6 +609,51 @@ erc-track-when-inactive (erc-track-enable)) (set sym val)))) +(defvar-local erc-track--normal-faces nil + "Local copy of `erc-track-faces-normal-list' as a hash table.") + +(defun erc-track--setup () + "Initialize a buffer for use with the `track' module. +If this is a server buffer or `erc-track-faces-normal-list' is +locally bound, create a new `erc-track--normal-faces' for the +current buffer. Otherwise, set the local value to the server +buffer's." + (if erc-track-mode + (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)))) + (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) + (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") + " 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) + '(hash-table :test equal :weakness value)))) + (setq erc-track--normal-faces (or table existing)) + (unless (or localp existing) + (erc-with-server-buffer (setq erc-track--normal-faces table)))) + (kill-local-variable 'erc-track--normal-faces))) + ;;; Visibility (defvar erc-buffer-activity nil @@ -767,7 +858,12 @@ erc-track-select-mode-line-face face, if a member of `erc-track-faces-normal-list', to be replaced with another with lower priority face from NEW-FACES, if that face with highest priority in NEW-FACES is also a member of -`erc-track-faces-normal-list'." +`erc-track-faces-normal-list'. + +To put it another way, when CUR-FACE outranks all NEW-FACES and +doesn't appear among them, it's eligible to be replaced with a +fellow \"normal\" from NEW-FACES. But if it does appear among +them, it can't be replaced." (let ((choice (catch 'face (dolist (candidate erc-track-faces-priority-list) (when (or (equal candidate cur-face) @@ -786,6 +882,53 @@ erc-track-select-mode-line-face choice)) choice)))) +(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. +Expect RANKS to be a list of faces and both NORMALS and the car +of NEW-FACES to be hash tables mapping faces to non-nil values. +Assume the latter's makeup and that of RANKS to resemble +`erc-track-face-normal-list' and `erc-track-faces-priority-list'. +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 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 + (dolist (candidate ranks) + (when (or (equal candidate cur-face) + (gethash candidate (car new-faces))) + (throw 'face candidate)))))) + (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.") @@ -820,31 +963,43 @@ erc-track-modified-channels ;; (in the car), change its face attribute (in the cddr) if ;; necessary. See `erc-modified-channels-alist' for the ;; exact data structure used. - (let ((faces (erc-faces-in (buffer-string))) - (erc-track-faces-priority-list - `(,@erc-track--attn-faces ,@erc-track-faces-priority-list))) - (unless (and - (or (eq erc-track-priority-faces-only 'all) - (member this-channel erc-track-priority-faces-only)) - (not (catch 'found - (dolist (f faces) - (when (member f erc-track-faces-priority-list) - (throw 'found t)))))) + (when-let + ((faces (if erc-track-ignore-normal-contenders-p + (erc-faces-in (buffer-string)) + (erc-track--get-faces-in-current-message))) + (normals erc-track--normal-faces) + (erc-track-faces-priority-list + `(,@erc-track--attn-faces ,@erc-track-faces-priority-list)) + (ranks erc-track-faces-priority-list) + ((not (and + (or (eq erc-track-priority-faces-only 'all) + (member this-channel erc-track-priority-faces-only)) + (not (catch 'found + (dolist (f ranks) + (when (gethash f (or (car-safe faces) faces)) + (throw 'found t))))))))) + (progn ; FIXME remove `progn' on next major edit (if (not (assq (current-buffer) erc-modified-channels-alist)) ;; Add buffer, faces and counts (setq erc-modified-channels-alist (cons (cons (current-buffer) (cons - 1 (erc-track-select-mode-line-face - nil faces))) + 1 (if erc-track-ignore-normal-contenders-p + (erc-track-select-mode-line-face + nil faces) + (erc-track--select-mode-line-face + nil faces ranks normals)))) erc-modified-channels-alist)) ;; Else modify the face for the buffer, if necessary. (when faces (let* ((cell (assq (current-buffer) erc-modified-channels-alist)) (old-face (cddr cell)) - (new-face (erc-track-select-mode-line-face - old-face faces))) + (new-face (if erc-track-ignore-normal-contenders-p + (erc-track-select-mode-line-face + old-face faces) + (erc-track--select-mode-line-face + old-face faces ranks normals)))) (setcdr cell (cons (1+ (cadr cell)) new-face))))) ;; And display it (erc-modified-channels-display))) @@ -873,6 +1028,30 @@ erc-faces-in (push cur faces))) faces)) +(defvar erc-track--face-reject-function nil + "Function called with face in current buffer to massage or reject.") + +(defun erc-track--get-faces-in-current-message () + "Collect all faces in the narrowed buffer. +Return a cons of a hash table and a list ordered from most +recently seen to earliest seen." + (let ((i (text-property-not-all (point-min) (point-max) 'font-lock-face nil)) + (seen (make-hash-table :test #'equal)) + ;; + (rfaces ()) + (faces (make-hash-table :test #'equal))) + (while-let ((i) + (cur (get-text-property i 'face))) + (unless (gethash cur seen) + (puthash cur t seen) + (when erc-track--face-reject-function + (setq cur (funcall erc-track--face-reject-function cur))) + (when cur + (push cur rfaces) + (puthash cur t faces))) + (setq i (next-single-property-change i 'font-lock-face))) + (cons faces rfaces))) + ;;; Buffer switching (defvar erc-track-last-non-erc-buffer nil diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index ab8d708b721..4477727be8a 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -120,4 +120,134 @@ erc-track--erc-faces-in (should (erc-faces-in str0)) (should (erc-faces-in str1)) )) +;; This simulates an alternating bold/non-bold [#c] in the mode-line, +;; i.e., an `erc-modified-channels-alist' that vacillates between +;; +;; ((# 42 . erc-default-face)) +;; +;; and +;; +;; ((# 42 erc-nick-default-face erc-default-face)) +;; +;; This is a fairly typical scenario where consecutive messages +;; feature speaker and addressee button highlighting and otherwise +;; plain message bodies. This mapping of phony to real faces +;; describes the picture in 5.6: +;; +;; `1': (erc-button erc-default-face) ; URL +;; `2': (erc-nick-default-face erc-default-face) ; mention +;; `3': erc-default-face ; body +;; `_': (erc-nick-default-face erc-nick-default-face) ; speaker +;; +;; The `_' represents a commonly occurring face (a ) that's +;; not present in either option's default (standard) value. It's a +;; no-op from the POV of `erc-track-select-mode-line-face'. + +(ert-deftest erc-track-select-mode-line-face () + + ;; Observed (see key above). + (let ((erc-track-faces-priority-list '(1 2 3)) + (erc-track-faces-normal-list '(1 2 3))) + + (should (equal 2 (erc-track-select-mode-line-face 3 '(2 _ 3)))) + (should (equal 2 (erc-track-select-mode-line-face 2 '(2 _ 3)))) + (should (equal 3 (erc-track-select-mode-line-face 2 '(_ 3)))) + (should (equal 2 (erc-track-select-mode-line-face 3 '(2 3)))) + (should (equal 3 (erc-track-select-mode-line-face 2 '(3)))) + + (should (equal 1 (erc-track-select-mode-line-face 1 '(2 1 3)))) + (should (equal 1 (erc-track-select-mode-line-face 1 '(1 3)))) + (should (equal 1 (erc-track-select-mode-line-face 1 '(1 3 2)))) + (should (equal 1 (erc-track-select-mode-line-face 1 '(3 1))))) + + ;; When the current face outranks all new faces and doesn't appear + ;; among them, it's eligible to be replaced with a fellow "normal" + ;; from those new faces. But if it does appear among them, it's + ;; never replaced. + (let ((erc-track-faces-priority-list '(a b)) + (erc-track-faces-normal-list '(a b))) + + (should (equal 'a (erc-track-select-mode-line-face 'a '(b a)))) + (should (equal 'a (erc-track-select-mode-line-face 'a '(a b)))) + (should (equal 'a (erc-track-select-mode-line-face 'b '(b a)))) + (should (equal 'a (erc-track-select-mode-line-face 'b '(a b)))) + + (should (equal 'a (erc-track-select-mode-line-face 'b '(a)))) + (should (equal 'b (erc-track-select-mode-line-face 'a '(b))))) + + ;; The ordering of the "normal" list doesn't matter. + (let ((erc-track-faces-priority-list '(a b)) + (erc-track-faces-normal-list '(b a))) + + (should (equal 'a (erc-track-select-mode-line-face 'a '(b a)))) + (should (equal 'a (erc-track-select-mode-line-face 'a '(a b)))) + (should (equal 'a (erc-track-select-mode-line-face 'b '(b a)))) + (should (equal 'a (erc-track-select-mode-line-face 'b '(a b)))))) + +(defun erc-track-tests--select-mode-line-face (ranked normals cases) + (setq normals (map-into (mapcar (lambda (f) (cons f t)) normals) + '(hash-table :test equal))) + (pcase-dolist (`(,want ,cur-face ,new-faces) cases) + + (ert-info ((format "Observed: {cur: %S, new: %S, want: %S}" + cur-face new-faces want)) + (setq new-faces (cons (map-into + (mapcar (lambda (f) (cons f t)) new-faces) + '(hash-table :test equal)) + (reverse new-faces))) + (should (equal want (funcall #'erc-track--select-mode-line-face + cur-face new-faces ranked normals)))))) + +;; The main difference between these variants is that with the above, +;; when given alternating lines like +;; +;; CUR NEW CHOICE +;; text (mention $speaker text) => mention +;; mention ($speaker text) => text +;; +;; we see the effect of alternating faces in the indicator. But when +;; given consecutive lines with a similar composition, like +;; +;; text (mention $speaker text) => mention +;; text (mention $speaker text) => mention +;; +;; we lose the effect. With the variant below, we get +;; +;; text (mention $speaker text) => mention +;; text (mention $speaker text) => text +;; + +(ert-deftest erc-track--select-mode-line-face () + (should-not erc-track-ignore-normal-contenders-p) + + ;; These are the same test cases from the previous test. The syntax + ;; is (expected cur-face new-faces). + (erc-track-tests--select-mode-line-face + '(1 2 3) '(1 2 3) + '((2 3 (2 _ 3)) + (3 2 (2 _ 3)) + (3 2 (_ 3)) + (2 3 (2 3)) + (3 2 (3)) + (2 1 (2 1 3)) + (3 1 (1 3)) + (2 1 (1 3 2)) + (3 1 (3 1)))) + + (erc-track-tests--select-mode-line-face + '(a b) '(a b) + '((b a (b a)) + (b a (a b)) + (a b (b a)) + (a b (a b)) + (a b (a)) + (b a (b)))) + + (erc-track-tests--select-mode-line-face + '(a b) '(b a) + '((b a (b a)) + (b a (a b)) + (a b (b a)) + (a b (a b))))) + ;;; erc-track-tests.el ends here -- 2.42.0 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0004-5.7-Cache-shortened-channel-names-in-erc-track.patch >From 105d66146f71f7d1060d845255d81c4fb9b9919d Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 13 Jun 2022 00:26:22 -0700 Subject: [PATCH 4/5] [5.7] Cache shortened channel names in erc-track * lisp/erc/erc-track.el (erc-track--shortened-names): New variable to stash both the latest inputs and most recent result of `erc-track-shorten-function'. (erc-track--shortened-names-current-hash, erc-track--shortened-names-set, erc-track--shortened-names-get): New pair of generalized-variable functions and helper variable for accessing and mutating `erc-track--shorten-prefixes'. (erc-modified-channels-display): Avoid redundant calls to `erc-track-shorten-function'. Mainly for use during batch processing. * test/lisp/erc/erc-track-tests.el (erc-track--shortened-names): New test. (Bug#67767) --- lisp/erc/erc-track.el | 42 +++++++++++++++++++++++++++++--- test/lisp/erc/erc-track-tests.el | 36 +++++++++++++++++++++++++++ 2 files changed, 74 insertions(+), 4 deletions(-) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 490fc52d42c..a6a1539b044 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -382,6 +382,37 @@ erc-track-add-to-mode-line ;;; Shortening of names +(defvar erc-track--shortened-names nil + "A cons of the last novel name-shortening params and the result. +The CAR is a hash of environmental inputs such as options and +parameters passed to `erc-track-shorten-function'. Its effect is +only really noticeable during batch processing.") + +(defvar erc-track--shortened-names-current-hash nil) + +(defun erc-track--shortened-names-set (_ shortened) + "Remember SHORTENED names with hash of contextual params." + (cl-assert erc-track--shortened-names-current-hash) + (setq erc-track--shortened-names + (cons erc-track--shortened-names-current-hash shortened))) + +(defun erc-track--shortened-names-get (channel-names) + "Cache CHANNEL-NAMES with various contextual parameters. +For now, omit relevant options like `erc-track-shorten-start' and +friends, even though they do affect the outcome, because they +likely change too infrequently to matter over sub-second +intervals and are unlikely to be let-bound or set locally." + (when-let ((hash (setq erc-track--shortened-names-current-hash + (sxhash-equal (list channel-names + (buffer-list) + erc-track-shorten-function)))) + (erc-track--shortened-names) + ((= hash (car erc-track--shortened-names)))) + (cdr erc-track--shortened-names))) + +(gv-define-simple-setter erc-track--shortened-names-get + erc-track--shortened-names-set) + (defun erc-track-shorten-names (channel-names) "Call `erc-unique-channel-names' with the correct parameters. This function is a good value for `erc-track-shorten-function'. @@ -797,10 +828,13 @@ erc-modified-channels-display (or (buffer-name buf) "")) buffers)) - (short-names (if (functionp erc-track-shorten-function) - (funcall erc-track-shorten-function - long-names) - long-names)) + (erc-track--shortened-names-current-hash nil) + (short-names + (if (functionp erc-track-shorten-function) + (with-memoization + (erc-track--shortened-names-get long-names) + (funcall erc-track-shorten-function long-names)) + long-names)) strings) (while buffers (when (car short-names) diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index 4477727be8a..ed3d190928f 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -104,6 +104,42 @@ erc-track--shorten-aggressive-max '("#emacs" "#vi")) '("#e" "#v"))) )) +(ert-deftest erc-track--shortened-names () + (let (erc-track--shortened-names + erc-track--shortened-names-current-hash + results) + + (with-memoization (erc-track--shortened-names-get + '("apple" "banana" "cherries")) + '("a" "b" "c")) + (should (integerp (car erc-track--shortened-names))) + (should (equal (cdr erc-track--shortened-names) '("a" "b" "c"))) + (push erc-track--shortened-names results) + + ;; Redundant call doesn't run. + (with-memoization (erc-track--shortened-names-get + '("apple" "banana" "cherries")) + (should-not 'run) + '("a" "b" "c")) + (should (equal erc-track--shortened-names (car results))) + + ;; Change in environment or context forces run. + (with-temp-buffer + (with-memoization (erc-track--shortened-names-get + '("apple" "banana" "cherries")) + '("x" "y" "z"))) + (should (and (integerp (car erc-track--shortened-names)) + (/= (car erc-track--shortened-names) (caar results)))) + (should (equal (cdr erc-track--shortened-names) '("x" "y" "z"))) + (push erc-track--shortened-names results) + + (with-memoization (erc-track--shortened-names-get + '("apple" "banana" "cherries")) + '("1" "2" "3")) + (should (and (integerp (car erc-track--shortened-names)) + (/= (car erc-track--shortened-names) (caar results)))) + (should (equal (cdr erc-track--shortened-names) '("1" "2" "3"))))) + (ert-deftest erc-track--erc-faces-in () "`erc-faces-in' should pick up both 'face and 'font-lock-face properties." (let ((str0 (copy-sequence "is bold")) -- 2.42.0 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0005-5.7-Add-erc-track-integration-to-erc-nicks.patch >From e14973511bf0c845ceaac2121c95cc47c6b17ae5 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 11 Dec 2023 01:30:48 -0800 Subject: [PATCH 5/5] [5.7] Add erc-track integration to erc-nicks * lisp/erc/erc-button.el (erc-button--nick): Add `face-cache' slot. (erc-button-add-nickname-buttons): Pass `erc-button--nick' object, if created' as the boolean NICK-P parameter when calling `erc-button-add-button'. Keeping the latter ignorant `erc-button--nick' is of course preferable, but some coordination is now required to convey and use the face cache. We could introduce an abstraction, like a local variable, if this becomes an issue. (erc-button-add-button): Use `erc--merge-prop' instead of `erc-button-add-face' to apply button faces. Hold off on deprecating the latter because it provides unique functionality for nesting faces. Also, consult NICK-P if it's an `erc-button--nick' object for the various overriding faces it knows about. * lisp/erc/erc-nicks.el (erc-nicks-track-faces): New option. (erc-nicks--highlight-button): Set the `face-cache' slot of the `erc-button--nick' object when `track' is loaded and initialized. (erc-nicks-mode, erc-nicks-enable, erc-nicks-disable): Add and remove `track' integration. (erc-nicks--reject-uninterned-faces): New function to remove faces created by `nicks' from buttonized speakers and mentions. Conform to `erc-track--face-reject-function' interface. (erc-nicks--ourps, erc-nicks--check-normals): New function and helper for `erc-track--alt-normals-function' interface. (erc-nicks--setup-track-integration): New function. (erc-nicks--remember-face-for-track): New function to cache nick faces owned by this module. (Bug#67767) --- lisp/erc/erc-button.el | 41 +++++++++++---------- lisp/erc/erc-nicks.el | 83 +++++++++++++++++++++++++++++++++++++++++- lisp/erc/erc.el | 8 +++- 3 files changed, 110 insertions(+), 22 deletions(-) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index f10d7a2fce7..fc2511bad42 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -369,7 +369,8 @@ erc-button--nick ( nickname-face erc-button-nickname-face :type symbol :documentation "Temp `erc-button-nickname-face' while buttonizing.") ( mouse-face erc-button-mouse-face :type symbol - :documentation "Temp `erc-button-mouse-face' while buttonizing.")) + :documentation "Function to return possibly cached face.") + ( face-cache nil :type (or null function))) ;; This variable is intended to serve as a "core" to be wrapped by ;; (built-in) modules during setup. It's unclear whether @@ -460,8 +461,7 @@ erc-button-add-nickname-buttons (erc-bounds-of-word-at-point))) (word (buffer-substring-no-properties (car bounds) (cdr bounds))) (down (erc-downcase word))) - (let* ((erc-button-mouse-face erc-button-mouse-face) - (erc-button-nickname-face erc-button-nickname-face) + (let* ((nick-obj t) (cuser (and erc-channel-users (or (gethash down erc-channel-users) (funcall erc-button--fallback-cmem-function @@ -470,19 +470,15 @@ erc-button-add-nickname-buttons (and erc-server-users (gethash down erc-server-users)))) (data (list word))) (when (or (not (functionp form)) - (and-let* ((user) - (obj (funcall form (make-erc-button--nick - :bounds bounds :data data - :downcased down :user user - :cuser (cdr cuser))))) - (setq erc-button-mouse-face ; might be null - (erc-button--nick-mouse-face obj) - erc-button-nickname-face ; might be null - (erc-button--nick-nickname-face obj) - data (erc-button--nick-data obj) - bounds (erc-button--nick-bounds obj)))) + (and user + (setq nick-obj (funcall form (make-erc-button--nick + :bounds bounds :data data + :downcased down :user user + :cuser (cdr cuser))) + data (erc-button--nick-data nick-obj) + bounds (erc-button--nick-bounds nick-obj)))) (erc-button-add-button (car bounds) (cdr bounds) (nth 3 entry) - 'nickp data)))))) + nick-obj data)))))) (defun erc-button-add-buttons-1 (regexp entry) "Search through the buffer for matches to ENTRY and add buttons." @@ -541,13 +537,20 @@ erc-button-add-button (move-marker pos (point)))))) (if nick-p (when erc-button-nickname-face - (erc-button-add-face from to erc-button-nickname-face)) + (erc--merge-prop from to 'font-lock-face + (or (and (erc-button--nick-p nick-p) + (erc-button--nick-nickname-face nick-p)) + erc-button-nickname-face) + nil (and (erc-button--nick-p nick-p) + (erc-button--nick-face-cache nick-p)))) (when erc-button-face - (erc-button-add-face from to erc-button-face))) + (erc--merge-prop from to 'font-lock-face erc-button-face))) (add-text-properties from to - (nconc (and erc-button-mouse-face - (list 'mouse-face erc-button-mouse-face)) + (nconc (and-let* ((face (or (and (erc-button--nick-p nick-p) + (erc-button--nick-mouse-face nick-p)) + erc-button-mouse-face))) + (list 'mouse-face face)) (list 'erc-callback fun) (list 'keymap erc-button-keymap) (list 'rear-nonsticky t) diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index 2f0c3261266..0b1e5e0c050 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -173,6 +173,20 @@ erc-nicks-key-suffix-format like \"@%-012n\"." :type 'string) +(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'.") @@ -516,7 +530,12 @@ erc-nicks--highlight-button 'font-lock-face)) (nick (erc-server-user-nickname (erc-button--nick-user nick-object))) (out (erc-nicks--highlight nick face))) - (setf (erc-button--nick-nickname-face nick-object) out)) + (setf (erc-button--nick-nickname-face nick-object) out + ;; + (erc-button--nick-face-cache nick-object) + (and erc-nicks-track-faces + (bound-and-true-p erc-track--normal-faces) + #'erc-nicks--remember-face-for-track))) nick-object) (define-erc-module nicks nil @@ -559,6 +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) + (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) @@ -570,8 +591,12 @@ nicks (kill-local-variable 'erc-nicks--downcased-skip-nicks) (when (fboundp 'erc-button--phantom-users-mode) (erc-button--phantom-users-mode -1)) + (remove-function (local 'erc-track--face-reject-function) + #'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) @@ -691,6 +716,62 @@ erc-nicks--colors-from-faces (color (face-foreground face))) (push color out))))) +(defun erc-nicks--reject-uninterned-faces (candidate) + "Remove own faces from CANDIDATE if it's a combination of faces." + (while-let ((next (car-safe candidate)) + ((facep next)) + ((not (intern-soft next)))) + (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." + (when (bound-and-true-p erc-track-mode) + (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." + (defvar erc-track--normal-faces) + (cl-assert erc-track--normal-faces) + (or (gethash face erc-track--normal-faces) + (if-let ((sym (or (car-safe face) face)) + ((symbolp sym)) + ((get sym 'erc-nicks--key))) + (puthash face face erc-track--normal-faces) + face))) + (provide 'erc-nicks) ;;; erc-nicks.el ends here diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 62fdc0ad6e8..2734c602fa2 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -3351,12 +3351,14 @@ erc--merge-text-properties-p ;; values and optionally dispense archetypal constants in their place ;; in order to ensure all occurrences of some list (a b) across all ;; text-properties in all ERC buffers are actually the same object. -(defun erc--merge-prop (from to prop val &optional object) +(defun erc--merge-prop (from to prop val &optional object cache-fn) "Combine existing PROP values with VAL between FROM and TO in OBJECT. For spans where PROP is non-nil, cons VAL onto the existing value, ensuring a proper list. Otherwise, just set PROP to VAL. When VAL is itself a list, prepend its members onto an existing -value. See also `erc-button-add-face'." +value. Call CACHE-FN, when given, with the new value for prop. +It must return a suitable replacement or the same value. See +also `erc-button-add-face'." (let ((old (get-text-property from prop object)) (pos from) (end (next-single-property-change from prop object to)) @@ -3370,6 +3372,8 @@ erc--merge-prop (append val (ensure-list old)) (cons val (ensure-list old)))) val)) + (when cache-fn + (setq new (funcall cache-fn new))) (put-text-property pos end prop new object) (setq pos end old (get-text-property pos prop object) -- 2.42.0 --=-=-=--