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

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

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

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
+(define-interface completion-utilities-interface
-  (export init-executables-completion-set!
+  (export files-in-dir
-	  complete))
+	  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
+	(subset srfi-1 (filter-map))
-	locks
+	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

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"
+ (make-command-plugin 
-		      no-completer
+  "cd"
- 		      (lambda (command args)
+  (lambda (command to-complete)
- 			(chdir (resolve-file-name (if (null? args)
+    (debug-message "cd-completer")
-                                                      "~"
+    (complete-with-filesystem-objects
-                                                      (car args))))
+     (lambda (file)
-                        (cwd))))
+       (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"