From: Spencer Baugh <sbaugh@janestreet.com>
Date: Mon, 10 Apr 2023 19:11:06 +0000 (-0400)
Subject: Add support for prompting for projects by name
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=9efa6d2cf28f4e21f23bb0dbfedc59a4286dab12;p=emacs.git

Add support for prompting for projects by name

* lisp/progmodes/project.el (project-prompter):
New user option (bug#62759).
(project-prompt-project-name): New function.
---

diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 877d79353aa..e7c0bd2069b 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -202,6 +202,17 @@ CL struct.")
   "Value to use instead of `default-directory' when detecting the project.
 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.
+Called with no arguments and should return a project root dir."
+  :type '(choice (const :tag "Prompt for a project directory"
+                        project-prompt-project-dir)
+                 (const :tag "Prompt for a project name"
+                        project-prompt-project-name)
+                 (function :tag "Custom function" nil))
+  :group 'project
+  :version "30.1")
+
 ;;;###autoload
 (defun project-current (&optional maybe-prompt directory)
   "Return the project instance in DIRECTORY, defaulting to `default-directory'.
@@ -226,7 +237,7 @@ of the project instance object."
      (pr)
      ((unless project-current-directory-override
         maybe-prompt)
-      (setq directory (project-prompt-project-dir)
+      (setq directory (funcall project-prompter)
             pr (project--find-in-directory directory))))
     (when maybe-prompt
       (if pr
@@ -1615,7 +1626,7 @@ passed to `message' as its first argument."
   "Remove directory PROJECT-ROOT from the project list.
 PROJECT-ROOT is the root directory of a known project listed in
 the project list."
-  (interactive (list (project-prompt-project-dir)))
+  (interactive (list (funcall project-prompter)))
   (project--remove-from-project-list
    project-root "Project `%s' removed from known projects"))
 
@@ -1639,6 +1650,32 @@ It's also possible to enter an arbitrary directory not in the list."
         (read-directory-name "Select directory: " default-directory nil t)
       pr-dir)))
 
+(defun project-prompt-project-name ()
+  "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'.
+It's also possible to enter an arbitrary directory not in the list."
+  (let* ((dir-choice "... (choose a dir)")
+         (choices
+          (let (ret)
+            (dolist (dir (project-known-project-roots))
+              ;; we filter out directories that no longer map to a project,
+              ;; since they don't have a clean project-name.
+              (if-let (proj (project--find-in-directory dir))
+                  (push (cons (project-name proj) proj) ret)))
+            ret))
+         ;; XXX: Just using this for the category (for the substring
+         ;; completion style).
+         (table (project--file-completion-table (cons dir-choice choices)))
+         (pr-name ""))
+    (while (equal pr-name "")
+      ;; If the user simply pressed RET, do this again until they don't.
+      (setq pr-name (completing-read "Select project: " table nil t)))
+    (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 ()
   "Return the list of root directories of all known projects."
@@ -1826,7 +1863,7 @@ made from `project-switch-commands'.
 
 When called in a program, it will use the project corresponding
 to directory DIR."
-  (interactive (list (project-prompt-project-dir)))
+  (interactive (list (funcall project-prompter)))
   (let ((command (if (symbolp project-switch-commands)
                      project-switch-commands
                    (project--switch-project-command))))