From: Eshel Yaron Date: Wed, 3 Jul 2024 18:43:50 +0000 (+0200) Subject: New command 'minibuffer-export' X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=22528cfab9d660d0738cc4d59def79478263ac50;p=emacs.git New command 'minibuffer-export' --- diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index e45c556465d..1c4a0e5ac6b 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1160,15 +1160,17 @@ styles for specific categories, such as files, buffers, etc." :version "23.1") (defvar completion-category-defaults - '((buffer (styles . (basic substring))) - (unicode-name (styles . (basic substring))) + '((buffer (styles basic substring) + (export-function . minibuffer-export-list-buffers)) + (file (export-function . minibuffer-export-dired)) + (unicode-name (styles basic substring)) ;; A new style that combines substring and pcm might be better, ;; e.g. one that does not anchor to bos. - (project-file (styles . (substring))) - (xref-location (styles . (substring))) - (info-menu (styles . (basic substring))) - (symbol-help (styles . (basic shorthand substring))) - (multiple-choice (styles . (basic substring)) (sort-function . identity)) + (project-file (styles substring)) + (xref-location (styles substring)) + (info-menu (styles basic substring)) + (symbol-help (styles basic shorthand substring)) + (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)) @@ -3480,6 +3482,7 @@ The completion method is determined by `completion-at-point-functions'." "C-x ~" #'minibuffer-toggle-exceptional-candidates "C-x C-a" #'minibuffer-toggle-completions-annotations "C-x C-." #'minibuffer-auto-completion-mode + "C-x M-e" #'minibuffer-export "C-p" #'minibuffer-previous-line-or-completion "C-n" #'minibuffer-next-line-or-completion "C-%" #'minibuffer-query-apply) @@ -6347,5 +6350,164 @@ interactions is customizable via `minibuffer-regexp-prompts'." (put 'minibuffer-kill-from-history 'minibuffer-action "delete") +(defvar minibuffer-collect-completions nil) +(defvar minibuffer-collect-base nil) +(defvar minibuffer-collect-action nil) + +(defun minibuffer-collect-apply (&optional event) + "Apply minibuffer action to the candidate at mouse EVENT or at point." + (interactive (list last-nonmenu-event) minibuffer-collect-mode) + (with-current-buffer (window-buffer (posn-window (event-start event))) + (funcall (car minibuffer-collect-action) + (concat minibuffer-collect-base + (get-text-property (posn-point (event-start event)) + 'completion--string))))) + +(defun minibuffer-collect-revert (&rest _) + (let ((inhibit-read-only t)) + (erase-buffer) + (delete-all-overlays) + (completion--insert-one-column minibuffer-collect-completions nil)) + (goto-char (point-min))) + +(defvar-keymap minibuffer-collect-mode-map + :doc "Keymap for Minibuffer Collect mode." + "n" #'next-completion + "p" #'previous-completion + "RET" #'minibuffer-collect-apply + "" #'minibuffer-collect-apply + "" 'mouse-face) + +(define-derived-mode minibuffer-collect-mode special-mode "Minibuffer Collect" + "Major mode for minibuffer completion collection buffers." + :interactive nil + (cursor-face-highlight-mode) + (setq-local revert-buffer-function #'minibuffer-collect-revert)) + +(defvar minibuffer-export-minibuffer nil) + +(defun minibuffer--export-data () + (let* ((start (minibuffer-prompt-end)) + (end (point-max)) + (string (buffer-substring start end)) + (md (completion--field-metadata start)) + (completion-lazy-hilit t) + (completions (completion-all-completions + string + minibuffer-completion-table + minibuffer-completion-predicate + (- (point) start) + md)) + (last (last completions)) + (base-size (or (cdr last) 0)) + (full-base (substring string 0 base-size)) + (base (funcall (or (alist-get 'adjust-base-function md) #'identity) + full-base))) + (when last (setcdr last nil)) + (list completions base md))) + +(defun minibuffer-collect (completions base md) + (let ((buffer (generate-new-buffer "*Collection*")) + (action (minibuffer-action)) + (sort-fun (completion-metadata-get md 'sort-function)) + (aff-fun (completion-metadata-get md 'affixation-function)) + (ann-fun (completion-metadata-get md 'annotation-function))) + (setq completions + (cond + (minibuffer-completions-sort-function + (funcall minibuffer-completions-sort-function completions)) + (sort-fun (funcall sort-fun completions)) + (t + (pcase completions-sort + ('nil completions) + ('alphabetical (minibuffer-sort-alphabetically completions)) + ('historical (minibuffer-sort-by-history completions)) + (_ (funcall completions-sort completions)))))) + (when minibuffer-completion-annotations + (cond + (aff-fun + (setq completions + (funcall aff-fun completions))) + (ann-fun + (setq completions + (mapcar (lambda (s) + (let ((ann (funcall ann-fun s))) + (if ann (list s ann) s))) + completions))))) + (with-current-buffer buffer + (minibuffer-collect-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (delete-all-overlays) + (completion--insert-one-column completions nil)) + (goto-char (point-min)) + (setq-local minibuffer-collect-completions completions + minibuffer-collect-base base + minibuffer-collect-action action)) + buffer)) + +(defvar minibuffer-default-export-function #'minibuffer-collect) + +(defun minibuffer-export-dired (files dir &optional _) + "Create a Dired buffer listing FILES in DIR." + (setq dir (file-name-as-directory (expand-file-name dir))) + (dired-noselect + (cons dir + (mapcar (compose (lambda (file) (file-relative-name file dir)) + #'directory-file-name) + (seq-filter #'file-exists-p + (mapcar (lambda (file) (expand-file-name file dir)) + files)))))) + +(defun minibuffer-export-list-buffers (buffer-names &rest _) + (list-buffers-noselect nil (mapcar #'get-buffer buffer-names))) + +(defvar minibuffer-export-history nil) + +;;;###autoload +(defun minibuffer-export (&optional export-fn top-level-p) + "Create a category-specific export buffer with current completion candidates. + +Optional argument EXPORT-FN is a function that creates the export +buffer. It should take three arguments: the list of completion +candidates, as strings; the common base part elided from all candidates, +also a string; and the completion metadata. If omitted or nil, +EXPORT-FN defaults to the `export-function' entry in the completion +metadata. If that is also nil, `minibuffer-default-export-function' is +used instead, which defaults to `minibuffer-collect'. Interactively, +without a prefix argument, EXPORT-FN is nil. With a prefix argument, +this command prompts for EXPORT-FN in a recursive minibuffer. + +If second optional argument TOP-LEVEL-P is non-nil, this function +exports the current minibuffer. Otherwise, it exports the minibuffer +that is the value of `minibuffer-export-minibuffer'. Interactively, +TOP-LEVEL-P is non-nil." + (interactive (list + (when current-prefix-arg + (let ((enable-recursive-minibuffers t) + (minibuffer-export-minibuffer (current-buffer))) + (completing-read + (format-prompt "Export function" "minibuffer-collect") + (completion-table-with-metadata + obarray + '((category . function) + (affixation-function . minibuffer--set-action-affixation))) + #'fboundp + nil nil 'minibuffer-export-history "minibuffer-collect"))) + t) + minibuffer-mode) + (when (stringp export-fn) (setq export-fn (read export-fn))) + (with-current-buffer + (if (or top-level-p (not minibuffer-export-minibuffer)) + (current-buffer) + minibuffer-export-minibuffer) + (seq-let (completions base md) (minibuffer--export-data) + (display-buffer (funcall (or export-fn + (completion-metadata-get md 'export-function) + minibuffer-default-export-function) + completions base md))))) + +(put 'minibuffer-export 'minibuffer-action "export") + (provide 'minibuffer) ;;; minibuffer.el ends here