Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 06:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding single-line line editing option

Browse source
This commit is contained in:
Alex Shinn 2012-05-13 21:24:27 +09:00
parent 3fdf435ba3
commit a43cd05711
2 changed files with 96 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

133
lib/chibi/term/edit-line.scm
View file

@ -118,7 +118,8 @@
;; buffers ;; buffers
(define-record-type Buffer (define-record-type Buffer
(%make-buffer refresh? min pos row max-row col gap width string history) (%make-buffer refresh? min pos row max-row col gap start width string
history complete? single-line?)
buffer? buffer?
(refresh? buffer-refresh? buffer-refresh?-set!) (refresh? buffer-refresh? buffer-refresh?-set!)
(min buffer-min buffer-min-set!) (min buffer-min buffer-min-set!)
@ -127,18 +128,20 @@
(max-row buffer-max-row buffer-max-row-set!) (max-row buffer-max-row buffer-max-row-set!)
(col buffer-col buffer-col-set!) (col buffer-col buffer-col-set!)
(gap buffer-gap buffer-gap-set!) (gap buffer-gap buffer-gap-set!)
(start buffer-start buffer-start-set!)
(width buffer-width buffer-width-set!) (width buffer-width buffer-width-set!)
(string buffer-string buffer-string-set!) (string buffer-string buffer-string-set!)
(kill-ring buffer-kill-ring buffer-kill-ring-set!) (kill-ring buffer-kill-ring buffer-kill-ring-set!)
(history buffer-history buffer-history-set!) (history buffer-history buffer-history-set!)
(complete? buffer-complete? buffer-complete?-set!)) (complete? buffer-complete? buffer-complete?-set!)
(single-line? buffer-single-line? buffer-single-line?-set!))
(define default-buffer-size 256) (define default-buffer-size 256)
(define default-buffer-width 80) (define default-buffer-width 80)
(define (make-buffer) (define (make-buffer)
(%make-buffer #f 0 0 0 0 0 default-buffer-size default-buffer-width (%make-buffer #f 0 0 0 0 0 default-buffer-size 0 default-buffer-width
(make-string default-buffer-size) '())) (make-string default-buffer-size) '() #f #f))
(define (buffer->string buf) (define (buffer->string buf)
(let ((str (buffer-string buf))) (let ((str (buffer-string buf)))
@ -173,20 +176,46 @@
(str (buffer-string buf)) (str (buffer-string buf))
(end (string-length (buffer-string buf))) (end (string-length (buffer-string buf)))
(width (buffer-width buf))) (width (buffer-width buf)))
(let lp ((i 0) (row 0) (col 0)) ;; update row/col ;; TODO: Support double and zero-width chars and ANSI escapes.
(cond ((= i pos) (cond
(buffer-row-set! buf row) ((buffer-single-line? buf)
(buffer-col-set! buf col) ;; The "start" is the last left-most column of the buffer when
(lp gap row col)) ;; we overflow and need to scroll horizontally. This defaults
((>= i end) ;; to 0 and increments as we move past the last column. We
(buffer-max-row-set! ;; update it when we find that (via movement or insertion) the
buf (if (and (zero? col) (> row 0)) (- row 1) row))) ;; point would no longer be visible from "start" to the end of
((eqv? #\newline (string-ref str i)) ;; the line, by shifting the start to the rightmost column that
(lp (+ i 1) (+ row 1) 0)) ;; would show the point. Thus, after scrolling off the
((= (+ col 1) width) ;; beginning of the buffer, successive movements left will first
(lp (+ i 1) (+ row 1) 0)) ;; go to the 0th column, then scroll to the start one character
(else ;; at a time. A beginning-of-line command will restore the
(lp (+ i 1) row (+ col 1))))))) ;; "start" to 0 immediately.
;; We assume no embedded newlines in this case.
(let ((start (buffer-start buf)))
(cond
((> start pos)
(buffer-start-set! buf pos))
((> (+ 1 (buffer-min buf) (- pos start)) (buffer-width buf))
(buffer-start-set! buf (max 0 (- (+ 1 (buffer-min buf) pos)
(buffer-width buf))))))
(buffer-col-set! buf (+ (buffer-min buf) (- pos (buffer-start buf))))))
(else
;; Otherwise, in a multi-line editor we need to scan for
;; newlines to determine the current (relative) row and column.
(let lp ((i 0) (row 0) (col 0)) ;; update row/col
(cond ((= i pos)
(buffer-row-set! buf row)
(buffer-col-set! buf col)
(lp gap row col)) ;; skip from pos->gap
((>= i end)
(buffer-max-row-set!
buf (if (and (zero? col) (> row 0)) (- row 1) row)))
((eqv? #\newline (string-ref str i))
(lp (+ i 1) (+ row 1) 0))
((= (+ col 1) width)
(lp (+ i 1) (+ row 1) 0))
(else
(lp (+ i 1) row (+ col 1)))))))))
(define (buffer-clear buf out) (define (buffer-clear buf out)
;; goto start of input ;; goto start of input
@ -205,14 +234,25 @@
;; update position and clear the current input ;; update position and clear the current input
(buffer-clear buf out) (buffer-clear buf out)
(buffer-update-position! buf) (buffer-update-position! buf)
(display (substring str 0 (buffer-pos buf)) out) (let ((left (if (buffer-single-line? buf)
(display (substring str (buffer-gap buf) end) out) (buffer-start buf)
;; move to next line if point at eol (buffer-min buf)))
(if (and (zero? (buffer-col buf)) (positive? (buffer-row buf))) (right
(write-char #\space out)) (if (buffer-single-line? buf)
;; move to correct row then col (min end (+ (buffer-gap buf)
(if (< (buffer-row buf) (buffer-max-row buf)) (- (buffer-width buf) (buffer-col buf))))
(terminal-up out (- (buffer-max-row buf) (buffer-row buf)))) end)))
(display (substring str 0 (buffer-min buf)) out)
(display (substring str left (buffer-pos buf)) out)
(display (substring str (buffer-gap buf) right) out))
(cond
((not (buffer-single-line? buf))
;; move to next line if point at eol
(if (and (zero? (buffer-col buf)) (positive? (buffer-row buf)))
(write-char #\space out))
;; move to correct row then col
(if (< (buffer-row buf) (buffer-max-row buf))
(terminal-up out (- (buffer-max-row buf) (buffer-row buf))))))
(terminal-goto-col out (buffer-col buf)) (terminal-goto-col out (buffer-col buf))
(flush-output out))) (flush-output out)))
@ -227,7 +267,7 @@
(str (buffer-string buf)) (str (buffer-string buf))
(n (buffer-clamp buf n))) (n (buffer-clamp buf n)))
(cond ((not (= n pos)) (cond ((not (= n pos))
(buffer-update-position! buf) ;; XXXX shouldn't be needed (buffer-update-position! buf) ;; necesary?
(if (< n pos) (if (< n pos)
(string-copy! str (- gap (- pos n)) str n pos) (string-copy! str (- gap (- pos n)) str n pos)
(string-copy! str pos str gap (+ gap (- n pos)))) (string-copy! str pos str gap (+ gap (- n pos))))
@ -235,12 +275,17 @@
(buffer-gap-set! buf (+ gap (- n pos))) (buffer-gap-set! buf (+ gap (- n pos)))
(cond (cond
((not (buffer-refresh? buf)) ((not (buffer-refresh? buf))
(let ((old-row (buffer-row buf))) (let ((old-row (buffer-row buf))
(old-start (buffer-start buf)))
(buffer-update-position! buf) (buffer-update-position! buf)
(let ((row-diff (- old-row (buffer-row buf)))) (cond
(cond ((> row-diff 0) (terminal-up out row-diff)) ((not (= old-start (buffer-start buf)))
((< row-diff 0) (terminal-down out (- row-diff))))) (buffer-refresh?-set! buf #t))
(terminal-goto-col out (buffer-col buf))))))))) (else
(let ((row-diff (- old-row (buffer-row buf))))
(cond ((> row-diff 0) (terminal-up out row-diff))
((< row-diff 0) (terminal-down out (- row-diff)))))
(terminal-goto-col out (buffer-col buf)))))))))))
(define (buffer-insert! buf out x) (define (buffer-insert! buf out x)
(let ((len (if (char? x) 1 (string-length x))) (let ((len (if (char? x) 1 (string-length x)))
@ -390,7 +435,7 @@
(let* ((keymap (make-printable-keymap)) (let* ((keymap (make-printable-keymap))
(v (car keymap))) (v (car keymap)))
(vector-set! v 0 command/enter) ;; for telnet (vector-set! v 0 command/enter) ;; for telnet
(vector-set! v 1 command/beggining-of-line) (vector-set! v 1 command/beginning-of-line)
(vector-set! v 2 command/backward-char) (vector-set! v 2 command/backward-char)
(vector-set! v 3 command/cancel) (vector-set! v 3 command/cancel)
(vector-set! v 4 command/forward-delete-char) (vector-set! v 4 command/forward-delete-char)
@ -451,7 +496,7 @@
(define (command/refresh ch buf out return) (define (command/refresh ch buf out return)
(buffer-draw buf out)) (buffer-draw buf out))
(define (command/beggining-of-line ch buf out return) (define (command/beginning-of-line ch buf out return)
(buffer-goto! buf out 0)) (buffer-goto! buf out 0))
(define (command/end-of-line ch buf out return) (define (command/end-of-line ch buf out return)
@ -537,28 +582,36 @@
(proc (current-input-port) (current-output-port) ls))) (proc (current-input-port) (current-output-port) ls)))
(define (make-line-editor . args) (define (make-line-editor . args)
(let* ((prompt (get-key args 'prompt: "> ")) (let* ((prompter (get-key args 'prompt: "> "))
(history (get-key args 'history:)) (history (get-key args 'history:))
(complete? (get-key args 'complete?: (lambda (buf) #t))) (complete? (get-key args 'complete?: (lambda (buf) #t)))
(completion (get-key args 'completion: (lambda args '()))) (completion (get-key args 'completion: (lambda args '())))
(terminal-width (get-key args 'terminal-width:)) (terminal-width (get-key args 'terminal-width:))
(keymap (get-key args 'keymap: standard-keymap))) (single-line? (get-key args 'single-line?: #f))
(no-stty? (get-key args 'no-stty?: #f))
(keymap (get-key args 'keymap: standard-keymap))
(buf (or (get-key args 'buffer: #f) (make-buffer))))
(if completion
(vector-set! (car keymap) 9 completion))
(lambda (in out) (lambda (in out)
(let* ((width (or terminal-width (get-terminal-width out) 80)) (let* ((width (or terminal-width (get-terminal-width out) 80))
(buf (make-buffer)) (prompt (if (procedure? prompter) (prompter) prompter))
(done? #f) (done? #f)
(return (lambda o (set! done? (if (pair? o) (car o) #t))))) (return (lambda o (set! done? (if (pair? o) (car o) #t)))))
;; Clear buffer and reset prompt.
(buffer-refresh?-set! buf #t) (buffer-refresh?-set! buf #t)
(buffer-min-set! buf 0)
(buffer-delete! buf out 0 (buffer-length buf))
(buffer-width-set! buf width) (buffer-width-set! buf width)
(buffer-insert! buf out prompt) (buffer-insert! buf out prompt)
(buffer-min-set! buf (string-length prompt)) (buffer-min-set! buf (string-length prompt))
(buffer-history-set! buf history) (buffer-history-set! buf history)
(buffer-complete?-set! buf complete?) (buffer-complete?-set! buf complete?)
(buffer-single-line?-set! buf single-line?)
(if single-line? (buffer-start-set! buf (buffer-min buf)))
(buffer-refresh buf out) (buffer-refresh buf out)
(flush-output out) (flush-output out)
(if completion ((if no-stty? (lambda (out f) (f)) with-raw-io)
(vector-set! (car keymap) 9 completion))
((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io)
out out
(lambda () (lambda ()
(let lp ((kmap keymap)) (let lp ((kmap keymap))

5
lib/chibi/term/edit-line.sld
View file

@ -1,7 +1,8 @@
(define-library (chibi term edit-line) (define-library (chibi term edit-line)
(export edit-line edit-line-repl make-history history-insert! (export make-line-editor edit-line edit-line-repl
make-history history-insert!
history-commit! history->list list->history buffer->string history-commit! history->list list->history buffer->string
buffer-make-completer) make-buffer buffer-make-completer buffer-row buffer-col)
(import (scheme) (chibi stty) (srfi 9)) (import (scheme) (chibi stty) (srfi 9))
(include "edit-line.scm")) (include "edit-line.scm"))