branch: master commit d0c6b0cff6588fa1e13c7bbb7c42d756c13f386c Author: Stephen Leake <stephen_le...@stephe-leake.org> Commit: Stephen Leake <stephen_le...@stephe-leake.org>
Improve uniquify-files * packages/uniquify-files/file-complete-root-relative.el: (fc-root-rel-all-completions): Fix paren bug. * packages/uniquify-files/uniquify-files.el: (completion-current-style):New. (uniq-file-try-completion, uniq-file-all-completions): Set it. (uniq-file-all-completions): Fix bug. (completion-get-data-string, completion-to-table-input): Use completion-current-style. (uniq-file-completing-read-default-advice): Let-bind completion-current-style. (locate-uniquified-file): Use completion table style metadata. --- .../uniquify-files/file-complete-root-relative.el | 4 +- packages/uniquify-files/uniquify-files.el | 71 ++++++++++++++-------- 2 files changed, 46 insertions(+), 29 deletions(-) diff --git a/packages/uniquify-files/file-complete-root-relative.el b/packages/uniquify-files/file-complete-root-relative.el index e09baa8..1724ecc 100644 --- a/packages/uniquify-files/file-complete-root-relative.el +++ b/packages/uniquify-files/file-complete-root-relative.el @@ -190,9 +190,9 @@ 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)) + (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) "Return non-nil if STRING is a valid completion in ALL, diff --git a/packages/uniquify-files/uniquify-files.el b/packages/uniquify-files/uniquify-files.el index dc6c491..9c8ffc7 100644 --- a/packages/uniquify-files/uniquify-files.el +++ b/packages/uniquify-files/uniquify-files.el @@ -176,6 +176,9 @@ (require 'cl-lib) (require 'path-iterator) +(defvar completion-current-style nil + "Current active completion style.") + (defconst uniq-file--regexp "^\\(.*\\)<\\([^>]*\\)>?$" ;; The trailing '>' is optional so the user can type "<dir" in the ;; input buffer to complete directories. @@ -413,6 +416,8 @@ Pattern is in reverse order." uniq-all done) + (setq completion-current-style 'uniquify-file) + ;; Compute result or uniq-all, set done. (cond ((or @@ -520,7 +525,8 @@ nil otherwise." result)) (defun uniq-file--set-style (all style) - "Set completion-style text property on each string in ALL to STYLE." + "Set completion-style text property on each string in ALL to STYLE. +Return a new list." (mapcar (lambda (str) (put-text-property 0 1 'completion-style style str) @@ -534,6 +540,8 @@ nil otherwise." (let ((table-string (uniq-file-to-table-input user-string)) all) + (setq completion-current-style 'uniquify-file) + (cond ((functionp table) (setq all (funcall table table-string pred t))) @@ -558,8 +566,10 @@ nil otherwise." (when all (setq all (uniq-file--uniquify all (file-name-directory table-string))) - (uniq-file--hilit user-string all point) - (uniq-file--set-style all 'uniquify-file)) + (setq all (uniq-file--hilit user-string all point)) + (setq all (uniq-file--set-style all 'uniquify-file)) + all + ) )) (defun uniq-file-get-data-string (user-string table pred) @@ -601,32 +611,27 @@ nil otherwise." (defun completion-get-data-string (user-string table pred) "Return the data string corresponding to USER-STRING." - ;; 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))))) + (let* ((to-data-func (when completion-current-style (nth 5 (assq completion-current-style completion-styles-alist))))) (if to-data-func - (funcall to-data-func user-string table pred) - user-string))) + (funcall to-data-func user-string table pred) + user-string)) + ) (defun completion-to-table-input (orig-fun user-string table &optional 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)))) + (let* ((table-string + (let ((to-table-func (if (functionp table) + (nth 4 (assq completion-current-style completion-styles-alist)) ;; user to table + + ;; TABLE is a list of absolute file names + (nth 5 (assq completion-current-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) @@ -634,9 +639,17 @@ nil otherwise." require-match initial-input hist def inherit-input-method) "Advice for `completing-read-default'; convert user string to data string." - (let ((user-string (funcall orig-fun prompt collection + (let* ((completion-current-style nil) + (user-string (funcall orig-fun prompt collection predicate require-match initial-input hist def inherit-input-method))) + + (unless completion-current-style + ;; If completion-current-style is not set here, it's because the + ;; user invoked `exit-minibuffer' to use the default string, or + ;; because the completion functions did not set it (they are + ;; legacy). + (setq completion-current-style (car (cdr (assq 'styles (completion-metadata "" collection nil)))))) (completion-get-data-string user-string collection predicate) )) @@ -775,9 +788,13 @@ PRED returns non-nil. DEFAULT is the default for completion. In the user input string, `*' is treated as a wildcard." (interactive) - (let ((iter (make-path-iterator :user-path-non-recursive (or path load-path)))) + (let* ((iter (make-path-iterator :user-path-non-recursive (or path load-path))) + (table (apply-partially #'uniq-file-completion-table iter)) + (table-styles (cdr (assq 'styles (completion-metadata "" table nil)))) + (completion-category-overrides + (list (list 'project-file (cons 'styles table-styles))))) (completing-read (or prompt "file: ") - (apply-partially #'uniq-file-completion-table iter) + table predicate t nil nil default) ))