519 lines
15 KiB
Scheme
519 lines
15 KiB
Scheme
;; ,open conditions extended-ports define-record-types srfi-1 srfi-6 srfi-8 srfi-13 srfi-14 silly signals handle
|
|
|
|
;; command line language:
|
|
;;
|
|
;; <cmdline> ::= (<cmd> (<sep> <cmd>)* <jobctrl>?
|
|
;; <cmd> ::= <prog> <arg>* <redir>*
|
|
;; <redir> ::= <redirop> <fname>
|
|
;; <redirop> ::= ">" | ">>" | "<<" | "<"
|
|
;; <fname> ::= <string> | <unquote>
|
|
;; <prog> ::= <string> | <unquote>
|
|
;; <string> ::= "..." | char+ with char = ASCII\{"&","|","<",">",","}
|
|
;; <jobctrl> ::= "&" | "&*"
|
|
;; <sep> ::= "|" | "&&" | "||" | ";"
|
|
;; <unquote> ::= "," <s-expr> | ",@" <s-expr>
|
|
|
|
;; lexer stuff
|
|
|
|
(define-record-type token :token
|
|
(really-make-token token type start-pos cursor-pos)
|
|
token?
|
|
(token token-token)
|
|
(type token-type)
|
|
(start-pos token-start-pos)
|
|
(cursor-pos token-cursor-pos))
|
|
|
|
;; all indices and positions are zero-based
|
|
|
|
(define-record-discloser :token
|
|
(lambda (r)
|
|
`(token ,(token-type r) ,(token-token r) ,(token-cursor-pos r))))
|
|
|
|
(define (make-token token type start-pos cursor-index port)
|
|
(really-make-token
|
|
token type start-pos
|
|
(and cursor-index
|
|
(<= start-pos cursor-index (current-column port))
|
|
(- cursor-index start-pos))))
|
|
|
|
(define (make-string-token data start-pos cursor-index port)
|
|
(make-token data 'string start-pos cursor-index port))
|
|
|
|
(define (string-token? thing)
|
|
(and (token? thing) (eq? (token-type thing) 'string)))
|
|
|
|
(define (make-s-expr-token data start-pos cursor-index port)
|
|
(make-token data 's-expr start-pos cursor-index port))
|
|
|
|
(define (s-expr-token? thing)
|
|
(and (token? thing) (eq? (token-type thing) 's-expr)))
|
|
|
|
(define (make-operator-token data start-pos cursor-index port)
|
|
(make-token data 'operator start-pos cursor-index port))
|
|
|
|
(define (operator-token? thing)
|
|
(and (token? thing) (eq? (token-type thing) 'operator)))
|
|
|
|
(define (cursor-on-token? token)
|
|
(or (to-complete? token)
|
|
(integer? (token-cursor-pos token))))
|
|
|
|
(define-record-type to-complete :to-complete
|
|
(make-to-complete prefix pos)
|
|
to-complete?
|
|
(prefix to-complete-prefix)
|
|
(pos to-complete-pos))
|
|
|
|
(define-record-discloser :to-complete
|
|
(lambda (r)
|
|
`(to-complete ,(to-complete-prefix r) ,(to-complete-pos r))))
|
|
|
|
(define to-complete-without-prefix?
|
|
to-complete-prefix)
|
|
|
|
(define (make-empty-to-complete pos)
|
|
(make-to-complete #f pos))
|
|
|
|
(define operator-chars (char-set #\& #\| #\< #\> #\, #\;))
|
|
|
|
(define composed-operator-derivations
|
|
(char-set #\& #\* #\| #\> #\<))
|
|
|
|
(define (valid-operator? str)
|
|
(member str '("&" "&&" "&*" "|" "||" "<" "<<" ">" ">>" "," ",@" ";")))
|
|
|
|
(define token-terminating-chars
|
|
(char-set-union operator-chars char-set:whitespace))
|
|
|
|
(define (lex-token cursor-index port)
|
|
(let ((start-pos (current-column port)))
|
|
(let lp ((c (peek-char port)) (chars '()))
|
|
(cond
|
|
((or (eof-object? c)
|
|
(char-set-contains? token-terminating-chars c))
|
|
(make-string-token (reverse-list->string chars (length chars))
|
|
start-pos cursor-index port))
|
|
(else
|
|
(read-char port)
|
|
(lp (peek-char port) (cons c chars)))))))
|
|
|
|
(define (lex-operator cursor-index port)
|
|
(let ((start-pos (current-column port))
|
|
(c-1 (read-char port))
|
|
(c-2 (peek-char port)))
|
|
(if (eof-object? c-2)
|
|
(make-operator-token (string->symbol (string c-1))
|
|
start-pos cursor-index port)
|
|
(let ((c (if (char-set-contains? composed-operator-derivations c-2)
|
|
(begin
|
|
(read-char port)
|
|
(string-append (string c-1) (string c-2)))
|
|
(string c-1))))
|
|
(cond
|
|
((valid-operator? c)
|
|
(make-operator-token (string->symbol c)
|
|
start-pos cursor-index port))
|
|
(else
|
|
(error "Invalid operator in command line" c start-pos)))))))
|
|
|
|
(define (lex-port cursor-index port)
|
|
(let lp ((c (peek-char port)) (tokens '()))
|
|
(cond
|
|
((eof-object? c)
|
|
(reverse tokens))
|
|
((or (char=? c #\") (char=? c #\,))
|
|
(let* ((start-pos (current-column port))
|
|
(s-expr (read port))
|
|
(token
|
|
(make-s-expr-token
|
|
s-expr start-pos cursor-index port)))
|
|
(lp (peek-char port) (cons token tokens))))
|
|
((char-set-contains? operator-chars c)
|
|
(let ((token (lex-operator cursor-index port)))
|
|
(lp (peek-char port) (cons token tokens))))
|
|
((char-set-contains? char-set:whitespace c)
|
|
(let ((start-pos (current-column port)))
|
|
(read-char port)
|
|
(let read-whitspaces ((c (peek-char port))
|
|
(cursor? #f))
|
|
(cond
|
|
((eof-object? c)
|
|
(lp c (if (or cursor?
|
|
(and cursor-index
|
|
(= (current-column port) cursor-index)))
|
|
(cons (make-empty-to-complete cursor-index)
|
|
tokens)
|
|
tokens)))
|
|
((char-set-contains? char-set:whitespace c)
|
|
(read-char port)
|
|
(read-whitspaces (peek-char port)
|
|
(or cursor?
|
|
(and cursor-index
|
|
(= (current-column port) cursor-index)))))
|
|
(else (lp c tokens))))))
|
|
(else
|
|
(let ((token (lex-token cursor-index port)))
|
|
(lp (peek-char port) (cons token tokens)))))))
|
|
|
|
(define (lex-command-line cmd-line . args)
|
|
(let-optionals args
|
|
((cursor-index #f))
|
|
(with-handler
|
|
(lambda (c more)
|
|
(if (read-error? c)
|
|
(signal-syntax-error (condition-stuff c))
|
|
(more)))
|
|
(lambda ()
|
|
(lex-port
|
|
cursor-index
|
|
(make-tracking-input-port
|
|
(make-string-input-port cmd-line)))))))
|
|
|
|
;; abstract syntax
|
|
|
|
(define-record-type command-line :command-line
|
|
(make-command-line first-cmd combinator/cmds job-ctrl)
|
|
command-line?
|
|
(first-cmd command-line-first-cmd)
|
|
(combinator/cmds command-line-combinator/cmds)
|
|
(job-ctrl command-line-job-ctrl))
|
|
|
|
(define-record-discloser :command-line
|
|
(lambda (r)
|
|
`(command-line ,(command-line-first-cmd r)
|
|
,(command-line-combinator/cmds r)
|
|
,(command-line-job-ctrl r))))
|
|
|
|
(define-record-type command :command
|
|
(make-command executable args redirections)
|
|
command?
|
|
(executable command-executable)
|
|
(args command-args)
|
|
(redirections command-redirections))
|
|
|
|
(define-record-discloser :command
|
|
(lambda (r)
|
|
`(command ,(command-executable r)
|
|
,(command-args r) ,(command-redirections r))))
|
|
|
|
(define-record-type redirection :redirection
|
|
(make-redirection op dest)
|
|
redirection?
|
|
(op redirection-op)
|
|
(dest redirection-dest))
|
|
|
|
(define-record-discloser :redirection
|
|
(lambda (r)
|
|
`(redir ,(redirection-op r) ,(redirection-dest r))))
|
|
|
|
;; condition raised during parsing
|
|
|
|
(define-condition-type 'parser-error '(error))
|
|
(define parser-error? (condition-predicate 'parser-error))
|
|
|
|
(define-condition-type 'parser-syntax-error '(parser-error))
|
|
(define parser-syntax-error?
|
|
(condition-predicate 'parser-syntax-error))
|
|
|
|
(define-condition-type 'parser-unexpected-eof '(parser-error))
|
|
(define parser-unexpected-eof?
|
|
(condition-predicate 'parser-unexpected-eof))
|
|
|
|
(define (signal-syntax-error info)
|
|
(signal 'parser-syntax-error info))
|
|
|
|
(define (signal-unexpected-eof info)
|
|
(signal 'parser-unexpected-eof info))
|
|
|
|
;; a simple recursive descent parser
|
|
|
|
(define (extract-token t)
|
|
(cond
|
|
((to-complete? t)
|
|
t)
|
|
((cursor-on-token? t)
|
|
(make-to-complete (token-token t) (token-cursor-pos t)))
|
|
(else
|
|
(token-token t))))
|
|
|
|
(define (string-or-s-expr? t)
|
|
(or (string-token? t)
|
|
(s-expr-token? t)
|
|
(to-complete? t)))
|
|
|
|
(define (parse-string/s-expr tokens)
|
|
(if (null? tokens)
|
|
(signal-unexpected-eof 'parse-string/s-expr)
|
|
(let ((t (car tokens)))
|
|
(if (or (string-token? t) (s-expr-token? t))
|
|
(values (extract-token t) (cdr tokens))
|
|
(signal-syntax-error `(parse-string/s-expr ,t ,tokens))))))
|
|
|
|
(define (parse-many-satisfying predicate tokens)
|
|
(let lp ((tokens tokens) (found '()))
|
|
(if (or (null? tokens) (not (predicate (car tokens))))
|
|
(values (reverse found) tokens)
|
|
(lp (cdr tokens) (cons (car tokens) found)))))
|
|
|
|
(define (parse-redirection tokens)
|
|
(if (< (length tokens) 2)
|
|
(values #f tokens)
|
|
(let ((op (car tokens))
|
|
(obj (cadr tokens)))
|
|
(cond
|
|
((and (operator-token? op)
|
|
(member (token-token op) '(> < >>))
|
|
(string-or-s-expr? obj))
|
|
(values
|
|
(make-redirection (token-token op) (extract-token obj))
|
|
(cddr tokens)))
|
|
((and (operator-token? op)
|
|
(eq? (token-token op) '<<)
|
|
(s-expr-token? obj))
|
|
(values
|
|
(make-redirection (token-token op) (extract-token obj))
|
|
(cddr tokens)))
|
|
(else
|
|
(values #f tokens))))))
|
|
|
|
(define (parse-redirections tokens)
|
|
(let lp ((tokens tokens) (redirs '()))
|
|
(receive (redir tokens)
|
|
(parse-redirection tokens)
|
|
(if redir
|
|
(lp tokens (cons redir redirs))
|
|
(values (reverse redirs) tokens)))))
|
|
|
|
(define (parse-command tokens)
|
|
(receive (executable tokens)
|
|
(parse-string/s-expr tokens)
|
|
(receive (args tokens)
|
|
(parse-many-satisfying string-or-s-expr? tokens)
|
|
(receive (redirs tokens)
|
|
(parse-redirections tokens)
|
|
(values (make-command executable
|
|
(map extract-token args) redirs)
|
|
tokens)))))
|
|
|
|
(define combinator-tokens
|
|
(map string->symbol '(";" "|" "&&" "||")))
|
|
|
|
(define (combinator-token? token)
|
|
(and (operator-token? token)
|
|
(member (token-token token) combinator-tokens)))
|
|
|
|
(define (parse-combinator/command tokens)
|
|
(if (< (length tokens) 2)
|
|
(values #f tokens)
|
|
(let ((comb (car tokens))
|
|
(cmd (cdr tokens)))
|
|
(cond
|
|
((combinator-token? comb)
|
|
(receive (command tokens)
|
|
(parse-command cmd)
|
|
(values (cons (extract-token comb) command)
|
|
tokens)))
|
|
(else
|
|
(values #f tokens))))))
|
|
|
|
(define (parse-combinators/commands-list tokens)
|
|
(let lp ((tokens tokens) (combs/cmds '()))
|
|
(receive (comb/cmd tokens)
|
|
(parse-combinator/command tokens)
|
|
(if comb/cmd
|
|
(lp tokens (cons comb/cmd combs/cmds))
|
|
(values (reverse combs/cmds) tokens)))))
|
|
|
|
(define (parse-job-control tokens)
|
|
(if (null? tokens)
|
|
(values #f tokens)
|
|
(let ((t (car tokens)))
|
|
(if (and (operator-token? t)
|
|
(member (token-token t) '(&* &)))
|
|
(values (token-token t) (cdr tokens))
|
|
(values #f tokens)))))
|
|
|
|
(define (parse-command-line tokens)
|
|
(receive (command tokens)
|
|
(parse-command tokens)
|
|
(receive (combinator/command-list tokens)
|
|
(parse-combinators/commands-list tokens)
|
|
(receive (job-control tokens)
|
|
(parse-job-control tokens)
|
|
(if (null? tokens)
|
|
(make-command-line command combinator/command-list
|
|
job-control)
|
|
(signal-syntax-error `(parse-command-line ,tokens)))))))
|
|
|
|
;; for use with tab completion
|
|
(define (parse-command-line-carefully tokens)
|
|
(call-with-current-continuation
|
|
(lambda (esc)
|
|
(with-handler
|
|
(lambda (condition . more)
|
|
(if (parser-error? condition)
|
|
(esc #f)
|
|
(more)))
|
|
(lambda ()
|
|
(parse-command-line tokens))))))
|
|
|
|
(define (lex/parse-partial-command-line cmdln cursor-index)
|
|
(let ((tokens (lex-command-line cmdln cursor-index)))
|
|
(let lp ((tokens tokens))
|
|
(cond
|
|
((null? tokens)
|
|
(make-command-line
|
|
(make-command (make-to-complete #f 0) '() '())
|
|
'() #f))
|
|
((parse-command-line-carefully tokens)
|
|
=> (lambda (v) v))
|
|
(else
|
|
(lp (drop-right tokens 1)))))))
|
|
|
|
;; unparser
|
|
|
|
(define (unparse-string/s-expr completion pos v start-of-line?)
|
|
(if (not start-of-line?)
|
|
(display " "))
|
|
(cond
|
|
((and completion (to-complete? v))
|
|
(completion v)
|
|
(cell-set! pos (current-column (current-output-port))))
|
|
((string? v)
|
|
(display v))
|
|
((and (pair? v) (eq? (car v) 'unquote))
|
|
(display ",")
|
|
(display (cadr v)))
|
|
((and (pair? v) (eq? (car v) 'unquote-splicing))
|
|
(display ",@")
|
|
(display (cadr v)))
|
|
(else
|
|
(error "Don't know how to unparse this." v))))
|
|
|
|
(define (unparse-redirection completion pos rd)
|
|
(display " ")
|
|
(display (symbol->string (redirection-op rd)))
|
|
(unparse-string/s-expr completion pos
|
|
(redirection-dest rd) #f))
|
|
|
|
(define (unparse-command completion pos cmd start-of-line?)
|
|
(unparse-string/s-expr completion pos (command-executable cmd) start-of-line?)
|
|
(for-each (lambda (arg)
|
|
(unparse-string/s-expr completion pos arg #f))
|
|
(command-args cmd))
|
|
(for-each (lambda (arg)
|
|
(display " ")
|
|
(unparse-redirection completion pos arg))
|
|
(command-redirections cmd)))
|
|
|
|
(define (unparse-command-line cmdln . arg)
|
|
(let-optionals arg
|
|
((completion #f))
|
|
(let* ((pos (make-cell #f))
|
|
(string-port (make-string-output-port))
|
|
(track-port (make-tracking-output-port string-port)))
|
|
(with-current-output-port track-port
|
|
(unparse-command completion pos
|
|
(command-line-first-cmd cmdln) #t)
|
|
(for-each
|
|
(lambda (comb.cmd)
|
|
(display " ")
|
|
(display (symbol->string (car comb.cmd)))
|
|
(unparse-command completion pos (cdr comb.cmd) #f))
|
|
(command-line-combinator/cmds cmdln))
|
|
(cond
|
|
((command-line-job-ctrl cmdln)
|
|
=> (lambda (sym)
|
|
(display " ")
|
|
(display (symbol->string sym)))))
|
|
;; we're done
|
|
(close-output-port track-port)
|
|
(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 (getenv (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)))
|