[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/ivy d8dace96ed 1/3: Speed up counsel-yank-pop on large
From: |
Basil L. Contovounesios |
Subject: |
[elpa] externals/ivy d8dace96ed 1/3: Speed up counsel-yank-pop on large kill-ring |
Date: |
Thu, 2 May 2024 04:11:51 -0400 (EDT) |
branch: externals/ivy
commit d8dace96ed08e10ca9250fdcf6ec65912d6a789e
Author: Basil L. Contovounesios <basil@contovou.net>
Commit: Basil L. Contovounesios <basil@contovou.net>
Speed up counsel-yank-pop on large kill-ring
cl-delete-duplicates rapidly slows down on large inputs.
Alternatives to the approach in this patch:
- Avoid deduplication beyond a certain threshold.
- Deduplicate only when kill-do-not-save-duplicates is non-nil.
- Make equality test customizable.
- Ignore text properties by default.
* counsel.el (counsel--idx-of): New macro.
(counsel--yank-pop-position): Use it.
(counsel-string-non-blank-p): Simplify.
(counsel--equal-w-props, counsel--yank-pop-filter): New functions
for replicating delete-dups under
equal-including-properties (#3045).
(counsel--yank-pop-kills): Use counsel--yank-pop-filter.
(counsel-yank-pop-action-remove): Prefer setq over set.
* ivy-test.el (counsel-string-non-blank-p, counsel--equal-w-props)
(counsel--yank-pop-filter): New tests.
Fixes #3040.
---
counsel.el | 81 ++++++++++++++++++++++++++++++++++++++++++++++++++-----------
ivy-test.el | 34 ++++++++++++++++++++++++++
2 files changed, 101 insertions(+), 14 deletions(-)
diff --git a/counsel.el b/counsel.el
index 9ed9b63196..ebd66123e9 100644
--- a/counsel.el
+++ b/counsel.el
@@ -4463,19 +4463,29 @@ Additional actions:\\<ivy-minibuffer-map>
cand-pairs
(propertize counsel-yank-pop-separator 'face 'ivy-separator)))
+;; Macro to leverage `compiler-macro' of `cl-member' in Emacs >= 24.
+(defmacro counsel--idx-of (elt list test)
+ "Return index of ELT in LIST, comparing with TEST.
+Typically faster than `cl-position' using `equal' on large LIST."
+ ;; No `macroexp-let2*' before Emacs 25.
+ (macroexp-let2 nil elt elt
+ (macroexp-let2 nil list list
+ (macroexp-let2 nil tail `(cl-member ,elt ,list :test ,test)
+ `(and ,tail (- (length ,list) (length ,tail)))))))
+
(defun counsel--yank-pop-position (s)
"Return position of S in `kill-ring' relative to last yank."
- (or (cl-position s kill-ring-yank-pointer :test #'equal-including-properties)
- (cl-position s kill-ring-yank-pointer :test #'equal)
- (+ (or (cl-position s kill-ring :test #'equal-including-properties)
- (cl-position s kill-ring :test #'equal))
+ (or (counsel--idx-of s kill-ring-yank-pointer #'equal-including-properties)
+ (counsel--idx-of s kill-ring-yank-pointer #'equal)
+ (+ (or (counsel--idx-of s kill-ring #'equal-including-properties)
+ (counsel--idx-of s kill-ring #'equal))
(- (length kill-ring-yank-pointer)
(length kill-ring)))))
(defun counsel-string-non-blank-p (s)
"Return non-nil if S includes non-blank characters.
Newlines and carriage returns are considered blank."
- (not (string-match-p "\\`[\n\r[:blank:]]*\\'" s)))
+ (string-match-p "[^\n\r[:blank:]]" s))
(defcustom counsel-yank-pop-filter #'counsel-string-non-blank-p
"Unary filter function applied to `counsel-yank-pop' candidates.
@@ -4484,9 +4494,53 @@ will be destructively removed from `kill-ring' before
completion.
All blank strings are deleted from `kill-ring' by default."
:type '(radio
(function-item counsel-string-non-blank-p)
- (function-item identity)
+ (function-item identity) ;; Faster than the newer `always'.
(function :tag "Other")))
+(defun counsel--equal-w-props ()
+ "Return a `hash-table-test' using `equal-including-properties'.
+If not available, return nil."
+ ;; Added in Emacs 28.
+ (when (fboundp 'sxhash-equal-including-properties)
+ (let ((name 'counsel--equal-w-props))
+ ;; Define the test only once.
+ (unless (get name 'hash-table-test)
+ (define-hash-table-test name #'equal-including-properties
+ #'sxhash-equal-including-properties))
+ name)))
+
+(defun counsel--yank-pop-filter (kills)
+ "Apply `counsel-yank-pop-filter' to and deduplicate KILLS.
+Equality is defined by `equal-including-properties' for some consistency
+with `kill-do-not-save-duplicates' (which is otherwise ignored). This
+function tries to be faster than `cl-delete-duplicates' when possible."
+ (let* ((pred counsel-yank-pop-filter)
+ (len (length kills))
+ ;; Same threshold as `delete-dups'.
+ (test (and (> len 100) (counsel--equal-w-props))))
+ (if (not test) ;; Slow fallback.
+ (cl-delete-duplicates (cl-delete-if-not pred kills)
+ :test #'equal-including-properties
+ :from-end t)
+ ;; The rest is `delete-dups' combined with `delete' in a single pass.
+ ;; Find first (or no) element that passes through filter.
+ (while (unless (funcall pred (car kills))
+ (cl-decf len)
+ (setq kills (cdr kills))))
+ (let ((ht (make-hash-table :test test :size len))
+ (tail kills)
+ retail)
+ ;; Mark it and continue with the rest.
+ (puthash (car tail) t ht)
+ (while (setq retail (cdr tail))
+ (let ((elt (car retail)))
+ (if (or (gethash elt ht)
+ (not (funcall pred elt)))
+ (setcdr tail (cdr retail))
+ (puthash elt t ht)
+ (setq tail retail)))))
+ kills)))
+
(defun counsel--yank-pop-kills ()
"Return filtered `kill-ring' for `counsel-yank-pop' completion.
Both `kill-ring' and `kill-ring-yank-pointer' may be
@@ -4497,11 +4551,9 @@ and incorporate `interprogram-paste-function'."
;; `interprogram-paste-function' both being nil
(ignore-errors (current-kill 0))
;; Keep things consistent with the rest of Emacs
- (dolist (sym '(kill-ring kill-ring-yank-pointer))
- (set sym (cl-delete-duplicates
- (cl-delete-if-not counsel-yank-pop-filter (symbol-value sym))
- :test #'equal-including-properties :from-end t)))
- kill-ring)
+ (prog1 (setq kill-ring (counsel--yank-pop-filter kill-ring))
+ (setq kill-ring-yank-pointer
+ (counsel--yank-pop-filter kill-ring-yank-pointer))))
(defcustom counsel-yank-pop-after-point nil
"Whether `counsel-yank-pop' yanks after point.
@@ -4539,9 +4591,10 @@ buffer position."
(defun counsel-yank-pop-action-remove (s)
"Remove all occurrences of S from the kill ring."
- (dolist (sym '(kill-ring kill-ring-yank-pointer))
- (set sym (cl-delete s (symbol-value sym)
- :test #'equal-including-properties)))
+ (setq kill-ring
+ (cl-delete s kill-ring :test #'equal-including-properties))
+ (setq kill-ring-yank-pointer
+ (cl-delete s kill-ring-yank-pointer :test
#'equal-including-properties))
;; Update collection and preselect for next `ivy-call'
(setf (ivy-state-collection ivy-last) kill-ring)
(setf (ivy-state-preselect ivy-last)
diff --git a/ivy-test.el b/ivy-test.el
index dc89c217ba..87dda1854b 100644
--- a/ivy-test.el
+++ b/ivy-test.el
@@ -1163,6 +1163,40 @@ Since `execute-kbd-macro' doesn't pick up a let-bound
`default-directory'.")
(ivy-with-temp-buffer '(counsel-yank-pop) "C-m"))
'(1 "foo"))))
+(ert-deftest counsel-string-non-blank-p ()
+ "Test `counsel-string-non-blank-p'."
+ (should-not (counsel-string-non-blank-p ""))
+ (should-not (counsel-string-non-blank-p " "))
+ (should-not (counsel-string-non-blank-p " "))
+ (should (counsel-string-non-blank-p "a"))
+ (should (counsel-string-non-blank-p " a"))
+ (should (counsel-string-non-blank-p "a "))
+ (should (counsel-string-non-blank-p "aa")))
+
+(ert-deftest counsel--equal-w-props ()
+ "Sanity check for `sxhash-equal-including-properties'."
+ (let ((name 'counsel--equal-w-props)
+ (test (counsel--equal-w-props)))
+ (should (eq test (and (>= emacs-major-version 28) name)))
+ (if test
+ (should (make-hash-table :test test :size 0))
+ (should-not (get name 'hash-table-test)))))
+
+(ert-deftest counsel--yank-pop-filter ()
+ "Test `counsel--yank-pop-filter'."
+ (should-not (counsel--yank-pop-filter ()))
+ (dolist (len '(1 2 3 120))
+ (let (kills)
+ (dotimes (_ len)
+ (push (propertize "a" t nil) kills))
+ (should (equal (counsel--yank-pop-filter kills) '("a")))))
+ (dolist (len '(1 2 3 60))
+ (let (kills)
+ (dotimes (_ len)
+ (push (propertize "a" t nil) kills)
+ (push (propertize "a" t t) kills))
+ (should (equal (counsel--yank-pop-filter kills) '("a" "a"))))))
+
(ert-deftest ivy-read-file-name-in-buffer-visiting-file ()
"Test `ivy-immediate-done' command in `read-file-name' without any editing in
a buffer visiting a file."