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

Support for parsing partial command lines (needed for tab completion)

This commit is contained in:
eknauel 2005-08-15 12:41:24 +00:00
parent c9f986f8cc
commit f71f975e6d
2 changed files with 145 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

180
scheme/cmdline.scm
View File

@ -1,4 +1,4 @@
;; ,open extended-ports define-record-types srfi-1 srfi-6 srfi-8 srfi-13 srfi-14 silly signals handle
;; ,open conditions extended-ports define-record-types srfi-1 srfi-6 srfi-8 srfi-13 srfi-14 silly signals handle
;; command line language:
;;
@ -16,34 +16,63 @@
;; lexer stuff
(define-record-type token :token
(make-token token type pos)
(really-make-token token type start-pos cursor-pos)
token?
(token token-token)
(type token-type)
(pos token-pos))
(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-pos r) ,(token-token r)))))
`(token ,(token-type r) ,(token-token r) ,(token-cursor-pos r))))
(define (make-string-token data pos)
(make-token data 'string pos))
(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 pos)
(make-token data 's-expr pos))
(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 pos)
(make-token data 'operator pos))
(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)
to-complete?
(prefix to-complete-prefix))
(define-record-discloser :to-complete
(lambda (r)
`(to-complete ,(to-complete-prefix r))))
(define to-complete-without-prefix?
to-complete-prefix)
(define (make-empty-to-complete)
(make-to-complete #f))
(define operator-chars (char-set #\& #\| #\< #\> #\, #\;))
(define composed-operator-derivations
@ -55,58 +84,72 @@
(define token-terminating-chars
(char-set-union operator-chars char-set:whitespace))
(define (lex-token port)
(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))
(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 port)
(let ((start-pos (current-column port)) ; makes no sense, do it anyways
(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)
(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-append (string c-1) (string c-2)))
(string c-1))))
(cond
((valid-operator? c)
(make-operator-token (string->symbol c) start-pos))
(make-operator-token (string->symbol c)
start-pos cursor-index port))
(else
(error "Invalid operator in command line" c start-pos)))))))
(define (lex-port port)
(define (lex-port cursor-index port)
(let lp ((c (peek-char port)) (tokens '()))
(display (list c (current-column port)))
(newline)
(cond
((eof-object? c)
(reverse tokens))
((or (char=? c #\") (char=? c #\,))
(let ((token (make-s-expr-token
(read port) (current-column port))))
(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 port)))
(let ((token (lex-operator cursor-index port)))
(lp (peek-char port) (cons token tokens))))
((char-set-contains? char-set:whitespace c)
(read-char port)
(lp (peek-char port) tokens))
(let ((pos (current-column port)))
(read-char port)
(lp (peek-char port)
(if (and cursor-index (= cursor-index pos))
(cons (make-empty-to-complete) tokens)
tokens))))
(else
(let ((token (lex-token port)))
(let ((token (lex-token cursor-index port)))
(lp (peek-char port) (cons token tokens)))))))
(define (lex-command-line cmd-line)
(lex-port
(make-tracking-input-port (make-string-input-port cmd-line))))
(define (lex-command-line cmd-line . args)
(let-optionals args
((cursor-index #f))
(lex-port
cursor-index
(make-tracking-input-port
(make-string-input-port cmd-line)))))
;; abstract syntax
@ -145,26 +188,48 @@
(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 (parse-error reason . more)
(error (string-append "error parsing command line; " reason)
more))
(define (parse-error-unexpected-end where)
(parse-error "unexpected end of line" where))
(define (extract-token t)
(cond
((to-complete? t)
t)
((cursor-on-token? t)
(make-to-complete (token-token t)))
(else
(token-token t))))
(define (string-or-s-expr? token)
(or (string-token? token) (s-expr-token? token)))
(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)
(parse-error-unexpected-end 'parse-string/s-expr)
(signal-unexpected-eof 'parse-string/s-expr)
(let ((t (car tokens)))
(if (or (string-token? t) (s-expr-token? t))
(values (token-token t) (cdr tokens))
(parse-error
"not a string or s-expr" 'parse-string/s-expr
t tokens)))))
(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 '()))
@ -182,13 +247,13 @@
(member (token-token op) '(> < >>))
(string-or-s-expr? obj))
(values
(make-redirection (token-token op) (token-token obj))
(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) (token-token obj))
(make-redirection (token-token op) (extract-token obj))
(cddr tokens)))
(else
(values #f tokens))))))
@ -209,7 +274,7 @@
(receive (redirs tokens)
(parse-redirections tokens)
(values (make-command executable
(map token-token args) redirs)
(map extract-token args) redirs)
tokens)))))
(define combinator-tokens
@ -228,7 +293,7 @@
((combinator-token? comb)
(receive (command tokens)
(parse-command cmd)
(values (cons (token-token comb) command)
(values (cons (extract-token comb) command)
tokens)))
(else
(values #f tokens))))))
@ -260,7 +325,30 @@
(if (null? tokens)
(make-command-line command combinator/command-list
job-control)
(error "error parsing command line" tokens))))))
(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)
#f)
((parse-command-line-carefully tokens)
=> (lambda (v) v))
(else
(lp (drop-right tokens 1)))))))
;; unparser

14
scheme/nuit-packages.scm
View File

@ -580,7 +580,7 @@
(define-interface command-line-lexer-tokens-interface
(export
token? token-token token-type token-pos
token? token-token token-type token-cursor-pos
string-token?
s-expr-token?
operator-token?))
@ -612,7 +612,13 @@
(define-interface command-line-parser-interface
(export parse-command-line
unparse-command-line))
unparse-command-line
parser-error?
parser-syntax-error?
parser-unexpected-eof?
lex/parse-partial-command-line))
(define-structures
((command-line-lexer (compound-interface
@ -627,12 +633,14 @@
(open scheme
extended-ports
define-record-types
(subset srfi-1 (filter))
(subset srfi-1 (filter drop-right))
srfi-6
srfi-8
(subset srfi-13 (string-join))
srfi-14
let-opt
silly
conditions
signals
handle)
(files cmdline))