changed algorithm for command-completion to speed it up

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)))))
+          (file-info-regular? info)))))

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)

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)