diff --git a/scheme/cmdline.scm b/scheme/cmdline.scm index f7007b2..72292d3 100644 --- a/scheme/cmdline.scm +++ b/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))) diff --git a/scheme/complete-util.scm b/scheme/complete-util.scm index 1e68014..cd4a83f 100644 --- a/scheme/complete-util.scm +++ b/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) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 4cbac2d..0f93f79 100644 --- a/scheme/nuit-packages.scm +++ b/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))) - (open scheme - (subset scsh (with-current-output-port)) + command-line-absyn-constructors-interface)) + (command-line-expansion command-line-expansion-interface)) + (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)) diff --git a/scheme/std-command.scm b/scheme/std-command.scm index f4dcd50..bcc4d25 100644 --- a/scheme/std-command.scm +++ b/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 - (lambda (f g) - (stringfs-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) - (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))))) + no-completer (lambda (command args) (let* ((exp-args (expand/glob-arguments args)) (arg (if (null? exp-args)