diff --git a/src/file-name-completion.scm b/src/file-name-completion.scm index 2edcc33..1d974a6 100644 --- a/src/file-name-completion.scm +++ b/src/file-name-completion.scm @@ -1,3 +1,63 @@ +;; cached prefix version + +(define *completion-check-executable* #f) + +(define *cache-alist* '()) + +(define (strings-with-prefix strings prefix) + (let ((plen (string-length prefix))) + (filter (lambda (s) + (and (>= (string-length s) plen) + (string=? (substring s 0 plen) prefix))) + strings))) + +(define (check-cache-for-prefix prefix) + (let ((p (assoc prefix *cache-alist*))) + (if p + (cdr p) + (let loop ((nprefix prefix)) + (if (string=? nprefix "") + #f + (let* ((nprefix (substring prefix 0 (- (string-length nprefix) 1))) + (p (assoc nprefix *cache-alist*))) + (if p + (strings-with-prefix (cdr p) prefix) + (loop nprefix)))))))) + +(define (has-prefix prefix s) + (let ((pl (string-length prefix))) + (and (>= (string-length s) (string-length prefix)) + (string=? (substring s 0 pl) prefix)))) + +(define (add-to-cache prefix list) + (let ((prefixes (strings-with-prefix (map car *cache-alist*) prefix))) + (receive (longer-ones others) + (partition (lambda (p) + (has-prefix prefix (car p))) + *cache-alist*) + (set! *cache-alist* + (cons (cons prefix (append list (append-map cdr longer-ones))) + others))))) + +(define (executables-in-path/prefix prefix) + (let ((maybe-result (check-cache-for-prefix prefix))) + (or maybe-result + (let ((result (append-map! (lambda (dir) + (dir-executables/prefix dir prefix)) + (thread-fluid exec-path-list)))) + (add-to-cache prefix result) + result)))) + +(define (dir-executables/prefix dir prefix) + (if (file-readable? dir) + (map file-name-nondirectory + (let ((files (glob (string-append dir "/" prefix "*")))) + (if *completion-check-executable* + (filter executable? files) + files))) + '())) + +;; caching version (define *cache* #f) @@ -16,10 +76,10 @@ (filter executable? (glob (string-append dir "/*")))) '())) -(define (executable? name) +(define (executable? name) ;; TODO maybe check if executable by this user (with-errno-handler ((errno packet) (else #f)) (let ((info (file-info name))) (and (file-info-executable? info) - (file-info-regular? info))))) \ No newline at end of file + (file-info-regular? info))))) diff --git a/src/packages.scm b/src/packages.scm index 5c6ec13..8c68e9b 100644 --- a/src/packages.scm +++ b/src/packages.scm @@ -80,7 +80,8 @@ (files button)) (define-structure file-name-completion - (export executables-in-path) + (export executables-in-path + executables-in-path/prefix) (open scheme-with-scsh srfi-1 thread-fluids) diff --git a/src/root-manager.scm b/src/root-manager.scm index 0f7e928..f154aa2 100644 --- a/src/root-manager.scm +++ b/src/root-manager.scm @@ -316,7 +316,7 @@ (exec (prompt (root-wm:dpy root-wm) (wm:window cm) (get-option-value (root-wm:options root-wm) 'execute-question) - #f (finite-complete (executables-in-path))))) + #f command-complete))) (and exec (not (string=? exec "")) (let* ((p (make-string-input-port exec)) @@ -372,22 +372,26 @@ (define (finite-complete strings) (lambda (str pos) - (let* ((s (substring str 0 pos)) - (candidates - (filter (lambda (str) - (and (<= (string-length s) (string-length str)) - (equal? s (substring str 0 (string-length s))))) - strings)) - (common (common-substring candidates))) - (cond - ((null? candidates) (cons str pos)) - ((null? (cdr candidates)) - (cons (car candidates) ;; or insert ?? - (string-length (car candidates)))) - ((not (or (equal? common "") (equal? common s))) - (cons common ;; or insert?? - (string-length common))) - (else candidates))))) + (do-complete strings str pos))) + +(define (do-complete strings str pos) + (let* ((s (substring str 0 pos)) + (rest (substring str pos (string-length str))) + (candidates + (filter (lambda (str) + (and (<= (string-length s) (string-length str)) + (equal? s (substring str 0 (string-length s))))) + strings)) + (common (common-substring candidates))) + (cond + ((null? candidates) (cons str pos)) + ((null? (cdr candidates)) + (cons (string-append (car candidates) rest) + (string-length (car candidates)))) + ((not (or (equal? common "") (equal? common s))) + (cons (string-append common rest) + (string-length common))) + (else candidates)))) (define (common-substring strings) (cond @@ -403,6 +407,9 @@ (substring s 0 i))))) (loop 0)))))) +(define (command-complete str pos) + (do-complete (executables-in-path/prefix (substring str 0 pos)) str pos)) + ;; *** observing managers ******************************************** (define (add-manager! root-wm manager)