[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] scratch/project-uniquify-files 640c2a3 3/4: Simplify file-
From: |
Stephen Leake |
Subject: |
[Emacs-diffs] scratch/project-uniquify-files 640c2a3 3/4: Simplify file-complete-root-relative |
Date: |
Fri, 19 Apr 2019 13:26:49 -0400 (EDT) |
branch: scratch/project-uniquify-files
commit 640c2a3bd8669fb14f2a85ef304a4db7a91b612e
Author: Stephen Leake <address@hidden>
Commit: Stephen Leake <address@hidden>
Simplify file-complete-root-relative
* lisp/file-complete-root-relative.el: Simplify; just use standard
completion styles on alist.
---
lisp/file-complete-root-relative.el | 156 ++----------------------------------
1 file changed, 7 insertions(+), 149 deletions(-)
diff --git a/lisp/file-complete-root-relative.el
b/lisp/file-complete-root-relative.el
index d8aa053..5c90cab 100644
--- a/lisp/file-complete-root-relative.el
+++ b/lisp/file-complete-root-relative.el
@@ -46,124 +46,6 @@ An error is signaled if any name in FILES does not begin
with ROOT."
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).
@@ -182,42 +64,18 @@ STRING, PRED, ACTION are completion table arguments."
(cons 'metadata
(list
'(alist . t)
- ;; category controls what completion styles are appropriate.
- '(category . fc-root-rel))))
+ '(category . project-file))))
- ((memq action
- '(nil ;; Called from `try-completion'
- lambda ;; Called from `test-completion'
- t)) ;; Called from all-completions
+ ((null action)
+ (try-completion string files pred))
- (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)))
+ ((eq 'lambda action)
+ (test-completion string files pred))
- (cond
- ((null action)
- (try-completion string result))
+ ((eq t action)
+ (all-completions string files pred))
- ((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