diff --git a/scheme/complete.scm b/scheme/complete.scm index 1d974a6..667ea19 100644 --- a/scheme/complete.scm +++ b/scheme/complete.scm @@ -1,9 +1,36 @@ +(define-record-type completion-set :completion-set + (really-make-completion-set strings cache) + completion-set? + (strings completion-set-strings set-completion-set-strings!) + (cache completion-set-cache set-completion-set-cache!)) + +(define (make-empty-completion-set) + (really-make-completion-set '() '())) + +(define (make-completion-set strings) + (really-make-completion-set + (lset-intersection strings strings) '())) + +(define (make-completion-set-for-executables path-list) + (really-make-completion-set + (executables-in-path-list path-list) '())) + +(define (adjoin-completion-set cs string) + (really-make-completion-set + (cons string (completion-set-strings cs)) '())) + +(define (completions-for cs prefix) + (let ((maybe-result (check-cache-for-prefix cs prefix))) + (or maybe-result + (let ((result (strings-with-prefix + (completion-set-strings cs) prefix))) + (add-to-cache cs prefix result) + result)))) + ;; 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) @@ -11,43 +38,49 @@ (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 (check-cache-for-prefix cs prefix) + (let* ((cache-alist (completion-set-cache cs)) + (p (assoc prefix cache-alist))) + (cond + (p => cdr) + (else + (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))) +(define (add-to-cache cs prefix list) + (let* ((cache-alist (completion-set-cache cs)) + (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))))) + cache-alist) + (set-completion-set-cache! + cs + (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))) +(define (executables-in-path/prefix cs prefix) + (let ((maybe-result (check-cache-for-prefix cs 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) + (add-to-cache cs prefix result) result)))) +(define completions-for-executables executables-in-path/prefix) + (define (dir-executables/prefix dir prefix) (if (file-readable? dir) (map file-name-nondirectory