master 8e06f224a9e 19/19: Add erc-track integration to erc-nicks

[F. Jason Park]

branch: master
commit 8e06f224a9e275776d422ce3dbc30defdb563867
Author: F. Jason Park <jp@neverwas.me>
Commit: F. Jason Park <jp@neverwas.me>

    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 function ignorant of
    `erc-button--nick' is of course preferable, but some coordination is
    now required to convey and use the "face cache".  We can 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--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'.
    (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.
    * lisp/erc/erc.el (erc--merge-prop): Add new optional parameter
    `cache-fn', and when non-nil, call it, assigning the returned value to
    that of the merged property.
    * test/lisp/erc/erc-nicks-tests.el (erc-nicks-list-faces): Skip
    the "Inherit: " button.  (Bug#67767)
---
 lisp/erc/erc-button.el           | 41 +++++++++---------
 lisp/erc/erc-nicks.el            | 92 ++++++++++++++++++++++++++++++++++++----
 lisp/erc/erc.el                  |  8 +++-
 test/lisp/erc/erc-nicks-tests.el |  2 +-
 4 files changed, 113 insertions(+), 30 deletions(-)

diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index 0af6911aaf4..d27aa299df2 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -372,7 +372,8 @@ specified by `erc-button-alist'."
   ( 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
@@ -479,8 +480,7 @@ retrieve it during buttonizing via
                      (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
@@ -489,19 +489,15 @@ retrieve it during buttonizing via
                        (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."
@@ -560,13 +556,20 @@ REGEXP is the regular expression which matched for this 
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 fcd3afdbbc4..b46c5d43cd7 100644
--- a/lisp/erc/erc-nicks.el
+++ b/lisp/erc/erc-nicks.el
@@ -173,6 +173,20 @@ adding extra characters or padding, for example, with 
something
 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'.")
 
@@ -195,6 +209,7 @@ Keys are nonempty strings but need not be valid nicks.")
 
 (defvar help-xref-stack)
 (defvar help-xref-stack-item)
+(defvar erc-track--normal-faces)
 
 ;; https://stackoverflow.com/questions/596216#answer-56678483
 (defun erc-nicks--get-luminance (color)
@@ -454,7 +469,9 @@ Favor a custom erc-nicks-NICK@NETWORK-face when defined."
           (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 +520,8 @@ Abandon search after examining LIMIT faces."
              ((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."
@@ -518,7 +531,12 @@ Abandon search after examining LIMIT faces."
                                 '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
@@ -561,6 +579,8 @@ Abandon search after examining LIMIT faces."
        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)
@@ -572,8 +592,12 @@ Abandon search after examining LIMIT faces."
    (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)
@@ -693,6 +717,58 @@ Expect PREFIX to be something like \"ansi-color-\" or 
\"font-lock-\"."
                  (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."
+  (and-let* (((eq contender 'erc-default-face))
+             ((or (null current) (gethash current normals)))
+             (spkr (or (null current) (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."
+  (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 d2452c5ca24..faa2cbefd1b 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -3413,12 +3413,14 @@ being equivalent to a `erc-display-message' TYPE of 
`notice'."
 ;; 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))
@@ -3432,6 +3434,8 @@ value.  See also `erc-button-add-face'."
                           (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 @@
              (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")