From unknown Fri Jun 20 19:47:40 2025 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable MIME-Version: 1.0 X-Mailer: MIME-tools 5.509 (Entity 5.509) Content-Type: text/plain; charset=utf-8 From: bug#67767 <67767@debbugs.gnu.org> To: bug#67767 <67767@debbugs.gnu.org> Subject: Status: 30.0.50; ERC 5.6: Add track integration to the nicks module Reply-To: bug#67767 <67767@debbugs.gnu.org> Date: Sat, 21 Jun 2025 02:47:40 +0000 retitle 67767 30.0.50; ERC 5.6: Add track integration to the nicks module reassign 67767 emacs submitter 67767 "J.P." severity 67767 normal tag 67767 patch thanks From debbugs-submit-bounces@debbugs.gnu.org Mon Dec 11 10:28:54 2023 Received: (at submit) by debbugs.gnu.org; 11 Dec 2023 15:28:54 +0000 Received: from localhost ([127.0.0.1]:54350 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rCiDD-0006G7-Ve for submit@debbugs.gnu.org; Mon, 11 Dec 2023 10:28:53 -0500 Received: from lists.gnu.org ([2001:470:142::17]:60456) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rCiD9-0006Fm-Ia for submit@debbugs.gnu.org; Mon, 11 Dec 2023 10:28:51 -0500 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 1rCiCp-0001WV-9k for bug-gnu-emacs@gnu.org; Mon, 11 Dec 2023 10:28:27 -0500 Received: from mail-108-mta135.mxroute.com ([136.175.108.135]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rCiCl-0005dE-5K for bug-gnu-emacs@gnu.org; Mon, 11 Dec 2023 10:28:27 -0500 Received: from filter006.mxroute.com ([136.175.111.2] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta135.mxroute.com (ZoneMTA) with ESMTPSA id 18c597e4d0d00065b4.001 for (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Mon, 11 Dec 2023 15:28:18 +0000 X-Zone-Loop: ffff4067b8d9635128df61d5476744bdfc9e64f8c8da X-Originating-IP: [136.175.111.2] DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=neverwas.me ; s=x; h=Content-Type:MIME-Version:Message-ID:Date:Subject:To:From:Sender: Reply-To:Cc:Content-Transfer-Encoding:Content-ID:Content-Description: Resent-Date:Resent-From:Resent-Sender:Resent-To:Resent-Cc:Resent-Message-ID: In-Reply-To:References:List-Id:List-Help:List-Unsubscribe:List-Subscribe: List-Post:List-Owner:List-Archive; bh=yszl5PYGCgzt3CIc5YiSWflxo1H21p2GSugwtl1qtZw=; b=NQt6jutv103D2i0bVIV5GIjmpd pLPq3p8/l22H1PGUC1iY9NW9CjEDTNnHWa43VsNE/CHoBk9993D+x6pBT8KB46MWObYiV8wT2TtE2 tWNEG8DXLeDaSpiv/+d3oD4mSqZldvoh7eAol7Sk73QRNJNyxExuwhG0904Ir1fIpAi3Q6DKM3Ty/ 11YiDfXsOS/vgoKSpicSN9ISqLoBGiHJHDUoRnTL78/V4dnDMHXTJphD4oVvFvB+R6CnCGRfg+gYI 76ix01rphVjaIO0NiqFZP9wkGxKiJJvfnawJSFaEwy7CKcgl4dqbaBdWSqaNQ+Z9OOvE18GpGAQa5 IbxT22cw==; From: "J.P." To: bug-gnu-emacs@gnu.org Subject: 30.0.50; ERC 5.6: Add track integration to the nicks module X-Debbugs-CC: emacs-erc@gnu.org Date: Mon, 11 Dec 2023 07:28:15 -0800 Message-ID: <87edfs3gj4.fsf@neverwas.me> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Authenticated-Id: masked@neverwas.me Received-SPF: pass client-ip=136.175.108.135; envelope-from=jp@neverwas.me; helo=mail-108-mta135.mxroute.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, SPF_HELO_NONE=0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no X-Spam_action: no action X-Spam-Score: 0.9 (/) X-Debbugs-Envelope-To: submit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -0.1 (/) --=-=-= Content-Type: text/plain Tags: patch ERC's `nicks' module doesn't currently play nice with `track'. Enabling it breaks the cycling effect normally occurring among faces in `erc-track-faces-normal-list' [1]. To address this, I'm proposing we expose two internal seams: 1. A function-valued variable for modifying or discarding faces gleaned in the narrowed buffer while `track' visits a message. 2. A buffer-local hash table created on init from the contents of `erc-track-faces-normal-list'. The first brings a small performance penalty and the second a small UX hiccup [2]. The proposed implementation offsets the first by passing around more refined data to cut down on some waste during processing. The second is only currently addressed via doc string, although there's a public compatibility flag to revert to a related historical behavior, which dispenses with the issue indirectly. The only actual addition to the `nicks' module is a user option named `erc-nicks-track-faces'. It's a boolean that lets you opt out of seeing nick colors as faces in the mode line indicator. There's also a loosely related patch that adds some caching to the uniquified name shortening performed by `track', although it should mainly benefit batch processing and history playback. Suggestions welcome, as always. Thanks. [1] Although, what we typically perceive as this effect is somewhat illusory, if not underrealized. See comments preceding the new tests in the first patch. [2] Users will have to toggle the module's minor-mode to update the variable mid-session, but we can provide a Custom :set function to help with this. Also, there's actually a resource penalty that comes with this change too. We can probably use per-server instead of per-channel hash tables, or only go per-channel if a local value for `erc-track-faces-normal-list' exists on `erc-track-mode' init. In GNU Emacs 30.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.24.38, cairo version 1.17.6) of 2023-12-06 built on localhost Repository revision: d8a00879309a3bf62f6ffcae103aa3bdba776ee9 Repository branch: master Windowing system distributor 'The X.Org Foundation', version 11.0.12014000 System Description: Fedora Linux 37 (Workstation Edition) Configured using: 'configure --enable-check-lisp-object-type --enable-checking=yes,glyphs 'CFLAGS=-O0 -g3' PKG_CONFIG_PATH=:/usr/lib64/pkgconfig:/usr/share/pkgconfig' Configured features: ACL CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GPM GSETTINGS HARFBUZZ JPEG JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 M17N_FLT MODULES NATIVE_COMP NOTIFY INOTIFY PDUMPER PNG RSVG SECCOMP SOUND SQLITE3 THREADS TIFF TOOLKIT_SCROLL_BARS WEBP X11 XDBE XIM XINPUT2 XPM GTK3 ZLIB Important settings: value of $LANG: en_US.UTF-8 value of $XMODIFIERS: @im=ibus locale-coding-system: utf-8-unix Major mode: Lisp Interaction Minor modes in effect: tooltip-mode: t global-eldoc-mode: t eldoc-mode: t show-paren-mode: t electric-indent-mode: t mouse-wheel-mode: t tool-bar-mode: t menu-bar-mode: t file-name-shadow-mode: t global-font-lock-mode: t font-lock-mode: t blink-cursor-mode: t minibuffer-regexp-mode: t line-number-mode: t indent-tabs-mode: t transient-mark-mode: t auto-composition-mode: t auto-encryption-mode: t auto-compression-mode: t Load-path shadows: None found. Features: (shadow sort mail-extr emacsbug message mailcap yank-media puny dired dired-loaddefs rfc822 mml mml-sec epa derived epg rfc6068 epg-config gnus-util time-date mm-decode mm-bodies mm-encode mail-parse rfc2231 mailabbrev gmm-utils mailheader sendmail rfc2047 rfc2045 ietf-drums mm-util mail-prsvr mail-utils compile text-property-search comint ansi-osc ansi-color ring comp-run comp-common rx erc auth-source cl-seq eieio eieio-core cl-macs password-cache json subr-x map format-spec cl-loaddefs cl-lib erc-backend erc-networks byte-opt gv bytecomp byte-compile erc-common erc-compat erc-loaddefs rmc iso-transl tooltip cconv eldoc paren electric uniquify ediff-hook vc-hooks lisp-float-type elisp-mode mwheel term/x-win x-win term/common-win x-dnd touch-screen tool-bar dnd fontset image regexp-opt fringe tabulated-list replace newcomment text-mode lisp-mode prog-mode register page tab-bar menu-bar rfn-eshadow isearch easymenu timer select scroll-bar mouse jit-lock font-lock syntax font-core term/tty-colors frame minibuffer nadvice seq simple cl-generic indonesian philippine cham georgian utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao korean japanese eucjp-ms cp51932 hebrew greek romanian slovak czech european ethiopic indian cyrillic chinese composite emoji-zwj charscript charprop case-table epa-hook jka-cmpr-hook help abbrev obarray oclosure cl-preloaded button loaddefs theme-loaddefs faces cus-face macroexp files window text-properties overlay sha1 md5 base64 format env code-pages mule custom widget keymap hashtable-print-readable backquote threads dbusbind inotify lcms2 dynamic-setting system-font-setting font-render-setting cairo gtk x-toolkit xinput2 x multi-tty move-toolbar make-network-process native-compile emacs) Memory information: ((conses 16 82762 11177) (symbols 48 9671 0) (strings 32 25958 4639) (string-bytes 1 784755) (vectors 16 19276) (vector-slots 8 328221 11347) (floats 8 24 28) (intervals 56 260 0) (buffers 984 12)) --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-5.6-Always-promote-normal-faces-in-erc-track.patch >From 1a35b08698dfdfb3cd6568b8dc474ddb45c8da43 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sun, 10 Dec 2023 05:33:48 -0800 Subject: [PATCH 1/3] [5.6] Always 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-track.el (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--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. --- etc/ERC-NEWS | 22 +++++ lisp/erc/erc-track.el | 143 +++++++++++++++++++++++++++---- test/lisp/erc/erc-track-tests.el | 130 ++++++++++++++++++++++++++++ 3 files changed, 280 insertions(+), 15 deletions(-) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 4642c742b0f..a5ebdef508e 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 @@ -306,6 +319,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-track.el b/lisp/erc/erc-track.el index a36b781e04d..a341ea42d24 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -224,10 +224,23 @@ 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." :type '(repeat (choice face (repeat :tag "Combination" face)))) +(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. @@ -518,6 +531,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) @@ -528,6 +544,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: @@ -539,6 +557,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) @@ -548,9 +567,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 @@ -562,6 +584,18 @@ 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 erc-track-mode + (setq erc-track--normal-faces + (map-into (mapcar (lambda (f) (cons f t)) + erc-track-faces-normal-list) + '(hash-table :test equal))) + (kill-local-variable 'erc-track--normal-faces))) + ;;; Visibility (defvar erc-buffer-activity nil @@ -766,7 +800,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) @@ -785,6 +824,44 @@ erc-track-select-mode-line-face choice)) choice)))) +(defun erc-track--select-mode-line-face (cur-face new-faces ranked normals) + "Return CUR-FACE or a replacement for displaying in the mode-line, or nil. +Expect RANKED 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 RANKED 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 reconsider NEW-FACES when CUR-FACE outranks all its +members. That is, choose the highest RANKED 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." + (cl-check-type erc-track-ignore-normal-contenders-p null) + (cl-check-type new-faces cons) + (cl-check-type normals hash-table) + (when-let ((choice (catch 'face + (dolist (candidate ranked) + (when (or (equal candidate cur-face) + (gethash candidate (car new-faces))) + (throw 'face candidate)))))) + (when-let (((equal choice cur-face)) + ((gethash choice normals)) + (contender (catch 'face + (progn + (dolist (candidate ranked) + (when (and (not (equal candidate choice)) + (gethash candidate (car new-faces)) + (gethash candidate normals)) + (throw 'face candidate))) + (dolist (f (cdr new-faces)) + (when (and (not (equal f choice)) + (gethash f normals)) + (throw 'face f))))))) + (setq choice contender)) + choice)) + (defvar erc-track--skipped-msgs '(datestamp) "Values of `erc-msg' text prop to ignore.") @@ -819,31 +896,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))) + (ranked erc-track-faces-priority-list) + (normals erc-track--normal-faces) + (erc-track-faces-priority-list + `(,@erc-track--attn-faces ,@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 erc-track-faces-priority-list) + (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 ranked 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 ranked normals)))) (setcdr cell (cons (1+ (cadr cell)) new-face))))) ;; And display it (erc-modified-channels-display))) @@ -872,6 +961,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=0002-5.6-Cache-shortened-channel-names-in-erc-track.patch >From 67b729dbb9f7bb5b24d66298a354a7c155abf544 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 13 Jun 2022 00:26:22 -0700 Subject: [PATCH 2/3] [5.6] 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. --- 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 a341ea42d24..85e7b398573 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -357,6 +357,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'. @@ -739,10 +770,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=0003-5.6-Add-erc-track-integration-to-erc-nicks.patch >From 9466b7ebb1ac4a8316f764e76cc57406d15d0f18 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 11 Dec 2023 01:30:48 -0800 Subject: [PATCH 3/3] [5.6] Add erc-track integration to erc-nicks * lisp/erc/erc-button.el (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. * lisp/erc/erc-nicks.el (erc-nicks-track-faces): New option. (erc-nicks--highlight-button): Add faces to `erc-track' "normal" table. (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--setup-track-integration): New function. (erc-nicks--track-nick-face-as-normal): New function to add newly created face and known likely combination working store of "normal" faces maintained by `track'. --- lisp/erc/erc-button.el | 4 ++-- lisp/erc/erc-nicks.el | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 2 deletions(-) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index e1c10be53f6..e72ceb705de 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -535,9 +535,9 @@ 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 erc-button-nickname-face)) (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 diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index fcd3afdbbc4..3043ad37f78 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -173,6 +173,10 @@ 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) + (defvar erc-nicks--max-skip-search 3 ; make this an option? "Max number of faces to visit when testing `erc-nicks-skip-faces'.") @@ -518,6 +522,8 @@ erc-nicks--highlight-button 'font-lock-face)) (nick (erc-server-user-nickname (erc-button--nick-user nick-object))) (out (erc-nicks--highlight nick face))) + (when erc-nicks-track-faces + (erc-nicks--track-nick-face-as-normal out)) (setf (erc-button--nick-nickname-face nick-object) out)) nick-object) @@ -561,6 +567,9 @@ 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)) (advice-add 'widget-create-child-and-convert :filter-args #'erc-nicks--redirect-face-widget-link)) ((kill-local-variable 'erc-nicks--face-table) @@ -572,6 +581,8 @@ 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) (setf (alist-get "Edit face" @@ -693,6 +704,28 @@ 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)) + +(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))) + +(defun erc-nicks--track-nick-face-as-normal (face) + "Add FACE to local hash table maintained by `track' module." + (when (bound-and-true-p erc-track--normal-faces) + (puthash `(,@(ensure-list face) erc-default-face) t + erc-track--normal-faces) + (puthash face t erc-track--normal-faces))) + (provide 'erc-nicks) ;;; erc-nicks.el ends here -- 2.42.0 --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Mon Dec 11 21:18:43 2023 Received: (at 67767) by debbugs.gnu.org; 12 Dec 2023 02:18:43 +0000 Received: from localhost ([127.0.0.1]:55059 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rCsM7-0005hX-45 for submit@debbugs.gnu.org; Mon, 11 Dec 2023 21:18:43 -0500 Received: from mail-108-mta191.mxroute.com ([136.175.108.191]:45315) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rCsM4-0005hM-I8 for 67767@debbugs.gnu.org; Mon, 11 Dec 2023 21:18:41 -0500 Received: from filter006.mxroute.com ([136.175.111.2] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta191.mxroute.com (ZoneMTA) with ESMTPSA id 18c5bd1701800065b4.001 for <67767@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Tue, 12 Dec 2023 02:18:21 +0000 X-Zone-Loop: 552559880155ddbeb5582b70e75bf63b8fd9ce55f048 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=Cf/hTWO7Xf8ABBHg6yAZ3qIGLgD7Re5nbNDB1jt1xCk=; b=KrYHuGKF1CjfW+vGY/kZa/MuEs D2804Ir3fAvFa6BIUmarEGIHAfwfBz27BYlGH3omjpizMHDFoZN94wTvEpoSVAMkmtEQ7HSIUgvEL XvnIc9FSCWnn9zkLyjrquUuJA93c8zNkrFer+fPSFtiFaEv+kyywBgHU/DUpHuUxWBtkKDX5uel1P hydVyWehdwJn/QWcz9JJXoQn81LcR4YQB5CskRooS2nh2wvu18qBrISvf8vEe1/TlnaaK+90PPJVI cZx2qJ2tejGq9MQ5L1h+BHNzBjHlg1b9/PfHWT/xhU5Y3R3+kq2gkjYAQ2lSmBNnb7U29k1FzpvYr AfzmzvyQ==; From: "J.P." To: 67767@debbugs.gnu.org Subject: Re: bug#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module In-Reply-To: <87edfs3gj4.fsf@neverwas.me> (J. P.'s message of "Mon, 11 Dec 2023 07:28:15 -0800") References: <87edfs3gj4.fsf@neverwas.me> Date: Mon, 11 Dec 2023 18:18:17 -0800 Message-ID: <87msug17va.fsf@neverwas.me> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain X-Authenticated-Id: masked@neverwas.me X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 67767 Cc: emacs-erc@gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) "J.P." writes: > [2] Users will have to toggle the module's minor-mode to update the > variable mid-session, but we can provide a Custom :set function to > help with this. Also, there's actually a resource penalty that comes > with this change too. We can probably use per-server instead of > per-channel hash tables, or only go per-channel if a local value for > `erc-track-faces-normal-list' exists on `erc-track-mode' init. It turns out these changes may require more planning than originally budgeted. There's a growing dependency on aspects of the `button' module that haven't been fully sorted, along with a rather heightened potential for leaking memory, so I'd rather not move too hastily without good reason. As such, I'll likely be putting a hold on this until 5.7 and retitling the bug accordingly. From debbugs-submit-bounces@debbugs.gnu.org Tue Dec 12 09:49:42 2023 Received: (at 67767) by debbugs.gnu.org; 12 Dec 2023 14:49:42 +0000 Received: from localhost ([127.0.0.1]:55616 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rD44p-0006tI-9k for submit@debbugs.gnu.org; Tue, 12 Dec 2023 09:49:42 -0500 Received: from mail-108-mta146.mxroute.com ([136.175.108.146]:37705) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rD44d-0006sx-RN for 67767@debbugs.gnu.org; Tue, 12 Dec 2023 09:49:37 -0500 Received: from filter006.mxroute.com ([136.175.111.2] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta146.mxroute.com (ZoneMTA) with ESMTPSA id 18c5e80d50f00065b4.001 for <67767@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Tue, 12 Dec 2023 14:49:10 +0000 X-Zone-Loop: 2a0afdb40490edb5e868f8cd398a9e60de561bf28960 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=aoQBMSt9FeQYTWort/tgnQINNBdugtKW4Op6cr4snGg=; b=at3BY13XLbKz4cPBJN0wQCXF8W Aw9gDTw40vUSq8q12wWhuKTa1s4+igJIURgYtzuxxfuqP5Pyq2ZajaM4s1lsb6DE1jm5trLt9vT/i qHgbfGyrWBljNHcbhccVT+ykXmrqRKgY1bC6zaG+veH1zbZIm4/1YselrgibTv8LE5jHAW4uQCsKo Da6FXgCDeYXGBJYmq0H5ZQzkL6Iek/31FOWYHSZqrrUboBR0Aag5HHVkqnP+2m+tPwnoVn8smpRER 2mKcn6Dg2uhIYmgGje/eSKeLXI2V0PaE7sPiZydPeJT+3uKlL4o4Or8sNMMRAB6I9N7ViyfkwyiOL EY57oylw==; From: "J.P." To: 67767@debbugs.gnu.org Subject: Re: bug#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module In-Reply-To: <87edfs3gj4.fsf@neverwas.me> (J. P.'s message of "Mon, 11 Dec 2023 07:28:15 -0800") References: <87edfs3gj4.fsf@neverwas.me> Date: Tue, 12 Dec 2023 06:49:06 -0800 Message-ID: <87il53zdb1.fsf@neverwas.me> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Authenticated-Id: masked@neverwas.me X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 67767 Cc: emacs-erc@gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain v2. Make "normal"-face hash table local to server buffers and double as cache for inserted `nicks' faces. "Pre-combine" generated `nicks' faces with `erc-nicks-backing-face' via :include. Overload `erc-button-add-button' NICKP param (internally) for conveying current `erc-button--nick' object. Remove `match'-based combo faces from `erc-track-faces-priority-list' and `erc-track-faces-normal-list'. Change default of `erc-button-nickname-face' to new face for distinguishing between button-applied and "speaker" faces. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0000-v1-v2.diff >From 41117716e971088c62a48ca638102cca069c6751 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Tue, 12 Dec 2023 06:06:10 -0800 Subject: [PATCH 0/4] *** NOT A PATCH *** *** BLURB HERE *** F. Jason Park (4): [5.6] Have nick faces :inherit from erc-nicks-backing-face [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 | 54 ++++++- lisp/erc/erc-track.el | 261 ++++++++++++++++++++++++++++--- lisp/erc/erc.el | 8 +- test/lisp/erc/erc-nicks-tests.el | 2 +- test/lisp/erc/erc-track-tests.el | 166 ++++++++++++++++++++ 7 files changed, 522 insertions(+), 57 deletions(-) Interdiff: diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index a5ebdef508e..40e3d5d5638 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -197,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 diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index e72ceb705de..fc2511bad42 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) @@ -363,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 @@ -454,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 @@ -464,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." @@ -535,13 +537,20 @@ erc-button-add-button (move-marker pos (point)))))) (if nick-p (when erc-button-nickname-face - (erc--merge-prop from to 'font-lock-face 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--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 3043ad37f78..92dd03912e6 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -458,7 +458,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))))) @@ -507,12 +509,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." @@ -522,9 +520,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))) - (when erc-nicks-track-faces - (erc-nicks--track-nick-face-as-normal out)) - (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 @@ -719,12 +720,16 @@ erc-nicks--setup-track-integration (add-function :override (local 'erc-track--face-reject-function) #'erc-nicks--reject-uninterned-faces))) -(defun erc-nicks--track-nick-face-as-normal (face) +(defun erc-nicks--remember-face-for-track (face) "Add FACE to local hash table maintained by `track' module." - (when (bound-and-true-p erc-track--normal-faces) - (puthash `(,@(ensure-list face) erc-default-face) t - erc-track--normal-faces) - (puthash face t erc-track--normal-faces))) + (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) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 85e7b398573..4c3c7ca49a5 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -161,23 +161,39 @@ 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. +(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)) + (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 +204,9 @@ 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))) :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) erc-button)) @@ -209,10 +228,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. @@ -229,6 +247,9 @@ erc-track-faces-normal-list \\[erc-track-mode]. 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)))) @@ -619,12 +640,46 @@ erc-track--normal-faces "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." + "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 - (setq erc-track--normal-faces - (map-into (mapcar (lambda (f) (cons f t)) - erc-track-faces-normal-list) - '(hash-table :test equal))) + (let ((existing (erc-with-server-buffer erc-track--normal-faces)) + (localp (and erc--target + (local-variable-p 'erc-track-faces-normal-list))) + warnp table) + (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)) + (push opt warnp) + (set opt (erc-track--massage-nick-button-faces + (symbol-value opt))))) + (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)))) + (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 @@ -858,40 +913,47 @@ erc-track-select-mode-line-face choice)) choice)))) -(defun erc-track--select-mode-line-face (cur-face new-faces ranked normals) +(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)))) + +(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 RANKED to be a list of faces and both NORMALS and the car +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 RANKED to resemble +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 reconsider NEW-FACES when CUR-FACE outranks all its -members. That is, choose the highest RANKED among NEW-FACES not +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." +has a cdr. If NORMALS is a function, call it with the name of a +face to query membership." (cl-check-type erc-track-ignore-normal-contenders-p null) (cl-check-type new-faces cons) - (cl-check-type normals hash-table) (when-let ((choice (catch 'face - (dolist (candidate ranked) + (dolist (candidate ranks) (when (or (equal candidate cur-face) (gethash candidate (car new-faces))) (throw 'face candidate)))))) (when-let (((equal choice cur-face)) - ((gethash choice normals)) + ((erc-track--gett normals choice)) (contender (catch 'face (progn - (dolist (candidate ranked) + (dolist (candidate ranks) (when (and (not (equal candidate choice)) (gethash candidate (car new-faces)) - (gethash candidate normals)) + (erc-track--gett normals candidate)) (throw 'face candidate))) (dolist (f (cdr new-faces)) (when (and (not (equal f choice)) - (gethash f normals)) + (erc-track--gett normals f)) (throw 'face f))))))) (setq choice contender)) choice)) @@ -934,15 +996,15 @@ erc-track-modified-channels ((faces (if erc-track-ignore-normal-contenders-p (erc-faces-in (buffer-string)) (erc-track--get-faces-in-current-message))) - (ranked erc-track-faces-priority-list) (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 erc-track-faces-priority-list) + (dolist (f ranks) (when (gethash f (or (car-safe faces) faces)) (throw 'found t))))))))) (progn ; FIXME remove `progn' on next major edit @@ -955,7 +1017,7 @@ erc-track-modified-channels (erc-track-select-mode-line-face nil faces) (erc-track--select-mode-line-face - nil faces ranked normals)))) + nil faces ranks normals)))) erc-modified-channels-alist)) ;; Else modify the face for the buffer, if necessary. (when faces @@ -966,7 +1028,7 @@ erc-track-modified-channels (erc-track-select-mode-line-face old-face faces) (erc-track--select-mode-line-face - old-face faces ranked normals)))) + old-face faces ranks normals)))) (setcdr cell (cons (1+ (cadr cell)) new-face))))) ;; And display it (erc-modified-channels-display))) 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) 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=0001-5.6-Have-nick-faces-inherit-from-erc-nicks-backing-f.patch >From 214ad79b5cfdb8e9baa9ad7f7ec2a38634b46081 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 11 Dec 2023 20:24:17 -0800 Subject: [PATCH 1/4] [5.6] Have nick faces :inherit from 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.7-Promote-normal-faces-in-erc-track.patch >From 666e2cd2546c7a9bda48f5857b032f97accac6fb Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sun, 10 Dec 2023 05:33:48 -0800 Subject: [PATCH 2/4] [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--old-nick-button-faces, erc-track--massage-nick-button-faces): New supporting variable and 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'. (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--gett): New helper function. (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 | 219 +++++++++++++++++++++++++++---- test/lisp/erc/erc-track-tests.el | 130 ++++++++++++++++++ 4 files changed, 373 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 a36b781e04d..478eabaa961 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -161,23 +161,39 @@ 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. +(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)) + (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 +204,9 @@ 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))) :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) erc-button)) @@ -209,10 +228,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,10 +242,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 (lambda (sym val) + (set-default sym (erc-track--massage-nick-button-faces val))) :type '(repeat (choice face (repeat :tag "Combination" face)))) +(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. @@ -518,6 +552,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) @@ -528,6 +565,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: @@ -539,6 +578,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) @@ -548,9 +588,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 @@ -562,6 +605,52 @@ 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))) + warnp table) + (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)) + (push opt warnp) + (set opt (erc-track--massage-nick-button-faces + (symbol-value opt))))) + (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)))) + (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 @@ -766,7 +855,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) @@ -785,6 +879,51 @@ 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)))) + +(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 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." + (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)))))) + (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)) + (defvar erc-track--skipped-msgs '(datestamp) "Values of `erc-msg' text prop to ignore.") @@ -819,31 +958,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))) @@ -872,6 +1023,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=0003-5.7-Cache-shortened-channel-names-in-erc-track.patch >From 712d8426f1fe86e141485698dee2c71f960fd8ce Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 13 Jun 2022 00:26:22 -0700 Subject: [PATCH 3/4] [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 478eabaa961..4c3c7ca49a5 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -378,6 +378,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'. @@ -794,10 +825,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=0004-5.7-Add-erc-track-integration-to-erc-nicks.patch >From 41117716e971088c62a48ca638102cca069c6751 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 11 Dec 2023 01:30:48 -0800 Subject: [PATCH 4/4] [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--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 | 42 +++++++++++++++++++++++++++++++++++++++++- lisp/erc/erc.el | 8 ++++++-- 3 files changed, 69 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..92dd03912e6 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -173,6 +173,10 @@ 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) + (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 +520,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 +568,9 @@ 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)) (advice-add 'widget-create-child-and-convert :filter-args #'erc-nicks--redirect-face-widget-link)) ((kill-local-variable 'erc-nicks--face-table) @@ -570,6 +582,8 @@ 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) (setf (alist-get "Edit face" @@ -691,6 +705,32 @@ 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)) + +(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))) + +(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 --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Wed Dec 13 09:06:38 2023 Received: (at 67767) by debbugs.gnu.org; 13 Dec 2023 14:06:38 +0000 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 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 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==; From: "J.P." To: 67767@debbugs.gnu.org Subject: Re: bug#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module In-Reply-To: <87edfs3gj4.fsf@neverwas.me> (J. P.'s message of "Mon, 11 Dec 2023 07:28:15 -0800") References: <87edfs3gj4.fsf@neverwas.me> Date: Wed, 13 Dec 2023 06:06:05 -0800 Message-ID: <8734w6yz76.fsf@neverwas.me> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Authenticated-Id: masked@neverwas.me X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 67767 Cc: emacs-erc@gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= 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 --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Mon Dec 18 09:51:58 2023 Received: (at 67767-done) by debbugs.gnu.org; 18 Dec 2023 14:51:59 +0000 Received: from localhost ([127.0.0.1]:59707 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rFEyM-00018x-Iz for submit@debbugs.gnu.org; Mon, 18 Dec 2023 09:51:58 -0500 Received: from mail-108-mta46.mxroute.com ([136.175.108.46]:46629) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rFEyK-00018l-ON for 67767-done@debbugs.gnu.org; Mon, 18 Dec 2023 09:51:57 -0500 Received: from filter006.mxroute.com ([136.175.111.2] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta46.mxroute.com (ZoneMTA) with ESMTPSA id 18c7d69793f00065b4.001 for <67767-done@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Mon, 18 Dec 2023 14:51:53 +0000 X-Zone-Loop: 787992ce250a17d3585c675737606942bd3311881fab 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=eth7C0qb2Z63L+/2Ry8k4e54y27grBPD9hMIfEW8pMc=; b=dqIDhLlnkvLEZQee8zLBPTAw8r 7YV/atljOSFaMT19ewwVZIaLz+eVt8zdEnGQx2BgXVHyruRa6OihsRo1n4UxiVX8YY69MLShWefWq V5PifNrrtNuyYwHwt47g2wZ4qgZUqdkt9S0o2cHw7ZjWaX0kEULXvLD3XY9vKBh4jd1pT3fTsUF9g yllcom3Brmypg7qIyRo9EBjM8cSbBVNqz/AKDaq3QjBMm3n75Di8O6URlq7+iF8cFjjqs/Is5Oi1c HPm+OxjoLSrm+AjA5KHACDhwDfEbCM0NkTAPN0PJNAca22z6aXcPHhow2DqxUFJw2SbxHCkguJJ5N KwHHTFrg==; From: "J.P." To: 67767-done@debbugs.gnu.org Subject: Re: bug#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module In-Reply-To: <8734w6yz76.fsf@neverwas.me> (J. P.'s message of "Wed, 13 Dec 2023 06:06:05 -0800") References: <87edfs3gj4.fsf@neverwas.me> <8734w6yz76.fsf@neverwas.me> Date: Mon, 18 Dec 2023 06:51:50 -0800 Message-ID: <87sf3zftrt.fsf@neverwas.me> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain X-Authenticated-Id: masked@neverwas.me X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 67767-done Cc: emacs-erc@gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) A version of this has been installed (perhaps prematurely) as 8e06f224a9e * Add erc-track integration to erc-nicks Also included are some superficial changes to a few essential variables and data structures, such as `erc-channel-users'. See etc/ERC-NEWS for details. Closing for now. From unknown Fri Jun 20 19:47:40 2025 Received: (at fakecontrol) by fakecontrolmessage; To: internal_control@debbugs.gnu.org From: Debbugs Internal Request Subject: Internal Control Message-Id: bug archived. Date: Tue, 16 Jan 2024 12:24:07 +0000 User-Agent: Fakemail v42.6.9 # This is a fake control message. # # The action: # bug archived. thanks # This fakemail brought to you by your local debbugs # administrator From debbugs-submit-bounces@debbugs.gnu.org Sun Sep 29 12:55:48 2024 Received: (at control) by debbugs.gnu.org; 29 Sep 2024 16:55:48 +0000 Received: from localhost ([127.0.0.1]:41228 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1suxD2-00045V-7i for submit@debbugs.gnu.org; Sun, 29 Sep 2024 12:55:48 -0400 Received: from mail-108-mta6.mxroute.com ([136.175.108.6]:36355) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1suxCz-00045N-97 for control@debbugs.gnu.org; Sun, 29 Sep 2024 12:55:45 -0400 Received: from filter006.mxroute.com ([136.175.111.3] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta6.mxroute.com (ZoneMTA) with ESMTPSA id 1923eb518510003e01.001 for (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Sun, 29 Sep 2024 16:55:08 +0000 X-Zone-Loop: c8adab5221d5201fce502effc4dd20c49a6facb8e6fd X-Originating-IP: [136.175.111.3] DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=neverwas.me ; s=x; h=Content-Type:MIME-Version:Message-ID:Date:Subject:To:From:Sender: Reply-To:Cc:Content-Transfer-Encoding:Content-ID:Content-Description: Resent-Date:Resent-From:Resent-Sender:Resent-To:Resent-Cc:Resent-Message-ID: In-Reply-To:References:List-Id:List-Help:List-Unsubscribe:List-Subscribe: List-Post:List-Owner:List-Archive; bh=LdFcWo8nX1n+hTkVtUNids/y8epzPECZ2HQNCPVWW+g=; b=SSe8RbZ18udpj6BjXjStrm7Rjd fbnBdSDHYie5jHh1qz1XIOAC4Vz0M4k9VWT4TaPewzcws7sSfkTel0ukLM/x2QP9faemp4aGG8p3c G6SMH969ClDjqgtfZ/Qw0ZtkCtwmDvEkxzEl8lejYuYZqrKC2hd6GFRvkQMq/CtUGcfQbiitSaER8 08ADXYlU0rykkSubSRpK8K8XOMPklq/0N6Whnk/EeBIVgAZreYa5mmMSKkmR9OQHhwhh51TGM1Ezx DoeVrwNvGRoMf4+5TV4OBkb1d0KbysVVulsNleGokHAeO/DBEoBL2YBxs6c/LDRy/KZveSwREy4xQ q5orSTNg==; From: "J.P." To: control@debbugs.gnu.org Subject: control message for bug #67767 Date: Sun, 29 Sep 2024 09:55:05 -0700 Message-ID: <87plomv1qu.fsf@neverwas.me> MIME-Version: 1.0 Content-Type: text/plain X-Authenticated-Id: masked@neverwas.me X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: control X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) unarchive 67767 quit From debbugs-submit-bounces@debbugs.gnu.org Sun Sep 29 20:35:29 2024 Received: (at 67767) by debbugs.gnu.org; 30 Sep 2024 00:35:29 +0000 Received: from localhost ([127.0.0.1]:43187 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sv4Nr-0004EY-Dq for submit@debbugs.gnu.org; Sun, 29 Sep 2024 20:35:29 -0400 Received: from mail-108-mta183.mxroute.com ([136.175.108.183]:40097) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sv4Nm-0004EO-OP for 67767@debbugs.gnu.org; Sun, 29 Sep 2024 20:35:25 -0400 Received: from filter006.mxroute.com ([136.175.111.3] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta183.mxroute.com (ZoneMTA) with ESMTPSA id 1924059f2230003e01.001 for <67767@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Mon, 30 Sep 2024 00:34:49 +0000 X-Zone-Loop: 43095258976c27f1c6ec803c9ae9b0b29a683f2b0dc8 X-Originating-IP: [136.175.111.3] 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=Ww4bO86vGBmP6VH4Q5x/N4wOfuCa9WTXu9nASqdIKeo=; b=XecwXqL3DFX3IfkQ5HsvgVbdKO rUTArW2TBPi/wdPlO1hp3a0eHUxegs2pjXKk+aNDGHuyByqvHJYERVDpKsAER5dlsxum7Uy6WPtHa wTlob1XaNp0yQgk6oc57sdhgobNn9uvvmpoOeP5KQudjglrttWYUwGthnjCCjRsTMjkDSyUd1tL50 9uUqsMID13gG+nDy/fkmpwHOt29AfRdaSzcMLzKAAqI+hKxLUnj4X+M+8Qi6McaMs1d6whjqqJsRq knK7fBoocNzm/kWFMdGtgWYKO5pbmZH6kIv5o413s70wWoyqUuIQGNAGmW6cRAZHDvTy8dG9ABngL ht5c09UA==; From: "J.P." To: 67767@debbugs.gnu.org Subject: Re: bug#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module In-Reply-To: <87edfs3gj4.fsf@neverwas.me> (J. P.'s message of "Mon, 11 Dec 2023 07:28:15 -0800") References: <87edfs3gj4.fsf@neverwas.me> Date: Sun, 29 Sep 2024 17:34:46 -0700 Message-ID: <87ed52q8rd.fsf@neverwas.me> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Authenticated-Id: masked@neverwas.me X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 67767 Cc: emacs-erc@gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain "J.P." writes: > ERC's `nicks' module doesn't currently play nice with `track'. Enabling > it breaks the cycling effect normally occurring among faces in > `erc-track-faces-normal-list' [1]. > [...] > > [1] Although, what we typically perceive as this effect is somewhat > illusory, if not underrealized. See comments preceding the new tests > in the first patch. It's been pointed out that the most recent attempt at improving the situation, especially with regard to the option `erc-nicks-track-faces', ended up perpetuating rather unintuitive aspects of the original behavior in certain common situations. While the particulars are tedious to lay out, a somewhat relatable example is a speaker with a `nicks'-owned face speaking immediately after an inserted JOIN message (displayed in `erc-notice-face'). Based on the doc string of `erc-nicks-track-faces', you'd think the `track' segment would favor the `nicks'-owned face, but that's not currently so. The attached patch aims to rectify this as well as address other, similar surprises. Another problem with the current "normals" behavior is that it fails to adequately exhibit the "flickering" effect when `nicks' _isn't_ enabled. You can see this by connecting using the default configuration. Notice that the mode-line segment stays on `erc-default-face while users are conversing so long as they don't mention one another. However, the "normals" feature was always meant to provide more responsive feedback to clearly indicate active conversations (including monologuing). The patch tries to address this by adding the default buttonized speaker face to the related options `erc-track-faces-priority-list' and `erc-track-faces-normal-list'. If there's a smarter way, hopefully someone will speak up. Thanks. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-5.6.1-Fix-prioritize-variant-of-erc-nicks-track-face.patch >From 75f12151384db0e257b6367ce357ef5d8bcfae6b Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 26 Sep 2024 21:34:25 -0700 Subject: [PATCH] [5.6.1] Fix prioritize variant of erc-nicks-track-faces * etc/ERC-NEWS: Mention changes to `erc-track-faces-normal-list' and `erc-track-faces-priority-list'. * lisp/erc/erc-nicks.el (erc-nicks-track-faces): Update doc. (erc-nicks--reject-uninterned-faces): Use helper. (erc-nicks-track-normal-max-rank): New variable. (erc-nicks--check-normals): Change behavior to also consider replacing the current mode-line face when it's not `nicks' owned if it's explicitly ranked lower than `erc-default-face'. * lisp/erc/erc-track.el (erc-track--massage-nick-button-faces): Change type of symbol property `erc-track--obsolete-faces' for options `erc-track-faces-priority-list' and friends from a boolean to an alist. (erc-track-faces-priority-list): Add new face for buttonized speakers. (erc-track-faces-normal-list): Add new face for buttonized speakers. Also add `erc-notice-face'. (erc-track--priority-faces): New local variable to cache ranked faces. (erc-track--setup): Initialize new `erc-track--priority-faces' variable and refactor. (erc-track--alt-normals-function): Doc. (erc-track--select-mode-line-face): Update expected type of `ranks' parameter. (erc-track-modified-channels): Fix wrong-type bug occurring when `erc-track-ignore-normal-contenders-p' and `erc-track-priority-faces-only' are both non-nil. Also fix subtle compatibility oversight regarding an empty face list returned by `erc-track--collect-faces-in'. * test/lisp/erc/erc-nicks-tests.el: Load helpers and fixtures library. (erc-nicks-tests--track-faces): New function. (erc-nicks-track-faces/prioritize, erc-nicks-track-faces/defer) (erc-nicks-track-faces/nil): New tests. * test/lisp/erc/erc-track-tests.el (erc-track-tests--select-mode-line-face): Update expected type of mocked parameter. (erc-track-tests--modified-channels/baseline): New function. (erc-track-modified-channels/baseline) (erc-track-modified-channels/baseline/mention) (erc-track-modified-channels/baseline/ignore) (erc-track-modified-channels/baseline/mention/ignore) (erc-track-modified-channels/priority-only-all/baseline) (erc-track-modified-channels/priority-only-all/sans-notice): New tests. * test/lisp/erc/resources/erc-tests-common.el (erc-tests-common-track-modified-channels) (erc-tests-common-track-modified-channels-sans-setup): New functions. (Bug67767) --- etc/ERC-NEWS | 7 + lisp/erc/erc-nicks.el | 44 ++-- lisp/erc/erc-track.el | 219 ++++++++++------ test/lisp/erc/erc-nicks-tests.el | 222 ++++++++++++++++- test/lisp/erc/erc-track-tests.el | 262 +++++++++++++++++++- test/lisp/erc/resources/erc-tests-common.el | 43 ++++ 6 files changed, 700 insertions(+), 97 deletions(-) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index b267db5502e..d5df54256af 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -35,6 +35,13 @@ has been removed. Option 'erc-keep-place-indicator-truncation' manages the tension between truncation and place keeping, prioritizing one or the other. +** Updated defaults for the 'track' module's face-list options. +The default values of options 'erc-track-faces-priority-list' and +'erc-track-faces-normal-list' have both gained a face for buttonized +speaker names, with the latter option also gaining 'erc-notice-face'. +This was done to provide a more frequent and practical indication of +channel activity in keeping with the module's original design. + * Changes in ERC 5.6 diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index a0d6d17d732..a17900d9330 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -179,12 +179,12 @@ erc-nicks-track-faces `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." +A value of `prioritize' works like `defer' when speakers stay the +same but allows a new speaker's face to impersonate a ranked +normal so nick faces can alternate back-to-back. 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? @@ -724,7 +724,7 @@ erc-nicks--reject-uninterned-faces ((facep next)) ((not (intern-soft next)))) (setq candidate (cdr candidate))) - (if (and (consp candidate) (not (cdr candidate))) (car candidate) candidate)) + (erc--solo candidate)) (define-inline erc-nicks--oursp (face) (inline-quote @@ -733,16 +733,30 @@ erc-nicks--oursp ((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'." - (and-let* (((eq contender 'erc-default-face)) +(defvar erc-nicks-track-normal-max-rank 'erc-default-face + "Highest priority normal face still eligible to alternate with `nicks' faces. +Must appear in both `erc-track-faces-priority-list' and +`erc-track-faces-normal-list'.") + +(defun erc-nicks--check-normals (current contender contenders ranks normals) + "Return a viable non-CURRENT `nicks' face in CONTENDERS. +But only do so if CURRENT and CONTENDER are \"normal\" faces either +unranked or at or below `erc-nicks-track-normal-max-rank'. See +`erc-track--select-mode-line-face' for the expected types of CONTENDERS, +RANKS, and NORMALS." + (and-let* (((or (null contender) (gethash contender normals))) ((or (null current) (gethash current normals))) - (spkr (or (null current) (erc-nicks--oursp current)))) + (threshold (gethash erc-nicks-track-normal-max-rank (car ranks))) + ((<= threshold (or (gethash contender (car ranks)) + ;; Unranked `contender' always replaceable. + most-positive-fixnum))) + (spkr (or (erc-nicks--oursp current) + ;; Use t to mean `current' is not a nick face but + ;; replaceable nonetheless. + (null current) + (<= threshold (or (gethash current (car ranks)) 0))))) (catch 'contender - (dolist (candidate (cdr contenders) contender) + (dolist (candidate (cdr contenders)) (when-let (((not (equal candidate current))) ((gethash candidate normals)) (s (erc-nicks--oursp candidate)) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index f40960e4a22..82e5f402910 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -161,25 +161,33 @@ erc-track-use-faces \(e.g. `erc-pal-face' is used if a pal sent a message to that channel.)" :type 'boolean) +;; In an emergency, users can opt out of this migration with: +;; +;; (put 'erc-track-faces-priority-list 'erc-track--obsolete-faces t) +;; (put 'erc-track-faces-normal-list 'erc-track--obsolete-faces t) +;; (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, set the symbol property `erc-track--obsolete-faces' of -SYM to t." - (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))))) + "Transform VAL of face-list option SYM to remove/replace obsolete items. +Use `set'-compatible SET-FN when given. Record any migrations as cons +cells of (OLD . NEW) in the symbol property `erc-track--obsolete-faces' +of SYM." + (let* ((oldface '(erc-nick-default-face erc-default-face)) + (newface '(erc-button-nick-default-face erc-default-face)) + (migrations (get sym 'erc-track--obsolete-faces)) + (new (if migrations + val + (delq nil + (mapcar + (lambda (f) + (if (equal f oldface) + (setf (alist-get oldface migrations + nil nil #'equal) + (and (not (member newface val)) newface)) + f)) + val))))) + (when migrations + (put sym 'erc-track--obsolete-faces migrations)) + (if set-fn (funcall set-fn sym new) (set-default sym new)))) (defcustom erc-track-faces-priority-list '(erc-error-face @@ -191,6 +199,7 @@ erc-track-faces-priority-list (erc-button erc-default-face) erc-dangerous-host-face erc-nick-default-face + (erc-button-nick-default-face erc-nick-default-face) (erc-button-nick-default-face erc-default-face) erc-default-face erc-action-face @@ -204,7 +213,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.6") + :package-version '(ERC . "5.6.1") :set #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) @@ -229,8 +238,10 @@ erc-track-faces-normal-list '((erc-button erc-default-face) erc-dangerous-host-face erc-nick-default-face + (erc-button-nick-default-face erc-nick-default-face) (erc-button-nick-default-face erc-default-face) erc-default-face + erc-notice-face erc-action-face) "A list of faces considered to be part of normal conversations. This list is used to highlight active buffer names in the mode line. @@ -246,7 +257,7 @@ erc-track-faces-normal-list \\[erc-track-mode]. The effect may be disabled by setting this variable to nil." - :package-version '(ERC . "5.6") + :package-version '(ERC . "5.6.1") :set #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) @@ -636,49 +647,79 @@ erc-track-when-inactive (erc-track-enable)) (set sym val)))) +(defvar-local erc-track--priority-faces nil + "Local copy of `erc-track-faces-priority-list' as a hash table. +Keys are faces and values are rank integers (smaller is more important).") + (defvar-local erc-track--normal-faces nil - "Local copy of `erc-track-faces-normal-list' as a hash table.") + "Local copy of `erc-track-faces-normal-list' as a hash table. +Keys and values are faces. The table is weak valued so it can double as +a buttonizing cache. See `erc-button-add-button' and `erc--merge-prop'.") (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 this is a server buffer or either `erc-track-faces-normal-list' or +`erc-track-faces-priority-list' is locally bound, create a new cache +table with corresponding local variable `erc-track--normal-faces' or +`erc-track--priority-faces'. Otherwise, in target buffers with no local +binding, set the cache variable's local value to that of server'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) + (let (warnp) ;; 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) + (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 (local-variable-p opt) (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)) + (when-let ((migrations (get opt 'erc-track--obsolete-faces)) + ((consp migrations))) + (push (cons opt + (mapcar (pcase-lambda (`(,old . ,new)) + (format (if new "changed %s to %s" + "removed %s") + old new)) + migrations)) + 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)))) + (pcase-dolist (`(,opt . ,migrations) warnp) + (erc--warn-once-before-connect 'erc-track-mode + "Option `%S' contains " + (if (cdr migrations) "obsolete items." "an obsolete item.") + " ERC has done the following for the current session: %s." + " Please review these changes and, if convinced," + " silence this message by saving the current value." + opt (string-join migrations ", "))))) + ;; Set `erc-track--priority-faces' cache to new or shared value. + (let* ((localp (and erc--target + (local-variable-p 'erc-track-faces-priority-list))) + (existing (erc-with-server-buffer erc-track--priority-faces)) + (table (or (and (not localp) existing) + (let ((p 0)) + (map-into + (mapcar (lambda (f) (cons f (cl-incf p))) + (append erc-track--attn-faces + erc-track-faces-priority-list)) + `(hash-table :test equal)))))) + (setq erc-track--priority-faces table) + (unless (or localp existing) + (erc-with-server-buffer (setq erc-track--priority-faces table)))) + ;; Likewise for `erc-track--normal-faces' cache. + (let* ((localp (and erc--target + (local-variable-p 'erc-track-faces-normal-list))) + (existing (erc-with-server-buffer erc-track--normal-faces)) + (table (or (and (not localp) existing) + (map-into (mapcar (lambda (f) (cons f f)) + erc-track-faces-normal-list) + `(hash-table :test equal + :weakness value))))) + (setq erc-track--normal-faces table) + (unless (or localp existing) + (erc-with-server-buffer (setq erc-track--normal-faces table))))) + (kill-local-variable 'erc-track--priority-faces) (kill-local-variable 'erc-track--normal-faces))) ;;; Visibility @@ -915,44 +956,54 @@ erc-track-select-mode-line-face (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.") +followed by all new contending faces, ranked 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-faces-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." +Expect NEW-FACES to be a cons cell whose car is a hash table mapping +faces present in the applicable region to t and whose cdr is its car's +contents ordered from most recently seen (later in the buffer) to +earliest. Expect RANKS to be a cons cell whose car is a hash table +similar to `erc-track--priority-faces' and whose cdr is a list of +prioritized faces resembling `erc-track-faces-priority-list'. Expect +NORMALS to be a hash table mapping faces to themselves. In general, act +identically to `erc-track-select-mode-line-face', except appeal to +`erc-track--alt-normals-function' if it's non-nil, and fall back on +reconsidering only NEW-FACES appearing in NORMALS when CUR-FACE is +itself \"normal\" and outranks all NEW-FACES. That is, choose the first +among RANKS in both NEW-FACES and NORMALS not equal to CUR-FACE. +Failing that, choose the first face in both NEW-FACES and NORMALS." (cl-check-type erc-track-ignore-normal-contenders-p null) (cl-check-type new-faces cons) + ;; Choose the highest ranked face in `erc-track-faces-priority-list' + ;; that's either `cur-face' itself or one appearing in the region + ;; being processed. (when-let ((choice (catch 'face - (dolist (candidate ranks) + (dolist (candidate (cdr 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)) + cur-face choice new-faces ranks normals)) + ;; If `choice' is still `cur-face' and also a "normal", attempt + ;; to choose another normal in order to produce the flickering + ;; effect mentioned in the doc of `erc-track-faces-normal-list'. (and (equal choice cur-face) (gethash choice normals) (catch 'face + ;; If ranked "normal" faces other than `choice' appear in + ;; the region, return the most important one. (progn - (dolist (candidate ranks) + (dolist (candidate (cdr ranks)) (when (and (not (equal candidate choice)) (gethash candidate (car new-faces)) (gethash choice normals)) (throw 'face candidate))) + ;; Otherwise, go with any "normal" face other than + ;; `choice' in the region. (dolist (candidate (cdr new-faces)) (when (and (not (equal candidate choice)) (gethash candidate normals)) @@ -996,14 +1047,24 @@ erc-track-modified-channels (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) + (ranks (cons erc-track--priority-faces + 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))))))))) + ;; Iterate over the shorter of `ranks' and `faces'. + (let* ((r>fp (or erc-track-ignore-normal-contenders-p + (> (hash-table-count (car ranks)) + (hash-table-count (car faces))))) + (elems (cond ((not r>fp) (cdr ranks)) ; f>=r + (erc-track-ignore-normal-contenders-p + faces) + ((cdr faces)))) + (table (if r>fp (car ranks) (car faces)))) + (not (catch 'found + (dolist (f elems) + (when (gethash f table) + (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 @@ -1017,7 +1078,7 @@ erc-track-modified-channels nil faces ranks normals)))) erc-modified-channels-alist)) ;; Else modify the face for the buffer, if necessary. - (when faces + (when (or erc-track-ignore-normal-contenders-p (cdr faces)) (let* ((cell (assq (current-buffer) erc-modified-channels-alist)) (old-face (cddr cell)) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index 08080d249d5..75cb98b8407 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -30,8 +30,11 @@ ;;; Code: -(require 'ert-x) (require 'erc-nicks) +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) ;; This function replicates the behavior of older "invert" strategy ;; implementations from EmacsWiki, etc. The values for the lower and @@ -568,4 +571,221 @@ erc-nicks--create-coerced-pool (should (equal erc-nicks--colors-rejects '(t))))) +(declare-function erc-track-modified-channels "erc-track" ()) + +(defun erc-nicks-tests--track-faces (test) + (require 'erc-track) + (defvar erc-modified-channels-alist) + (defvar erc-track--normal-faces) + + (erc-tests-common-make-server-buf) + (erc-nicks-mode +1) + + (let ((erc-modules (cons 'nicks erc-modules)) + ;; Pretend these faces were added in response-handling during + ;; insertion modification by buttonizing hooks. See + ;; `erc-nicks--highlight-button'. + (add-face (lambda (face) + (erc-nicks--remember-face-for-track ; speaker + (list face 'erc-nick-default-face)) + (erc-nicks--remember-face-for-track ; mention + (list face 'erc-default-face)))) + ;; + bob-face alice-face assert-result) + + (with-current-buffer (erc--open-target "#chan") + (should erc-nicks-mode) + (should (setq bob-face (erc-nicks--get-face "bob" "bob@foonet"))) + (should (setq alice-face (erc-nicks--get-face "alice" "alice@foonet"))) + + (erc-tests-common-track-modified-channels-sans-setup + + (lambda (set-faces) + + (setq assert-result ; fixture binds `erc-modified-channels-alist' + (lambda (result) + (should (equal (alist-get (current-buffer) + erc-modified-channels-alist) + result)))) + + (funcall test set-faces assert-result add-face + bob-face alice-face))))) + + (erc-tests-common-kill-buffers)) + +(ert-deftest erc-nicks-track-faces/prioritize () + (should (eq erc-nicks-track-faces 'prioritize)) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result add-face bob-face alice-face) + + (defvar erc-track--alt-normals-function) + (should erc-track--alt-normals-function) + + (funcall add-face bob-face) + (funcall add-face alice-face) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line changes to a `nicks' owned + ;; composite face for the speaker. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 ,bob-face erc-nick-default-face)) + + ;; That same someone speaks, and the mode-line indicator changes to + ;; another "normal" face in the message body. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(3 . erc-default-face)) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(4 ,bob-face erc-nick-default-face)) + + ;; Now the same person mentions another server user, resulting in a + ;; change to *that* `nicks' owned face because it appears later in + ;; the message content (timestamp is last). + (funcall set-faces `(erc-timestamp-face + (,alice-face erc-default-face) + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(5 ,alice-face erc-default-face)) + + ;; The mentioned user replies, mentioning the mentioner. But + ;; instead of the normal "normals" processing preferring the ranked + ;; `erc-default-face', the `erc-nicks-track-faces' logic kicks in + ;; via `erc-track--alt-normals-function' and provides a `nicks' + ;; owned replacement. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-default-face) + (,alice-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(6 ,bob-face erc-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(7 . erc-notice-face))))) + +(ert-deftest erc-nicks-track-faces/defer () + (should (eq erc-nicks-track-faces 'prioritize)) + (let ((erc-nicks-track-faces 'defer)) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result add-face bob-face alice-face) + + (funcall add-face bob-face) + (funcall add-face alice-face) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line indicator changes to the + ;; highest ranked face in the message. (All `nicks' owned faces + ;; are unranked). + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 . erc-default-face)) + + ;; That same someone speaks, and the mode-line indicator changes + ;; to a `nicks' owned face. It first reaches for the highest + ;; ranked face in the message but then applies the "normals" + ;; rules, resulting in a promoted alternate. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(3 ,bob-face erc-nick-default-face)) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(4 . erc-default-face)) + + ;; The same person mentions another server user, resulting in a + ;; change to that `nicks' owned face because the logic from + ;; 3. again applies. + (funcall set-faces `(erc-timestamp-face + (,alice-face erc-default-face) + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(5 ,alice-face erc-default-face)) + + ;; The mentioned user replies, mentioning the mentioner. + ;; However, the `nicks' module does not intercede in the decision + ;; making to overrule the ranked nominee. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-default-face) + (,alice-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(6 . erc-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(7 . erc-notice-face)))))) + +(ert-deftest erc-nicks-track-faces/nil () + (should (eq erc-nicks-track-faces 'prioritize)) + (let (erc-nicks-track-faces) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result _ bob-face alice-face) + + (defvar erc-track--face-reject-function) + (should erc-track--face-reject-function) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line indicator changes to the + ;; only ranked face in the message. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 . erc-default-face)) + + ;; That same someone speaks, and since no other "normals" exist + ;; in the message, the indicator is not updated. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(3 . erc-default-face)) + + ;; Now the same person mentions another server user, but the same + ;; logic applies, and the indicator is not updated. + (funcall set-faces `(erc-timestamp-face + (,alice-face erc-default-face) + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(4 . erc-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(5 . erc-notice-face)))))) + ;;; erc-nicks-tests.el ends here diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index 8149138a971..c830c8b2016 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -227,6 +227,13 @@ erc-track-select-mode-line-face (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))) + + (setq ranked (cons (map-into (mapcar (let ((i 0)) + (lambda (f) (cons f (cl-incf i)))) + ranked) + '(hash-table :test equal)) + ranked)) + (pcase-dolist (`(,want ,cur-face ,new-faces) cases) (ert-info ((format "Observed: {cur: %S, new: %S, want: %S}" @@ -235,8 +242,8 @@ erc-track-tests--select-mode-line-face (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)))))) + (should (equal want (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 @@ -410,4 +417,255 @@ erc-track--collect-faces-in (when noninteractive (kill-buffer)))) +(defun erc-track-tests--modified-channels/baseline (set-faces) + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, and the mode-line face goes from ERC's generic + ;; "notice" face, `erc-notice-face', to the first face in the + ;; inserted message that outranks it, which happens to be the + ;; `button' module's composite face for buttonized speakers: + ;; (erc-button-nick-default-face erc-nick-default-face). It + ;; outranks both the previous occupant, `erc-notice-face', and its + ;; one cohabitant in the message text, `erc-default-face', in + ;; `erc-track-faces-priority-list'. Note that in the following + ;; list, `erc-default-face' appears first because it's used for the + ;; opening speaker bracket "<". The timestamp appears last because + ;; it's a right-sided stamp appended to the message body. + (funcall set-faces '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; The speaker speaks again immediately, and the segment changes to + ;; `erc-default-face', which appears later in the message, as + ;; normal body text. This happens because both `erc-default-face' + ;; and (erc-button-nick-default-face erc-nick-default-face) appear + ;; in `erc-track-faces-normal-list', meaning the lower-ranked + ;; former can replace the higher-ranked latter in the mode-line for + ;; the purpose of indicating channel activity. + (funcall set-faces '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 . erc-default-face))) + + ;; Note: if (erc-button-nick-default-face erc-nick-default-face) + ;; were removed from `erc-track-faces-priority-list' but kept in + ;; `erc-track-faces-normal-list', then replaying the sequence would + ;; result in the previous two results being switched: + ;; `erc-default-face' would replace `erc-notice-face' before being + ;; replaced by the buttonized composite. + + ;; The speaker speaks yet again, and the segment goes back to the + ;; higher ranking face. + (funcall set-faces '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. Although lower ranked, it also + ;; appears in `erc-track-faces-normal-list' and so is eligible to + ;; replace the incumbent. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(5 . erc-notice-face)))) + +(ert-deftest erc-track-modified-channels/baseline () + (erc-tests-common-track-modified-channels + #'erc-track-tests--modified-channels/baseline)) + +(ert-deftest erc-track-modified-channels/baseline/mention () + (erc-tests-common-track-modified-channels + (lambda (set-faces) + ;; Note: these messages don't have timestamps. + + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, mentioning someone else, and the mode-line + ;; changes to (erc-button-nick-default-face erc-nick-default-face) + ;; rather than (erc-button-nick-default-face erc-default-face) + ;; based on their rankings in `erc-track-faces-priority-list'. + (funcall set-faces '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; Someone else speaks, again with a mention and additional body text. + (funcall set-faces '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-default-face))) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(5 . erc-notice-face)))))) + +;; The compat-oriented option `erc-track-ignore-normal-contenders-p' +;; blinds track to `erc-track-faces-normal-list' for certain consecutive +;; messages with an identical face makeup. +(ert-deftest erc-track-modified-channels/baseline/ignore () + (let ((erc-track-ignore-normal-contenders-p t)) + (erc-tests-common-track-modified-channels + (lambda (set-faces) + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, and the mode-line indicator's face changes to + ;; that of a buttonized speaker. + (funcall set-faces + '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; The speaker speaks again immediately, and the segment doesn't + ;; change. + (funcall set-faces + '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 . erc-notice-face))))))) + +;; Compat-oriented option `erc-track-ignore-normal-contenders-p'. +(ert-deftest erc-track-modified-channels/baseline/mention/ignore () + (let ((erc-track-ignore-normal-contenders-p t)) + (erc-tests-common-track-modified-channels + (lambda (set-faces) + + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, and the mode-line indicator's face changes to + ;; that of a buttonized speaker. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; Someone else speaks, again with a mention and additional body + ;; text, but the indicator stays the same. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 . erc-notice-face))))))) + +;; Option `erc-track-priority-faces-only' does not affect the behavior +;; of the baseline "normals" scenario because all faces appear in +;; `erc-track-faces-priority-list'. +(ert-deftest erc-track-modified-channels/priority-only-all/baseline () + (let ((erc-track-priority-faces-only 'all)) + (erc-tests-common-track-modified-channels + #'erc-track-tests--modified-channels/baseline))) + +;; This test simulates a common configuration that combines an +;; `erc-track-faces-priority-list' removed of `erc-notice-face' with +;; `erc-track-priority-faces-only' being `all'. It also features in the +;; sample configuration in ERC's manual. +(ert-deftest erc-track-modified-channels/priority-only-all/sans-notice () + (let ((erc-track-priority-faces-only 'all) + (erc-track-faces-priority-list + (remq 'erc-notice-face erc-track-faces-priority-list))) + + (erc-tests-common-track-modified-channels + (lambda (set-faces) + ;; Note: these messages don't have timestamps. + + ;; Simulate a message normally displayed in `erc-notice-face', + ;; which has been removed from `erc-track-faces-priority-list'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should-not (alist-get (current-buffer) erc-modified-channels-alist)) + + ;; Someone speaks, mentioning someone else, and the mode-line + ;; changes to the buttonized speaker face rather than the + ;; buttonized mention face, due to their respective ranks. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 erc-button-nick-default-face erc-nick-default-face))) + + ;; Someone else speaks, again with a mention and additional body text. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-default-face))) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives, which is ignored. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face + erc-nick-default-face))))))) + ;;; erc-track-tests.el ends here diff --git a/test/lisp/erc/resources/erc-tests-common.el b/test/lisp/erc/resources/erc-tests-common.el index 1cd54a1f715..91654467dae 100644 --- a/test/lisp/erc/resources/erc-tests-common.el +++ b/test/lisp/erc/resources/erc-tests-common.el @@ -330,4 +330,47 @@ erc-tests-common-create-subprocess (set-process-query-on-exit-flag proc t) proc)) +(declare-function erc-track--setup "erc-track" ()) + +(defun erc-tests-common-track-modified-channels (test) + (erc-tests-common-prep-for-insertion) + (setq erc--target (erc--target-from-string "#chan")) + (erc-tests-common-track-modified-channels-sans-setup test)) + +(defun erc-tests-common-track-modified-channels-sans-setup (test) + "Provide a fixture for testing `erc-track-modified-channels'. +Call function TEST with another function that sets the mocked return +value of `erc-track--collect-faces-in' to the given argument, a list of +faces in the reverse order they appear in an inserted message." + (defvar erc-modified-channels-alist) + (defvar erc-modified-channels-object) + (defvar erc-track--attn-faces) + (defvar erc-track--normal-faces) + (defvar erc-track--priority-faces) + (defvar erc-track-faces-normal-list) + (defvar erc-track-faces-priority-list) + (defvar erc-track-mode) + + (cl-letf* ((erc-track-mode t) + (erc-modified-channels-alist nil) + (erc-modified-channels-object erc-modified-channels-object) + (faces ()) + ((symbol-function 'force-mode-line-update) #'ignore) + ((symbol-function 'erc-faces-in) (lambda (_) faces)) + ((symbol-function 'erc-track--collect-faces-in) + (lambda () + (cons (map-into (mapcar (lambda (f) (cons f t)) faces) + '(hash-table :test equal)) + faces)))) + (erc-track--setup) + + ;; Faces from `erc-track--attn-faces' prepended. + (should (= (+ (length erc-track--attn-faces) + (length erc-track-faces-priority-list)) + (hash-table-count erc-track--priority-faces))) + (should (= (length erc-track-faces-normal-list) + (hash-table-count erc-track--normal-faces))) + + (funcall test (lambda (arg) (setq faces arg))))) + (provide 'erc-tests-common) -- 2.46.1 --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Fri Oct 04 04:31:14 2024 Received: (at 67767) by debbugs.gnu.org; 4 Oct 2024 08:31:14 +0000 Received: from localhost ([127.0.0.1]:34368 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1swdiQ-0006dZ-Q0 for submit@debbugs.gnu.org; Fri, 04 Oct 2024 04:31:14 -0400 Received: from mail-108-mta78.mxroute.com ([136.175.108.78]:41639) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1swdiL-0006dO-M2 for 67767@debbugs.gnu.org; Fri, 04 Oct 2024 04:31:09 -0400 Received: from filter006.mxroute.com ([136.175.111.3] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta78.mxroute.com (ZoneMTA) with ESMTPSA id 19256a757640003e01.001 for <67767@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Fri, 04 Oct 2024 08:31:00 +0000 X-Zone-Loop: a7357b1c4e5f53cc0f9992c4f03b8803a66babb80420 X-Originating-IP: [136.175.111.3] 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=DTN3jxlM9QK0yusnBOjIEvd9dp+al3GUXoEDaxprUiI=; b=RphFBUMNVWKt/oaQMDOvm7tka/ ShSCSMvQviOigq/WQ4ARcdCm9RJGKBE1/tR9hU3f9XmV0tz597EU6wivJO9BoqixxkgpVyaw7sM6Q UQBF+r9WJV8SRS66kd6XmyPnBR5JuNGV8xU3XAyVXVjKe3pyoekvJVSnGMccGIAhjqcj32Ybis6wA KZZ8FhqJC5AnXTfhWRWZdq1nX+Dgu50ITYkGbSH2P6fe/CNBicExbuVG+9StDtZFdaCJxas2vYMER k4COKAP/CPAxDeX0qb6yoMDxwUak7npRe5CfT3kv0FEcOctzFSz5FuSRd/HbpB9PdtnkPOUvZTjal PITRFxWQ==; From: "J.P." To: 67767@debbugs.gnu.org Subject: Re: bug#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module In-Reply-To: <87ed52q8rd.fsf@neverwas.me> (J. P.'s message of "Sun, 29 Sep 2024 17:34:46 -0700") References: <87edfs3gj4.fsf@neverwas.me> <87ed52q8rd.fsf@neverwas.me> Date: Fri, 04 Oct 2024 01:30:56 -0700 Message-ID: <87ldz4b77j.fsf@neverwas.me> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Authenticated-Id: masked@neverwas.me X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 67767 Cc: Trevor Arjeski , emacs-erc@gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain "J.P." writes: > It's been pointed out that the most recent attempt at improving the > situation, especially with regard to the option `erc-nicks-track-faces', > ended up perpetuating rather unintuitive aspects of the original > behavior in certain common situations. [...] > > Another problem with the current "normals" behavior is that it fails to > adequately exhibit the "flickering" effect when `nicks' _isn't_ enabled. > You can see this by connecting using the default configuration. Notice > that the mode-line segment stays on `erc-default-face while users are > conversing so long as they don't mention one another. However, the > "normals" feature was always meant to provide more responsive feedback > to clearly indicate active conversations (including monologuing). The > patch tries to address this by adding the default buttonized speaker > face to the related options `erc-track-faces-priority-list' and > `erc-track-faces-normal-list'. If there's a smarter way, hopefully > someone will speak up. Attached is a v2 introducing a `t' choice for `erc-nicks-track-faces'. It suppresses the "alternating" effect associated with the option `erc-track-faces-normal-list'. See [1] for additional context. This strays into new feature territory, which should be verboten for patch releases. However, since closely related code exhibits bug-like inconsistencies addressed by this patch, and such an addition might help improve users' mental model in terms of predictability vis-a-vis the current slate of related options, it seems a somewhat justifiable inclusion (IMO). OTOH, we could just as well wait until 5.7. [1] https://lists.gnu.org/archive/html/emacs-erc/2024-10/msg00006.html --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0000-v1-v2.diff >From 417de6ebaf70fe4dfcf3cc03171f01e4c42a6d52 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Fri, 4 Oct 2024 00:01:38 -0700 Subject: [PATCH 0/1] *** NOT A PATCH *** v2. Add new `t' variant for `erc-nicks-track-faces', which suppresses the "alternating" behavior associated with `erc-track-faces-normal-list'. Refactor related aspects of erc-nicks.el to facilitate this. Add supporting test. F. Jason Park (1): [5.6.1] Clarify behavior of erc-nicks-track-faces variants etc/ERC-NEWS | 13 + lisp/erc/erc-nicks.el | 89 +++++-- lisp/erc/erc-track.el | 219 ++++++++++------ test/lisp/erc/erc-nicks-tests.el | 269 +++++++++++++++++++- test/lisp/erc/erc-track-tests.el | 262 ++++++++++++++++++- test/lisp/erc/resources/erc-tests-common.el | 43 ++++ 6 files changed, 787 insertions(+), 108 deletions(-) Interdiff: diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index d5df54256af..ea65a170b38 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -42,6 +42,12 @@ speaker names, with the latter option also gaining 'erc-notice-face'. This was done to provide a more frequent and practical indication of channel activity in keeping with the module's original design. +** An arguably less distracting 'erc-nicks-track-faces' variant. +Setting this option to t tells the 'track' module to have the mode-line +indicator stick with the most recent speaker's face, even when they're +monologuing, instead of alternating between it and the highest ranked +'erc-track-faces-normal-list' member in a given message. + * Changes in ERC 5.6 diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index a17900d9330..3aed985ea21 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -175,17 +175,20 @@ erc-nicks-key-suffix-format (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. -A value of `prioritize' works like `defer' when speakers stay the -same but allows a new speaker's face to impersonate a ranked -normal so nick faces can alternate back-to-back. 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))) +A value of nil means don't show `nicks'-managed faces at all. A value +of t means treat them as non-\"normal\" faces ranked at or below +`erc-default-face'. This has the effect of always showing them while +suppressing the \"alternating\" behavior normally associated with +`erc-track-faces-normal-list' (including between the speaker and nicks +mentioned in the message body.) A value of `defer' means treat nicks as +unranked normals to favor alternating between them and ranked normals. +A value of `prioritize' exhibits the same alternating effect as `defer' +when speakers stay the same but allows a new speaker's face to +impersonate a ranked normal so that adjacent speakers alternate among +themselves before deferring to non-face normals. 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 boolean (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'.") @@ -597,7 +600,9 @@ nicks (remove-function (local 'erc-button--modify-nick-function) #'erc-nicks--highlight-button) (remove-function (local 'erc-track--alt-normals-function) - #'erc-nicks--check-normals) + #'erc-nicks--track-prioritize) + (remove-function (local 'erc-track--alt-normals-function) + #'erc-nicks--track-always) (remove-hook 'erc-track-mode-hook #'erc-nicks--setup-track-integration t) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil 'remove #'equal) @@ -726,7 +731,8 @@ erc-nicks--reject-uninterned-faces (setq candidate (cdr candidate))) (erc--solo candidate)) -(define-inline erc-nicks--oursp (face) +(define-inline erc-nicks--ours-p (face) + "Return uninterned `nicks'-created face if FACE is a known list of faces." (inline-quote (and-let* ((sym (car-safe ,face)) ((symbolp sym)) @@ -738,29 +744,43 @@ erc-nicks-track-normal-max-rank Must appear in both `erc-track-faces-priority-list' and `erc-track-faces-normal-list'.") -(defun erc-nicks--check-normals (current contender contenders ranks normals) - "Return a viable non-CURRENT `nicks' face in CONTENDERS. -But only do so if CURRENT and CONTENDER are \"normal\" faces either -unranked or at or below `erc-nicks-track-normal-max-rank'. See -`erc-track--select-mode-line-face' for the expected types of CONTENDERS, -RANKS, and NORMALS." - (and-let* (((or (null contender) (gethash contender normals))) - ((or (null current) (gethash current normals))) - (threshold (gethash erc-nicks-track-normal-max-rank (car ranks))) - ((<= threshold (or (gethash contender (car ranks)) - ;; Unranked `contender' always replaceable. - most-positive-fixnum))) - (spkr (or (erc-nicks--oursp current) - ;; Use t to mean `current' is not a nick face but - ;; replaceable nonetheless. - (null current) - (<= threshold (or (gethash current (car ranks)) 0))))) +(defun erc-nicks--assess-track-faces (current contender ranks normals) + "Return symbol face for CURRENT or t, to mean CURRENT is replaceable. +But only do so if CURRENT and CONTENDER are either nil or \"normal\" +faces ranking at or below `erc-nicks-track-normal-max-rank'. See +`erc-track--select-mode-line-face' for the expected types of RANKS and +NORMALS. Expect a non-nil CONTENDER to always be ranked." + (and-let* + (((or (null contender) (gethash contender normals))) + ((or (null current) (gethash current normals))) + (threshold (gethash erc-nicks-track-normal-max-rank (car ranks))) + ((or (null contender) (<= threshold (gethash contender (car ranks))))) + ((or (erc-nicks--ours-p current) + (null current) + (<= threshold (or (gethash current (car ranks)) 0))))))) + +(defun erc-nicks--track-prioritize (current contender contenders ranks normals) + "Return a viable non-CURRENT `nicks' face among CONTENDERS. +See `erc-track--select-mode-line-face' for parameter types." + (when-let + ((spkr (erc-nicks--assess-track-faces current contender ranks normals))) (catch 'contender (dolist (candidate (cdr contenders)) (when-let (((not (equal candidate current))) - ((gethash candidate normals)) - (s (erc-nicks--oursp candidate)) + (s (erc-nicks--ours-p candidate)) ((not (eq s spkr)))) + (cl-assert (gethash candidate normals)) + (throw 'contender candidate)))))) + +(defun erc-nicks--track-always (current contender contenders ranks normals) + "Return a viable `nicks' face, possibly CURRENT, among CONTENDERS. +See `erc-track--select-mode-line-face' for parameter types." + (when-let + ((spkr (erc-nicks--assess-track-faces current contender ranks normals))) + (catch 'contender + (dolist (candidate (cdr (reverse contenders))) + (when (erc-nicks--ours-p candidate) + (cl-assert (gethash candidate normals)) (throw 'contender candidate)))))) (defun erc-nicks--setup-track-integration () @@ -770,7 +790,10 @@ erc-nicks--setup-track-integration ;; Variant `defer' is handled elsewhere. ('prioritize (add-function :override (local 'erc-track--alt-normals-function) - #'erc-nicks--check-normals)) + #'erc-nicks--track-prioritize)) + ((or 't 'always) + (add-function :override (local 'erc-track--alt-normals-function) + #'erc-nicks--track-always)) ('nil (add-function :override (local 'erc-track--face-reject-function) #'erc-nicks--reject-uninterned-faces))))) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index 75cb98b8407..c865a902a0e 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -788,4 +788,51 @@ erc-nicks-track-faces/nil (erc-track-modified-channels) (funcall assert-result '(5 . erc-notice-face)))))) +(ert-deftest erc-nicks-track-faces/t () + (should (eq erc-nicks-track-faces 'prioritize)) + (let ((erc-nicks-track-faces t)) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result add-face bob-face alice-face) + + (defvar erc-track--alt-normals-function) + (should erc-track--alt-normals-function) + + (funcall add-face bob-face) + (funcall add-face alice-face) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line indicator changes to that + ;; someone's `nicks'-owned face. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 ,bob-face erc-nick-default-face)) + + ;; That same someone speaks, and though one other "normal" exists + ;; in the message, `erc-default-face', no update occurs. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(3 ,bob-face erc-nick-default-face)) + + ;; Another server user speaks, mentioning the previous speaker, + ;; and the indicator is updated to reflect the new speaker. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-default-face) ; bob: + (,alice-face erc-nick-default-face) ; + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(4 ,alice-face erc-nick-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(5 . erc-notice-face)))))) + ;;; erc-nicks-tests.el ends here -- 2.46.2 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-5.6.1-Clarify-behavior-of-erc-nicks-track-faces-vari.patch >From 417de6ebaf70fe4dfcf3cc03171f01e4c42a6d52 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 26 Sep 2024 21:34:25 -0700 Subject: [PATCH 1/1] [5.6.1] Clarify behavior of erc-nicks-track-faces variants * etc/ERC-NEWS: Mention changes to `erc-track-faces-normal-list' and `erc-track-faces-priority-list'. Also mention new choice variant for option `erc-nicks-track-faces'. * lisp/erc/erc-nicks.el (erc-nicks-track-faces): Update doc, and introduce new `t' value choice. (erc-nicks-mode, erc-nicks-disable): Update removals from `erc-track--alt-normals-function' to reflect recent refactoring. (erc-nicks--reject-uninterned-faces): Use helper. (erc-nicks--oursp, erc-nicks--ours-p): Rename former to latter to respect project style guidelines regarding predicates. (erc-nicks-track-normal-max-rank): New variable. (erc-nicks--check-normals, erc-nicks--assess-track-faces): Rename former to latter and change purpose to checking for "normals" membership, ranks position, and incumbent face ownership. Remove unused CONTENDERS parameter. Also change behavior to consider replacing the current mode-line face when it's not `nicks' owned if it's explicitly ranked lower than `erc-default-face'. (erc-nicks--track-prioritize, erc-nicks--track-always): New complementary functions implementing the t and `prioritize' variants of `erc-nicks-track-faces'. Both make use of the factored-out `erc-nicks--check-normals' logic. (erc-nicks--setup-track-integration): Add `erc-nicks--track-always' to `erc-track--alt-normals-function' when `erc-track-normal-faces' is t. * lisp/erc/erc-track.el (erc-track--massage-nick-button-faces): Change type of symbol property `erc-track--obsolete-faces' for options `erc-track-faces-priority-list' and friends from a boolean to an alist. (erc-track-faces-priority-list): Add new face for buttonized speakers. (erc-track-faces-normal-list): Add new face for buttonized speakers. Also add `erc-notice-face'. (erc-track--priority-faces): New local variable to cache ranked faces. (erc-track--setup): Initialize new `erc-track--priority-faces' variable and refactor. (erc-track--alt-normals-function): Doc. (erc-track--select-mode-line-face): Update expected type of `ranks' parameter. (erc-track-modified-channels): Fix wrong-type bug occurring when `erc-track-ignore-normal-contenders-p' and `erc-track-priority-faces-only' are both non-nil. Also fix subtle compatibility oversight regarding an empty face list returned by `erc-track--collect-faces-in'. * test/lisp/erc/erc-nicks-tests.el: Load helpers and fixtures library. (erc-nicks-tests--track-faces): New function. (erc-nicks-track-faces/prioritize, erc-nicks-track-faces/defer) (erc-nicks-track-faces/nil, erc-nicks-track-faces/t): New tests. * test/lisp/erc/erc-track-tests.el (erc-track-tests--select-mode-line-face): Update expected type of mocked parameter. (erc-track-tests--modified-channels/baseline): New function. (erc-track-modified-channels/baseline) (erc-track-modified-channels/baseline/mention) (erc-track-modified-channels/baseline/ignore) (erc-track-modified-channels/baseline/mention/ignore) (erc-track-modified-channels/priority-only-all/baseline) (erc-track-modified-channels/priority-only-all/sans-notice): New tests. * test/lisp/erc/resources/erc-tests-common.el (erc-tests-common-track-modified-channels) (erc-tests-common-track-modified-channels-sans-setup): New functions. (Bug67767) --- etc/ERC-NEWS | 13 + lisp/erc/erc-nicks.el | 89 +++++-- lisp/erc/erc-track.el | 219 ++++++++++------ test/lisp/erc/erc-nicks-tests.el | 269 +++++++++++++++++++- test/lisp/erc/erc-track-tests.el | 262 ++++++++++++++++++- test/lisp/erc/resources/erc-tests-common.el | 43 ++++ 6 files changed, 787 insertions(+), 108 deletions(-) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index b267db5502e..ea65a170b38 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -35,6 +35,19 @@ has been removed. Option 'erc-keep-place-indicator-truncation' manages the tension between truncation and place keeping, prioritizing one or the other. +** Updated defaults for the 'track' module's face-list options. +The default values of options 'erc-track-faces-priority-list' and +'erc-track-faces-normal-list' have both gained a face for buttonized +speaker names, with the latter option also gaining 'erc-notice-face'. +This was done to provide a more frequent and practical indication of +channel activity in keeping with the module's original design. + +** An arguably less distracting 'erc-nicks-track-faces' variant. +Setting this option to t tells the 'track' module to have the mode-line +indicator stick with the most recent speaker's face, even when they're +monologuing, instead of alternating between it and the highest ranked +'erc-track-faces-normal-list' member in a given message. + * Changes in ERC 5.6 diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index a0d6d17d732..3aed985ea21 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -175,17 +175,20 @@ erc-nicks-key-suffix-format (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))) +A value of nil means don't show `nicks'-managed faces at all. A value +of t means treat them as non-\"normal\" faces ranked at or below +`erc-default-face'. This has the effect of always showing them while +suppressing the \"alternating\" behavior normally associated with +`erc-track-faces-normal-list' (including between the speaker and nicks +mentioned in the message body.) A value of `defer' means treat nicks as +unranked normals to favor alternating between them and ranked normals. +A value of `prioritize' exhibits the same alternating effect as `defer' +when speakers stay the same but allows a new speaker's face to +impersonate a ranked normal so that adjacent speakers alternate among +themselves before deferring to non-face normals. 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 boolean (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'.") @@ -597,7 +600,9 @@ nicks (remove-function (local 'erc-button--modify-nick-function) #'erc-nicks--highlight-button) (remove-function (local 'erc-track--alt-normals-function) - #'erc-nicks--check-normals) + #'erc-nicks--track-prioritize) + (remove-function (local 'erc-track--alt-normals-function) + #'erc-nicks--track-always) (remove-hook 'erc-track-mode-hook #'erc-nicks--setup-track-integration t) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil 'remove #'equal) @@ -724,29 +729,58 @@ erc-nicks--reject-uninterned-faces ((facep next)) ((not (intern-soft next)))) (setq candidate (cdr candidate))) - (if (and (consp candidate) (not (cdr candidate))) (car candidate) candidate)) + (erc--solo candidate)) -(define-inline erc-nicks--oursp (face) +(define-inline erc-nicks--ours-p (face) + "Return uninterned `nicks'-created face if FACE is a known list of faces." (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'." - (and-let* (((eq contender 'erc-default-face)) - ((or (null current) (gethash current normals))) - (spkr (or (null current) (erc-nicks--oursp current)))) +(defvar erc-nicks-track-normal-max-rank 'erc-default-face + "Highest priority normal face still eligible to alternate with `nicks' faces. +Must appear in both `erc-track-faces-priority-list' and +`erc-track-faces-normal-list'.") + +(defun erc-nicks--assess-track-faces (current contender ranks normals) + "Return symbol face for CURRENT or t, to mean CURRENT is replaceable. +But only do so if CURRENT and CONTENDER are either nil or \"normal\" +faces ranking at or below `erc-nicks-track-normal-max-rank'. See +`erc-track--select-mode-line-face' for the expected types of RANKS and +NORMALS. Expect a non-nil CONTENDER to always be ranked." + (and-let* + (((or (null contender) (gethash contender normals))) + ((or (null current) (gethash current normals))) + (threshold (gethash erc-nicks-track-normal-max-rank (car ranks))) + ((or (null contender) (<= threshold (gethash contender (car ranks))))) + ((or (erc-nicks--ours-p current) + (null current) + (<= threshold (or (gethash current (car ranks)) 0))))))) + +(defun erc-nicks--track-prioritize (current contender contenders ranks normals) + "Return a viable non-CURRENT `nicks' face among CONTENDERS. +See `erc-track--select-mode-line-face' for parameter types." + (when-let + ((spkr (erc-nicks--assess-track-faces current contender ranks normals))) (catch 'contender - (dolist (candidate (cdr contenders) contender) + (dolist (candidate (cdr contenders)) (when-let (((not (equal candidate current))) - ((gethash candidate normals)) - (s (erc-nicks--oursp candidate)) + (s (erc-nicks--ours-p candidate)) ((not (eq s spkr)))) + (cl-assert (gethash candidate normals)) + (throw 'contender candidate)))))) + +(defun erc-nicks--track-always (current contender contenders ranks normals) + "Return a viable `nicks' face, possibly CURRENT, among CONTENDERS. +See `erc-track--select-mode-line-face' for parameter types." + (when-let + ((spkr (erc-nicks--assess-track-faces current contender ranks normals))) + (catch 'contender + (dolist (candidate (cdr (reverse contenders))) + (when (erc-nicks--ours-p candidate) + (cl-assert (gethash candidate normals)) (throw 'contender candidate)))))) (defun erc-nicks--setup-track-integration () @@ -756,7 +790,10 @@ erc-nicks--setup-track-integration ;; Variant `defer' is handled elsewhere. ('prioritize (add-function :override (local 'erc-track--alt-normals-function) - #'erc-nicks--check-normals)) + #'erc-nicks--track-prioritize)) + ((or 't 'always) + (add-function :override (local 'erc-track--alt-normals-function) + #'erc-nicks--track-always)) ('nil (add-function :override (local 'erc-track--face-reject-function) #'erc-nicks--reject-uninterned-faces))))) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index f40960e4a22..82e5f402910 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -161,25 +161,33 @@ erc-track-use-faces \(e.g. `erc-pal-face' is used if a pal sent a message to that channel.)" :type 'boolean) +;; In an emergency, users can opt out of this migration with: +;; +;; (put 'erc-track-faces-priority-list 'erc-track--obsolete-faces t) +;; (put 'erc-track-faces-normal-list 'erc-track--obsolete-faces t) +;; (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, set the symbol property `erc-track--obsolete-faces' of -SYM to t." - (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))))) + "Transform VAL of face-list option SYM to remove/replace obsolete items. +Use `set'-compatible SET-FN when given. Record any migrations as cons +cells of (OLD . NEW) in the symbol property `erc-track--obsolete-faces' +of SYM." + (let* ((oldface '(erc-nick-default-face erc-default-face)) + (newface '(erc-button-nick-default-face erc-default-face)) + (migrations (get sym 'erc-track--obsolete-faces)) + (new (if migrations + val + (delq nil + (mapcar + (lambda (f) + (if (equal f oldface) + (setf (alist-get oldface migrations + nil nil #'equal) + (and (not (member newface val)) newface)) + f)) + val))))) + (when migrations + (put sym 'erc-track--obsolete-faces migrations)) + (if set-fn (funcall set-fn sym new) (set-default sym new)))) (defcustom erc-track-faces-priority-list '(erc-error-face @@ -191,6 +199,7 @@ erc-track-faces-priority-list (erc-button erc-default-face) erc-dangerous-host-face erc-nick-default-face + (erc-button-nick-default-face erc-nick-default-face) (erc-button-nick-default-face erc-default-face) erc-default-face erc-action-face @@ -204,7 +213,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.6") + :package-version '(ERC . "5.6.1") :set #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) @@ -229,8 +238,10 @@ erc-track-faces-normal-list '((erc-button erc-default-face) erc-dangerous-host-face erc-nick-default-face + (erc-button-nick-default-face erc-nick-default-face) (erc-button-nick-default-face erc-default-face) erc-default-face + erc-notice-face erc-action-face) "A list of faces considered to be part of normal conversations. This list is used to highlight active buffer names in the mode line. @@ -246,7 +257,7 @@ erc-track-faces-normal-list \\[erc-track-mode]. The effect may be disabled by setting this variable to nil." - :package-version '(ERC . "5.6") + :package-version '(ERC . "5.6.1") :set #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) @@ -636,49 +647,79 @@ erc-track-when-inactive (erc-track-enable)) (set sym val)))) +(defvar-local erc-track--priority-faces nil + "Local copy of `erc-track-faces-priority-list' as a hash table. +Keys are faces and values are rank integers (smaller is more important).") + (defvar-local erc-track--normal-faces nil - "Local copy of `erc-track-faces-normal-list' as a hash table.") + "Local copy of `erc-track-faces-normal-list' as a hash table. +Keys and values are faces. The table is weak valued so it can double as +a buttonizing cache. See `erc-button-add-button' and `erc--merge-prop'.") (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 this is a server buffer or either `erc-track-faces-normal-list' or +`erc-track-faces-priority-list' is locally bound, create a new cache +table with corresponding local variable `erc-track--normal-faces' or +`erc-track--priority-faces'. Otherwise, in target buffers with no local +binding, set the cache variable's local value to that of server'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) + (let (warnp) ;; 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) + (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 (local-variable-p opt) (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)) + (when-let ((migrations (get opt 'erc-track--obsolete-faces)) + ((consp migrations))) + (push (cons opt + (mapcar (pcase-lambda (`(,old . ,new)) + (format (if new "changed %s to %s" + "removed %s") + old new)) + migrations)) + 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)))) + (pcase-dolist (`(,opt . ,migrations) warnp) + (erc--warn-once-before-connect 'erc-track-mode + "Option `%S' contains " + (if (cdr migrations) "obsolete items." "an obsolete item.") + " ERC has done the following for the current session: %s." + " Please review these changes and, if convinced," + " silence this message by saving the current value." + opt (string-join migrations ", "))))) + ;; Set `erc-track--priority-faces' cache to new or shared value. + (let* ((localp (and erc--target + (local-variable-p 'erc-track-faces-priority-list))) + (existing (erc-with-server-buffer erc-track--priority-faces)) + (table (or (and (not localp) existing) + (let ((p 0)) + (map-into + (mapcar (lambda (f) (cons f (cl-incf p))) + (append erc-track--attn-faces + erc-track-faces-priority-list)) + `(hash-table :test equal)))))) + (setq erc-track--priority-faces table) + (unless (or localp existing) + (erc-with-server-buffer (setq erc-track--priority-faces table)))) + ;; Likewise for `erc-track--normal-faces' cache. + (let* ((localp (and erc--target + (local-variable-p 'erc-track-faces-normal-list))) + (existing (erc-with-server-buffer erc-track--normal-faces)) + (table (or (and (not localp) existing) + (map-into (mapcar (lambda (f) (cons f f)) + erc-track-faces-normal-list) + `(hash-table :test equal + :weakness value))))) + (setq erc-track--normal-faces table) + (unless (or localp existing) + (erc-with-server-buffer (setq erc-track--normal-faces table))))) + (kill-local-variable 'erc-track--priority-faces) (kill-local-variable 'erc-track--normal-faces))) ;;; Visibility @@ -915,44 +956,54 @@ erc-track-select-mode-line-face (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.") +followed by all new contending faces, ranked 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-faces-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." +Expect NEW-FACES to be a cons cell whose car is a hash table mapping +faces present in the applicable region to t and whose cdr is its car's +contents ordered from most recently seen (later in the buffer) to +earliest. Expect RANKS to be a cons cell whose car is a hash table +similar to `erc-track--priority-faces' and whose cdr is a list of +prioritized faces resembling `erc-track-faces-priority-list'. Expect +NORMALS to be a hash table mapping faces to themselves. In general, act +identically to `erc-track-select-mode-line-face', except appeal to +`erc-track--alt-normals-function' if it's non-nil, and fall back on +reconsidering only NEW-FACES appearing in NORMALS when CUR-FACE is +itself \"normal\" and outranks all NEW-FACES. That is, choose the first +among RANKS in both NEW-FACES and NORMALS not equal to CUR-FACE. +Failing that, choose the first face in both NEW-FACES and NORMALS." (cl-check-type erc-track-ignore-normal-contenders-p null) (cl-check-type new-faces cons) + ;; Choose the highest ranked face in `erc-track-faces-priority-list' + ;; that's either `cur-face' itself or one appearing in the region + ;; being processed. (when-let ((choice (catch 'face - (dolist (candidate ranks) + (dolist (candidate (cdr 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)) + cur-face choice new-faces ranks normals)) + ;; If `choice' is still `cur-face' and also a "normal", attempt + ;; to choose another normal in order to produce the flickering + ;; effect mentioned in the doc of `erc-track-faces-normal-list'. (and (equal choice cur-face) (gethash choice normals) (catch 'face + ;; If ranked "normal" faces other than `choice' appear in + ;; the region, return the most important one. (progn - (dolist (candidate ranks) + (dolist (candidate (cdr ranks)) (when (and (not (equal candidate choice)) (gethash candidate (car new-faces)) (gethash choice normals)) (throw 'face candidate))) + ;; Otherwise, go with any "normal" face other than + ;; `choice' in the region. (dolist (candidate (cdr new-faces)) (when (and (not (equal candidate choice)) (gethash candidate normals)) @@ -996,14 +1047,24 @@ erc-track-modified-channels (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) + (ranks (cons erc-track--priority-faces + 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))))))))) + ;; Iterate over the shorter of `ranks' and `faces'. + (let* ((r>fp (or erc-track-ignore-normal-contenders-p + (> (hash-table-count (car ranks)) + (hash-table-count (car faces))))) + (elems (cond ((not r>fp) (cdr ranks)) ; f>=r + (erc-track-ignore-normal-contenders-p + faces) + ((cdr faces)))) + (table (if r>fp (car ranks) (car faces)))) + (not (catch 'found + (dolist (f elems) + (when (gethash f table) + (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 @@ -1017,7 +1078,7 @@ erc-track-modified-channels nil faces ranks normals)))) erc-modified-channels-alist)) ;; Else modify the face for the buffer, if necessary. - (when faces + (when (or erc-track-ignore-normal-contenders-p (cdr faces)) (let* ((cell (assq (current-buffer) erc-modified-channels-alist)) (old-face (cddr cell)) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index 08080d249d5..c865a902a0e 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -30,8 +30,11 @@ ;;; Code: -(require 'ert-x) (require 'erc-nicks) +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) ;; This function replicates the behavior of older "invert" strategy ;; implementations from EmacsWiki, etc. The values for the lower and @@ -568,4 +571,268 @@ erc-nicks--create-coerced-pool (should (equal erc-nicks--colors-rejects '(t))))) +(declare-function erc-track-modified-channels "erc-track" ()) + +(defun erc-nicks-tests--track-faces (test) + (require 'erc-track) + (defvar erc-modified-channels-alist) + (defvar erc-track--normal-faces) + + (erc-tests-common-make-server-buf) + (erc-nicks-mode +1) + + (let ((erc-modules (cons 'nicks erc-modules)) + ;; Pretend these faces were added in response-handling during + ;; insertion modification by buttonizing hooks. See + ;; `erc-nicks--highlight-button'. + (add-face (lambda (face) + (erc-nicks--remember-face-for-track ; speaker + (list face 'erc-nick-default-face)) + (erc-nicks--remember-face-for-track ; mention + (list face 'erc-default-face)))) + ;; + bob-face alice-face assert-result) + + (with-current-buffer (erc--open-target "#chan") + (should erc-nicks-mode) + (should (setq bob-face (erc-nicks--get-face "bob" "bob@foonet"))) + (should (setq alice-face (erc-nicks--get-face "alice" "alice@foonet"))) + + (erc-tests-common-track-modified-channels-sans-setup + + (lambda (set-faces) + + (setq assert-result ; fixture binds `erc-modified-channels-alist' + (lambda (result) + (should (equal (alist-get (current-buffer) + erc-modified-channels-alist) + result)))) + + (funcall test set-faces assert-result add-face + bob-face alice-face))))) + + (erc-tests-common-kill-buffers)) + +(ert-deftest erc-nicks-track-faces/prioritize () + (should (eq erc-nicks-track-faces 'prioritize)) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result add-face bob-face alice-face) + + (defvar erc-track--alt-normals-function) + (should erc-track--alt-normals-function) + + (funcall add-face bob-face) + (funcall add-face alice-face) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line changes to a `nicks' owned + ;; composite face for the speaker. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 ,bob-face erc-nick-default-face)) + + ;; That same someone speaks, and the mode-line indicator changes to + ;; another "normal" face in the message body. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(3 . erc-default-face)) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(4 ,bob-face erc-nick-default-face)) + + ;; Now the same person mentions another server user, resulting in a + ;; change to *that* `nicks' owned face because it appears later in + ;; the message content (timestamp is last). + (funcall set-faces `(erc-timestamp-face + (,alice-face erc-default-face) + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(5 ,alice-face erc-default-face)) + + ;; The mentioned user replies, mentioning the mentioner. But + ;; instead of the normal "normals" processing preferring the ranked + ;; `erc-default-face', the `erc-nicks-track-faces' logic kicks in + ;; via `erc-track--alt-normals-function' and provides a `nicks' + ;; owned replacement. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-default-face) + (,alice-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(6 ,bob-face erc-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(7 . erc-notice-face))))) + +(ert-deftest erc-nicks-track-faces/defer () + (should (eq erc-nicks-track-faces 'prioritize)) + (let ((erc-nicks-track-faces 'defer)) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result add-face bob-face alice-face) + + (funcall add-face bob-face) + (funcall add-face alice-face) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line indicator changes to the + ;; highest ranked face in the message. (All `nicks' owned faces + ;; are unranked). + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 . erc-default-face)) + + ;; That same someone speaks, and the mode-line indicator changes + ;; to a `nicks' owned face. It first reaches for the highest + ;; ranked face in the message but then applies the "normals" + ;; rules, resulting in a promoted alternate. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(3 ,bob-face erc-nick-default-face)) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(4 . erc-default-face)) + + ;; The same person mentions another server user, resulting in a + ;; change to that `nicks' owned face because the logic from + ;; 3. again applies. + (funcall set-faces `(erc-timestamp-face + (,alice-face erc-default-face) + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(5 ,alice-face erc-default-face)) + + ;; The mentioned user replies, mentioning the mentioner. + ;; However, the `nicks' module does not intercede in the decision + ;; making to overrule the ranked nominee. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-default-face) + (,alice-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(6 . erc-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(7 . erc-notice-face)))))) + +(ert-deftest erc-nicks-track-faces/nil () + (should (eq erc-nicks-track-faces 'prioritize)) + (let (erc-nicks-track-faces) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result _ bob-face alice-face) + + (defvar erc-track--face-reject-function) + (should erc-track--face-reject-function) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line indicator changes to the + ;; only ranked face in the message. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 . erc-default-face)) + + ;; That same someone speaks, and since no other "normals" exist + ;; in the message, the indicator is not updated. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(3 . erc-default-face)) + + ;; Now the same person mentions another server user, but the same + ;; logic applies, and the indicator is not updated. + (funcall set-faces `(erc-timestamp-face + (,alice-face erc-default-face) + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(4 . erc-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(5 . erc-notice-face)))))) + +(ert-deftest erc-nicks-track-faces/t () + (should (eq erc-nicks-track-faces 'prioritize)) + (let ((erc-nicks-track-faces t)) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result add-face bob-face alice-face) + + (defvar erc-track--alt-normals-function) + (should erc-track--alt-normals-function) + + (funcall add-face bob-face) + (funcall add-face alice-face) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line indicator changes to that + ;; someone's `nicks'-owned face. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 ,bob-face erc-nick-default-face)) + + ;; That same someone speaks, and though one other "normal" exists + ;; in the message, `erc-default-face', no update occurs. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(3 ,bob-face erc-nick-default-face)) + + ;; Another server user speaks, mentioning the previous speaker, + ;; and the indicator is updated to reflect the new speaker. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-default-face) ; bob: + (,alice-face erc-nick-default-face) ; + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(4 ,alice-face erc-nick-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(5 . erc-notice-face)))))) + ;;; erc-nicks-tests.el ends here diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index 8149138a971..c830c8b2016 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -227,6 +227,13 @@ erc-track-select-mode-line-face (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))) + + (setq ranked (cons (map-into (mapcar (let ((i 0)) + (lambda (f) (cons f (cl-incf i)))) + ranked) + '(hash-table :test equal)) + ranked)) + (pcase-dolist (`(,want ,cur-face ,new-faces) cases) (ert-info ((format "Observed: {cur: %S, new: %S, want: %S}" @@ -235,8 +242,8 @@ erc-track-tests--select-mode-line-face (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)))))) + (should (equal want (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 @@ -410,4 +417,255 @@ erc-track--collect-faces-in (when noninteractive (kill-buffer)))) +(defun erc-track-tests--modified-channels/baseline (set-faces) + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, and the mode-line face goes from ERC's generic + ;; "notice" face, `erc-notice-face', to the first face in the + ;; inserted message that outranks it, which happens to be the + ;; `button' module's composite face for buttonized speakers: + ;; (erc-button-nick-default-face erc-nick-default-face). It + ;; outranks both the previous occupant, `erc-notice-face', and its + ;; one cohabitant in the message text, `erc-default-face', in + ;; `erc-track-faces-priority-list'. Note that in the following + ;; list, `erc-default-face' appears first because it's used for the + ;; opening speaker bracket "<". The timestamp appears last because + ;; it's a right-sided stamp appended to the message body. + (funcall set-faces '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; The speaker speaks again immediately, and the segment changes to + ;; `erc-default-face', which appears later in the message, as + ;; normal body text. This happens because both `erc-default-face' + ;; and (erc-button-nick-default-face erc-nick-default-face) appear + ;; in `erc-track-faces-normal-list', meaning the lower-ranked + ;; former can replace the higher-ranked latter in the mode-line for + ;; the purpose of indicating channel activity. + (funcall set-faces '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 . erc-default-face))) + + ;; Note: if (erc-button-nick-default-face erc-nick-default-face) + ;; were removed from `erc-track-faces-priority-list' but kept in + ;; `erc-track-faces-normal-list', then replaying the sequence would + ;; result in the previous two results being switched: + ;; `erc-default-face' would replace `erc-notice-face' before being + ;; replaced by the buttonized composite. + + ;; The speaker speaks yet again, and the segment goes back to the + ;; higher ranking face. + (funcall set-faces '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. Although lower ranked, it also + ;; appears in `erc-track-faces-normal-list' and so is eligible to + ;; replace the incumbent. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(5 . erc-notice-face)))) + +(ert-deftest erc-track-modified-channels/baseline () + (erc-tests-common-track-modified-channels + #'erc-track-tests--modified-channels/baseline)) + +(ert-deftest erc-track-modified-channels/baseline/mention () + (erc-tests-common-track-modified-channels + (lambda (set-faces) + ;; Note: these messages don't have timestamps. + + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, mentioning someone else, and the mode-line + ;; changes to (erc-button-nick-default-face erc-nick-default-face) + ;; rather than (erc-button-nick-default-face erc-default-face) + ;; based on their rankings in `erc-track-faces-priority-list'. + (funcall set-faces '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; Someone else speaks, again with a mention and additional body text. + (funcall set-faces '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-default-face))) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(5 . erc-notice-face)))))) + +;; The compat-oriented option `erc-track-ignore-normal-contenders-p' +;; blinds track to `erc-track-faces-normal-list' for certain consecutive +;; messages with an identical face makeup. +(ert-deftest erc-track-modified-channels/baseline/ignore () + (let ((erc-track-ignore-normal-contenders-p t)) + (erc-tests-common-track-modified-channels + (lambda (set-faces) + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, and the mode-line indicator's face changes to + ;; that of a buttonized speaker. + (funcall set-faces + '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; The speaker speaks again immediately, and the segment doesn't + ;; change. + (funcall set-faces + '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 . erc-notice-face))))))) + +;; Compat-oriented option `erc-track-ignore-normal-contenders-p'. +(ert-deftest erc-track-modified-channels/baseline/mention/ignore () + (let ((erc-track-ignore-normal-contenders-p t)) + (erc-tests-common-track-modified-channels + (lambda (set-faces) + + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, and the mode-line indicator's face changes to + ;; that of a buttonized speaker. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; Someone else speaks, again with a mention and additional body + ;; text, but the indicator stays the same. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 . erc-notice-face))))))) + +;; Option `erc-track-priority-faces-only' does not affect the behavior +;; of the baseline "normals" scenario because all faces appear in +;; `erc-track-faces-priority-list'. +(ert-deftest erc-track-modified-channels/priority-only-all/baseline () + (let ((erc-track-priority-faces-only 'all)) + (erc-tests-common-track-modified-channels + #'erc-track-tests--modified-channels/baseline))) + +;; This test simulates a common configuration that combines an +;; `erc-track-faces-priority-list' removed of `erc-notice-face' with +;; `erc-track-priority-faces-only' being `all'. It also features in the +;; sample configuration in ERC's manual. +(ert-deftest erc-track-modified-channels/priority-only-all/sans-notice () + (let ((erc-track-priority-faces-only 'all) + (erc-track-faces-priority-list + (remq 'erc-notice-face erc-track-faces-priority-list))) + + (erc-tests-common-track-modified-channels + (lambda (set-faces) + ;; Note: these messages don't have timestamps. + + ;; Simulate a message normally displayed in `erc-notice-face', + ;; which has been removed from `erc-track-faces-priority-list'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should-not (alist-get (current-buffer) erc-modified-channels-alist)) + + ;; Someone speaks, mentioning someone else, and the mode-line + ;; changes to the buttonized speaker face rather than the + ;; buttonized mention face, due to their respective ranks. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 erc-button-nick-default-face erc-nick-default-face))) + + ;; Someone else speaks, again with a mention and additional body text. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-default-face))) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives, which is ignored. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face + erc-nick-default-face))))))) + ;;; erc-track-tests.el ends here diff --git a/test/lisp/erc/resources/erc-tests-common.el b/test/lisp/erc/resources/erc-tests-common.el index 1cd54a1f715..91654467dae 100644 --- a/test/lisp/erc/resources/erc-tests-common.el +++ b/test/lisp/erc/resources/erc-tests-common.el @@ -330,4 +330,47 @@ erc-tests-common-create-subprocess (set-process-query-on-exit-flag proc t) proc)) +(declare-function erc-track--setup "erc-track" ()) + +(defun erc-tests-common-track-modified-channels (test) + (erc-tests-common-prep-for-insertion) + (setq erc--target (erc--target-from-string "#chan")) + (erc-tests-common-track-modified-channels-sans-setup test)) + +(defun erc-tests-common-track-modified-channels-sans-setup (test) + "Provide a fixture for testing `erc-track-modified-channels'. +Call function TEST with another function that sets the mocked return +value of `erc-track--collect-faces-in' to the given argument, a list of +faces in the reverse order they appear in an inserted message." + (defvar erc-modified-channels-alist) + (defvar erc-modified-channels-object) + (defvar erc-track--attn-faces) + (defvar erc-track--normal-faces) + (defvar erc-track--priority-faces) + (defvar erc-track-faces-normal-list) + (defvar erc-track-faces-priority-list) + (defvar erc-track-mode) + + (cl-letf* ((erc-track-mode t) + (erc-modified-channels-alist nil) + (erc-modified-channels-object erc-modified-channels-object) + (faces ()) + ((symbol-function 'force-mode-line-update) #'ignore) + ((symbol-function 'erc-faces-in) (lambda (_) faces)) + ((symbol-function 'erc-track--collect-faces-in) + (lambda () + (cons (map-into (mapcar (lambda (f) (cons f t)) faces) + '(hash-table :test equal)) + faces)))) + (erc-track--setup) + + ;; Faces from `erc-track--attn-faces' prepended. + (should (= (+ (length erc-track--attn-faces) + (length erc-track-faces-priority-list)) + (hash-table-count erc-track--priority-faces))) + (should (= (length erc-track-faces-normal-list) + (hash-table-count erc-track--normal-faces))) + + (funcall test (lambda (arg) (setq faces arg))))) + (provide 'erc-tests-common) -- 2.46.2 --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Fri Oct 04 21:40:38 2024 Received: (at 67767) by debbugs.gnu.org; 5 Oct 2024 01:40:38 +0000 Received: from localhost ([127.0.0.1]:37021 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1swtmg-00030r-3e for submit@debbugs.gnu.org; Fri, 04 Oct 2024 21:40:38 -0400 Received: from mail-108-mta1.mxroute.com ([136.175.108.1]:38121) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1swtme-00030h-4u for 67767@debbugs.gnu.org; Fri, 04 Oct 2024 21:40:37 -0400 Received: from filter006.mxroute.com ([136.175.111.3] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta1.mxroute.com (ZoneMTA) with ESMTPSA id 1925a55d8f50003e01.001 for <67767@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Sat, 05 Oct 2024 01:40:28 +0000 X-Zone-Loop: cddd3dc70374b92aae2ef6bbb80ac0c79d61fa2d4524 X-Originating-IP: [136.175.111.3] 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=9WuIvNlbdQ7gn+XgushdvHrWt+ZXtPYFbVcHXRYPYao=; b=c5JEfXvfYaojUa0S9afiVU97w8 fRadOXbYUfpKUUOsjn/UgZtJGvHTIoFw2LjvXDqGXTC+GIddy0cQi3CX+tRPxOVKvjs638402fj2q Wfyvw1B4h093SIh8//W9K3JHQjgGF217eOXpVS+ECz8fmiD7J6LHNScnXbJDsNDdG9ccmX61T9MHW aKCw+yyyTqxbCOUYo5FTWl8UlDG8P+KMVLjdGNn7t4tm+GNSTyB7amZENfL21IIhGLwQ3/smD8p2o 5W0RUq8EnxLBDE0+Y/1obetWSr5ZO/UslmTCUuyAixRBo4NHCIXlJA7xR8Sf6Ca7r3epwVZqOaHVj zp2bly2Q==; From: "J.P." To: 67767@debbugs.gnu.org Subject: Re: bug#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module In-Reply-To: <87ldz4b77j.fsf@neverwas.me> (J. P.'s message of "Fri, 04 Oct 2024 01:30:56 -0700") References: <87edfs3gj4.fsf@neverwas.me> <87ed52q8rd.fsf@neverwas.me> <87ldz4b77j.fsf@neverwas.me> Date: Fri, 04 Oct 2024 18:40:25 -0700 Message-ID: <87wmin9vjq.fsf@neverwas.me> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain X-Authenticated-Id: masked@neverwas.me X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 67767 Cc: emacs-erc@gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) "J.P." writes: > +(defun erc-nicks--track-always (current contender contenders ranks normals) > + "Return a viable `nicks' face, possibly CURRENT, among CONTENDERS. > +See `erc-track--select-mode-line-face' for parameter types." > + (when-let > + ((spkr (erc-nicks--assess-track-faces current contender ranks normals))) > + (catch 'contender > + (dolist (candidate (cdr (reverse contenders))) ~~~~~~~~~~~~~~~~~~~~~~~ That should be (dolist (candidate (reverse (cdr contenders))) Also, `spkr' is unused. > + (when (erc-nicks--ours-p candidate) > + (cl-assert (gethash candidate normals)) > (throw 'contender candidate)))))) > > (defun erc-nicks--setup-track-integration () From debbugs-submit-bounces@debbugs.gnu.org Mon Oct 14 23:02:41 2024 Received: (at 67767) by debbugs.gnu.org; 15 Oct 2024 03:02:41 +0000 Received: from localhost ([127.0.0.1]:49936 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t0XpZ-00033M-Ck for submit@debbugs.gnu.org; Mon, 14 Oct 2024 23:02:41 -0400 Received: from mail-108-mta47.mxroute.com ([136.175.108.47]:46177) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t0XpX-00033B-Fw for 67767@debbugs.gnu.org; Mon, 14 Oct 2024 23:02:40 -0400 Received: from filter006.mxroute.com ([136.175.111.3] filter006.mxroute.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta47.mxroute.com (ZoneMTA) with ESMTPSA id 1928e2052b60003e01.001 for <67767@debbugs.gnu.org> (version=TLSv1.3 cipher=TLS_AES_256_GCM_SHA384); Tue, 15 Oct 2024 03:02:15 +0000 X-Zone-Loop: 9a5531721d51b70f5bcba07928a9e410582a6ef86057 X-Originating-IP: [136.175.111.3] 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=YwM19Lj6t1jw+hHiiQwiRLKDo7/eKpHHId2c2emxNfI=; b=NF7K8w3QkuazuxNa8kexvUhWDm iijdK5nrF9jb+aRQGeSPR4rUNR2eeftz5b0iSVyjoo57Bmdh6NcZh9bA+IELru2NqFbpB/8w16yGu xjCN8uDVRVwR8rUQeDlmTSEDJj57Wlec1DTH9vXELmtuooZxYFLoeQoPWkZexTzyeTRHlY9Ad21V3 FdsVlAB0znRNmRNMjyw+/oNoEeyvx7cLPC8qa+QJJO6P+WLf41ChnxVFQgsVa4qfM1FNe5yyXrR32 4hEvGP4GWvWVxccj79/d2y+hvkoK/A30vS06knFqy1Y84SnjFijXxY0WOChLAxDRRL0H9d0kbb7bo SjuW/qzQ==; From: "J.P." To: 67767@debbugs.gnu.org Subject: Re: bug#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module In-Reply-To: <87ldz4b77j.fsf@neverwas.me> (J. P.'s message of "Fri, 04 Oct 2024 01:30:56 -0700") References: <87edfs3gj4.fsf@neverwas.me> <87ed52q8rd.fsf@neverwas.me> <87ldz4b77j.fsf@neverwas.me> Date: Mon, 14 Oct 2024 20:02:13 -0700 Message-ID: <87ldyqgjbe.fsf@neverwas.me> User-Agent: Gnus/5.13 (Gnus v5.13) MIME-Version: 1.0 Content-Type: text/plain X-Authenticated-Id: masked@neverwas.me X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 67767 Cc: emacs-erc@gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) "J.P." writes: > Attached is a v2 introducing a `t' choice for `erc-nicks-track-faces'. > It suppresses the "alternating" effect associated with the option > `erc-track-faces-normal-list'. This was added recently as 9906e34f973 Crystallize erc-nicks-track-faces behavior The bug is already closed. From unknown Fri Jun 20 19:47:40 2025 Received: (at fakecontrol) by fakecontrolmessage; To: internal_control@debbugs.gnu.org From: Debbugs Internal Request Subject: Internal Control Message-Id: bug archived. Date: Tue, 12 Nov 2024 12:24:13 +0000 User-Agent: Fakemail v42.6.9 # This is a fake control message. # # The action: # bug archived. thanks # This fakemail brought to you by your local debbugs # administrator