From 4795e83a69484de276c1e2b0b2d9a04525d9b05c Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 1 May 2026 11:33:41 +0100 Subject: [PATCH] Project prompters always default to current project, if any * lisp/progmodes/project.el (project-prompter) (project-prompt-project-dir, project-prompt-project-name): Delete ALLOW-EMPTY parameter. Default to the current project if there is one. * lisp/vc/vc.el (project-root): Declare. (vc--prompt-other-working-tree): Replace ALLOW-EMPTY parameter with new ALLOW-CURRENT parameter. (vc-working-tree-switch-project): Allow selecting the current working tree, for symmetry with project-switch-project. * etc/NEWS: Update. --- etc/NEWS | 5 +- lisp/progmodes/project.el | 108 ++++++++++++++++++++------------------ lisp/vc/vc.el | 40 +++++++------- 3 files changed, 80 insertions(+), 73 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 8f266f2d670..f195e0a9b51 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -976,11 +976,10 @@ It is equivalent to running 'project-any-command' with The prompt now displays the chosen project on which to invoke a command. --- -*** 'project-prompter' values may be called with up to four arguments. +*** 'project-prompter' values may be called with up to three arguments. These allow callers of the value of 'project-prompter' to specify a prompt string; prompt the user to choose between a subset of all the -known projects; disallow returning arbitrary directories; and allow -returning an empty string. +known projects; and disallow returning arbitrary directories. See the docstring of 'project-prompter' for a full specification of these new optional arguments. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 9a9dc6df186..7e794330b1f 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -212,8 +212,8 @@ When it is non-nil, `project-current' will always skip prompting too.") (defcustom project-prompter #'project-prompt-project-dir "Function to call to prompt for a project. -The function is called either with no arguments or with up to four -optional arguments: (&optional PROMPT PREDICATE REQUIRE-KNOWN ALLOW-EMPTY). +The function is called either with no arguments or with up to three +optional arguments: (&optional PROMPT PREDICATE REQUIRE-KNOWN). PROMPT is the prompt string to use. @@ -231,12 +231,14 @@ may allow the user to input arbitrary directories. If PREDICATE and REQUIRE-KNOWN are both non-nil, the value of `project-prompter' should not return any project root directory for which PREDICATE returns nil. -If ALLOW-EMPTY is non-nil, then irrespective of REQUIRE-KNOWN, the user -may enter nothing (i.e., just type RET). -In this case the function should return \"\". Conventionally this is -used to allow the user to select the current project. -Callers should append something like \" (empty for current project)\" to -PROMPT when passing ALLOW-EMPTY non-nil." +The function must always return a valid project. + +If there is a current project, it satisfies PREDICATE (or PREDICATE is +nil), and the method of prompting involves a default selection, then +this default selection should be the current project root. For example +if the function uses `completing-read' then the current project, if any, +should be passed as the DEF argument to `completing-read', and returned +in the case that the user replies with empty input." :type '(choice (const :tag "Prompt for a project directory" project-prompt-project-dir) (const :tag "Prompt for a project name" @@ -1416,7 +1418,7 @@ directories listed in `vc-directory-exclusion-list'." project "Find file" all-files nil 'file-name-history suggested-filename))) - (if (string= file "") + (if (string-empty-p file) (user-error "You didn't specify the file") (find-file file)))) @@ -1845,7 +1847,7 @@ Return non-nil if PROJECT is not a remote project." '(metadata . ((category . project-buffer) (cycle-sort-function . identity)))) ((and (eq action t) - (equal string "")) ;Pcm completion or empty prefix. + (string-empty-p string)) ;Pcm completion or empty prefix. (let* ((all (complete-with-action action buffers string pred)) (non-internal (cl-remove-if (lambda (b) (= (aref b 0) ?\s)) all))) (if (null non-internal) @@ -2311,8 +2313,7 @@ the project list." (defvar project--dir-history) -(defun project-prompt-project-dir - (&optional prompt predicate require-known allow-empty) +(defun project-prompt-project-dir (&optional prompt predicate require-known) "Prompt the user for a directory that is one of the known project roots. The project is chosen among projects known from the project list, see `project-list-file'. @@ -2320,13 +2321,17 @@ If PROMPT is non-nil, use it as the prompt string. If PREDICATE is non-nil, filter possible project choices using this function; see `project-prompter' for more details. Unless REQUIRE-KNOWN is non-nil, it's also possible to enter an -arbitrary directory not in the list of known projects. -If ALLOW-EMPTY is non-nil, it is possible to exit with no input." +arbitrary directory not in the list of known projects." (project--ensure-read-project-list) (when-let* ((pred (alist-get 'prompt project-prune-zombie-projects)) (inhibit-message t)) (project--delete-zombie-projects pred)) (let* ((dir-choice "... (choose a dir)") + (current (and-let* ((p (project-current)) + (_ (or (null predicate) + (funcall predicate + (project-root p))))) + (project-root p))) (choices ;; XXX: Just using this for the category (for the substring ;; completion style). @@ -2334,30 +2339,29 @@ If ALLOW-EMPTY is non-nil, it is possible to exit with no input." (if require-known project--list (append project--list `(,dir-choice))))) (project--dir-history (project-known-project-roots)) - pr-dir) - (cl-loop - do (setq pr-dir - (let (history-add-new-input) - (completing-read (if prompt - ;; TODO: Use `format-prompt' (Emacs 28.1+) - (format "%s: " (substitute-command-keys prompt)) - "Select project: ") - choices - (and predicate - (lambda (choice) - (or (equal choice dir-choice) - (funcall predicate choice)))) - t nil 'project--dir-history))) - ;; If the user simply pressed RET, do this again until they don't. - while (and (not allow-empty) (equal pr-dir ""))) + (pr-dir "")) + (while (string-empty-p pr-dir) + ;; If the user simply pressed RET (and CURRENT is nil), do this + ;; again until they don't. + (setq pr-dir + (let (history-add-new-input) + (completing-read + ;; Emacs 28.1+: Use `format-prompt'. + (cond (prompt (format "%s: " prompt)) + (current "Select project (default current project): ") + (t "Select project: ")) + choices (and predicate + (lambda (choice) + (or (equal choice dir-choice) + (funcall predicate choice)))) + t nil 'project--dir-history current)))) (if (equal pr-dir dir-choice) (read-directory-name "Select directory: " default-directory nil t) pr-dir))) (defvar project--name-history) -(defun project-prompt-project-name - (&optional prompt predicate require-known allow-empty) +(defun project-prompt-project-name (&optional prompt predicate require-known) "Prompt the user for a project, by name, that is one of the known project roots. The project is chosen among projects known from the project list, see `project-list-file'. @@ -2365,13 +2369,17 @@ If PROMPT is non-nil, use it as the prompt string. If PREDICATE is non-nil, filter possible project choices using this function; see `project-prompter' for more details. Unless REQUIRE-KNOWN is non-nil, it's also possible to enter an -arbitrary directory not in the list of known projects. -If ALLOW-EMPTY is non-nil, it is possible to exit with no input." +arbitrary directory not in the list of known projects." (when-let* ((pred (alist-get 'prompt project-prune-zombie-projects)) (inhibit-message t)) (project--delete-zombie-projects pred)) (let* ((dir-choice "... (choose a dir)") project--name-history + (current (and-let* ((p (project-current)) + (_ (or (null predicate) + (funcall predicate + (project-root p))))) + (project-name p))) (choices (let (ret) ;; Iterate in reverse order so project--name-history is in @@ -2390,22 +2398,22 @@ If ALLOW-EMPTY is non-nil, it is possible to exit with no input." (table (project--file-completion-table (reverse (if require-known choices (cons dir-choice choices))))) - pr-name) - (cl-loop - do (setq pr-name - (let (history-add-new-input) - (completing-read (if prompt - (format "%s: " prompt) - "Select project: ") - table nil t nil 'project--name-history))) - ;; If the user simply pressed RET, do this again until they don't. - while (and (not allow-empty) (equal pr-name ""))) - (pcase pr-name - ("" "") - ((pred (equal dir-choice)) (read-directory-name "Select directory: " - default-directory nil t)) - (_ (let ((proj (assoc pr-name choices))) - (if (stringp proj) proj (project-root (cdr proj)))))))) + (pr-name "")) + (while (string-empty-p pr-name) + ;; If the user simply pressed RET (and CURRENT is nil), do this + ;; again until they don't. + (setq pr-name + (let (history-add-new-input) + (completing-read + ;; Emacs 28.1+: Use `format-prompt'. + (cond (prompt (format "%s: " prompt)) + (current "Select project (default current project): ") + (t "Select project: ")) + table nil t nil 'project--name-history current)))) + (if (equal pr-name dir-choice) + (read-directory-name "Select directory: " default-directory nil t) + (let ((proj (assoc pr-name choices))) + (if (stringp proj) proj (project-root (cdr proj))))))) ;;;###autoload (defun project-known-project-roots () diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 3d8c4bf4f1c..303926b8159 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -5732,15 +5732,14 @@ When called from Lisp, BACKEND is the VC backend." (dired directory)) (defvar project-prompter) +(declare-function project-root "project") -(defun vc--prompt-other-working-tree (backend prompt &optional allow-empty) +(defun vc--prompt-other-working-tree (backend prompt &optional allow-current) "Invoke `project-prompter' to choose another working tree. BACKEND is the VC backend. PROMPT is the prompt string for `project-prompter'. -If ALLOW-EMPTY is non-nil, empty input means the current working tree. -In typical usage ALLOW-EMPTY non-nil means that it makes sense to apply -the caller's operation to the current working tree." - ;; If there are no other working trees and ALLOW-EMPTY is non-nil, we +If ALLOW-CURRENT is non-nil, allow selecting the current working tree." + ;; If there are no other working trees and ALLOW-CURRENT is non-nil we ;; still invoke the `project-prompter' and require the user to type ;; \\`RET', even though it's redundant. Doing it this way means that ;; invoking the command on the current working tree works the same @@ -5752,25 +5751,25 @@ the caller's operation to the current working tree." ;; stopping to look at the echo area. (let ((trees (vc-call-backend backend 'known-other-working-trees)) res) - (unless (or trees allow-empty) - (user-error - (substitute-command-keys - "No other working trees. Use \\[vc-add-working-tree] to add one"))) (require 'project) + (cond* ((bind-and* (_ allow-current) + (p (project-current))) + (push (project-root p) trees)) + ((null trees) + (user-error + (substitute-command-keys + "No other working trees. Use \\[vc-add-working-tree] to add one")))) (dolist (tree trees) (when-let* ((p (project-current nil tree))) (project-remember-project p nil t))) (setq res (funcall project-prompter - (if allow-empty - (format "%s (empty for this working tree)" - prompt) + (if allow-current + (concat prompt " (default current working tree)") prompt) - (if trees - (lambda (k &optional _v) - (member (or (car-safe k) k) trees)) - #'ignore) - t allow-empty)) + (lambda (k &optional _v) + (member (or (car-safe k) k) trees)) + 'require-known)) (if (string-empty-p res) (vc-root-dir) res))) (defvar project-current-directory-override) @@ -5801,7 +5800,8 @@ Prompts for the directory file name of the other working tree." (interactive (list (vc--prompt-other-working-tree (vc-responsible-backend default-directory) - "Other working tree to switch to"))) + "Other working tree to switch to" + 'allow-current))) (project-switch-project dir)) ;;;###autoload @@ -5814,7 +5814,7 @@ BACKEND is the VC backend." (let ((backend (vc-responsible-backend default-directory))) (list backend (vc--prompt-other-working-tree backend "Delete working tree" - 'allow-empty)))) + 'allow-current)))) (let* ((delete-this (file-in-directory-p default-directory directory)) (directory (expand-file-name directory)) (default-directory @@ -5860,7 +5860,7 @@ BACKEND is the VC backend." (let ((backend (vc-responsible-backend default-directory))) (list backend (vc--prompt-other-working-tree backend "Relocate working tree" - 'allow-empty) + 'allow-current) (read-directory-name "New location for working tree: " (file-name-parent-directory (vc-root-dir)))))) (let* ((move-this (file-in-directory-p default-directory from))