commander-s/scheme/complete-util.scm

;; some helpers for the implementation of completion functions

;; it's a hack
(define (syscall-error? thing)
  (and (pair? thing)
       (eq? (condition-type thing) 'syscall-error)))

(define (glob-carefully pattern)
  (call-with-current-continuation
   (lambda (esc)
     (with-handler
      (lambda (c more)
	(if (syscall-error? c)
	    (esc '())
	    (more)))
      (lambda ()
	(glob pattern))))))

(define (files-in-dir file-filter dir)
  (debug-message "files-in-dir " file-filter " " dir)
  (with-cwd dir
    (filter-map file-filter 
		(glob-carefully "*"))))

(define (complete-path path)
  (debug-message "complete-path " path ", " (cwd))
  (let ((dir (file-name-directory path)))
    (glob-carefully (string-append path "*"))))

(define (file-exists-and-is-directory? fname)
  (call-with-current-continuation
   (lambda (esc)
     (with-handler 
      (lambda (c more)
	(if (error? c)
	    (esc #f)
	    (more)))
      (lambda ()
	(and (file-exists? fname) (file-directory? fname)))))))

(define (complete-with-filesystem-objects filter partial-name)
  (debug-message "complete-with-filesystem-objects " filter " " partial-name)
  (if (file-exists-and-is-directory? partial-name)
      (files-in-dir filter partial-name)
      (filter-map filter (complete-path partial-name))))

(define (make-completer-for-file-with-extension extensions)
  (lambda (command to-complete)
    (complete-with-filesystem-objects
     (lambda (file)
       (and (member (file-name-extension file) extensions)
	    file))
     (or (to-complete-prefix to-complete) (cwd)))))

(define (complete-executables/path partial-name)
  (complete-with-filesystem-objects
   (lambda (file)
     (call-with-current-continuation
      (lambda (esc)
	(with-handler
	 (lambda (c more)
	   (if (error? c)
	       (esc #f)
	       (more)))
	 (lambda ()
	   (and (or (file-executable? file) (file-directory? file))
		file))))))
   partial-name))

;; completion functions for arguments and redirection 

(define (find-completions-for-arg cmd to-complete)
  (debug-message "find-completions-for-arg " cmd "," to-complete)
  (let ((prefix (to-complete-prefix to-complete)))
    (complete-with-filesystem-objects
     (if prefix
	 (lambda (file)
	   (and (string-prefix? prefix file) file))
	 (lambda (file) file))
     (or (to-complete-prefix to-complete) (cwd)))))

;; #### no special treatment yet
(define find-completions-for-redir find-completions-for-arg)