branch: externals/hotfuzz
commit 21fe545d5ff110aebc9ea157548614d2640cb863
Author: Axel Forsman <[email protected]>
Commit: Axel Forsman <[email protected]>
Sort already in hotfuzz-all-completions
This is a hack since it places additional assumptions on the caller,
although the intended mechanism for sorting is already a hack ugly
enough that it never should have been envisioned in the first place.
By doing things this way, the implementation of the completion style can
be simplified and now calls out to the dynamic module and does
highlighting in a limited capacity.
Closes #2
---
README.md | 33 ++++++++++-------
hotfuzz.el | 117 ++++++++++++++++++++++++++++++++++++++--------------------
test/tests.el | 33 +++++++++++++++++
3 files changed, 131 insertions(+), 52 deletions(-)
diff --git a/README.md b/README.md
index 47e2fb99d8..64a0c6c465 100644
--- a/README.md
+++ b/README.md
@@ -15,9 +15,20 @@ To use hotfuzz, add it to the `completion-styles` list:
```
or, if using [Selectrum], enable `hotfuzz-selectrum-mode`.
-**Note:** For now highlighting is only applied with `hotfuzz-selectrum-mode`
-because doing it for the default completions API would require
-the highlighting to be computed even for completions that are not displayed.
+**Note:** Highlighting of the matched characters is only applied to
+the first `hotfuzz-max-highlighted-completions` completions, out of
+performance concerns. The default value is large enough so that
+generally you will need to scroll the list of completions beyond the
+second page to first see non-highlighted completions. If you are
+annoyed by this you can make it highlight all completions instead
+using
+```elisp
+(setq hotfuzz-max-highlighted-completions most-positive-fixnum)
+```
+provided you are completing small enough lists and/or do not encounter
+performance problems.
+This is a non-issue when using `hotfuzz-selectrum-mode` since
+Selectrum supports lazy highlighting.
## Customization
@@ -29,24 +40,20 @@ Hotfuzz adheres to a few of the default Emacs completion
configuration options:
## Dynamic module
-Optionally, you can compile the bundled dynamic module
-to improve the performance of `hotfuzz-selectrum-mode`.
-(The completion style API is infinitely more awkward to interface with,
-mostly because matching and sorting are forced to be done separately.)
+Optionally, you may compile the bundled dynamic module
+to greatly improve the performance of filtering.
Once the shared object is available in `load-path`
it will automatically be picked up when hotfuzz is loaded,
or you may evaluate `(require 'hotfuzz-module)`
-if hotfuzz has already been loaded.
+if hotfuzz already has been loaded.
To compile, make sure GCC, CMake and GNU Make or similar are present,
and run
```sh
mkdir build
cd build
-cmake -G 'Unix Makefiles' \
- -DCMAKE_C_FLAGS='-O3 -march=native' \
- .. \
- && make
+cmake -DCMAKE_C_FLAGS='-O3 -march=native' .. \
+ && cmake --build .
```
and place the resulting shared library somewhere in `load-path`.
@@ -94,4 +101,4 @@ and so users who dislike that may prefer orderless.
[Selectrum]: https://github.com/raxod502/selectrum
[flx]: https://github.com/lewang/flx
[Ido]: https://www.gnu.org/software/emacs/manual/html_node/ido/index.html
-[orderless]: https://github.com/oantolin/orderless
\ No newline at end of file
+[orderless]: https://github.com/oantolin/orderless
diff --git a/hotfuzz.el b/hotfuzz.el
index d48687f11d..97c6d03c09 100644
--- a/hotfuzz.el
+++ b/hotfuzz.el
@@ -30,6 +30,13 @@
:group 'minibuffer
:link '(url-link :tag "GitHub" "https://github.com/axelf4/hotfuzz";))
+(defcustom hotfuzz-max-highlighted-completions 25
+ "The number of top-ranking completions that should be highlighted.
+Large values will decrease performance. Only applies when using the
+Emacs `completion-styles' interface."
+ :group 'hotfuzz
+ :type 'integer)
+
(declare-function hotfuzz--filter-c "hotfuzz-module")
;; If the dynamic module is available: Load it
(require 'hotfuzz-module nil t)
@@ -105,7 +112,7 @@ and ND/PD respectively may alias."
(defun hotfuzz-highlight (needle haystack)
"Highlight the characters that NEEDLE matched in HAYSTACK.
-HAYSTACK has to be a match according to `hotfuzz-all-completions'."
+HAYSTACK has to be a match according to `hotfuzz-filter'."
(let ((n (length haystack)) (m (length needle))
(c hotfuzz--c) (d hotfuzz--d)
(case-fold-search completion-ignore-case))
@@ -133,58 +140,90 @@ HAYSTACK has to be a match according to
`hotfuzz-all-completions'."
(add-face-text-property i (1+ i) 'completions-common-part nil haystack)
finally return haystack))))
+;;;###autoload
+(cl-defun hotfuzz-filter (string candidates &optional (start 0))
+ "Filter CANDIDATES that match STRING and sort by the match costs.
+CANDIDATES should be a list of strings. If START is non-nil, the first
+START characters of each candidate string are ignored."
+ (cond
+ ((or (string= string "") (> (length string) hotfuzz--max-needle-len))
+ candidates)
+ ((and (featurep 'hotfuzz-module) (= start 0))
+ (hotfuzz--filter-c string candidates))
+ ((let ((re (concat
+ "\\`"
+ (when (> start 0) (format ".\\{%d\\}" start))
+ (mapconcat
+ (lambda (ch) (format "[^%c]*%s" ch (regexp-quote
(char-to-string ch))))
+ string "")))
+ (case-fold-search completion-ignore-case))
+ (mapcar
+ #'car
+ (cl-sort
+ (cl-loop for x in candidates if (string-match-p re x)
+ collect (cons x (hotfuzz--cost string (if (> start 0)
(substring x start) x))))
+ #'< :key #'cdr))))))
+
;;; Completion style implementation
-;; Without deferred highlighting (bug#47711) we do not even make an attempt
;;;###autoload
(defun hotfuzz-all-completions (string table pred point)
- "Implementation of `completion-all-completions' that uses hotfuzz."
- (pcase-let ((`(,all ,_pattern ,prefix ,_suffix ,_carbounds)
- (completion-substring--all-completions
- string table pred point
- #'completion-flex--make-flex-pattern))
- (case-fold-search completion-ignore-case))
- (when all
- (nconc (if (or (> (length string) hotfuzz--max-needle-len) (string=
string ""))
- all
- (mapcar (lambda (x)
- (setq x (copy-sequence x))
- (put-text-property 0 1 'completion-score (-
(hotfuzz--cost string x)) x)
- x)
- all))
- (length prefix)))))
+ "Implementation of `completion-all-completions' that uses hotfuzz.
+This function prematurely sorts the completions; mutating the returned
+list before passing it to `display-sort-function' or
+`cycle-sort-function' will lead to inaccuracies."
+ (let* ((beforepoint (substring string 0 point))
+ (afterpoint (substring string point))
+ (bounds (completion-boundaries beforepoint table pred afterpoint))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (needle (substring beforepoint (car bounds)))
+ (completion-regexp-list nil)
+ (all (hotfuzz-filter
+ needle
+ (if (and (listp table) (not (consp (car-safe table)))
+ (not pred) (string= prefix ""))
+ table
+ (all-completions prefix table pred))
+ (length prefix))))
+ (when (and (not (string= needle "")) all)
+ ;; Highlighting all completions without deferred highlighting
+ ;; (bug#47711) would take too long.
+ (cl-loop
+ repeat hotfuzz-max-highlighted-completions and for x in-ref all do
+ (setf x (concat prefix
+ (hotfuzz-highlight needle (substring x (length
prefix))))))
+ (unless (> hotfuzz-max-highlighted-completions 0)
+ (setcar all (copy-sequence (car all))))
+ (put-text-property 0 1 'completion-sorted t (car all)))
+ (if (string= prefix "") all (nconc all (length prefix)))))
+
+(defun hotfuzz--adjust-metadata (metadata)
+ "Adjust completion METADATA for hotfuzz sorting."
+ (let ((existing-dsf (completion-metadata-get metadata
'display-sort-function))
+ (existing-csf (completion-metadata-get metadata 'cycle-sort-function)))
+ (cl-flet
+ ((compose-sort-fn
+ (existing-sort-fn)
+ (lambda (completions)
+ (if (or (null completions)
+ (get-text-property 0 'completion-sorted (car completions)))
+ completions
+ (funcall existing-sort-fn completions)))))
+ `(metadata
+ (display-sort-function . ,(compose-sort-fn (or existing-dsf
#'identity)))
+ (cycle-sort-function . ,(compose-sort-fn (or existing-csf #'identity)))
+ ,@(cdr metadata)))))
;;;###autoload
(progn
;; Why is the Emacs completions API so cursed?
- (put 'hotfuzz 'completion--adjust-metadata
#'completion--flex-adjust-metadata)
+ (put 'hotfuzz 'completion--adjust-metadata #'hotfuzz--adjust-metadata)
(add-to-list 'completion-styles-alist
'(hotfuzz completion-flex-try-completion hotfuzz-all-completions
"Fuzzy completion.")))
;;; Selectrum integration
-;;;###autoload
-(defun hotfuzz-filter (string candidates)
- "Filter CANDIDATES that match STRING and sort by the match costs.
-This is a performance optimization of `completion-all-completions'
-followed by `display-sort-function' for when CANDIDATES is a list of
-strings."
- (if (featurep 'hotfuzz-module)
- (hotfuzz--filter-c string candidates)
- (if (or (> (length string) hotfuzz--max-needle-len) (string= string ""))
- candidates
- (let ((re (concat "^" (mapconcat (lambda (ch)
- (format "[^%c]*%s"
- ch
- (regexp-quote (char-to-string
ch))))
- string "")))
- (case-fold-search completion-ignore-case))
- (mapcar #'car
- (sort (cl-loop for x in candidates if (string-match re x)
- collect (cons x (hotfuzz--cost string x)))
- (lambda (a b) (< (cdr a) (cdr b)))))))))
-
(defun hotfuzz--highlight-all (string candidates)
"Highlight where STRING matches in the elements of CANDIDATES."
(mapcar (lambda (candidate)
diff --git a/test/tests.el b/test/tests.el
index 9b211e6ebd..00cc8fafff 100644
--- a/test/tests.el
+++ b/test/tests.el
@@ -50,3 +50,36 @@
(let ((completion-ignore-case t))
(should (equal (hotfuzz-filter "a" xs) xs))
(should (equal (hotfuzz-filter "A" xs) xs)))))
+
+(ert-deftest all-completions-test ()
+ (let* ((completion-styles '(hotfuzz))
+ (s "fb")
+ (table '("foobar" "fxxx" "foo-baz" "" "fb"))
+ (meta (completion-metadata s table nil))
+ (candidates (completion-all-completions s table nil (length s) meta))
+ (sortfun (alist-get 'display-sort-function meta))
+ (last (last candidates)))
+ (when (numberp (cdr last)) (setcdr last nil))
+ (when sortfun (setq candidates (funcall sortfun candidates)))
+ (should (equal candidates '("fb" "foo-baz" "foobar")))))
+
+;; The built-in `flex' completion style fails this test since it
+;; allows the search term "s" to match inside of the prefix "/usr/",
+;; meaning no completions get filtered.
+(ert-deftest boundaries-test ()
+ "Test completion on a single field of a filename."
+ (let ((completion-styles '(hotfuzz)))
+ (should
+ (equal
+ (completion-all-completions
+ "/usr/s/man"
+ (lambda (string _pred action)
+ (pcase action
+ ('metadata '(metadata (category . file)))
+ (`(boundaries . ,suffix)
+ `(boundaries ,(length (file-name-directory string))
+ . ,(string-search "/" suffix)))
+ ('t (list "/usr/bin" "/usr/share" "/usr/local"))))
+ nil
+ 6) ; Point as in "/usr/s|/man"
+ '("/usr/share" . 5)))))
