[Patch] Speeding up circe-color-nicks-anywhere option

[wasamasa]

I've found that ZNC playback is super slow for me, https://github.com/lastquestion/explain-pause-mode pointed me towards this code in circe-color-nicks:

(when circe-color-nicks-everywhere
  (let ((body (text-property-any (point-min) (point-max)
                                 'lui-format-argument 'body)))
    (when body
      (with-syntax-table circe-nick-syntax-table
        (goto-char body)
        (let* ((nicks (circe-nick-color-nick-list))
               (regex (regexp-opt nicks 'words)))
          (let (case-fold-search)
            (while (re-search-forward regex nil t)
              (let* ((nick (match-string-no-properties 0))
                     (color (circe-nick-color-for-nick nick)))
                (add-face-text-property (match-beginning 0) (match-end 0)
                                        `(:foreground ,color))))))))))

This is run on every inserted chat line. It's suboptimal to retrieve the full nick list and convert it to a regular expression every time, especially inside a tight loop. One improvement idea is to instead create the regular expression whenever a user is added or removed in irc-channel-add-user and irc-channel-remove-user. This helped a bit with speed, but not nearly enough as the regexp is still recreated very often at the start of ZNC playback. Another improvement idea was to completely do away with regular expressions and instead looking up each word in a trie holding all nicknames. This finally resolved the speed issue for me, here's my init file hack:

(with-eval-after-load 'circe-color-nicks
  (require 'trie)

  (defun my-char-ci< (a b) (< (downcase a) (downcase b)))

  (defvar my-circe-color-nick-trie nil)
  (make-variable-buffer-local 'my-circe-color-nick-trie)

  (defun my-circe-add-nick-to-trie (channel userstring)
    (let* ((user-table (irc-channel-users channel))
           (conn (irc-channel-connection channel))
           (user (irc-user-from-userstring conn userstring))
           (folded-nick (irc-user-folded-nick user)))
      (with-current-buffer (irc-connection-get conn :server-buffer)
        (let ((name (irc-channel-name channel)))
          (with-current-buffer (circe-server-get-chat-buffer name)
            (when (not my-circe-color-nick-trie)
              (setq my-circe-color-nick-trie (make-trie 'my-char-ci<)))
            (trie-insert my-circe-color-nick-trie folded-nick t))))))

  (defun my-circe-remove-nick-from-trie (channel nick)
    (let* ((user-table (irc-channel-users channel))
           (conn (irc-channel-connection channel))
           (folded-nick (irc-isupport--case-fold conn nick)))
      (with-current-buffer (irc-connection-get conn :server-buffer)
        (let ((name (irc-channel-name channel)))
          (with-current-buffer (circe-server-get-chat-buffer name)
            (when (not my-circe-color-nick-trie)
              (setq my-circe-color-nick-trie (make-trie 'my-char-ci<)))
            (trie-delete my-circe-color-nick-trie folded-nick))))))

  (advice-add 'irc-channel-add-user :after 'my-circe-add-nick-to-trie)
  (advice-add 'irc-channel-remove-user :after 'my-circe-remove-nick-from-trie)

  (defun circe-color-nicks ()
    "Color nicks on this lui output line."
    (when (eq major-mode 'circe-channel-mode)
      (let ((nickstart (text-property-any (point-min) (point-max)
                                          'lui-format-argument 'nick)))
        (when nickstart
          (goto-char nickstart)
          (let ((nickend (next-single-property-change nickstart
                                                      'lui-format-argument))
                (nick (plist-get (plist-get (text-properties-at nickstart)
                                            'lui-keywords)
                                 :nick)))
            (when (not (circe-server-my-nick-p nick))
              (let ((color (circe-nick-color-for-nick nick)))
                (add-face-text-property nickstart nickend
                                        `(:foreground ,color)))))))
      (when circe-color-nicks-everywhere
        (let ((body (text-property-any (point-min) (point-max)
                                       'lui-format-argument 'body)))
          (when (and body my-circe-color-nick-trie)
            (with-syntax-table circe-nick-syntax-table
              (goto-char body)
              (while (forward-word 1)
                (let ((word (thing-at-point 'word)))
                  (when (trie-lookup my-circe-color-nick-trie word)
                    (let ((bounds (bounds-of-thing-at-point 'word))
                          (color (circe-nick-color-for-nick word)))
                      (add-face-text-property (car bounds) (cdr bounds)
                                              `(:foreground ,color)))))))))))))

This code isn't ideal for several reasons:

• It's using an additional external package. At least it's available on GNU ELPA, but maybe regular hash tables can do fine.
• Advising irc-channel-add-user and irc-channel-remove-user is rather ugly. It would be better to have a hook instead or maybe even exposing hash tables holding all folded nicks instead, then there would be no need for advice or hooks whatsoever.
• I haven't found a good way of dealing with the case-insensitive matching so far, if I mention the same nick with different casing, it gets two different highlight colors.

edit: I forgot to mention @TaylanUB who wrote the module in the first place.

[wasamasa]

Hash table version:

(with-eval-after-load 'circe-color-nicks
  (defun my-string-ci-equal (a b) (string-equal (downcase a) (downcase b)))
  (defun my-string-ci-hash (s) (sxhash (downcase s)))
  (define-hash-table-test 'my-string-ci-equal 'my-string-ci-equal
    'my-string-ci-hash)

  (defvar my-circe-color-nick-table nil)
  (make-variable-buffer-local 'my-circe-color-nick-table)

  (defun my-circe-add-nick-to-table (channel userstring)
    (let* ((user-table (irc-channel-users channel))
           (conn (irc-channel-connection channel))
           (user (irc-user-from-userstring conn userstring))
           (nick (irc-user-nick user)))
      (with-current-buffer (irc-connection-get conn :server-buffer)
        (let ((name (irc-channel-name channel)))
          (with-current-buffer (circe-server-get-chat-buffer name)
            (when (not my-circe-color-nick-table)
              (setq my-circe-color-nick-table
                    (make-hash-table :test 'my-string-ci-equal)))
            (puthash nick t my-circe-color-nick-table))))))

  (defun my-circe-remove-nick-from-table (channel nick)
    (let* ((user-table (irc-channel-users channel))
           (conn (irc-channel-connection channel)))
      (with-current-buffer (irc-connection-get conn :server-buffer)
        (let ((name (irc-channel-name channel)))
          (with-current-buffer (circe-server-get-chat-buffer name)
            (when (not my-circe-color-nick-table)
              (setq my-circe-color-nick-table
                    (make-hash-table :test 'my-string-ci-equal)))
            (remhash nick my-circe-color-nick-table))))))

  (advice-add 'irc-channel-add-user :after 'my-circe-add-nick-to-table)
  (advice-add 'irc-channel-remove-user :after 'my-circe-remove-nick-from-table)

  (defun circe-color-nicks ()
    "Color nicks on this lui output line."
    (when (eq major-mode 'circe-channel-mode)
      (let ((nickstart (text-property-any (point-min) (point-max)
                                          'lui-format-argument 'nick)))
        (when nickstart
          (goto-char nickstart)
          (let ((nickend (next-single-property-change nickstart
                                                      'lui-format-argument))
                (nick (plist-get (plist-get (text-properties-at nickstart)
                                            'lui-keywords)
                                 :nick)))
            (when (not (circe-server-my-nick-p nick))
              (let ((color (circe-nick-color-for-nick nick)))
                (add-face-text-property nickstart nickend
                                        `(:foreground ,color)))))))
      (when circe-color-nicks-everywhere
        (let ((body (text-property-any (point-min) (point-max)
                                       'lui-format-argument 'body)))
          (when (and body my-circe-color-nick-table)
            (with-syntax-table circe-nick-syntax-table
              (goto-char body)
              (while (forward-word 1)
                (let ((word (thing-at-point 'word)))
                  (when (gethash word my-circe-color-nick-table)
                    (let ((bounds (bounds-of-thing-at-point 'word))
                          (color (circe-nick-color-for-nick word)))
                      (add-face-text-property (car bounds) (cdr bounds)
                                              `(:foreground ,color)))))))))))))

Looking at circe-nick-color-for-nick it appears that a case-sensitive hash table is used, instead a hash table using the test defined above could resolve the issue.

edit: I've also noticed folding isn't what we want here and folded user tables already exist. Maybe the hash table check should use folding instead of making a new table with unfolded users...

[wasamasa]

Forgot to close this.