[elpa] externals/uniquify-files ca881b6 11/22: In uniquify-files, use text property to pass completion style

[Stefan Monnier]

branch: externals/uniquify-files
commit ca881b68ff0ebedbc988512f77ba8dc16c4ffa3e
Author: Stephen Leake <stephen_leake@stephe-leake.org>
Commit: Stephen Leake <stephen_leake@stephe-leake.org>

    In uniquify-files, use text property to pass completion style
    
    * packages/uniquify-files/uniquify-files.el:
    (uniq-file--regexp, uniq-file--conflicts, uniq-file--hilit): Rename from
    uniq-files-*.
    (uniq-file--set-style): New.
    (uniq-file-all-completions): Use it.
    (completion-get-data-string, completion-to-table-input): Use
    'completion-style text property.
    
    * packages/uniquify-files/uniquify-files-test.el: Match code changes.
    
    * packages/uniquify-files/file-complete-root-relative.el:
    (fc-root-rel-all-completions): Set 'completion-style text property.
    
    * packages/uniquify-files/file-complete-root-relative-test.el:
    (test-fc-root-rel-test-completion-1): Match code changes.
---
 file-complete-root-relative-test.el | 43 ++++++++++---------
 file-complete-root-relative.el      |  1 +
 uniquify-files-test.el              | 45 +++++++++++---------
 uniquify-files.el                   | 84 +++++++++++++++++--------------------
 4 files changed, 90 insertions(+), 83 deletions(-)

diff --git a/file-complete-root-relative-test.el 
b/file-complete-root-relative-test.el
index f696288..ddf863e 100644
--- a/file-complete-root-relative-test.el
+++ b/file-complete-root-relative-test.el
@@ -174,33 +174,38 @@
   )
 
 (defun test-fc-root-rel-test-completion-1 (table)
-  (should (equal (test-completion "foo-fi" table)
-                nil))
+  ;; In normal operation, 'all-completions' is called before
+  ;; test-completion, and it sets the 'completion-style text property.
+  (cl-flet ((ss (str)
+               (put-text-property 0 1 'completion-style 'file-root-rel str)
+               str))
+    (should (equal (test-completion (ss "foo-fi") table)
+                  nil))
 
-  (should (equal (test-completion "dir/f-fi" table)
-                nil))
+    (should (equal (test-completion (ss "dir/f-fi") table)
+                  nil))
 
-  (should (equal (test-completion "foo-file1.text" table)
-                t)) ;; starts at root
+    (should (equal (test-completion (ss "foo-file1.text") table)
+                  t)) ;; starts at root
 
-  (should (equal (test-completion "alice-1/foo-file1.text" table)
-                nil)) ;; does not start at root
+    (should (equal (test-completion (ss "alice-1/foo-file1.text") table)
+                  nil)) ;; does not start at root
 
-  (should (equal (test-completion "Alice/alice-1/foo-file1.text" table)
-                t)) ;; starts at root
+    (should (equal (test-completion (ss "Alice/alice-1/foo-file1.text") table)
+                  t)) ;; starts at root
 
-  (should (equal (test-completion "foo-file3.text" table)
-                nil))
+    (should (equal (test-completion (ss "foo-file3.text") table)
+                  nil))
 
-  (should (equal (test-completion "foo-file3.texts2" table)
-                t))
+    (should (equal (test-completion (ss "foo-file3.texts2") table)
+                  t))
 
-  (should (equal (test-completion "Alice/alice-/bar-file2.text" table)
-                nil))
+    (should (equal (test-completion (ss "Alice/alice-/bar-file2.text") table)
+                  nil))
 
-  (should (equal (test-completion "Alice/alice-1/bar-file2.text" table)
-                t))
-  )
+    (should (equal (test-completion (ss "Alice/alice-1/bar-file2.text") table)
+                  t))
+    ))
 
 (ert-deftest test-fc-root-rel-test-completion-iter ()
   (let ((table (apply-partially 'fc-root-rel-completion-table-iter 
fc-root-rel-iter))
diff --git a/file-complete-root-relative.el b/file-complete-root-relative.el
index 929afdc..e3ece9a 100644
--- a/file-complete-root-relative.el
+++ b/file-complete-root-relative.el
@@ -191,6 +191,7 @@ character after each completion field."
     (when all
       (setq all (fc-root-rel-to-user all (fc-root-rel--root table)))
       (fc-root-rel--hilit user-string all point))
+      (uniq-file--set-style all 'file-root-rel))
     ))
 
 (defun fc-root-rel--valid-completion (string all root)
diff --git a/uniquify-files-test.el b/uniquify-files-test.el
index 4dc1923..13214a4 100644
--- a/uniquify-files-test.el
+++ b/uniquify-files-test.el
@@ -159,30 +159,35 @@
   )
 
 (defun test-uniq-file-test-completion-1 (table)
-  (should (equal (test-completion "foo-fi" table)
-                nil))
+  ;; In normal operation, 'all-completions' is called before
+  ;; test-completion, and it sets the 'completion-style text property.
+  (cl-flet ((ss (str)
+               (put-text-property 0 1 'completion-style 'uniquify-file str)
+               str))
+    (should (equal (test-completion (ss "foo-fi") table)
+                  nil))
 
-  (should (equal (test-completion "f-fi<dir" table)
-                nil))
+    (should (equal (test-completion (ss "f-fi<dir") table)
+                  nil))
 
-  (should (equal (test-completion "foo-file1.text<>" table)
-                t))
+    (should (equal (test-completion (ss "foo-file1.text<>") table)
+                  t))
 
-  (should (equal (test-completion "foo-file1.text" table)
-                t))
+    (should (equal (test-completion (ss "foo-file1.text") table)
+                  t))
 
-  (should (equal (test-completion "foo-file1.text<alice-1/>" table)
-                t))
+    (should (equal (test-completion (ss "foo-file1.text<alice-1/>") table)
+                  t))
 
-  (should (equal (test-completion "foo-file3.tex" table) ;; partial file name
-                nil))
+    (should (equal (test-completion (ss "foo-file3.tex") table) ;; partial 
file name
+                  nil))
 
-  (should (equal (test-completion "foo-file3.texts2" table)
-                t))
+    (should (equal (test-completion (ss "foo-file3.texts2") table)
+                  t))
 
-  (should (equal (test-completion "bar-file2.text<Alice/alice-" table)
-                nil))
-  )
+    (should (equal (test-completion (ss "bar-file2.text<Alice/alice-") table)
+                  nil))
+    ))
 
 (ert-deftest test-uniq-file-test-completion-func ()
   (let ((table (apply-partially 'uniq-file-completion-table uft-iter)))
@@ -411,7 +416,9 @@
 
 (defun test-uniq-file-hilit (pos-list string)
   "Set 'face text property to 'completions-first-difference at
-all positions in POS-LIST in STRING; return new string."
+all positions in POS-LIST in STRING; return new string.
+Also set 'completion-style."
+  (put-text-property 0 1 'completion-style 'uniquify-file string)
   (while pos-list
     (let ((pos (pop pos-list)))
       (put-text-property pos (1+ pos) 'face 'completions-first-difference 
string)))
@@ -509,7 +516,7 @@ all positions in POS-LIST in STRING; return new string."
     (should (equal-including-properties
             (sort (uniq-file-all-completions "foo-file3.text" table nil nil) 
#'string-lessp)
             (list
-             "foo-file3.text"
+             (test-uniq-file-hilit '()   "foo-file3.text")
              (test-uniq-file-hilit '(14) "foo-file3.texts")
              (test-uniq-file-hilit '(14) "foo-file3.texts2")
              )))
diff --git a/uniquify-files.el b/uniquify-files.el
index a281ebb..dc6c491 100644
--- a/uniquify-files.el
+++ b/uniquify-files.el
@@ -176,7 +176,7 @@
 (require 'cl-lib)
 (require 'path-iterator)
 
-(defconst uniq-files--regexp "^\\(.*\\)<\\([^>]*\\)>?$"
+(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.
@@ -212,8 +212,8 @@ Match 1 is the filename, match 2 is the relative 
directory.")
     "")
    ))
 
-(defun uniq-files--conflicts (conflicts dir)
-  "Subroutine of `uniq-files-uniquify'."
+(defun uniq-file--conflicts (conflicts dir)
+  "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)))))
 
@@ -307,7 +307,7 @@ If DIR is non-nil, all elements of NAMES must match DIR."
                   (concat (file-name-nondirectory (car conflicts))))
                 result))
 
-           (setq result (append (uniq-files--conflicts conflicts dir) result)))
+           (setq result (append (uniq-file--conflicts conflicts dir) result)))
          )
        (nreverse result)
        ))
@@ -315,7 +315,7 @@ If DIR is non-nil, all elements of NAMES must match DIR."
 
 (defun uniq-file-to-table-input (user-string &optional _table _pred)
   "Implement `completion-to-table-input' for uniquify-file."
-  (let* ((match (string-match uniq-files--regexp user-string))
+  (let* ((match (string-match uniq-file--regexp user-string))
         (dir (and match (match-string 2 user-string))))
 
     (if match
@@ -479,7 +479,7 @@ Pattern is in reverse order."
        (cons merged new-point)))
     ))
 
-(defun uniq-files--hilit (string all 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.
@@ -519,6 +519,14 @@ nil otherwise."
        (setq result nil)))
     result))
 
+(defun uniq-file--set-style (all style)
+  "Set completion-style text property on each string in ALL to STYLE."
+  (mapcar
+   (lambda (str)
+     (put-text-property 0 1 'completion-style style str)
+     str)
+   all))
+
 (defun uniq-file-all-completions (user-string table pred point)
   "Implement `completion-all-completions' for uniquify-file."
   ;; Returns list of data format strings (abs file names).
@@ -550,7 +558,8 @@ nil otherwise."
 
     (when all
       (setq all (uniq-file--uniquify all (file-name-directory table-string)))
-      (uniq-files--hilit user-string all point))
+      (uniq-file--hilit user-string all point)
+      (uniq-file--set-style all 'uniquify-file))
     ))
 
 (defun uniq-file-get-data-string (user-string table pred)
@@ -592,46 +601,31 @@ nil otherwise."
 
 (defun completion-get-data-string (user-string table pred)
   "Return the data string corresponding to USER-STRING."
-  (let* ((styles
-         (or (cdr (assq 'styles (completion-metadata user-string table pred)))
-             (completion--styles (completion-metadata user-string table 
pred))))
-
-        (results
-         ;;  FIXME: This is ultimately called from
-         ;;  `completion-try-completion' or `completion-all-completions';
-         ;;  there is only one style currently being used. Need to pass that
-         ;;  style from there to here.
-         (mapcar (lambda (style)
-                   (let ((to-data-func (nth 5 (assq style 
completion-styles-alist))))
-                     (if to-data-func
-                         (funcall to-data-func user-string table pred)
-                       user-string)))
-                 styles))
-        )
-    (car (delete-dups results))
-    ))
+  ;; If the style requires a conversion here, the completion-style
+  ;; text property was set on USER-STRING by the style implementation
+  ;; of all-completions.
+  (let* ((style (get-text-property 0 'completion-style user-string))
+        (to-data-func (when style (nth 5 (assq style 
completion-styles-alist)))))
+    (if to-data-func
+       (funcall to-data-func user-string table pred)
+      user-string)))
 
 (defun completion-to-table-input (orig-fun user-string table &optional pred)
-  "Advice for `test-completion'; convert user string to table input."
-  ;; See FIXME: in completion-get-data-string
-  (let* ((styles
-         (or (cdr (assq 'styles (completion-metadata user-string table pred)))
-             (completion--styles (completion-metadata user-string table 
pred))))
-        (table-strings
-         (mapcar
-          (lambda (style)
-            (let ((to-table-func (if (functionp table)
-                                     (nth 4 (assq style 
completion-styles-alist)) ;; user to table
-
-                                   ;; TABLE is a list of absolute file names
-                                   (nth 5 (assq style 
completion-styles-alist)) ;; user to data
-                                   )))
-              (if to-table-func
-                  (funcall to-table-func user-string table pred)
-                user-string)))
-          styles)))
-    (setq table-strings (delete-dups table-strings))
-    (funcall orig-fun (car table-strings) table pred)
+  "Convert user string to table input."
+  ;; See comment in completion-get-data-string about completion-style
+  ;; text-property.
+  (let* ((style (get-text-property 0 'completion-style user-string))
+        (table-string
+         (let ((to-table-func (if (functionp table)
+                                  (nth 4 (assq style completion-styles-alist)) 
;; user to table
+
+                                ;; TABLE is a list of absolute file names
+                                (nth 5 (assq style completion-styles-alist)) 
;; user to data
+                                )))
+           (if to-table-func
+               (funcall to-table-func user-string table pred)
+             user-string))))
+    (funcall orig-fun table-string table pred)
     ))
 
 (advice-add #'test-completion :around #'completion-to-table-input)