More completion fixes

scheme/cmdline.scm

@@ -431,3 +431,88 @@
 	(values (string-output-port-output string-port)
 		(cell-ref pos))))))
 
+;;; cmdline expansion
+
+;; helper functions for globbing
+
+(define (contains-glob-enumerator? arg)
+  (if-match
+   (regexp-search 
+    (rx (: (submatch (* any)) ("{[") (* any) (submatch (* any)) ("]}")))
+    arg)
+   (whole-arg submatch-before submatch-after)
+   (not (or (string-suffix? "\\" submatch-before)
+	    (string-suffix? "\\" submatch-after)))
+   #f))
+
+(define (contains-glob-wildcard? arg)
+  (if-match
+   (regexp-search (rx (: (submatch (* any)) ("*?"))) arg)
+   (whole-arg submatch-before)
+   (not (string-suffix? "\\" submatch-before))
+   #f))
+   
+(define (contains-glob-expression? arg)
+  (or (contains-glob-wildcard? arg)
+      (contains-glob-enumerator? arg)))
+
+(define (glob-argument arg)
+  (let ((files (glob arg)))
+    (if (null? files)
+	(error "no files match this glob expression" arg (cwd))
+	files)))
+
+;; expand command list:
+;; - substiute environment vars in strings with their values
+;; - globbing
+;; - tilde expansion
+
+
+(define (substitute-env-vars str)
+  (regexp-substitute/global
+   #f
+   (rx (: #\$ (? #\{) (submatch (+ alphanum)) (? #\})))
+   str
+   'pre
+   (lambda (m)
+     (or (lookup-env-var (match:substring m 1)) (match:substring m 1)))
+   'post))
+  
+
+(define (expand-filename-string s)
+  (debug-message "expand-filename-string " s)
+  (resolve-file-name (substitute-env-vars s)))
+
+(define (expand-string/s-expr v)
+  (if (string? v)
+      (expand-filename-string v)
+      v))
+
+(define (expand/glob-arguments args)
+  (fold-right 
+      (lambda (arg args)
+	(let ((expanded (expand-string/s-expr arg)))
+          (if (and (string? expanded) (contains-glob-expression? expanded))
+              (append (glob-argument expanded) args)
+              (cons expanded args))))
+      '() args))
+
+(define (expand-redirection redirection)
+  (make-redirection
+   (redirection-op redirection)
+   (expand-string/s-expr (redirection-dest redirection))))
+
+(define (expand-command command)
+  (make-command
+   (expand-string/s-expr (command-executable command))
+   (expand/glob-arguments (command-args command))
+   (map expand-redirection (command-redirections command))))
+
+(define (expand-command-line command-line)
+  (make-command-line
+   (expand-command (command-line-first-cmd command-line))
+   (map (lambda (combinator.command)
+	  (cons (car combinator.command)
+		(expand-command (cdr combinator.command))))
+	(command-line-combinator/cmds command-line))
+   (command-line-job-ctrl command-line)))

scheme/complete-util.scm

@@ -85,7 +85,12 @@
 	     (if (file-directory? file)
                  (file-name-as-directory file)
                  file))))))
-     (or (to-complete-prefix to-complete) (file-name-as-directory (cwd))))))
+     (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)

scheme/nuit-packages.scm

@@ -323,6 +323,7 @@
 	command-line-parser
 	command-line-absyn
 	command-line-compiler
+        command-line-expansion
 	completion-sets
 	completion-utilities
 	joblist
@@ -693,7 +694,7 @@
 		 file-name-extension
                  file-name-as-directory
                  file-name-directory?
-                 absolute-file-name expand-file-name
+                 absolute-file-name expand-file-name resolve-file-name
 		 file-exists? file-directory? file-executable?
 		 directory-files getenv))
 	(subset srfi-1 (filter-map))
@@ -705,6 +706,7 @@
 
 	tty-debug
 	command-line-absyn
+        command-line-expansion
 	completion-sets)
   (files complete-util))
 
@@ -904,6 +906,11 @@
 
 	  lex/parse-partial-command-line))
 
+(define-interface command-line-expansion-interface
+  (export expand-command-line
+          expand/glob-arguments
+          expand-filename-string))
+
 (define-structures
   ((command-line-lexer (compound-interface
 			command-line-lexer-tokens-interface
@@ -913,20 +920,22 @@
 			 command-line-parser-interface))
    (command-line-absyn (compound-interface
 			command-line-absyn-interface
-			command-line-absyn-constructors-interface)))
+			command-line-absyn-constructors-interface))
-  (open scheme
+   (command-line-expansion command-line-expansion-interface))
-	(subset scsh (with-current-output-port))
+  (open scheme-with-scsh
+	; (subset scsh (with-current-output-port))
 	extended-ports
 	define-record-types
-	(subset srfi-1 (filter drop-right))
+	(subset srfi-1 (filter drop-right fold-right))
 	srfi-8
-	(subset srfi-13 (string-join))
+	(subset srfi-13 (string-join string-suffix?))
 	srfi-14
 	let-opt
 	cells
 	silly
 	conditions
-	signals 
+	signals
+        tty-debug
 	handle)
   (files cmdline))
 

scheme/std-command.scm

@@ -1,96 +1,6 @@
 (define (standard-command-plugin-completer command args)
   #f)
 
-;; helper functions for globbing
-
-(define (contains-glob-enumerator? arg)
-  (if-match
-   (regexp-search 
-    (rx (: (submatch (* any)) ("{[") (* any) (submatch (* any)) ("]}")))
-    arg)
-   (whole-arg submatch-before submatch-after)
-   (not (or (string-suffix? "\\" submatch-before)
-	    (string-suffix? "\\" submatch-after)))
-   #f))
-
-(define (contains-glob-wildcard? arg)
-  (if-match
-   (regexp-search (rx (: (submatch (* any)) ("*?"))) arg)
-   (whole-arg submatch-before)
-   (not (string-suffix? "\\" submatch-before))
-   #f))
-   
-(define (contains-glob-expression? arg)
-  (or (contains-glob-wildcard? arg)
-      (contains-glob-enumerator? arg)))
-
-(define (glob-argument arg)
-  (let ((files (glob arg)))
-    (if (null? files)
-	(error "no files match this glob expression" arg (cwd))
-	files)))
-
-;; expand command list:
-;; - substiute environment vars in strings with their values
-;; - globbing
-
-(define (env-var-name str)
-  (cond
-   ((regexp-search 
-     (rx (: #\$ (? #\{) (submatch (+ (- ascii #\}))) (? #\}))) str)
-    => (lambda (matches)
-	 (match:substring matches 1)))
-   (else #f)))
-
-(define (lookup-env-var var)
-  (cond
-   ((assoc var (env->alist))
-    => cdr)
-   (else
-    (error "Undefined environment variable" var))))
-
-(define (substitute-env-vars str)
-  (cond
-   ((env-var-name str)
-    => lookup-env-var)
-   (else str)))
-
-(define (expand-filename-string s)
-  (resolve-file-name (substitute-env-vars s)))
-
-(define (expand-string/s-expr v)
-  (if (string? v)
-      (expand-filename-string v)
-      v))
-
-(define (expand/glob-arguments args)
-  (fold-right 
-      (lambda (arg args)
-	(let ((expanded (expand-string/s-expr arg)))
-          (if (and (string? expanded) (contains-glob-expression? expanded))
-              (append (glob-argument expanded) args)
-              (cons expanded args))))
-      '() args))
-
-(define (expand-redirection redirection)
-  (make-redirection
-   (redirection-op redirection)
-   (expand-string/s-expr (redirection-dest redirection))))
-
-(define (expand-command command)
-  (make-command
-   (expand-string/s-expr (command-executable command))
-   (expand/glob-arguments (command-args command))
-   (map expand-redirection (command-redirections command))))
-
-(define (expand-command-line command-line)
-  (make-command-line
-   (expand-command (command-line-first-cmd command-line))
-   (map (lambda (combinator.command)
-	  (cons (car combinator.command)
-		(expand-command (cdr combinator.command))))
-	(command-line-combinator/cmds command-line))
-   (command-line-job-ctrl command-line)))
 
 ;; #####
 ;; it's a dumb idea to keep command and args separate, merge
@@ -129,7 +39,8 @@
 (define defaults-ls-options
   '((long . #f) 
     (dot-files? . #f) 
-    (sort-by-mtime . #f) 
+    (sort-by-mtime . #f)
+    (dont-sort . #f)
     (reverse-sort . #f)))
 
 (define (parse-ls-arguments args)
@@ -146,6 +57,9 @@
 	 (sort-mtime-option
 	  (option '(#\t) #f #f
 		  (on/off-option-processor 'sort-by-mtime)))
+         (dont-sort-option
+	  (option '(#f) #f #f
+		  (on/off-option-processor 'dont-sort)))
 	 (reverse-sort-option
 	  (option '(#\r) #f #f
 		  (on/off-option-processor 'reverse-sort))))
@@ -153,7 +67,7 @@
 	   (args-fold
 	    args
 	    (list long-option dotfiles-option 
-		  sort-mtime-option reverse-sort-option)
+		  sort-mtime-option dont-sort-option reverse-sort-option)
 	    (lambda (option name args operands)
 	      (error "Unknown ls option" name))
 	    cons '())))
@@ -180,25 +94,33 @@
                        (< (file-info:mtime (fs-object-info f)) 
                           (file-info:mtime (fs-object-info g))))
                      lst))
-                  (lambda (lst)
+                  
-                    (list-sort 
+                  (if (set? 'dont-sort)
-                     (lambda (f g)
+                      (lambda (lst) lst)
-                       (string<? (fs-object-name f) (fs-object-name g)))
+                      (lambda (lst)
-                     lst))))
+                        (list-sort 
+                         (lambda (f g)
+                           (string<? (fs-object-name f) (fs-object-name g)))
+                         lst)))))
              (reverse 
               (if (set? 'reverse-sort)
                   reverse
                   (lambda (l) l)))
              (paths (if (null? paths)
                         (list (file-name-as-directory (cwd)))
-                        paths)))
+                        paths))
+             (dot-files? (set? 'dot-files?)))
         (reverse 
          (sort
           (apply 
            append
            (map (lambda (path)
                   (if (file-directory? path)
-                      (directory-files path (set? 'dot-files?))
+                      (if dot-files?
+                          (cons (file-name->fs-object ".")
+                                (cons (file-name->fs-object "..")
+                                      (directory-files path dot-files?)))
+                          (directory-files path dot-files?))
                       (list (file-name->fs-object path))))
                 (expand/glob-arguments paths))))))))))
 
@@ -217,21 +139,7 @@
 (register-plugin!
  (make-command-plugin 
   "cd"
-  (lambda (command to-complete)
+  no-completer
-    (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-name-as-directory file)))))))
-     (or (to-complete-prefix to-complete) (file-name-as-directory (cwd)))))
   (lambda (command args)
     (let* ((exp-args (expand/glob-arguments args))
            (arg (if (null? exp-args)