emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] scratch/project-uniquify-files b701fb1 1/4: Add uniquify-f


From: Stephen Leake
Subject: [Emacs-diffs] scratch/project-uniquify-files b701fb1 1/4: Add uniquify-files.el and file-complete-root-relative.el completion
Date: Fri, 19 Apr 2019 13:26:47 -0400 (EDT)

branch: scratch/project-uniquify-files
commit b701fb125c78b162eaf46f23893225deb27ec44f
Author: Stephen Leake <address@hidden>
Commit: Stephen Leake <address@hidden>

    Add uniquify-files.el and file-complete-root-relative.el completion
    
    * lisp/files.el (path-files): New; return all files in path.
    
    * lisp/minibuffer.el (completion-category-defaults): Add
    uniquify-file, file-root-rel.
    (completing-read-default): Query table for 'alist result.
    
    * lisp/progmodes/project.el (project-file-completion-table): Use
    fc-file-root-rel-completion-table.
    (project-find-file): Add optional filename arg.
    (project--completing-read-strict): Delete common-parent-directory
    computation; assume user or project uses file-root-rel completion
    style instead.
    
    * lisp/uniquify-files.el: New file.
    
    * lisp/file-complete-root-relative.el: New file.
---
 lisp/file-complete-root-relative.el | 223 ++++++++++++++++++++++++
 lisp/files.el                       |  26 +++
 lisp/minibuffer.el                  |   9 +
 lisp/progmodes/project.el           |  68 +++-----
 lisp/uniquify-files.el              | 326 ++++++++++++++++++++++++++++++++++++
 5 files changed, 609 insertions(+), 43 deletions(-)

diff --git a/lisp/file-complete-root-relative.el 
b/lisp/file-complete-root-relative.el
new file mode 100644
index 0000000..d8aa053
--- /dev/null
+++ b/lisp/file-complete-root-relative.el
@@ -0,0 +1,223 @@
+;;; file-complete-root-relative.el --- Completion style for files  -*- 
lexical-binding:t -*-
+;;
+;; Copyright (C) 2019 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <address@hidden>
+;; Maintainer: Stephen Leake <address@hidden>
+;;
+;; 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--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 relative or absolute file names.
+Pattern is in reverse order."
+  (let* ((case-fold-search completion-ignore-case)
+        (completion-pcm--delim-wild-regex
+         (concat "[" completion-pcm-word-delimiters "*]"))
+        (pattern (completion-pcm--string->pattern string point)))
+    (completion-pcm--merge-completions all pattern)
+    ))
+
+(defun fc-root-rel-try-completion (string table pred point)
+  "Implement `completion-try-completion' for file-root-rel."
+  (let (result
+       rel-all
+       done)
+
+    ;; Compute result, set done.
+    (cond
+     ((functionp table)
+      (setq rel-all (fc-root-rel-all-completions string table pred point))
+
+      (cond
+       ((null rel-all) ;; No matches.
+       (setq result nil)
+       (setq done t))
+
+       ((= 1 (length rel-all)) ;; One match; unique.
+       (setq done t)
+
+       ;; Check for valid completion
+       (if (string-equal string (car rel-all))
+           (setq result t)
+
+         (setq result (car rel-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
+     ;; relative file names.
+
+     ((null table) ;; No matches.
+      (setq result nil)
+      (setq done t))
+
+     (t
+      (setq rel-all table)
+      (setq done nil))
+     )
+
+    (if done
+       result
+
+      ;; Find merged completion of relative file names
+      (let* ((merged-pat (fc-root-rel--pcm-merged-pat string rel-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 fc-root-rel--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 (fc-root-rel--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)
+       (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 fc-root-rel-all-completions (string table pred point)
+  "Implement `completion-all-completions' for root-relative."
+  ;; Returns list of abs file names.
+  (let* ((all (all-completions string table pred)))
+    (when all
+      (fc-root-rel--hilit string all point)
+      )))
+
+(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 controls what completion styles are appropriate.
+          '(category . fc-root-rel))))
+
+   ((memq action
+         '(nil    ;; Called from `try-completion'
+           lambda ;; Called from `test-completion'
+           t))    ;; Called from all-completions
+
+    (let ((regex (completion-pcm--pattern->regex
+                 (completion-pcm--string->pattern 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
+            '(file-root-rel
+              fc-root-rel-try-completion
+              fc-root-rel-all-completions
+              "display relative file names"))
+
+(provide 'file-complete-root-relative)
+;;; file-complete-root-relative.el ends here
diff --git a/lisp/files.el b/lisp/files.el
index 77a194b..7e98f5a 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 dbd24df..fa646cc 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)))
+    (uniquify-file (styles . (uniquify-file)))
+    (file-root-rel (styles . (file-root-rel)))
     (project-file (styles . (substring)))
     (info-menu (styles . (basic substring))))
   "Default settings for specific completion categories.
@@ -3582,6 +3584,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 dabc4ab..f05e1f9 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 (length (= 1 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)))
@@ -448,14 +447,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 ()
@@ -482,42 +481,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 default
+                     (format "%s (default %s): " prompt default)
+                   (format "%s: " prompt)))
+         (res (completing-read (format "%s: " 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
+                             collection predicate t res hist nil
                              inherit-input-method)))
-    (concat common-parent-directory res)))
+    ))
 
 (declare-function fileloop-continue "fileloop" ())
 
diff --git a/lisp/uniquify-files.el b/lisp/uniquify-files.el
new file mode 100644
index 0000000..fc7dace
--- /dev/null
+++ b/lisp/uniquify-files.el
@@ -0,0 +1,326 @@
+;;; uniquify-files.el --- Completion style for files, minimizing directories  
-*- lexical-binding:t -*-
+;;
+;; Copyright (C) 2019  Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <address@hidden>
+;; Maintainer: Stephen Leake <address@hidden>
+;;
+;; 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)
+       (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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]