- make the lexer work if called without CURSOR-INDEX

- revamp the unparser to track the cursor-position after a TO-COMPLETE
  tokens was replaced by some completion or so.
This commit is contained in:
eknauel 2005-08-19 12:28:53 +00:00
parent ca2baa2c56
commit 2476b86e0b
1 changed files with 59 additions and 52 deletions

View File

@ -135,7 +135,8 @@
(let ((start-pos (current-column port)))
(read-char port)
(let read-whitspaces ((c (peek-char port))
(cursor? (= start-pos cursor-index)))
(cursor? (and cursor-index
(= start-pos cursor-index))))
(cond
((eof-object? c)
(lp c (if (or cursor?
@ -146,8 +147,9 @@
((char-set-contains? char-set:whitespace c)
(read-char port)
(read-whitspaces (peek-char port)
(or cursor?
(= (current-column port) cursor-index))))
(or cursor?
(and cursor-index
(= (current-column port) cursor-index)))))
(else (lp c tokens))))))
(else
(let ((token (lex-token cursor-index port)))
@ -224,7 +226,7 @@
((to-complete? t)
t)
((cursor-on-token? t)
(make-to-complete (token-token t) (token-start-pos t)))
(make-to-complete (token-token t) (token-cursor-pos t)))
(else
(token-token t))))
@ -364,58 +366,63 @@
;; unparser
(define append*
(lambda args
(apply append
(map (lambda (arg)
(if (pair? arg)
arg
(list arg)))
(filter (lambda (v) (not (null? v)))
args)))))
(define string-join*
(lambda args
(string-join (apply append* args))))
(define (unparse-arbitrary v)
(let ((p (open-output-string)))
(display v p)
(get-output-string p)))
(define (unparse-string/s-expr v)
(define (unparse-string/s-expr completion pos v)
(cond
((string? v) v)
((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))
(string-append
"," (unparse-arbitrary (cadr v))))
(display ",")
(display (cadr v)))
((and (pair? v) (eq? (car v) 'unquote-splicing))
(string-append
",@" (unparse-arbitrary (cadr v))))
(display ",@")
(display (cadr v)))
(else
(unparse-arbitrary v))))
(error "Don't know how to unparse this." v))))
(define (unparse-redirection rd)
(string-join*
(symbol->string (redirection-op rd))
(unparse-string/s-expr (redirection-dest rd))))
(define (unparse-redirection completion pos rd)
(display (symbol->string (redirection-op rd)))
(display " ")
(unparse-string/s-expr completion pos
(redirection-dest rd)))
(define (unparse-command cmd)
(string-join*
(unparse-string/s-expr (command-executable cmd))
(map unparse-string/s-expr (command-args cmd))
(map unparse-redirection
(command-redirections cmd))))
(define (unparse-command completion pos cmd)
(unparse-string/s-expr completion pos (command-executable cmd))
(display " ")
(for-each (lambda (arg)
(unparse-string/s-expr completion pos arg)
(display " "))
(command-args cmd))
(for-each (lambda (arg)
(unparse-redirection completion pos arg)
(display " "))
(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))
(display " ")
(for-each
(lambda (comb.cmd)
(display (symbol->string (car comb.cmd)))
(display " ")
(unparse-command completion pos (cdr comb.cmd)))
(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))))))
(define (unparse-command-line cmdln)
(string-join*
(unparse-command (command-line-first-cmd cmdln))
(map (lambda (comb.cmd)
(string-append
(symbol->string (car comb.cmd))
" "
(unparse-command (cdr comb.cmd))))
(command-line-combinator/cmds cmdln))
(cond ((command-line-job-ctrl cmdln)
=> symbol->string)
(else '()))))