( 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
(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
(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."
(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)
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'.")
(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)
(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)))))
((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."
'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
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)
(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)
(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
;; 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))
(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)
projects / emacs.git / commitdiff