Add new file completion tables, change project.el to allow using themscratch/project-uniquify-files

* lisp/file-complete-root-relative.el: New file.

* lisp/uniquify-files.el: New file.

* test/lisp/progmodes/uniquify-files-resources/: New directory
containing files for testing uniquify-files.

* test/lisp/progmodes/uniquify-files-test.el: New file; test
uniquify-files.

* lisp/files.el (path-files): New function; useful with new completion
tables.

* lisp/progmodes/project.el (project-file-completion-table): Use
file-complete-root-relative completion table.
(project-find-file): Add optional FILENAME parameter.
(project--completing-read-strict): Rewrite to just use the given
completion table; extracting the common directory is now done by
file-complete-root-relative. This also allows using the new
uniquify-files completion table.

* lisp/minibuffer.el (completion-category-defaults): Add
uniquify-file.
(completing-read-default): Add final step to call completion table
with 'alist action if supported.

5 files changed, 470 insertions, 44 deletions

diff --git a/lisp/file-complete-root-relative.el b/lisp/file-complete-root-relative.el
new file mode 100644
index 00000000000..5c90cabb891
--- /dev/null
+++ b/lisp/file-complete-root-relative.el
@@ -0,0 +1,81 @@
+;;; file-complete-root-relative.el --- Completion style for files  -*- lexical-binding:t -*-
+;;
+;; Copyright (C) 2019 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
+;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary
+
+;; A file completion style in which the root directory is left out of
+;; the completion string displayed to the user.
+;;
+;; We accomplish this by preprocessing the list of absolute file names
+;; to be in that style, in an alist with the original absolute file
+;; names, and do completion on that alist.
+
+(require 'cl-lib)
+
+(defun fc-root-rel-to-alist (root files)
+  "Return a file-root-rel alist with file names from FILES.
+Result is a list (REL-NAME . ABS-NAME), where REL-NAME is ABS-NAME with ROOT deleted.
+An error is signaled if any name in FILES does not begin with ROOT."
+  (let ((root-len (length root))
+	result)
+    (mapc
+     (lambda (abs-name)
+       (unless (string-equal root (substring abs-name 0 root-len))
+	 (error "%s does not begin with %s" abs-name root))
+       (push (cons (substring abs-name root-len) abs-name) result))
+     files)
+    result))
+
+(defun fc-root-rel-completion-table (files string pred action)
+  "Implement a completion table for file names in FILES,
+FILES is a list of (REL-NAME . ABS-NAME).
+
+STRING, PRED, ACTION are completion table arguments."
+  (cond
+   ((eq action 'alist)
+    (cdr (assoc string files)))
+
+   ((eq (car-safe action) 'boundaries)
+    ;; We don't use boundaries; return the default definition.
+    (cons 'boundaries
+	  (cons 0 (length (cdr action)))))
+
+   ((eq action 'metadata)
+    (cons 'metadata
+	  (list
+	   '(alist . t)
+	   '(category . project-file))))
+
+   ((null action)
+    (try-completion string files pred))
+
+   ((eq 'lambda action)
+    (test-completion string files pred))
+
+   ((eq t action)
+    (all-completions string files pred))
+
+   ))
+
+(provide 'file-complete-root-relative)
+;;; file-complete-root-relative.el ends here
diff --git a/lisp/files.el b/lisp/files.el
index c05d70a00ec..47ee197536e 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -842,6 +842,32 @@ output directories whose names match REGEXP."
 	    (push (expand-file-name file dir) files)))))
     (nconc result (nreverse files))))
 
+(defun path-files (path &optional pred)
+  "Return a list of all files matching PRED in PATH.
+PATH is flat; no subdirectories of entries in PATH are
+visited (unless they are also in PATH).  PRED is a function
+taking one argument; an absolute file name."
+  (let (visited ;; list of already visited directories, to avoid duplication
+        result)
+    (dolist (dir path)
+      (while (member dir visited)
+	(setq dir (pop path)))
+      (when (and dir
+                 (file-directory-p dir))
+	(push dir visited)
+        (mapc
+         (lambda (rel-file)
+           (let ((absfile (concat (file-name-as-directory dir) rel-file)))
+	     (when (and (not (string-equal "." (substring absfile -1)))
+		        (not (string-equal ".." (substring absfile -2)))
+		        (not (file-directory-p absfile))
+                        (or (null pred)
+                            (funcall pred absfile)))
+	       (push absfile result))))
+	 (file-name-all-completions "" dir));; uses completion-regexp-list
+        ))
+    result))
+
 (defvar module-file-suffix)
 
 (defun load-file (file)
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index dbd24dfa0a3..969f82aa0d5 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -846,6 +846,7 @@ styles for specific categories, such as files, buffers, etc."
 (defvar completion-category-defaults
   '((buffer (styles . (basic substring)))
     (unicode-name (styles . (basic substring)))
+    (uniquify-file (styles . (uniquify-file)))
     (project-file (styles . (substring)))
     (info-menu (styles . (basic substring))))
   "Default settings for specific completion categories.
@@ -3582,6 +3583,13 @@ See `completing-read' for the meaning of the arguments."
                                        nil hist def inherit-input-method)))
     (when (and (equal result "") def)
       (setq result (if (consp def) (car def) def)))
+
+    (when (completion-metadata-get (completion-metadata "" collection nil) 'alist)
+      (setq result (funcall collection result nil 'alist)))
+
+    ;; If collection is itself an alist, we could also fetch that
+    ;; result here, but that would not be backward compatible.
+
     result))
 
 ;; Miscellaneous
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 11a2ef40094..0b10e0935b2 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -88,6 +88,7 @@
 ;;; Code:
 
 (require 'cl-generic)
+(require 'file-complete-root-relative)
 
 (defvar project-find-functions (list #'project-try-vc)
   "Special hook to find the project containing a given directory.
@@ -162,14 +163,12 @@ end it with `/'.  DIR must be one of `project-roots' or
 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))))))
+The default implementation gets a file list from `project-files',
+and uses the `file-root-rel' completion style."
+  (when (= 1 (length dirs))
+    (let* ((all-files (project-files project dirs))
+           (alist (fc-root-rel-to-alist (car dirs) all-files)))
+      (apply-partially #'fc-root-rel-completion-table alist))))
 
 (cl-defmethod project-roots ((project (head transient)))
   (list (cdr project)))
@@ -449,14 +448,14 @@ pattern to search for."
     (read-regexp "Find regexp" (and id (regexp-quote id)))))
 
 ;;;###autoload
-(defun project-find-file ()
+(defun project-find-file (&optional filename)
   "Visit a file (with completion) in the current project's roots.
-The completion default is the filename at point, if one is
-recognized."
+The completion default is FILENAME, or if nil, the filename at
+point, if one is recognized."
   (interactive)
   (let* ((pr (project-current t))
          (dirs (project-roots pr)))
-    (project-find-file-in (thing-at-point 'filename) dirs pr)))
+    (project-find-file-in (or filename (thing-at-point 'filename)) dirs pr)))
 
 ;;;###autoload
 (defun project-or-external-find-file ()
@@ -483,42 +482,25 @@ recognized."
 (defun project--completing-read-strict (prompt
                                         collection &optional predicate
                                         hist default inherit-input-method)
-  ;; 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
-                         (format "%s (default %s): " prompt default)
-                       (format "%s: " prompt)))
-         (res (completing-read new-prompt
-                               new-collection predicate t
-                               nil ;; initial-input
-                               hist default inherit-input-method)))
+  (let* ((prompt (if (and default (< 0 (length default)))
+                     (format "%s (default %s): " prompt default)
+                   (format "%s: " prompt)))
+         (res (completing-read prompt
+                       collection predicate
+                       t   ;; require-match
+                       nil ;; initial-input
+                       hist default inherit-input-method)))
     (when (and (equal res default)
                (not (test-completion res collection predicate)))
+      ;; 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.
       (setq res
-            (completing-read (format "%s: " prompt)
-                             new-collection predicate t res hist nil
+            (completing-read prompt
+                             collection predicate t res hist nil
                              inherit-input-method)))
-    (concat common-parent-directory res)))
+    res))
 
 (declare-function fileloop-continue "fileloop" ())
 
diff --git a/lisp/uniquify-files.el b/lisp/uniquify-files.el
new file mode 100644
index 00000000000..fd6769f46ad
--- /dev/null
+++ b/lisp/uniquify-files.el
@@ -0,0 +1,329 @@
+;;; uniquify-files.el --- Completion style for files, minimizing directories  -*- lexical-binding:t -*-
+;;
+;; Copyright (C) 2019  Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@stephe-leake.org>
+;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary
+
+;; A file completion style in which the completion string displayed to
+;; the user consists of the file basename followed by enough of the
+;; directory part to make the string identify a unique file.
+;;
+;; We accomplish this by preprocessing the list of absolute file names
+;; to be in that style, in an alist with the original absolute file
+;; names, and do completion on that alist.
+
+(require 'cl-lib)
+(require 'files)
+
+
+(defconst uniq-file--regexp "^\\(.*\\)<\\([^>]*\\)>?$"
+  ;; The trailing '>' is optional so the user can type "<dir" in the
+  ;; input buffer to complete directories.
+  "Regexp matching uniqufied file name.
+Match 1 is the filename, match 2 is the relative directory.")
+
+(defun uniq-file-conflicts (conflicts)
+  "Subroutine of `uniq-file-uniquify'."
+  (let ((common-root ;; shared prefix of dirs in conflicts - may be nil
+	 (fill-common-string-prefix (file-name-directory (nth 0 conflicts)) (file-name-directory (nth 1 conflicts)))))
+
+    (let ((temp (cddr conflicts)))
+      (while (and common-root
+		  temp)
+	(setq common-root (fill-common-string-prefix common-root (file-name-directory (pop temp))))))
+
+    (when common-root
+      ;; Trim `common-root' back to last '/'
+      (let ((i (1- (length common-root))))
+	(while (and (> i 0)
+		    (not (= (aref common-root i) ?/)))
+	  (setq i (1- i)))
+	(setq common-root (substring common-root 0 (1+ i)))))
+
+    (cl-mapcar
+     (lambda (name)
+	 (cons (concat (file-name-nondirectory name)
+                       "<"
+                       (substring (file-name-directory name) (length common-root))
+                       ">")
+               name))
+     conflicts)
+    ))
+
+(defun uniq-file-uniquify (names)
+  "Return an alist of uniquified names built from NAMES.
+NAMES is a list containing absolute file names.
+
+The result contains file basenames with partial directory paths
+appended."
+  (let ((case-fold-search completion-ignore-case)
+        result
+	conflicts ;; list of names where all non-directory names are the same.
+	)
+
+    ;; Sort names on basename so duplicates are grouped together
+    (setq names (sort names (lambda (a b)
+			      (string< (file-name-nondirectory a) (file-name-nondirectory b)))))
+
+    (while names
+      (setq conflicts (list (pop names)))
+      (while (and names
+		  (string= (file-name-nondirectory (car conflicts)) (file-name-nondirectory (car names))))
+	(push (pop names) conflicts))
+
+      (if (= 1 (length conflicts))
+	  (push (cons
+		 (concat (file-name-nondirectory (car conflicts)))
+		 (car conflicts))
+		result)
+
+        (setq result (append (uniq-file-conflicts conflicts) result)))
+      )
+    result))
+
+(defun uniq-file--pcm-pat (string point)
+  "Return a pcm pattern that matches STRING (a uniquified file name)."
+  (let* ((completion-pcm--delim-wild-regex
+	  (concat "[" completion-pcm-word-delimiters "<>*]"))
+	 ;; If STRING ends in an empty directory part, some valid
+	 ;; completions won't have any directory part.
+	 (trimmed-string
+	  (if (and (< 0 (length string))
+		   (= (aref string (1- (length string))) ?<))
+	      (substring string 0 -1)
+	    string))
+	 dir-start
+	 (pattern (completion-pcm--string->pattern trimmed-string point)))
+
+    ;; If trimmed-string has a directory part, allow uniquifying
+    ;; directories.
+    (when (and (setq dir-start (string-match "<" trimmed-string))
+	       (< dir-start (1- (length trimmed-string))))
+      (let (new-pattern
+	    item)
+	(while pattern
+	  (setq item (pop pattern))
+	  (push item new-pattern)
+	  (when (equal item "<")
+	    (setq item (pop pattern))
+	    (if (eq item 'any-delim)
+		(push 'any new-pattern)
+	      (push item new-pattern))))
+	(setq pattern (nreverse new-pattern))))
+    pattern))
+
+(defun uniq-file--pcm-merged-pat (string all point)
+  "Return a pcm pattern that is the merged completion of STRING in ALL.
+ALL must be a list of uniquified file names.
+Pattern is in reverse order."
+  (let* ((pattern (uniq-file--pcm-pat string point)))
+    (completion-pcm--merge-completions all pattern)))
+
+(defun uniq-file-try-completion (user-string table pred point)
+  "Implement `completion-try-completion' for uniquify-file."
+  (let (result
+	uniq-all
+	done)
+
+    ;; Compute result or uniq-all, set done.
+    (cond
+     ((functionp table) ;; TABLE is a wrapper function that calls uniq-file-completion-table.
+
+      (setq uniq-all (uniq-file-all-completions user-string table pred point))
+
+      (cond
+       ((null uniq-all) ;; No matches.
+	(setq result nil)
+	(setq done t))
+
+       ((= 1 (length uniq-all)) ;; One match; unique.
+	(setq done t)
+
+	;; Check for valid completion
+	(if (string-equal user-string (car uniq-all))
+	    (setq result t)
+
+	  (setq result (car uniq-all))
+	  (setq result (cons result (length result)))))
+
+       (t ;; Multiple matches
+	(setq done nil))
+       ))
+
+     ;; The following cases handle being called from
+     ;; icomplete-completions with the result of `all-completions'
+     ;; instead of the real table function. TABLE is a list of
+     ;; uniquified file names.
+
+     ((null table) ;; No matches.
+      (setq result nil)
+      (setq done t))
+
+     (t ;; TABLE is a list of uniquified file names
+      (setq uniq-all table)
+      (setq done nil))
+     )
+
+    (if done
+	result
+
+      ;; Find merged completion of uniqified file names
+      (let* ((merged-pat (uniq-file--pcm-merged-pat user-string uniq-all point))
+
+	     ;; `merged-pat' is in reverse order.  Place new point at:
+	     (point-pat (or (memq 'point merged-pat) ;; the old point
+			    (memq 'any   merged-pat) ;; a place where there's something to choose
+			    (memq 'star  merged-pat) ;; ""
+			    merged-pat))             ;; the end
+
+	     ;; `merged-pat' does not contain 'point when the field
+	     ;; containing 'point is fully completed.
+
+	     (new-point (length (completion-pcm--pattern->string point-pat)))
+
+	     ;; Compute this after `new-point' because `nreverse'
+	     ;; changes `point-pat' by side effect.
+	     (merged (completion-pcm--pattern->string (nreverse merged-pat))))
+
+	(cons merged new-point)))
+    ))
+
+(defun uniq-file--hilit (string all point)
+  "Apply face text properties to each element of ALL.
+STRING is the current user input.
+ALL is a list of strings in user format.
+POINT is the position of point in STRING.
+Returns new list.
+
+Adds the face `completions-first-difference' to the first
+character after each completion field."
+  (let* ((merged-pat (nreverse (uniq-file--pcm-merged-pat string all point)))
+	 (field-count 0)
+	 (regex (completion-pcm--pattern->regex merged-pat '(any star any-delim point)))
+	 )
+    (dolist (x merged-pat)
+      (when (not (stringp x))
+	(setq field-count (1+ field-count))))
+
+    (mapcar
+     (lambda (str)
+       ;; First remove previously applied face; `str' may be a reference
+       ;; to a list used in a previous completion.
+       (remove-text-properties 0 (length str) '(face completions-first-difference) str)
+       (when (string-match regex str)
+	 (cl-loop
+	  for i from 1 to field-count
+	  do
+	  (when (and
+		 (match-beginning i)
+		 (<= (1+ (match-beginning i)) (length str)))
+	    (put-text-property (match-beginning i) (1+ (match-beginning i)) 'face 'completions-first-difference str))
+	  ))
+       str)
+     all)))
+
+(defun uniq-file-all-completions (string table pred point)
+  "Implement `completion-all-completions' for uniquify-file."
+  ;; Returns list of data format strings (abs file names).
+  (let ((all (all-completions string table pred)))
+    (when all
+      (uniq-file--hilit string all point))
+    ))
+
+(defun uniq-file-completion-table (files string pred action)
+  "Implement a completion table for uniquified file names in FILES.
+FILES is a list of (UNIQIFIED-NAME . ABS-NAME).
+PRED is called with the ABS-NAME.
+
+If ACTION is 'abs-file-name, return the absolute file name for STRING."
+  (cond
+   ((eq action 'alist)
+    (cdr (assoc string files #'string-equal)))
+
+   ((eq (car-safe action) 'boundaries)
+    ;; We don't use boundaries; return the default definition.
+    (cons 'boundaries
+	  (cons 0 (length (cdr action)))))
+
+   ((eq action 'metadata)
+    (cons 'metadata
+	  (list
+	   '(alist . t)
+           ;; category controls what completion styles are appropriate.
+	   '(category . uniquify-file)
+	   )))
+
+   ((memq action
+	  '(nil    ;; Called from `try-completion'
+	    lambda ;; Called from `test-completion'
+	    t))    ;; Called from all-completions
+
+    (let ((regex (completion-pcm--pattern->regex
+                  (uniq-file--pcm-pat string (length string))))
+	  (case-fold-search completion-ignore-case)
+	  (result nil))
+      (dolist (pair files)
+	(when (and
+	       (string-match regex (car pair))
+	       (or (null pred)
+		   (funcall pred (cdr pair))))
+	  (push (car pair) result)))
+
+      (cond
+       ((null action)
+	(try-completion string result))
+
+       ((eq 'lambda action)
+	(test-completion string files pred))
+
+       ((eq t action)
+	result)
+       )))
+   ))
+
+(add-to-list 'completion-styles-alist
+	     '(uniquify-file
+	       uniq-file-try-completion
+	       uniq-file-all-completions
+	       "display uniquified file names."))
+
+
+;;; Example use case.
+
+(defun locate-uniquified-file (&optional path predicate default prompt)
+  "Return an absolute filename, with completion in non-recursive PATH
+\(default `load-path').  If PREDICATE is nil, it is ignored. If
+non-nil, it must be a function that takes one argument; the
+absolute file name.  The file name is included in the result if
+PRED returns non-nil. DEFAULT is the default for completion.
+
+In the user input string, `*' is treated as a wildcard."
+  (interactive)
+  (let* ((alist (uniq-file-uniquify (path-files path predicate)))
+         (table (apply-partially #'uniq-file-completion-table alist))
+	 (table-styles (cdr (assq 'styles (completion-metadata "" table nil))))
+         (found (completing-read (or prompt "file: ")
+                                 table nil t nil nil default)))
+    (funcall table found nil 'abs-file-name)
+    ))
+
+(provide 'uniquify-files)
+;;; uniquify-files.el ends here