>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