emacs-elpa-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[elpa] externals/consult ae7fdb2 2/3: Add consult-completing-read-multip


From: ELPA Syncer
Subject: [elpa] externals/consult ae7fdb2 2/3: Add consult-completing-read-multiple
Date: Wed, 7 Jul 2021 14:57:07 -0400 (EDT)

branch: externals/consult
commit ae7fdb26fb23632a6a5c1b7538b478c6b8a96c8e
Author: Daniel Mendler <mail@daniel-mendler.de>
Commit: Daniel Mendler <mail@daniel-mendler.de>

    Add consult-completing-read-multiple
---
 CHANGELOG.org        |   5 ++
 README.org           |   7 +++
 consult-icomplete.el |   6 +--
 consult-selectrum.el |   9 ++--
 consult-vertico.el   |   9 +++-
 consult.el           | 137 +++++++++++++++++++++++++++++++++++++++++++++++++++
 6 files changed, 165 insertions(+), 8 deletions(-)

diff --git a/CHANGELOG.org b/CHANGELOG.org
index 3ddcea9..52147dd 100644
--- a/CHANGELOG.org
+++ b/CHANGELOG.org
@@ -2,6 +2,11 @@
 #+author: Daniel Mendler
 #+language: en
 
+* Development
+
+- =consult-mark=, =consult-global-mark=: Added optional marker list argument
+- =consult-completing-read-multiple=: New function
+
 * Version 0.9 (2021-06-22)
 
 - Add =consult-preview-excluded-hooks=
diff --git a/README.org b/README.org
index 4fd47ce..ed08b1a 100644
--- a/README.org
+++ b/README.org
@@ -343,6 +343,7 @@ their descriptions.
  #+findex: consult-apropos
  #+findex: consult-file-externally
  #+findex: consult-completion-in-region
+ #+findex: consult-completing-read-multiple
  #+findex: consult-theme
  #+findex: consult-man
  #+findex: consult-preview-at-point
@@ -384,6 +385,9 @@ their descriptions.
    buffer to the minibuffer, the server does not receive the updated input. Lsp
    completion should work with Corfu or Company though, which perform the
    completion directly in the original buffer.
+  - =consult-completing-read-multiple=: Enhanced drop-in replacement for
+    =completing-read-multiple= which works better for long candidates.
+
 * Special features
   :properties:
   :description: Enhancements over built-in `completing-read'
@@ -835,6 +839,9 @@ contributed.
      (setq xref-show-xrefs-function #'consult-xref
            xref-show-definitions-function #'consult-xref)
 
+     ;; Optionally replace `completing-read-multiple' with an enhanced version.
+     (advice-add #'completing-read-multiple :override 
#'consult-completing-read-multiple)
+
      ;; Configure other variables and modes in the :config section,
      ;; after lazily loading the package.
      :config
diff --git a/consult-icomplete.el b/consult-icomplete.el
index 053f71b..8186ff7 100644
--- a/consult-icomplete.el
+++ b/consult-icomplete.el
@@ -27,14 +27,14 @@
 (require 'consult)
 (require 'icomplete)
 
-(defun consult-icomplete--refresh ()
-  "Refresh icomplete view, keep current candidate selected if possible."
+(defun consult-icomplete--refresh (&optional reset)
+  "Refresh icomplete view, keep current candidate unless RESET is non-nil."
   (when icomplete-mode
     (let ((top (car completion-all-sorted-completions)))
       (completion--flush-all-sorted-completions)
       ;; force flushing, otherwise narrowing is broken!
       (setq completion-all-sorted-completions nil)
-      (when top
+      (when (and top (not reset))
         (let* ((completions (completion-all-sorted-completions))
                (last (last completions))
                (before)) ;; completions before top
diff --git a/consult-selectrum.el b/consult-selectrum.el
index c5696e2..d47e07f 100644
--- a/consult-selectrum.el
+++ b/consult-selectrum.el
@@ -31,6 +31,7 @@
 (defvar selectrum-highlight-candidates-function)
 (defvar selectrum-is-active)
 (defvar selectrum-refine-candidates-function)
+(defvar selectrum--history-hash)
 (declare-function selectrum-exhibit "ext:selectrum")
 (declare-function selectrum-get-current-candidate "ext:selectrum")
 
@@ -56,13 +57,15 @@ See `consult--completion-filter' for arguments PATTERN, 
CANDS, CATEGORY and HIGH
   "Return current selectrum candidate."
   (and selectrum-is-active (selectrum-get-current-candidate)))
 
-(defun consult-selectrum--refresh ()
-  "Refresh selectrum view."
+(defun consult-selectrum--refresh (&optional reset)
+  "Refresh completion UI, keep current candidate unless RESET is non-nil."
   (when selectrum-is-active
     (if consult--narrow
         (setq-local selectrum-default-value-format nil)
       (kill-local-variable 'selectrum-default-value-format))
-    (selectrum-exhibit 'keep-selected)))
+    (when reset
+      (setq selectrum--history-hash nil))
+    (selectrum-exhibit (not reset))))
 
 (defun consult-selectrum--split-wrap (orig split)
   "Wrap candidates highlight/refinement ORIG function, splitting the input 
using SPLIT."
diff --git a/consult-vertico.el b/consult-vertico.el
index 0a7b3d7..61b00c4 100644
--- a/consult-vertico.el
+++ b/consult-vertico.el
@@ -28,6 +28,8 @@
 
 ;; NOTE: It is not guaranteed that Vertico is available during compilation!
 (defvar vertico--input)
+(defvar vertico--history-hash)
+(defvar vertico--lock-candidate)
 (declare-function vertico--exhibit "ext:vertico")
 (declare-function vertico--candidate "ext:vertico")
 
@@ -35,10 +37,13 @@
   "Return current candidate for Consult preview."
   (and vertico--input (vertico--candidate 'highlight)))
 
-(defun consult-vertico--refresh ()
-  "Refresh completion UI, used by Consult async/narrowing."
+(defun consult-vertico--refresh (&optional reset)
+  "Refresh completion UI, keep current candidate unless RESET is non-nil."
   (when vertico--input
     (setq vertico--input t)
+    (when reset
+      (setq vertico--history-hash nil
+            vertico--lock-candidate nil))
     (vertico--exhibit)))
 
 (add-hook 'consult--completion-candidate-hook #'consult-vertico--candidate)
diff --git a/consult.el b/consult.el
index 0035ad5..0bb63f1 100644
--- a/consult.el
+++ b/consult.el
@@ -388,6 +388,10 @@ Used by `consult-completion-in-region', `consult-yank' and 
`consult-history'.")
   '((t))
   "Face used to highlight buffers in `consult-buffer'.")
 
+(defface consult-crm-selected
+  '((t :inherit secondary-selection))
+  "Face used to highlight selected items in 
`consult-completing-read-multiple'.")
+
 (defface consult-line-number-prefix
   '((t :inherit line-number))
   "Face used to highlight line numbers in selections.")
@@ -412,6 +416,7 @@ Used by `consult-completion-in-region', `consult-yank' and 
`consult-history'.")
 (defvar consult--mode-command-history nil)
 (defvar consult--kmacro-history nil)
 (defvar consult--buffer-history nil)
+(defvar consult--crm-history nil)
 
 ;;;; Internal variables
 
@@ -2138,6 +2143,138 @@ These configuration options are supported:
           (message "No completion")
           nil)))))
 
+;;;;; Function: consult-completing-read-multiple
+
+;;;###autoload
+(defun consult-completing-read-multiple (prompt table &optional
+                                                pred require-match 
initial-input
+                                                hist def inherit-input-method)
+  "Enhanced replacement for `completing-read-multiple'.
+See `completing-read-multiple' for the documentation of the arguments."
+  (let* ((orig-candidates (all-completions "" table pred))
+         (format-item
+          (lambda (item)
+            ;; Restore original candidate in order to preserve formatting
+            (setq item (substring (or (car (member item orig-candidates)) 
item)))
+            (add-face-text-property 0 (length item) 'consult-crm-selected 
'append item)
+            (put-text-property 0 (length item) 'consult--crm-selected t item)
+            item))
+         (separator (or (bound-and-true-p crm-separator) "[ \t]*,[ \t]*"))
+         (hist-sym (pcase hist
+                     ('nil 'minibuffer-history)
+                     ('t 'consult--crm-history)
+                     (`(,sym . ,_) sym) ;; ignore history position
+                     (_ hist)))
+         (hist-val (symbol-value hist-sym))
+         (selected
+          (and initial-input
+               (or
+                ;; initial-input is multiple candidates
+                (string-match-p separator initial-input)
+                ;; initial-input is a single candidate
+                (member initial-input orig-candidates))
+               (prog1
+                   (mapcar format-item
+                           (split-string initial-input separator 'omit-nulls))
+                 (setq initial-input nil))))
+         (consult--crm-history (append (mapcar #'substring-no-properties 
selected) hist-val))
+         (candidates (append selected
+                             (seq-remove (lambda (x) (member x selected))
+                                         orig-candidates)))
+         (select-item
+          (lambda (item)
+            (unless (equal item "")
+              (setq selected (if (member item selected)
+                                 ;; Multi selections are not possible.
+                                 ;; This is probably no problem, since this is 
rarely desired.
+                                 (delete item selected)
+                               (nconc selected (list (funcall format-item 
item))))
+                    consult--crm-history (append (mapcar 
#'substring-no-properties selected) hist-val)
+                    candidates (append selected
+                                       (seq-remove (lambda (x) (member x 
selected))
+                                                   orig-candidates))))))
+         (orig-md (and (functionp table) (cdr (funcall table "" nil 
'metadata))))
+         (sort-fun
+          (lambda (sort)
+            (pcase (alist-get sort orig-md)
+              ('identity `((,sort . identity)))
+              ((and sort (guard sort))
+               `((,sort . ,(lambda (cands)
+                             (setq cands (funcall sort cands))
+                             (nconc
+                              (seq-filter (lambda (x) (member x selected)) 
cands)
+                              (seq-remove (lambda (x) (member x selected)) 
cands)))))))))
+         (md
+          `(metadata
+            (group-function
+             . ,(lambda (cand transform)
+                  (if (get-text-property 0 'consult--crm-selected cand)
+                      (if transform cand "Selected")
+                    (or (when-let (group-fun (alist-get 'group-function 
orig-md))
+                          (funcall group-fun cand transform))
+                        (if transform cand "Select multiple")))))
+            ,@(funcall sort-fun 'cycle-sort-function)
+            ,@(funcall sort-fun 'display-sort-function)
+            ,@(seq-filter (lambda (x) (memq (car x) '(annotation-function
+                                                      affixation-function
+                                                      category)))
+                          orig-md)))
+         (overlay)
+         (update-overlay
+          (lambda ()
+            (when overlay
+              (overlay-put overlay 'display
+                           (when selected
+                             (format " (%s selected): " (length selected)))))))
+         (command)
+         (hook (make-symbol "consult--crm-hook"))
+         (wrapper (make-symbol "consult--crm-wrapper")))
+    (fset wrapper
+          (lambda ()
+            (interactive)
+            (pcase (catch 'exit
+                     (setq this-command command)
+                     (call-interactively command)
+                     'continue)
+              ('nil
+               (let ((item (minibuffer-contents-no-properties)))
+                 (when (equal item "")
+                   (throw 'exit nil))
+                 (delete-minibuffer-contents)
+                 (funcall select-item item)
+                 (funcall update-overlay)
+                 (run-hook-with-args 'consult--completion-refresh-hook 
'reset)))
+              ('t (throw 'exit t)))))
+    (fset hook (lambda ()
+                 (setq command this-command
+                       this-command wrapper)))
+    (consult--minibuffer-with-setup-hook
+        (:append
+         (lambda ()
+           (when-let (pos (string-match-p "\\(?: (default[^)]+)\\)?: \\'" 
prompt))
+             (setq overlay (make-overlay (+ (point-min) pos) (+ (point-min) 
(length prompt))))
+             (funcall update-overlay))
+           (add-hook 'pre-command-hook hook nil 'local)))
+      (funcall select-item
+               (completing-read
+                prompt
+                (lambda (str pred action)
+                  (if (eq action 'metadata)
+                      md
+                    (complete-with-action action candidates str pred)))
+                nil ;; predicate
+                require-match
+                initial-input
+                'consult--crm-history
+                "" ;; default
+                inherit-input-method)))
+    (set hist-sym consult--crm-history)
+    (when (consp def)
+      (setq def (car def)))
+    (if (and def (not (equal "" def)) (not selected))
+        (split-string def separator 'omit-nulls)
+      (mapcar #'substring-no-properties selected))))
+
 ;;;; Commands
 
 ;;;;; Command: consult-multi-occur



reply via email to

[Prev in Thread] Current Thread [Next in Thread]