- 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:
parent
ca2baa2c56
commit
2476b86e0b
|
@ -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 '()))))
|
||||
|
|
Loading…
Reference in New Issue