emacs-diffs
[Top][All Lists]
Advanced

[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



reply via email to

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