bug#41572: 28.0.50; [PATCH] Support plain project marked with file .emacs-project

[Dmitry Gutov <dgutov@yandex.ru>]

[-- Attachment #1: Type: text/plain, Size: 854 bytes --]

On 30/11/2022 15:29, Eli Zaretskii wrote:
>> Date: Wed, 30 Nov 2022 04:26:36 +0200
>> Cc:philipk@posteo.net,rudi@constantly.at,eric@ericabrahamsen.net,
>>   cjpeople2013@gmail.com,theo@thornhill.no,mardani29@yahoo.es,
>>   joaotavora@gmail.com,manuel.uberti@inventati.org,juri@linkov.net,
>>   salutis@me.com,arstoffel@gmail.com,41572@debbugs.gnu.org
>> From: Dmitry Gutov<dgutov@yandex.ru>
>>
>> On 28/11/2022 18:51, Eli Zaretskii wrote:
>>> Then okay, we have 2 built-in project types, and the difference is that one
>>> will use a VCS when available, the other won't.  That's clear enough to have
>>> in the docs, I think.
>> Very good.
>>
>> Eli, what do you think about this feature
>> (project-vc-extra-root-markers) for emacs-29?
> Where can I see the code that you are proposing?

Here you go, I also added some documentation updates and 2 tests.

[-- Attachment #2: project-vc-extra-root-markers-v3.diff --]
[-- Type: text/x-patch, Size: 8383 bytes --]

diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index cc28bddff22..af136ab60e9 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -1,7 +1,7 @@
 ;;; project.el --- Operations on the current project  -*- lexical-binding: t; -*-
 
 ;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
-;; Version: 0.8.3
+;; Version: 0.9.0
 ;; Package-Requires: ((emacs "26.1") (xref "1.4.0"))
 
 ;; This is a GNU ELPA :core package.  Avoid using functionality that
@@ -58,13 +58,30 @@
 ;;
 ;; This list can change in future versions.
 ;;
-;; VC project:
+;; Transient project:
+;;
+;; An instance of this type can be returned by `project-current' if no
+;; project was detected automatically, and the user had to pick a
+;; directory manually.  The fileset it describes is the whole
+;; directory, with the exception of some standard ignored files and
+;; directories.  This type has little purpose otherwise, as the only
+;; generic function it provides an override for is `project-root'.
+;;
+;; VC-aware project:
 ;;
 ;; Originally conceived as an example implementation, now it's a
 ;; relatively fast backend that delegates to 'git ls-files' or 'hg
 ;; status' to list the project's files.  It honors the VC ignore
 ;; files, but supports additions to the list using the user option
-;; `project-vc-ignores' (usually through .dir-locals.el).
+;; `project-vc-ignores' (usually through .dir-locals.el).  See the
+;; customization group `project-vc' for other options that control its
+;; behavior.
+;;
+;; If the repository is using any other VCS than Git or Hg, the file
+;; listing uses the default mechanism based on 'find'.
+;;
+;; This project type can also be used for non-VCS controlled
+;; directories, see the variable `project-vc-extra-root-markers'.
 ;;
 ;; Utils:
 ;;
@@ -377,7 +394,7 @@ project-buffers
     (nreverse bufs)))
 
 (defgroup project-vc nil
-  "Project implementation based on the VC package."
+  "VC-aware project implementation."
   :version "25.1"
   :group 'project)
 
@@ -397,21 +414,48 @@ project-vc-merge-submodules
   :safe #'booleanp)
 
 (defcustom project-vc-include-untracked t
-  "When non-nil, the VC project backend includes untracked files."
+  "When non-nil, the VC-aware project backend includes untracked files."
   :type 'boolean
   :version "29.1"
   :safe #'booleanp)
 
 (defcustom project-vc-name nil
-  "When non-nil, the name of the current VC project.
+  "When non-nil, the name of the current VC-aware project.
 
-The best way to change the value a VC project reports as its
-name, is by setting this in .dir-locals.el."
+The best way to change the value a VC-aware project reports as
+its name, is by setting this in .dir-locals.el."
   :type '(choice (const :tag "Default to the base name" nil)
                  (string :tag "Custom name"))
   :version "29.1"
   :safe #'stringp)
 
+;; Not using regexps because these wouldn't work in Git pathspecs, in
+;; case we decide we need to be able to list nested projects.
+(defcustom project-vc-extra-root-markers nil
+  "List of additional markers to signal project roots.
+
+A marker is either a base file name or a glob pattern for such.
+
+A directory containing such a marker file or a file matching a
+marker pattern will be recognized as the root of a VC-aware
+project.
+
+Example values: \".dir-locals.el\", \"package.json\", \"pom.xml\",
+\"requirements.txt\", \"Gemfile\", \"*.gemspec\", \"autogen.sh\".
+
+These will be used in addition to regular directory markers such
+as \".git\", \".hg\", and so on, depending on the value of
+`vc-handled-backends'.  It is most useful when a project has
+subdirectories inside it that need to be considered as separate
+projects.  It can also be used for projects outside of VC
+repositories.
+
+In either case, their behavior will still obey the relevant
+variables, such as `project-vc-ignores' or `project-vc-name'."
+  :type 'list
+  :version "29.1"
+  :safe (lambda (val) (and (listp val) (cl-every #'stringp val))))
+
 ;; FIXME: Using the current approach, major modes are supposed to set
 ;; this variable to a buffer-local value.  So we don't have access to
 ;; the "external roots" of language A from buffers of language B, which
@@ -420,7 +464,7 @@ project-vc-name
 ;;
 ;; We could add a second argument to this function: a file extension,
 ;; or a language name.  Some projects will know the set of languages
-;; used in them; for others, like VC-based projects, we'll need
+;; used in them; for others, like the VC-aware type, we'll need
 ;; auto-detection.  I see two options:
 ;;
 ;; - That could be implemented as a separate second hook, with a
@@ -444,32 +488,54 @@ project-vc-external-roots-function
 It should return a list of directory roots that contain source
 files related to the current buffer.
 
-The directory names should be absolute.  Used in the VC project
-backend implementation of `project-external-roots'.")
+The directory names should be absolute.  Used in the VC-aware
+project backend implementation of `project-external-roots'.")
 
 (defun project-try-vc (dir)
+  (defvar vc-svn-admin-directory)
+  (require 'vc-svn)
+  ;; FIXME: Learn to invalidate when the value of
+  ;; `project-vc-merge-submodules' or `project-vc-extra-root-markers'
+  ;; changes.
   (or (vc-file-getprop dir 'project-vc)
-      (let* ((backend (ignore-errors (vc-responsible-backend dir)))
+      (let* ((backend-markers-alist `((Git . ".git")
+                                      (Hg . ".hg")
+                                      (Bzr . ".bzr")
+                                      (SVN . ,vc-svn-admin-directory)
+                                      (DARCS . "_darcs")
+                                      (Fossil . ".fslckout")))
+             (backend-markers
+              (delete
+               nil
+               (mapcar
+                (lambda (b) (assoc-default b backend-markers-alist))
+                vc-handled-backends)))
+             (marker-re
+              (mapconcat
+               (lambda (m) (format "\\(%s\\)" (wildcard-to-regexp m)))
+               (append backend-markers project-vc-extra-root-markers)
+               "\\|"))
+             (locate-dominating-stop-dir-regexp
+              (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp))
+             last-matches
              (root
-              (pcase backend
-                ('Git
-                 ;; Don't stop at submodule boundary.
-                 (or (vc-file-getprop dir 'project-git-root)
-                     (let ((root (vc-call-backend backend 'root dir)))
-                       (vc-file-setprop
-                        dir 'project-git-root
-                        (if (and
-                             ;; FIXME: Invalidate the cache when the value
-                             ;; of this variable changes.
-                             project-vc-merge-submodules
-                             (project--submodule-p root))
-                            (let* ((parent (file-name-directory
-                                            (directory-file-name root))))
-                              (vc-call-backend backend 'root parent))
-                          root)))))
-                ('nil nil)
-                (_ (ignore-errors (vc-call-backend backend 'root dir)))))
+              (locate-dominating-file
+               dir
+               (lambda (d)
+                 (setq last-matches (directory-files d nil marker-re t 100)))))
+             (backend
+              (cl-find-if
+               (lambda (b)
+                 (member (assoc-default b backend-markers-alist)
+                         last-matches))
+               vc-handled-backends))
              project)
+        (when (and
+               (eq backend 'Git)
+               project-vc-merge-submodules
+               (project--submodule-p root))
+          (let* ((parent (file-name-directory (directory-file-name root))))
+            (setq root (vc-call-backend 'Git 'root parent))))
         (when root
           (setq project (list 'vc backend root))
           ;; FIXME: Cache for a shorter time.
@@ -627,7 +693,8 @@ project-ignores
   (let* ((root (nth 2 project))
          backend)
     (append
-     (when (file-equal-p dir root)
+     (when (and backend
+                (file-equal-p dir root))
        (setq backend (cadr project))
        (delq
         nil