branch: externals/corfu
commit beae37b96ba368e252ce9f9b8588768378953519
Author: Daniel Mendler <m...@daniel-mendler.de>
Commit: Daniel Mendler <m...@daniel-mendler.de>
Use cl-defgeneric instead of advices
The recent discussion on emacs-devel made me reconsider advices again.
It is better to be more disciplined in avoiding them in particular if
we have better facilities at our disposal. The great thing is, we even
save some code on the way!
---
corfu.el | 200 +++++++++++++++++++++---------------------
extensions/corfu-echo.el | 24 ++---
extensions/corfu-history.el | 16 ++--
extensions/corfu-indexed.el | 45 +++++-----
extensions/corfu-popupinfo.el | 15 +---
5 files changed, 137 insertions(+), 163 deletions(-)
diff --git a/corfu.el b/corfu.el
index 5447aba5ed..a9603491db 100644
--- a/corfu.el
+++ b/corfu.el
@@ -697,35 +697,6 @@ A scroll bar is displayed from LO to LO+BAR."
(eq sym x)
(string-match-p x (symbol-name sym))))))
-(defun corfu--affixate (cands)
- "Annotate CANDS with annotation function."
- (setq cands
- (if-let (aff (or (corfu--metadata-get 'affixation-function)
- (plist-get corfu--extra :affixation-function)))
- (funcall aff cands)
- (if-let (ann (or (corfu--metadata-get 'annotation-function)
- (plist-get corfu--extra :annotation-function)))
- (cl-loop for cand in cands collect
- (let ((suffix (or (funcall ann cand) "")))
- ;; The default completion UI adds the
- ;; `completions-annotations' face if no other faces
are
- ;; present. We use a custom `corfu-annotations' face
to
- ;; allow further styling which fits better for popups.
- (unless (text-property-not-all 0 (length suffix)
'face nil suffix)
- (setq suffix (propertize suffix 'face
'corfu-annotations)))
- (list cand "" suffix)))
- (cl-loop for cand in cands collect (list cand "" "")))))
- (let* ((dep (plist-get corfu--extra :company-deprecated))
- (completion-extra-properties corfu--extra)
- (mf (run-hook-with-args-until-success 'corfu-margin-formatters
corfu--metadata)))
- (cl-loop for x in cands for (c . _) = x do
- (when mf
- (setf (cadr x) (funcall mf c)))
- (when (and dep (funcall dep c))
- (setcar x (setq c (substring c)))
- (add-face-text-property 0 (length c) 'corfu-deprecated 'append
c)))
- (cons mf cands)))
-
(defun corfu--metadata-get (prop)
"Return PROP from completion metadata."
;; Note: Do not use `completion-metadata-get' in order to avoid Marginalia.
@@ -803,51 +774,6 @@ A scroll bar is displayed from LO to LO+BAR."
(overlay-put corfu--preview-ov 'window (selected-window))
(overlay-put corfu--preview-ov (if (= beg end) 'after-string 'display)
cand)))
-(defun corfu--exhibit (&optional auto)
- "Exhibit Corfu UI.
-AUTO is non-nil when initializing auto completion."
- (pcase-let ((`(,beg ,end ,table ,pred) completion-in-region--data)
- (`(,str . ,pt) (corfu--update 'interruptible)))
- (cond
- ;; 1) Single exactly matching candidate and no further completion is
possible.
- ((and (not (equal str ""))
- (equal (car corfu--candidates) str) (not (cdr corfu--candidates))
- (not (consp (completion-try-completion str table pred pt
corfu--metadata)))
- (or auto corfu-on-exact-match))
- ;; Quit directly when initializing auto completion.
- (if (or auto (eq corfu-on-exact-match 'quit))
- (corfu-quit)
- (corfu--done str 'finished)))
- ;; 2) There exist candidates => Show candidates popup.
- (corfu--candidates
- (corfu--candidates-popup beg)
- (corfu--preview-current beg end)
- (redisplay 'force)) ;; XXX HACK Ensure that popup is redisplayed
- ;; 3) No candidates & corfu-quit-no-match & initialized => Confirmation
popup.
- ((pcase-exhaustive corfu-quit-no-match
- ('t nil)
- ('nil corfu--input)
- ('separator (seq-contains-p (car corfu--input) corfu-separator)))
- (corfu--popup-show beg 0 8 '(#("No match" 0 8 (face italic))))
- (redisplay 'force)) ;; XXX HACK Ensure that popup is redisplayed
- ;; 4) No candidates & auto completing or initialized => Quit.
- ((or auto corfu--input) (corfu-quit)))))
-
-(defun corfu--pre-command ()
- "Insert selected candidate unless command is marked to continue completion."
- (when corfu--preview-ov
- (delete-overlay corfu--preview-ov)
- (setq corfu--preview-ov nil))
- ;; Ensure that state is initialized before next Corfu command
- (when (and (symbolp this-command) (string-prefix-p "corfu-" (symbol-name
this-command)))
- (corfu--update))
- (when (and (eq corfu-preview-current 'insert)
- (/= corfu--index corfu--preselect)
- ;; See the comment about `overriding-local-map' in
`corfu--post-command'.
- (not (or overriding-terminal-local-map
- (corfu--match-symbol-p corfu-continue-commands
this-command))))
- (corfu--insert 'exact)))
-
(defun corfu--continue-p ()
"Continue completion?"
(pcase-let ((pt (point))
@@ -890,23 +816,6 @@ AUTO is non-nil when initializing auto completion."
"Go to candidate with INDEX."
(setq corfu--index (max corfu--preselect (min index (1- corfu--total)))))
-(defun corfu--insert (status)
- "Insert current candidate, exit with STATUS if non-nil."
- (pcase-let* ((`(,beg ,end . ,_) completion-in-region--data)
- (str (buffer-substring-no-properties beg end)))
- ;; XXX There is a small bug here, depending on interpretation.
- ;; When completing "~/emacs/master/li|/calc" where "|" is the
- ;; cursor, then the candidate only includes the prefix
- ;; "~/emacs/master/lisp/", but not the suffix "/calc". Default
- ;; completion has the same problem when selecting in the
- ;; *Completions* buffer. See bug#48356.
- (setq str (concat corfu--base (substring-no-properties
- (nth corfu--index corfu--candidates))))
- ;; bug#55205: completion--replace removes properties!
- (completion--replace beg end (concat str))
- (corfu--goto -1) ;; Reset selection, but continue completion.
- (when status (corfu--done str status)))) ;; Exit with status
-
(defun corfu--done (str status)
"Call the `:exit-function' with STR and STATUS and exit completion."
(let ((exit (plist-get corfu--extra :exit-function)))
@@ -938,15 +847,6 @@ AUTO is non-nil when initializing auto completion."
(corfu--teardown)))))
(add-hook 'completion-in-region-mode-hook sym)))
-(defun corfu--teardown ()
- "Teardown Corfu."
- (corfu--popup-hide)
- (remove-hook 'pre-command-hook #'corfu--pre-command 'local)
- (remove-hook 'post-command-hook #'corfu--post-command)
- (when corfu--preview-ov (delete-overlay corfu--preview-ov))
- (accept-change-group corfu--change-group)
- (mapc #'kill-local-variable corfu--state-vars))
-
(defun corfu--in-region (&rest args)
"Corfu completion in region function called with ARGS."
;; XXX We can get an endless loop when `completion-in-region-function' is set
@@ -1071,6 +971,106 @@ See `completion-in-region' for the arguments BEG, END,
TABLE, PRED."
Auto completion is only performed if the tick did not change."
(list (selected-window) (current-buffer) (buffer-chars-modified-tick)
(point)))
+(cl-defgeneric corfu--insert (status)
+ "Insert current candidate, exit with STATUS if non-nil."
+ (pcase-let* ((`(,beg ,end . ,_) completion-in-region--data)
+ (str (buffer-substring-no-properties beg end)))
+ ;; XXX There is a small bug here, depending on interpretation.
+ ;; When completing "~/emacs/master/li|/calc" where "|" is the
+ ;; cursor, then the candidate only includes the prefix
+ ;; "~/emacs/master/lisp/", but not the suffix "/calc". Default
+ ;; completion has the same problem when selecting in the
+ ;; *Completions* buffer. See bug#48356.
+ (setq str (concat corfu--base (substring-no-properties
+ (nth corfu--index corfu--candidates))))
+ ;; bug#55205: completion--replace removes properties!
+ (completion--replace beg end (concat str))
+ (corfu--goto -1) ;; Reset selection, but continue completion.
+ (when status (corfu--done str status)))) ;; Exit with status
+
+(cl-defgeneric corfu--affixate (cands)
+ "Annotate CANDS with annotation function."
+ (setq cands
+ (if-let (aff (or (corfu--metadata-get 'affixation-function)
+ (plist-get corfu--extra :affixation-function)))
+ (funcall aff cands)
+ (if-let (ann (or (corfu--metadata-get 'annotation-function)
+ (plist-get corfu--extra :annotation-function)))
+ (cl-loop for cand in cands collect
+ (let ((suffix (or (funcall ann cand) "")))
+ ;; The default completion UI adds the
+ ;; `completions-annotations' face if no other faces
are
+ ;; present. We use a custom `corfu-annotations' face
to
+ ;; allow further styling which fits better for popups.
+ (unless (text-property-not-all 0 (length suffix)
'face nil suffix)
+ (setq suffix (propertize suffix 'face
'corfu-annotations)))
+ (list cand "" suffix)))
+ (cl-loop for cand in cands collect (list cand "" "")))))
+ (let* ((dep (plist-get corfu--extra :company-deprecated))
+ (completion-extra-properties corfu--extra)
+ (mf (run-hook-with-args-until-success 'corfu-margin-formatters
corfu--metadata)))
+ (cl-loop for x in cands for (c . _) = x do
+ (when mf
+ (setf (cadr x) (funcall mf c)))
+ (when (and dep (funcall dep c))
+ (setcar x (setq c (substring c)))
+ (add-face-text-property 0 (length c) 'corfu-deprecated 'append
c)))
+ (cons mf cands)))
+
+(cl-defgeneric corfu--pre-command ()
+ "Insert selected candidate unless command is marked to continue completion."
+ (when corfu--preview-ov
+ (delete-overlay corfu--preview-ov)
+ (setq corfu--preview-ov nil))
+ ;; Ensure that state is initialized before next Corfu command
+ (when (and (symbolp this-command) (string-prefix-p "corfu-" (symbol-name
this-command)))
+ (corfu--update))
+ (when (and (eq corfu-preview-current 'insert)
+ (/= corfu--index corfu--preselect)
+ ;; See the comment about `overriding-local-map' in
`corfu--post-command'.
+ (not (or overriding-terminal-local-map
+ (corfu--match-symbol-p corfu-continue-commands
this-command))))
+ (corfu--insert 'exact)))
+
+(cl-defgeneric corfu--exhibit (&optional auto)
+ "Exhibit Corfu UI.
+AUTO is non-nil when initializing auto completion."
+ (pcase-let ((`(,beg ,end ,table ,pred) completion-in-region--data)
+ (`(,str . ,pt) (corfu--update 'interruptible)))
+ (cond
+ ;; 1) Single exactly matching candidate and no further completion is
possible.
+ ((and (not (equal str ""))
+ (equal (car corfu--candidates) str) (not (cdr corfu--candidates))
+ (not (consp (completion-try-completion str table pred pt
corfu--metadata)))
+ (or auto corfu-on-exact-match))
+ ;; Quit directly when initializing auto completion.
+ (if (or auto (eq corfu-on-exact-match 'quit))
+ (corfu-quit)
+ (corfu--done str 'finished)))
+ ;; 2) There exist candidates => Show candidates popup.
+ (corfu--candidates
+ (corfu--candidates-popup beg)
+ (corfu--preview-current beg end)
+ (redisplay 'force)) ;; XXX HACK Ensure that popup is redisplayed
+ ;; 3) No candidates & corfu-quit-no-match & initialized => Confirmation
popup.
+ ((pcase-exhaustive corfu-quit-no-match
+ ('t nil)
+ ('nil corfu--input)
+ ('separator (seq-contains-p (car corfu--input) corfu-separator)))
+ (corfu--popup-show beg 0 8 '(#("No match" 0 8 (face italic))))
+ (redisplay 'force)) ;; XXX HACK Ensure that popup is redisplayed
+ ;; 4) No candidates & auto completing or initialized => Quit.
+ ((or auto corfu--input) (corfu-quit)))))
+
+(cl-defgeneric corfu--teardown ()
+ "Teardown Corfu."
+ (corfu--popup-hide)
+ (remove-hook 'pre-command-hook #'corfu--pre-command 'local)
+ (remove-hook 'post-command-hook #'corfu--post-command)
+ (when corfu--preview-ov (delete-overlay corfu--preview-ov))
+ (accept-change-group corfu--change-group)
+ (mapc #'kill-local-variable corfu--state-vars))
+
(defun corfu-sort-length-alpha (list)
"Sort LIST by length and alphabetically."
(sort list #'corfu--length-string<))
diff --git a/extensions/corfu-echo.el b/extensions/corfu-echo.el
index 09244d5afe..83eaa99fe4 100644
--- a/extensions/corfu-echo.el
+++ b/extensions/corfu-echo.el
@@ -57,10 +57,6 @@ floats to specify initial and subsequent delay."
(defvar-local corfu-echo--message nil
"Last echo message.")
-(defun corfu-echo--refresh ()
- "Refresh message to avoid flicker."
- (corfu-echo--cancel corfu-echo--message))
-
(defun corfu-echo--cancel (&optional msg)
"Cancel echo timer and refresh MSG."
(when corfu-echo--timer
@@ -80,8 +76,7 @@ floats to specify initial and subsequent delay."
msg
(propertize msg 'face 'corfu-echo)))))
-(defun corfu-echo--exhibit (&rest _)
- "Show documentation string of current candidate in echo area."
+(cl-defmethod corfu--exhibit :after (&context (corfu-echo-mode (eql t))
&optional _auto)
(if-let ((delay (if (consp corfu-echo-delay)
(funcall (if corfu-echo--message #'cdr #'car)
corfu-echo-delay)
@@ -98,19 +93,16 @@ floats to specify initial and subsequent delay."
(corfu-echo--show (funcall fun cand))))))
(corfu-echo--cancel)))
+(cl-defmethod corfu--teardown :before (&context (corfu-echo-mode (eql t)))
+ (corfu-echo--cancel))
+
+(cl-defmethod corfu--pre-command :before (&context (corfu-echo-mode (eql t)))
+ (corfu-echo--cancel corfu-echo--message))
+
;;;###autoload
(define-minor-mode corfu-echo-mode
"Show candidate documentation in echo area."
- :global t :group 'corfu
- (cond
- (corfu-echo-mode
- (advice-add #'corfu--pre-command :before #'corfu-echo--refresh)
- (advice-add #'corfu--exhibit :after #'corfu-echo--exhibit)
- (advice-add #'corfu--teardown :before #'corfu-echo--cancel))
- (t
- (advice-remove #'corfu--pre-command #'corfu-echo--refresh)
- (advice-remove #'corfu--exhibit #'corfu-echo--exhibit)
- (advice-remove #'corfu--teardown #'corfu-echo--cancel))))
+ :global t :group 'corfu)
(provide 'corfu-echo)
;;; corfu-echo.el ends here
diff --git a/extensions/corfu-history.el b/extensions/corfu-history.el
index e42306be2c..c83004667d 100644
--- a/extensions/corfu-history.el
+++ b/extensions/corfu-history.el
@@ -76,8 +76,7 @@
(cl-loop for cand on candidates do (setcar cand (caar cand)))
candidates)
-(defun corfu-history--insert (&rest _)
- "Advice for `corfu--insert'."
+(cl-defmethod corfu--insert :before (_status &context (corfu-history-mode (eql
t)))
(when (>= corfu--index 0)
(add-to-history 'corfu-history
(substring-no-properties
@@ -88,15 +87,10 @@
;;;###autoload
(define-minor-mode corfu-history-mode
"Update Corfu history and sort completions by history."
- :global t
- :group 'corfu
- (cond
- (corfu-history-mode
- (setq corfu-sort-function #'corfu-history--sort)
- (advice-add #'corfu--insert :before #'corfu-history--insert))
- (t
- (setq corfu-sort-function #'corfu-sort-length-alpha)
- (advice-remove #'corfu--insert #'corfu-history--insert))))
+ :global t :group 'corfu
+ (if corfu-history-mode
+ (add-function :override corfu-sort-function #'corfu-history--sort)
+ (remove-function corfu-sort-function #'corfu-history--sort)))
(provide 'corfu-history)
;;; corfu-history.el ends here
diff --git a/extensions/corfu-indexed.el b/extensions/corfu-indexed.el
index 8c2ccbc4bc..44093b9fad 100644
--- a/extensions/corfu-indexed.el
+++ b/extensions/corfu-indexed.el
@@ -56,8 +56,20 @@
'(corfu-insert corfu-complete)
"Commands that should be indexed.")
-(defun corfu-indexed--affixate (cands)
- "Advice for `corfu--affixate' which prefixes the CANDS with an index."
+(defun corfu-indexed--handle-prefix (orig &rest args)
+ "Handle prefix argument before calling ORIG function with ARGS."
+ (if (and current-prefix-arg (called-interactively-p t))
+ (let ((corfu--index (+ corfu--scroll
+ (- (prefix-numeric-value current-prefix-arg)
+ corfu-indexed-start))))
+ (if (or (< corfu--index 0)
+ (>= corfu--index corfu--total)
+ (>= corfu--index (+ corfu--scroll corfu-count)))
+ (message "Out of range")
+ (funcall orig)))
+ (apply orig args)))
+
+(cl-defmethod corfu--affixate (cands &context (corfu-indexed-mode (eql t)))
(setq cands (cdr cands))
(let* ((space #(" " 0 1 (face (:height 0.5 :inherit corfu-indexed))))
(width (if (length> cands (- 10 corfu-indexed-start)) 2 1))
@@ -77,32 +89,17 @@
(cadr cand))))
(cons t cands)))
-(defun corfu-indexed--handle-prefix (orig &rest args)
- "Handle prefix argument before calling ORIG function with ARGS."
- (if (and current-prefix-arg (called-interactively-p t))
- (let ((corfu--index (+ corfu--scroll
- (- (prefix-numeric-value current-prefix-arg)
- corfu-indexed-start))))
- (if (or (< corfu--index 0)
- (>= corfu--index corfu--total)
- (>= corfu--index (+ corfu--scroll corfu-count)))
- (message "Out of range")
- (funcall orig)))
- (apply orig args)))
-
;;;###autoload
(define-minor-mode corfu-indexed-mode
"Prefix candidates with indices."
:global t :group 'corfu
- (cond
- (corfu-indexed-mode
- (advice-add #'corfu--affixate :filter-return #'corfu-indexed--affixate)
- (dolist (cmd corfu-indexed--commands)
- (advice-add cmd :around #'corfu-indexed--handle-prefix)))
- (t
- (advice-remove #'corfu--affixate #'corfu-indexed--affixate)
- (dolist (cmd corfu-indexed--commands)
- (advice-remove cmd #'corfu-indexed--handle-prefix)))))
+ ;; TODO I had forgotten that `corfu-indexed-mode' is double evil, since it
+ ;; uses advices and the forbidden function `called-interactively-p'. Find a
+ ;; better implementation which avoids these kludges.
+ (dolist (cmd corfu-indexed--commands)
+ (if corfu-indexed-mode
+ (advice-add cmd :around #'corfu-indexed--handle-prefix)
+ (advice-remove cmd #'corfu-indexed--handle-prefix))))
(provide 'corfu-indexed)
;;; corfu-indexed.el ends here
diff --git a/extensions/corfu-popupinfo.el b/extensions/corfu-popupinfo.el
index 4201ad6023..8531e0e0b1 100644
--- a/extensions/corfu-popupinfo.el
+++ b/extensions/corfu-popupinfo.el
@@ -463,8 +463,7 @@ not be displayed until this command is called again, even if
(interactive)
(corfu-popupinfo--toggle corfu-popupinfo--function))
-(defun corfu-popupinfo--exhibit (&rest _)
- "Update the info popup automatically."
+(cl-defmethod corfu--exhibit :after (&context (corfu-popupinfo-mode (eql t))
&optional _auto)
(when completion-in-region-mode
(setf (alist-get #'corfu-popupinfo-mode minor-mode-overriding-map-alist)
corfu-popupinfo-map)
@@ -494,8 +493,7 @@ not be displayed until this command is called again, even if
(corfu-popupinfo--hide))))
(corfu-popupinfo--hide))))
-(defun corfu-popupinfo--teardown ()
- "Teardown the info popup state."
+(cl-defmethod corfu--teardown :before (&context (corfu-popupinfo-mode (eql t)))
(corfu-popupinfo--hide)
(mapc #'kill-local-variable corfu-popupinfo--state-vars)
(setq minor-mode-overriding-map-alist
@@ -505,14 +503,7 @@ not be displayed until this command is called again, even
if
;;;###autoload
(define-minor-mode corfu-popupinfo-mode
"Corfu info popup minor mode."
- :global t :group 'corfu
- (cond
- (corfu-popupinfo-mode
- (advice-add #'corfu--exhibit :after #'corfu-popupinfo--exhibit)
- (advice-add #'corfu--teardown :before #'corfu-popupinfo--teardown))
- (t
- (advice-remove #'corfu--exhibit #'corfu-popupinfo--exhibit)
- (advice-remove #'corfu--teardown #'corfu-popupinfo--teardown))))
+ :global t :group 'corfu)
;; Emacs 28: Do not show Corfu commands with M-X
(dolist (sym '(corfu-popupinfo-scroll-down corfu-popupinfo-scroll-up
