97 lines
2.8 KiB
Scheme
97 lines
2.8 KiB
Scheme
;; 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)
|
|
(filter-map file-filter
|
|
(glob-carefully (string-append dir "*"))))
|
|
|
|
(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 (and (file-name-directory? partial-name)
|
|
(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) (file-name-as-directory (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
|
|
(lambda (file)
|
|
(call-with-current-continuation
|
|
(lambda (esc)
|
|
(with-handler
|
|
(lambda (c more)
|
|
(if (error? c)
|
|
(esc #f)
|
|
(more)))
|
|
(lambda ()
|
|
(if (file-directory? file)
|
|
(file-name-as-directory file)
|
|
file))))))
|
|
(if prefix
|
|
(if (file-name-directory? prefix) ;; preserve trailing slash
|
|
(file-name-as-directory (expand-filename-string prefix))
|
|
(expand-filename-string prefix))
|
|
"./"; (file-name-as-directory (cwd))
|
|
))))
|
|
|
|
;; #### no special treatment yet
|
|
(define find-completions-for-redir find-completions-for-arg)
|