From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: "J.P." Newsgroups: gmane.emacs.bugs Subject: bug#67767: 30.0.50; ERC 5.6: Add track integration to the nicks module Date: Tue, 12 Dec 2023 06:49:06 -0800 Message-ID: <87il53zdb1.fsf__1471.36255852587$1702392615$gmane$org@neverwas.me> References: <87edfs3gj4.fsf@neverwas.me> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="22135"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: emacs-erc@gnu.org To: 67767@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Tue Dec 12 15:50:07 2023 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1rD45G-0005X5-Qv for geb-bug-gnu-emacs@m.gmane-mx.org; Tue, 12 Dec 2023 15:50:07 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rD44y-0001Fn-Re; Tue, 12 Dec 2023 09:49:48 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rD44w-0001Et-Vx for bug-gnu-emacs@gnu.org; Tue, 12 Dec 2023 09:49:47 -0500 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rD44w-0004XE-Nn for bug-gnu-emacs@gnu.org; Tue, 12 Dec 2023 09:49:46 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rD45C-0006u0-3V for bug-gnu-emacs@gnu.org; Tue, 12 Dec 2023 09:50:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: "J.P." Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Tue, 12 Dec 2023 14:50:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 67767 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 67767-submit@debbugs.gnu.org id=B67767.170239258226499 (code B ref 67767); Tue, 12 Dec 2023 14:50:02 +0000 Original-Received: (at 67767) by debbugs.gnu.org; 12 Dec 2023 14:49:42 +0000 Original-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 Original-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 Original-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==; In-Reply-To: <87edfs3gj4.fsf@neverwas.me> (J. P.'s message of "Mon, 11 Dec 2023 07:28:15 -0800") X-Authenticated-Id: masked@neverwas.me X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.bugs:276049 Archived-At: --=-=-= 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 --=-=-=--