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