From cd7adbf97e8bf62e9c60b87500c2d2b05963d9a5 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Wed, 10 Jul 2024 21:56:52 +0200 Subject: [PATCH] New commands for filtering minibuffer completions --- lisp/minibuffer.el | 245 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 194 insertions(+), 51 deletions(-) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 56c830a34ae..55ba323b593 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1173,7 +1173,8 @@ styles for specific categories, such as files, buffers, etc." (multiple-choice (styles basic substring) (sort-function . identity)) (calendar-month (sort-function . identity)) (keybinding (sort-function . minibuffer-sort-alphabetically)) - (function (sort-function . minibuffer-sort-alphabetically)) + (function (sort-function . minibuffer-sort-alphabetically) + (affixation-function . minibuffer-function-affixation)) (library (sort-function . minibuffer-sort-alphabetically))) "Default settings for specific completion categories. @@ -2251,15 +2252,39 @@ completions." 'keymap completions-header-order-map)) " ")) +(defface completions-header-restriction-separator-highlight + '((t :inherit mode-line-highlight)) + "Face for restriction separator in completions header when mouse is on it." + :version "31.1") + (defvar completions-header-restriction - '("/" - (:eval (or (completions-predicate-description completions-predicate) - (and completions-predicate - (symbolp completions-predicate) - (not (eq completions-predicate 'always)) - (symbol-name completions-predicate)) - "all")) - "/ ")) + '(:eval (let* ((neg (advice-function-member-p #'not completions-predicate)) + (sep + (propertize (if neg "\\" "/") + 'help-echo (concat (when neg "Negated\n") + "mouse-2: Toggle negation") + 'mouse-face 'completions-header-restriction-separator-highlight + 'keymap + (let ((map (make-sparse-keymap))) + (define-key map [header-line mouse-2] + (lambda (e) + (interactive "e") + (with-current-buffer + (buffer-local-value + 'completion-reference-buffer + (window-buffer (posn-window (event-end e)))) + (minibuffer-negate-completion-predicate)))) + map)))) + (concat + sep + (or (completions-predicate-description completions-predicate) + (and completions-predicate + (symbolp completions-predicate) + (not (eq completions-predicate 'always)) + (symbol-name completions-predicate)) + "all") + sep + " ")))) (defvar completions-header-action '(completions-action @@ -2580,6 +2605,7 @@ and with BASE-SIZE appended as the last element." (nconc completions base-size)))) (defun completions-predicate-description (pred) + "Return string describing predicate PRED, or nil." (and (functionp pred) (let ((descs nil)) (advice-function-mapc @@ -2587,7 +2613,32 @@ and with BASE-SIZE appended as the last element." (when-let ((description (alist-get 'description alist))) (push description descs))) pred) - (when descs (mapconcat #'identity descs ", "))))) + (when descs (mapconcat + (lambda (desc) + (propertize + desc + 'mouse-face 'mode-line-highlight + 'help-echo "mouse-2: Negate\nmouse-3: Remove" + 'keymap + (let ((map (make-sparse-keymap))) + (define-key map [header-line mouse-2] + (lambda (e) + (interactive "e") + (with-current-buffer + (buffer-local-value + 'completion-reference-buffer + (window-buffer (posn-window (event-end e)))) + (minibuffer-negate-completion-predicate desc)))) + (define-key map [header-line mouse-3] + (lambda (e) + (interactive "e") + (with-current-buffer + (buffer-local-value + 'completion-reference-buffer + (window-buffer (posn-window (event-end e)))) + (minibuffer-widen-completions desc)))) + map))) + descs ", "))))) (defvar minibuffer-completions-sort-function nil "Function for sorting minibuffer completion candidates, or nil. @@ -3505,6 +3556,8 @@ The completion method is determined by `completion-at-point-functions'." "h" #'minibuffer-narrow-completions-to-history "m" #'minibuffer-narrow-completions "g" #'minibuffer-narrow-completions-by-regexp + "p" #'minibuffer-add-completion-predicate + "-" #'minibuffer-negate-completion-predicate "w" #'minibuffer-widen-completions) (defvar-keymap minibuffer-local-ns-map @@ -4401,7 +4454,7 @@ possible completions." (setq done t) (message "Done")))))) -(defun minibuffer--set-action-affixation (cands) +(defun minibuffer-function-affixation (cands) "Annotate completion candidates CANDS with their documentation strings." (let ((max (seq-max (cons 0 (mapcar #'string-width cands))))) (mapcar @@ -4426,9 +4479,7 @@ possible completions." (let ((enable-recursive-minibuffers t)) (list (completing-read "Action function: " (completion-table-with-metadata - obarray - '((category . function) - (affixation-function . minibuffer--set-action-affixation))) + obarray '((category . function))) #'fboundp nil nil 'minibuffer-action-history))) minibuffer-mode) @@ -5739,6 +5790,88 @@ DESC is a string describing predicate PRED." pred `((description . ,desc))) (when completion-auto-help (minibuffer-completion-help))) +(defun minibuffer-read-predicate-description (prompt &optional default) + "Prompt with PROMPT for current completion predicate description. +Optional argument DEFAULT is the default minibuffer argument. If +omitted or nil, it defaults to the description of the predicate you +added last." + (let ((default (or default (minibuffer-latest-predicate-description)))) + (completing-read (format-prompt prompt default) + (completion-table-dynamic + (let ((buf (current-buffer))) + (lambda (&rest _) + (with-current-buffer buf + (let ((descs nil)) + (advice-function-mapc + (lambda (_a p) + (when-let ((d (alist-get 'description p))) + (push d descs))) + minibuffer-completion-predicate) + ;; Put latest restriction first. + (reverse descs)))))) + nil t nil nil default))) + +(defun minibuffer-predicate-description-to-function (desc) + (catch 'stop + (advice-function-mapc + (lambda (a p) + (when (equal (alist-get 'description p) desc) + (throw 'stop (cons (alist-get 'description p) a)))) + minibuffer-completion-predicate) + nil)) + +(defun minibuffer-latest-predicate-description () + "Return the completion predicate you added most recently." + (catch 'stop + (advice-function-mapc + (lambda (_ p) + (when-let ((desc (alist-get 'description p))) + (throw 'stop desc))) + minibuffer-completion-predicate) + nil)) + +(defun minibuffer-negate-completion-predicate (&optional desc) + "Negate completion predicate with description DESC. + +Optional argument DESC says which predicate to negate. If it is a +string, negate the predicate that DESC describes. Otherwise, negate the +conjunction of all current predicates together. + +Interactively, prompt for DESC among curent predicates, unless there is +only one predicate, in which case DESC is the string describing that +predicate. With a prefix argument, negate the conjunction of all +predicates together." + (interactive (list (or current-prefix-arg + (minibuffer-read-predicate-description "Negate"))) + minibuffer-mode) + (unless minibuffer-completion-predicate + (setq-local minibuffer-completion-predicate #'always)) + (if (stringp desc) + ;; Negate the conjuct with description DESC. + (if-let* ((desc-fn (minibuffer-predicate-description-to-function desc)) + (desc (car desc-fn)) + (fn (cdr desc-fn))) + (progn + (remove-function (local 'minibuffer-completion-predicate) fn) + (if-let ((neg (get-text-property 0 'negated desc))) + (minibuffer--add-completions-predicate (cdr neg) (car neg)) + (minibuffer--add-completions-predicate + (compose #'not fn) + (propertize (concat "-(" desc ")") 'negated (cons desc fn))))) + (user-error "`%s' is not a description of a current predicate" desc)) + ;; Negate the entire predicate. + (if (advice-function-member-p #'not minibuffer-completion-predicate) + (remove-function (local 'minibuffer-completion-predicate) #'not) + (add-function :filter-return (local 'minibuffer-completion-predicate) + #'not '((depth . -100))))) + (when completion-auto-help (minibuffer-completion-help))) + +(put 'minibuffer-negate-completion-predicate 'minibuffer-action + (cons (lambda (d) + (with-current-buffer minibuffer--original-buffer + (minibuffer-negate-completion-predicate d))) + "negate")) + (defun minibuffer-narrow-completions () "Restrict completion candidates for current minibuffer interaction." (interactive "" minibuffer-mode) @@ -5761,6 +5894,21 @@ DESC is a string describing predicate PRED." (filter-desc (minibuffer-completions-regexp-predicate))) (minibuffer--add-completions-predicate (car filter-desc) (cdr filter-desc)))) +(defun minibuffer-add-completion-predicate (pred) + "Restrict completion candidates to those satisfying PRED." + (interactive + (list + (let ((enable-recursive-minibuffers t)) + (completing-read "Predicate: " + (completion-table-with-metadata + obarray '((category . function))) + #'fboundp + nil nil 'minibuffer-completions-predicate-history + "minibuffer-collect"))) + minibuffer-mode) + (when (stringp pred) (setq pred (read pred))) + (minibuffer--add-completions-predicate pred (prin1-to-string pred))) + (defun minibuffer-narrow-completions-to-current (arg) "Restrict completion candidates according to current minibuffer input. ARG is the numeric prefix argument. When ARG is negative, @@ -5854,45 +6002,42 @@ members of the minibuffer history list." (minibuffer-message "Completion annotations %sabled" (if minibuffer-completion-annotations "en" "dis"))) -(defun minibuffer-widen-completions (&optional all) +(defun minibuffer-widen-completions (&optional desc) "Remove restrictions on current minibuffer completions list. -Prompt for one or more restrictions that currently apply to the -list of possible minibuffer completions, and remove those -restrictions. You can use completion to select the restrictions -to remove, separating each of your selections with -`crm-separator' (usually, a comma). +Optional argument DESC says which restrictions to remove. If it is a +string, remove the restriction that DESC describes. Otherwise, remove +all current restrictions. -When there is only one restriction, remove it without prompting. -With optional argument ALL (interactively, the prefix argument), -remove all current restrictions without prompting." - (interactive "P" minibuffer-mode) - (let ((desc-pred-alist nil)) - (advice-function-mapc - (lambda (a p) - (when-let ((d (alist-get 'description p))) - (push (cons d a) desc-pred-alist))) - minibuffer-completion-predicate) - (unless desc-pred-alist - (user-error "No completions restrictions")) - ;; Put latest restriction first. - (setq desc-pred-alist (reverse desc-pred-alist)) - (mapc - (lambda (pair) - (remove-function (local 'minibuffer-completion-predicate) (cdr pair))) - (if (or all - ;; Only one restriction. - (not (cdr desc-pred-alist))) - desc-pred-alist - (mapcar (lambda (desc) - (assoc desc desc-pred-alist)) - (let ((enable-recursive-minibuffers t)) - (completing-read-multiple - (format-prompt "Remove completions restrictions" - (caar desc-pred-alist)) - desc-pred-alist nil t nil nil (caar desc-pred-alist))))))) +Interactively, prompt for DESC among curent restrictions, unless there +is only one restriction, in which case DESC is the string describing +that restriction. With a prefix argument, remove all restrictions, +regardless of how many there are." + (interactive (list (or current-prefix-arg + (minibuffer-read-predicate-description "Remove"))) + minibuffer-mode) + (if (stringp desc) + ;; Remove conjunct with description DESC. + (if-let* ((fn (cdr (minibuffer-predicate-description-to-function desc)))) + (remove-function (local 'minibuffer-completion-predicate) fn) + (user-error "`%s' is not a description of a current predicate" desc)) + ;; Remove all restrictions. + (let ((preds nil)) + (advice-function-mapc + (lambda (a p) + (when (alist-get 'description p) + (push a preds))) + minibuffer-completion-predicate) + (dolist (pred preds) + (remove-function (local 'minibuffer-completion-predicate) pred)))) (when completion-auto-help (minibuffer-completion-help))) +(put 'minibuffer-widen-completions 'minibuffer-action + (cons (lambda (d) + (with-current-buffer minibuffer--original-buffer + (minibuffer-widen-completions d))) + "remove")) + (defcustom minibuffer-default-prompt-format " (default %s)" "Format string used to output \"default\" values. When prompting for input, there will often be a default value, @@ -6522,9 +6667,7 @@ TOP-LEVEL-P is non-nil." (completing-read (format-prompt "Export function" "minibuffer-collect") (completion-table-with-metadata - obarray - '((category . function) - (affixation-function . minibuffer--set-action-affixation))) + obarray '((category . function))) #'fboundp nil nil 'minibuffer-export-history "minibuffer-collect"))) t) -- 2.39.2