scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

More completion fixes

This commit is contained in:
mainzelm 2006-04-18 15:46:57 +00:00
parent 3b1e318c88
commit 4228a359b8
4 changed files with 129 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
scheme/cmdline.scm
View File

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

7
scheme/complete-util.scm
View File

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

23
scheme/nuit-packages.scm
View File

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

136
scheme/std-command.scm
View File

@ -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)
(string<? (fs-object-name f) (fs-object-name g)))
lst))))
(if (set? 'dont-sort)
(lambda (lst) lst)
(lambda (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)
(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)