scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Various changes and fixes for f<TAB> completion stuff.

This commit is contained in:
eknauel 2005-08-20 15:20:16 +00:00
parent 0cade47534
commit 8c9e1bde33
4 changed files with 179 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
scheme/complete-util.scm Normal file
View File

@ -0,0 +1,86 @@
;; 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))
(define (complete-files/path partial-name)
(debug-message "complete-files/path " partial-name)
(complete-with-filesystem-objects
(lambda (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)))
(if prefix
(complete-files/path (expand-file-name prefix (cwd)))
(complete-files/path ""))))
;; #### no special treatment yet
(define find-completions-for-redir find-completions-for-arg)

77
scheme/completer.scm
View File

@ -11,6 +11,7 @@
;; completion set for executables in PATH
(define executable-completions-lock (make-lock))
(define executable-completions #f)
(define (get-path-list)
@ -73,20 +74,13 @@
=> (lambda (v) v))
(else (lp (cdr lst))))))))
;; 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)))
(if prefix
(complete-files/path (expand-file-name prefix (cwd)))
(complete-files/path ""))))
;; #### no special treatment yet
(define find-completions-for-redir find-completions-for-arg)
;; completion functions for commands
(define (command-contains-path? command)
(or (string-contains command "/")
(string-contains command "~")
(string-contains command "..")))
(define (find-completions-for-command cmd to-complete)
(debug-message "find-completions-for-command " cmd "," to-complete)
(let ((prefix (or (to-complete-prefix to-complete) "")))
@ -102,64 +96,6 @@
(completions-for-executables
executable-completions prefix)))))))
;; some helpers for the implementation of completion functions
(define (command-contains-path? command)
(or (string-contains command "/")
(string-contains command "~")
(string-contains command "..")))
(define (files-in-dir file-filter dir)
(with-cwd dir
(filter-map
(lambda (file)
(and (file-filter file)
(absolute-file-name file dir)))
(directory-files))))
(define (complete-path path)
(let ((dir (file-name-directory path)))
(map (lambda (p)
(if (string-prefix? "/" p)
p
(string-append dir p)))
(glob (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)
(if (file-exists-and-is-directory? partial-name)
(files-in-dir filter partial-name)
(complete-path partial-name)))
(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 ()
(or (file-executable? file) (file-directory? file)))))))
partial-name))
(define (complete-files/path partial-name)
(debug-message "complete-files/path " partial-name)
(complete-with-filesystem-objects
(lambda (file) #t) partial-name))
;; the main part
(define (find-plugin-completer cmd)
@ -195,6 +131,7 @@
(and completion-info
(destructure (((type cmd to-complete) completion-info))
(let ((completions ((find-completer type cmd) cmd to-complete)))
(debug-message "Possible completions " completions)
(cond
((= (length completions) 1)
(call-with-values

54
scheme/nuit-packages.scm
View File

@ -228,6 +228,8 @@
(export standard-command-plugin show-shell-screen)
(open let-opt
signals
handle
conditions
srfi-1
srfi-13
srfi-37
@ -238,6 +240,7 @@
command-line-absyn
command-line-compiler
completion-sets
completion-utilities
joblist
jobs
run-jobs-internals
@ -419,6 +422,7 @@
let-opt
signals
tty-debug
completion-sets)
(files plugins))
@ -463,31 +467,63 @@
thread-fluids)
(files complete))
;;; standard completion mechanism
;;; utility functions for implementing completion
(define-interface completer-interface
(export init-executables-completion-set!
complete))
(define-interface completion-utilities-interface
(export files-in-dir
complete-path
file-exists-and-is-directory?
complete-with-filesystem-objects
make-completer-for-file-with-extension
complete-executables/path
complete-files/path
(define-structure completer completer-interface
find-completions-for-arg
find-completions-for-redir))
(define-structure completion-utilities completion-utilities-interface
(open scheme
(subset scsh
(file-name-directory glob with-cwd cwd
file-name-extension
absolute-file-name expand-file-name
file-exists? file-directory? file-executable?
directory-files getenv))
threads
locks
(subset srfi-1 (filter-map))
srfi-13
srfi-14
signals
conditions
handle
tty-debug
command-line-absyn
completion-sets)
(files complete-util))
;;; standard completion mechanism
(define-interface completer-interface
(export complete
init-executables-completion-set!))
(define-structure completer completer-interface
(open scheme
(subset scsh (getenv cwd expand-file-name))
signals
conditions
handle
conditions
destructuring
let-opt
(subset srfi-1 (filter-map find))
(subset srfi-1 (find))
srfi-13
srfi-14
threads
locks
tty-debug
completion-utilities
completion-sets
plugin
plugin-host
@ -758,7 +794,7 @@
joblist-viewer
dirlist-view-plugin
user-group-info-plugin
afs-plugin
;afs-plugin
process-viewer
standard-command-plugin
standard-viewer

48
scheme/std-command.scm
View File

@ -109,6 +109,14 @@
(define no-completer #f)
(define just-run-in-foreground
(lambda (command args)
(run/fg (,command ,@args))))
(define just-run-in-background
(lambda (command args)
(run/bg (,command ,@args))))
;; Parse options for ls command using args-fold (SRFI 37)
;; We don't care for options that format the output.
@ -186,13 +194,27 @@
(cwd))))
(register-plugin!
(make-command-plugin "cd"
no-completer
(lambda (command args)
(chdir (resolve-file-name (if (null? args)
"~"
(car args))))
(cwd))))
(make-command-plugin
"cd"
(lambda (command to-complete)
(debug-message "cd-completer")
(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 (file-directory? file) file))))))
(or (to-complete-prefix to-complete) (cwd))))
(lambda (command args)
(chdir (resolve-file-name (if (null? args)
"~"
(car args))))
(cwd))))
(register-plugin!
(make-command-plugin "setenv"
@ -242,6 +264,18 @@
(map car selectors)
(delete-duplicates args)))))))
(register-plugin!
(make-command-plugin
"latex"
(make-completer-for-file-with-extension '(".tex"))
just-run-in-foreground))
(register-plugin!
(make-command-plugin
"xdvi"
(make-completer-for-file-with-extension '(".dvi"))
just-run-in-background))
(register-plugin!
(make-command-plugin
"ftp"