From 8c9e1bde33f4bcc12c3c0c0565a62f264e66a0de Mon Sep 17 00:00:00 2001
From: eknauel <eknauel>
Date: Sat, 20 Aug 2005 15:20:16 +0000
Subject: [PATCH] Various changes and fixes for f<TAB> 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"