master d45770e8d03 06/15: Optionally combine faces in erc-display-message

[F. Jason Park]

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

    Optionally combine faces in erc-display-message
    
    * etc/ERC-NEWS: Tell module authors that `erc-display-message' can now
    combine faces.
    * lisp/erc/erc-button.el (erc-button--display-error-notice-with-keys):
    Ask `erc-display-message' to compose `erc-notice-face' and
    `erc-error-face'.
    * lisp/erc/erc-match.el (erc-hide-fools): Merge `invisible' prop
    `erc-match' with existing, if present, and move body to helper for
    hiding matched messages.
    (erc-match--hide-message): New helper function to hide messages
    regardless of match type.
    * lisp/erc/erc-track.el: (erc-track-faces-priority-list): Note in doc
    string that faces reserved for critical messages are always
    prioritized.  Wrap :type declaration in macro helper to ensure
    `erc-button' is loaded beforehand.  Otherwise calling `setopt' with
    the option's default value fails.
    (erc-track--attn-faces): Add new internal variable for faces that
    should always appear in the mode line, at least in the default client.
    (erc-track-modified-channels, erc-track-face-priority): Prepend
    `erc-track--attn-faces' to `erc-track-faces-priority-list'.
    * lisp/erc/erc.el (erc-send-action): Ask `erc-display-message' to
    apply both `erc-input-face' and `erc-action-face' to messages.
    (erc--compose-text-properties): New internal variable to act as flag
    for altering behavior of `erc-put-text-property'.
    (erc--merge-prop): New function copied from `erc-button-add-face' for
    general internal use with any text property by all of ERC.
    (erc-display-message-highlight): Set fallback face to
    `erc-default-face' the symbol instead of the string.  For this to
    break third-party code, callers would have to supply erroneous types
    for nonexistent or undefined handlers and then explicitly check for
    and depend on such misuse, which seems unlikely and therefore not
    worth mentioning in etc/ERC-NEWS.
    (erc-display-message): Explain how `type' param works when it's a
    list.  Fix code in type-as-list branch so that it optionally combines
    faces instead of clobbers them.
    (erc-put-text-property): Unalias from `put-text-property', but fall
    back to the latter unless caller wants to combine faces, in which case,
    defer to `erc--merge-prop'.
    * test/lisp/erc/erc-button-tests.el
    (erc-button--display-error-notice-with-keys): Expect a combined "error
    notice" face.  (Bug#64301)
---
 etc/ERC-NEWS                      | 13 +++++++++++
 lisp/erc/erc-button.el            |  2 +-
 lisp/erc/erc-match.el             | 13 ++++++-----
 lisp/erc/erc-track.el             | 21 +++++++++++++----
 lisp/erc/erc.el                   | 49 ++++++++++++++++++++++++++++++++-------
 test/lisp/erc/erc-button-tests.el |  2 +-
 6 files changed, 79 insertions(+), 21 deletions(-)

diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index 3d062e2e9ab..9c94f68ce27 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -251,6 +251,19 @@ The 'fill' module is now defined by 'define-erc-module'.  
The same
 goes for ERC's imenu integration, which has 'imenu' now appearing in
 the default value of 'erc-modules'.
 
+*** 'erc-display-message' optionally combines faces.
+Users may notice that ERC now inserts some important error messages in
+a combination of 'erc-error-face' and 'erc-notice-face'.  This is
+merely a consequence of 'erc-display-message' getting smarter about
+how it treats face properties when its 'type' parameter is a list that
+starts with t.  Originally, ERC's authors intended to display both
+server-originating and ERC-generated errors in this style, but that
+intent was never realized.  Though now possible, the effect has been
+limited to special errors involving usage and internal state.  For
+third-party code, the key takeaway is that more 'font-lock-face'
+properties encountered in the wild may be combinations of faces rather
+than lone ones.
+
 *** Prompt input is split before 'erc-pre-send-functions' has a say.
 Hook members are now treated to input whose lines have already been
 adjusted to fall within the allowed length limit.  For convenience,
diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el
index c30f7c10ca6..89a6cd131c0 100644
--- a/lisp/erc/erc-button.el
+++ b/lisp/erc/erc-button.el
@@ -815,7 +815,7 @@ non-strings, concatenate leading string members before 
applying
              erc-button--display-error-with-buttons
              erc-button-describe-symbol 1)
             ,@erc-button-alist)))
-    (erc-display-message parsed '(notice error) (or buffer 'active) string)
+    (erc-display-message parsed '(t notice error) (or buffer 'active) string)
     string))
 
 ;;;###autoload
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el
index cd2c55b0091..a5b0af41b2a 100644
--- a/lisp/erc/erc-match.el
+++ b/lisp/erc/erc-match.el
@@ -657,21 +657,22 @@ See `erc-log-match-format'."
 
 (defvar-local erc-match--hide-fools-offset-bounds nil)
 
-;; FIXME this should merge with instead of overwrite existing
-;; `invisible' values.
 (defun erc-hide-fools (match-type _nickuserhost _message)
- "Hide foolish comments.
-This function should be called from `erc-text-matched-hook'."
+  "Hide comments from designated fools."
   (when (eq match-type 'fool)
+    (erc-match--hide-message)))
+
+(defun erc-match--hide-message ()
+  (progn ; FIXME raise sexp
     (if erc-match--hide-fools-offset-bounds
         (let ((beg (point-min))
               (end (point-max)))
           (save-restriction
             (widen)
-            (put-text-property (1- beg) (1- end) 'invisible 'erc-match)))
+            (erc--merge-prop (1- beg) (1- end) 'invisible 'erc-match)))
       ;; Before ERC 5.6, this also used to add an `intangible'
       ;; property, but the docs say it's now obsolete.
-      (put-text-property (point-min) (point-max) 'invisible 'erc-match))))
+      (erc--merge-prop (point-min) (point-max) 'invisible 'erc-match))))
 
 (defun erc-beep-on-match (match-type _nickuserhost _message)
   "Beep when text matches.
diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el
index e060b7039bd..8101183ce3d 100644
--- a/lisp/erc/erc-track.el
+++ b/lisp/erc/erc-track.el
@@ -184,9 +184,13 @@ The faces used are the same as used for text in the 
buffers.
     erc-prompt-face)
   "A list of faces used to highlight active buffer names in the mode line.
 If a message contains one of the faces in this list, the buffer name will
-be highlighted using that face.  The first matching face is used."
-  :type '(repeat (choice face
-                        (repeat :tag "Combination" face))))
+be highlighted using that face.  The first matching face is used.
+
+Note that ERC prioritizes certain faces reserved for critical
+messages regardless of this option's value."
+  :type (erc--with-dependent-type-match
+         (repeat (choice face (repeat :tag "Combination" face)))
+         erc-button))
 
 (defcustom erc-track-priority-faces-only nil
   "Only track text highlighted with a priority face.
@@ -309,6 +313,8 @@ important."
                 (const leastactive)
                 (const mostactive)))
 
+(defconst erc-track--attn-faces '((erc-error-face erc-notice-face))
+  "Faces whose presence always triggers mode-line inclusion.")
 
 (defun erc-track-remove-from-mode-line ()
   "Remove `erc-track-modified-channels' from the mode-line."
@@ -736,6 +742,9 @@ Use `erc-make-mode-line-buffer-name' to create buttons."
   (declare (obsolete erc-track-select-mode-line-face "28.1"))
   (erc-track-select-mode-line-face (car faces) (cdr faces)))
 
+;; Note that unless called by `erc-track-modified-channels',
+;; `erc-track-faces-priority-list' will not begin with
+;; `erc-track--attn-faces'.
 (defun erc-track-select-mode-line-face (cur-face new-faces)
   "Return the face to use in the mode line.
 
@@ -802,7 +811,9 @@ the current buffer is in `erc-mode'."
        ;; (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))))
+        (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))
@@ -873,7 +884,7 @@ If face is not in `erc-track-faces-priority-list', it will 
have a
 higher number than any other face in that list."
   (let ((count 0))
     (catch 'done
-      (dolist (item erc-track-faces-priority-list)
+      (dolist (item `(,@erc-track--attn-faces ,@erc-track-faces-priority-list))
        (if (equal item face)
            (throw 'done t)
          (setq count (1+ count)))))
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index c10b39e9a1b..f2ea69f6bba 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -2745,7 +2745,7 @@ If ARG is non-nil, show the *erc-protocol* buffer."
                erc-insert-pre-hook))
         (nick (erc-current-nick)))
     (setq nick (propertize nick 'erc-speaker nick))
-    (erc-display-message nil 'input (current-buffer)
+    (erc-display-message nil '(t action input) (current-buffer)
                          'ACTION ?n nick ?a str ?u "" ?h "")))
 
 ;; Display interface
@@ -2899,6 +2899,25 @@ If STRING is nil, the function does nothing."
                                      (process-buffer erc-server-process)
                                    (current-buffer))))))
 
+(defvar erc--compose-text-properties nil
+  "Non-nil when `erc-put-text-property' defers to `erc--merge-prop'.")
+
+(defun erc--merge-prop (from to prop val &optional object)
+  "Compose 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.
+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))
+        new)
+    (while (< pos to)
+      (setq new (if old (cons val (ensure-list old)) val))
+      (put-text-property pos end prop new object)
+      (setq pos end
+            old (get-text-property pos prop object)
+            end (next-single-property-change pos prop object to)))))
+
 (defun erc-display-message-highlight (type string)
   "Highlight STRING according to TYPE, where erc-TYPE-face is an ERC face.
 
@@ -2910,7 +2929,7 @@ See also `erc-make-notice'."
           0 (length string)
           'font-lock-face (or (intern-soft
                               (concat "erc-" (symbol-name type) "-face"))
-                             "erc-default-face")
+                              'erc-default-face)
           string)
          string)))
 
@@ -3114,6 +3133,17 @@ returns non-nil."
 
 ARGS, PARSED, and TYPE are used to format MSG sensibly.
 
+When TYPE is a list of symbols, call handlers from left to right
+without influencing how they behave when encountering existing
+faces.  As of ERC 5.6, expect a TYPE of (notice error) to insert
+MSG with `font-lock-face' as `erc-error-face' throughout.
+However, when the list of symbols begins with t, tell compatible
+handlers to compose rather than clobber faces.  For example, as
+of ERC 5.6, expect a TYPE of (t notice error) to result in MSG's
+`font-lock-face' being (erc-error-face erc-notice-face)
+throughout when `erc-notice-highlight-type' is set to its default
+`all'.
+
 See also `erc-format-message' and `erc-display-line'."
   (let ((string (if (symbolp msg)
                     (apply #'erc-format-message msg args)
@@ -3124,10 +3154,10 @@ See also `erc-format-message' and `erc-display-line'."
            ((null type)
             string)
            ((listp type)
-            (mapc (lambda (type)
-                    (setq string
-                          (erc-display-message-highlight type string)))
-                  type)
+            (let ((erc--compose-text-properties
+                   (and (eq (car type) t) (setq type (cdr type)))))
+              (dolist (type type)
+                (setq string (erc-display-message-highlight type string))))
             string)
            ((symbolp type)
             (erc-display-message-highlight type string))))
@@ -6129,7 +6159,7 @@ See also variable `erc-notice-highlight-type'."
   (erc-put-text-property 0 (length s) 'font-lock-face 'erc-error-face s)
   s)
 
-(defalias 'erc-put-text-property 'put-text-property
+(defun erc-put-text-property (start end property value &optional object)
   "Set text-property for an object (usually a string).
 START and END define the characters covered.
 PROPERTY is the text-property set, usually the symbol `face'.
@@ -6139,7 +6169,10 @@ OBJECT is a string which will be modified and returned.
 OBJECT is modified without being copied first.
 
 You can redefine or `defadvice' this function in order to add
-EmacsSpeak support.")
+EmacsSpeak support."
+  (if erc--compose-text-properties
+      (erc--merge-prop start end property value object)
+    (put-text-property start end property value object)))
 
 (defalias 'erc-list 'ensure-list)
 
diff --git a/test/lisp/erc/erc-button-tests.el 
b/test/lisp/erc/erc-button-tests.el
index 6a6f6934389..3dacf95a59f 100644
--- a/test/lisp/erc/erc-button-tests.el
+++ b/test/lisp/erc/erc-button-tests.el
@@ -265,7 +265,7 @@
       (ert-info ("Symbol-description face preserved") ; mutated by d-e-n-w-k
         (erc-button-next 1)
         (should (equal (get-text-property (point) 'font-lock-face)
-                       '(erc-button erc-error-face)))
+                       '(erc-button erc-error-face erc-notice-face)))
         (should (eq (get-text-property (point) 'mouse-face) 'highlight))
         (should (eq erc-button-face 'erc-button))) ; extent evaporates