From 8c9e1bde33f4bcc12c3c0c0565a62f264e66a0de Mon Sep 17 00:00:00 2001 From: eknauel Date: Sat, 20 Aug 2005 15:20:16 +0000 Subject: [PATCH] Various changes and fixes for f completion stuff. --- scheme/complete-util.scm | 86 ++++++++++++++++++++++++++++++++++++++++ scheme/completer.scm | 77 ++++------------------------------- scheme/nuit-packages.scm | 54 ++++++++++++++++++++----- scheme/std-command.scm | 48 ++++++++++++++++++---- 4 files changed, 179 insertions(+), 86 deletions(-) create mode 100644 scheme/complete-util.scm diff --git a/scheme/complete-util.scm b/scheme/complete-util.scm new file mode 100644 index 0000000..4217d78 --- /dev/null +++ b/scheme/complete-util.scm @@ -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) + diff --git a/scheme/completer.scm b/scheme/completer.scm index f0ed368..1bf5c15 100644 --- a/scheme/completer.scm +++ b/scheme/completer.scm @@ -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 diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index f402ea5..420b8e3 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -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 diff --git a/scheme/std-command.scm b/scheme/std-command.scm index 9a04fc6..ce7e2ab 100644 --- a/scheme/std-command.scm +++ b/scheme/std-command.scm @@ -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"