Allow customizing the display of project file names when reading

To hopefully resolve a long-running discussion
(https://lists.gnu.org/archive/html/emacs-devel/2019-05/msg00162.html).

* lisp/progmodes/project.el (project-read-file-name-function):
New variable.
(project--read-file-absolute, project--read-file-cpd-relative):
New functions, possible values for the above.
(project-find-file-in): Use the introduced variable.
(project--completing-read-strict): Retain just the logic that fits
the name.

2 files changed, 55 insertions, 42 deletions

diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index dbd24dfa0a3..d11a5cf574d 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -846,6 +846,8 @@ styles for specific categories, such as files, buffers, etc."
 (defvar completion-category-defaults
   '((buffer (styles . (basic substring)))
     (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)))
     (info-menu (styles . (basic substring))))
   "Default settings for specific completion categories.
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 7c8ca15868e..ddb4f3354cd 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -157,19 +157,13 @@ end it with `/'.  DIR must be one of `project-roots' or
     vc-directory-exclusion-list)
    grep-find-ignored-files))
 
-(cl-defgeneric project-file-completion-table (project dirs)
-  "Return a completion table for files in directories DIRS in PROJECT.
-DIRS is a list of absolute directories; it should be some
-subset of the project roots and external roots.
-
-The default implementation delegates to `project-files'."
-  (let ((all-files (project-files project dirs)))
-    (lambda (string pred action)
-      (cond
-       ((eq action 'metadata)
-        '(metadata . ((category . project-file))))
-       (t
-        (complete-with-action action all-files string pred))))))
+(defun project--file-completion-table (all-files)
+  (lambda (string pred action)
+    (cond
+     ((eq action 'metadata)
+      '(metadata . ((category . project-file))))
+     (t
+      (complete-with-action action all-files string pred)))))
 
 (cl-defmethod project-roots ((project (head transient)))
   (list (cdr project)))
@@ -470,55 +464,72 @@ recognized."
                 (project-external-roots pr))))
     (project-find-file-in (thing-at-point 'filename) dirs pr)))
 
+(defcustom project-read-file-name-function #'project--read-file-cpd-relative
+  "Function to call to read a file name from a list.
+For the arguments list, see `project--read-file-cpd-relative'."
+  :type '(repeat (choice (const :tag "Read with completion from relative names"
+                                project--read-file-cpd-relative)
+                         (const :tag "Read with completion from absolute names"
+                                project--read-file-absolute)
+                         (function :tag "custom function" nil))))
+
+(defun project--read-file-cpd-relative (prompt
+                                        all-files &optional predicate
+                                        hist default)
+  (let* ((common-parent-directory
+          (let ((common-prefix (try-completion "" all-files)))
+            (if (> (length common-prefix) 0)
+                (file-name-directory common-prefix))))
+         (cpd-length (length common-parent-directory))
+         (prompt (if (zerop cpd-length)
+                     prompt
+                   (concat prompt (format " in %s" common-parent-directory))))
+         (substrings (mapcar (lambda (s) (substring s cpd-length)) all-files))
+         (new-collection (project--file-completion-table substrings))
+         (res (project--completing-read-strict prompt
+                                               new-collection
+                                               predicate
+                                               hist default)))
+    (concat common-parent-directory res)))
+
+(defun project--read-file-absolute (prompt
+                                    all-files &optional predicate
+                                    hist default)
+  (project--completing-read-strict prompt
+                                   (project--file-completion-table all-files)
+                                   predicate
+                                   hist default))
+
 (defun project-find-file-in (filename dirs project)
   "Complete FILENAME in DIRS in PROJECT and visit the result."
-  (let* ((table (project-file-completion-table project dirs))
-         (file (project--completing-read-strict
-                "Find file" table nil nil
-                filename)))
+  (let* ((all-files (project-files project dirs))
+         (file (funcall project-read-file-name-function
+                       "Find file" all-files nil nil
+                       filename)))
     (if (string= file "")
         (user-error "You didn't specify the file")
       (find-file file))))
 
 (defun project--completing-read-strict (prompt
                                         collection &optional predicate
-                                        hist default inherit-input-method)
+                                        hist default)
   ;; Tried both expanding the default before showing the prompt, and
   ;; removing it when it has no matches.  Neither seems natural
   ;; enough.  Removal is confusing; early expansion makes the prompt
   ;; too long.
-  (let* ((common-parent-directory
-          (let ((common-prefix (try-completion "" collection)))
-            (if (> (length common-prefix) 0)
-                (file-name-directory common-prefix))))
-         (cpd-length (length common-parent-directory))
-         (prompt (if (zerop cpd-length)
-                     prompt
-                   (concat prompt (format " in %s" common-parent-directory))))
-         ;; XXX: This requires collection to be "flat" as well.
-         (substrings (mapcar (lambda (s) (substring s cpd-length))
-                             (all-completions "" collection)))
-         (new-collection
-          (lambda (string pred action)
-            (cond
-             ((eq action 'metadata)
-              (if (functionp collection) (funcall collection nil nil 'metadata)))
-             (t
-              (complete-with-action action substrings string pred)))))
-         (new-prompt (if default
+  (let* ((new-prompt (if default
                          (format "%s (default %s): " prompt default)
                        (format "%s: " prompt)))
          (res (completing-read new-prompt
-                               new-collection predicate t
+                               collection predicate t
                                nil ;; initial-input
-                               hist default inherit-input-method)))
+                               hist default)))
     (when (and (equal res default)
                (not (test-completion res collection predicate)))
       (setq res
             (completing-read (format "%s: " prompt)
-                             new-collection predicate t res hist nil
-                             inherit-input-method)))
-    (concat common-parent-directory res)))
+                             collection predicate t res hist nil)))
+    res))
 
 (declare-function fileloop-continue "fileloop" ())