diff --git a/counsel.el b/counsel.el index 9ed9b631..ebd66123 100644 --- a/counsel.el +++ b/counsel.el @@ -4463,19 +4463,29 @@ Additional actions:\\ 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 dc89c217..87dda185 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."