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

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)
+(define (make-token token type start-pos cursor-index port)
-  (make-token data 'string pos))
+  (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)
+(define (make-s-expr-token data start-pos cursor-index port)
-  (make-token data 's-expr pos))
+  (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)
+(define (make-operator-token data start-pos cursor-index port)
-  (make-token data 'operator pos))
+  (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 
+	(make-string-token (reverse-list->string chars (length chars))
-	 (reverse-list->string chars (length chars))
+			   start-pos cursor-index port))
-	 start-pos))
        (else
 	(read-char port)
 	(lp (peek-char port) (cons c chars)))))))
 
-(define (lex-operator port)
+(define (lex-operator cursor-index port)
-  (let ((start-pos (current-column port)) ; makes no sense, do it anyways
+  (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 
+      (let* ((start-pos (current-column port))
-		    (read port) (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)
+      (let ((pos (current-column port)))
-      (lp (peek-char port) tokens))
+	(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)
+(define (lex-command-line cmd-line . args)
-  (lex-port 
+  (let-optionals args
-   (make-tracking-input-port (make-string-input-port cmd-line))))
+      ((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)
+(define (extract-token t)
-  (parse-error "unexpected end of line" where))
+  (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)
+(define (string-or-s-expr? t)
-  (or (string-token? token) (s-expr-token? token)))
+  (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))
+	    (values (extract-token t) (cdr tokens))
-	    (parse-error 
+	    (signal-syntax-error `(parse-string/s-expr ,t ,tokens))))))
-	     "not a string or s-expr" '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
 

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