(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 (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 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 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-completion-set-cache!
       cs
       (cons (cons prefix (append list (append-map cdr longer-ones)))
	     others)))))

(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 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
           (let ((files (glob (string-append dir "/" prefix "*"))))
              (if *completion-check-executable*
                  (filter executable? files)
                  files)))
      '()))

;; caching version

(define *cache* #t)

(define (executables-in-path)
  (or *cache*
      (begin 
        (set! *cache* (executables-in-path-list (thread-fluid exec-path-list)))
        *cache*)))

(define (executables-in-path-list path-list)
  (append-map! dir-executables path-list))

(define (dir-executables dir)
  (if (file-readable? dir)
      (map file-name-nondirectory 
           (filter executable? (glob (string-append dir "/*"))))
      '()))

(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)))))