From f71f975e6dca2d3a86a830ac3efd80d852929090 Mon Sep 17 00:00:00 2001 From: eknauel Date: Mon, 15 Aug 2005 12:41:24 +0000 Subject: [PATCH] Support for parsing partial command lines (needed for tab completion) --- scheme/cmdline.scm | 180 +++++++++++++++++++++++++++++---------- scheme/nuit-packages.scm | 14 ++- 2 files changed, 145 insertions(+), 49 deletions(-) diff --git a/scheme/cmdline.scm b/scheme/cmdline.scm index b4d4159..92f2c48 100644 --- a/scheme/cmdline.scm +++ b/scheme/cmdline.scm @@ -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 diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index d97bcdb..bdae4b0 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -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))