mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
873 lines
35 KiB
Scheme
873 lines
35 KiB
Scheme
;;;; edit-line.scm - pure scheme line editor
|
|
;;
|
|
;; Copyright (c) 2011-2017 Alex Shinn. All rights reserved.
|
|
;; BSD-style license: http://synthcode.com/license.txt
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; vt100 terminal utilities
|
|
|
|
(define (terminal-escape out ch arg)
|
|
(write-char (integer->char 27) out)
|
|
(write-char #\[ out)
|
|
(if arg (display arg out))
|
|
(write-char ch out)
|
|
(flush-output-port out))
|
|
|
|
;; we use zero-based columns
|
|
(define (terminal-goto-col out n) (terminal-escape out #\G (+ n 1)))
|
|
(define (terminal-up out n) (terminal-escape out #\A n))
|
|
(define (terminal-down out n) (terminal-escape out #\B n))
|
|
(define (terminal-clear-below out) (terminal-escape out #\J #f))
|
|
(define (terminal-clear-right out) (terminal-escape out #\K #f))
|
|
|
|
(define (read-numeric-sequence in)
|
|
(let lp ((c (peek-char in)) (acc '()))
|
|
(case c
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
(read-char in) ;; skip peeked char
|
|
(lp (peek-char in) (cons c acc)))
|
|
(else
|
|
(string->number (apply string (reverse acc)))))))
|
|
|
|
(define (terminal-current-position in out)
|
|
(with-stty '(not icanon isig echo)
|
|
(lambda ()
|
|
(terminal-escape out #\n 6)
|
|
(read-char in)
|
|
(and (eqv? #\[ (read-char in))
|
|
(let ((y (read-numeric-sequence in)))
|
|
(and y
|
|
(eqv? #\; (read-char in))
|
|
(let ((x (read-numeric-sequence in)))
|
|
(and x
|
|
(eqv? #\R (read-char in))
|
|
(list (- y 1) (- x 1))))))))))
|
|
|
|
(define (at-first-column? in out)
|
|
(let ((pos (terminal-current-position in out)))
|
|
(and pos (zero? (cadr pos)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; history
|
|
|
|
(define maximum-history-size 512)
|
|
|
|
(define-record-type History
|
|
(%make-history remaining past future filter)
|
|
history?
|
|
(remaining history-remaining history-remaining-set!)
|
|
(past history-past history-past-set!)
|
|
(future history-future history-future-set!)
|
|
(filter history-filter history-filter-set!))
|
|
|
|
(define (make-history . o)
|
|
(%make-history (if (pair? o) (car o) maximum-history-size)
|
|
'()
|
|
'()
|
|
(and (pair? o) (pair? (cdr o)) (cadr o))))
|
|
|
|
(define (history-current h)
|
|
(let ((p (history-past h)))
|
|
(and (pair? p) (car p))))
|
|
|
|
(define (history->list h)
|
|
(let ((past (history-past h)) (future (history-future h)))
|
|
(if (pair? past) (cons (car past) (append future (cdr past))) future)))
|
|
|
|
(define (list->history ls . o)
|
|
(%make-history (max maximum-history-size (length ls)) ls '()
|
|
(and (pair? o) (car o))))
|
|
|
|
(define (history-flatten! h)
|
|
(history-past-set! h (history->list h))
|
|
(history-future-set! h '()))
|
|
|
|
(define (drop-last ls) (reverse (cdr (reverse ls))))
|
|
|
|
(define (history-past-push! h x)
|
|
(if (positive? (history-remaining h))
|
|
(history-remaining-set! h (- (history-remaining h) 1))
|
|
(if (pair? (history-past h))
|
|
(history-past-set! h (drop-last (history-past h)))
|
|
(history-future-set! h (drop-last (history-future h)))))
|
|
(history-past-set! h (cons x (history-past h))))
|
|
|
|
(define (history-insert! h x)
|
|
(history-flatten! h)
|
|
(if (not (and (history-filter h) ((history-filter h) x)))
|
|
(history-past-push! h x)))
|
|
|
|
(define (history-reset! h)
|
|
(cond
|
|
((pair? (history-future h))
|
|
(history-past-set! h (append (drop-last (history-future h))
|
|
(history-past h)))
|
|
(history-future-set! h '()))))
|
|
|
|
(define (history-commit! h x)
|
|
(history-reset! h)
|
|
(if (not (and (pair? (history-past h)) (equal? x (car (history-past h)))))
|
|
(history-insert! h x)))
|
|
|
|
(define (history-prev! h)
|
|
(let ((past (history-past h)))
|
|
(and (pair? past)
|
|
(pair? (cdr past))
|
|
(begin
|
|
(history-future-set! h (cons (car past) (history-future h)))
|
|
(history-past-set! h (cdr past))
|
|
(cadr past)))))
|
|
|
|
(define (history-next! h)
|
|
(let ((future (history-future h)))
|
|
(and (pair? future)
|
|
(begin
|
|
(history-past-set! h (cons (car future) (history-past h)))
|
|
(history-future-set! h (cdr future))
|
|
(car future)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; char and string utils
|
|
|
|
(define (char-word-constituent? ch)
|
|
(or (char-alphabetic? ch) (char-numeric? ch)
|
|
(memv ch '(#\_ #\- #\+ #\:))))
|
|
|
|
(define (char-non-word-constituent? ch) (not (char-word-constituent? ch)))
|
|
|
|
(define (string-copy! dst dstart src start end)
|
|
(if (>= start dstart)
|
|
(do ((i start (+ i 1)) (j dstart (+ j 1)))
|
|
((= i end))
|
|
(string-set! dst j (string-ref src i)))
|
|
(do ((i (- end 1) (- i 1)) (j (+ dstart (- end start 1)) (- j 1)))
|
|
((< i start))
|
|
(string-set! dst j (string-ref src i)))))
|
|
|
|
(define (string-index ch x)
|
|
(let ((len (string-length x)))
|
|
(let lp ((i 0))
|
|
(cond ((>= i len) #f)
|
|
((eqv? ch (string-ref x i)))
|
|
(else (lp (+ i 1)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; buffers
|
|
|
|
(define-record-type Buffer
|
|
(%make-buffer refresh? cleared? min pos row max-row col gap start width
|
|
string history complete? single-line?)
|
|
buffer?
|
|
(refresh? buffer-refresh? buffer-refresh?-set!)
|
|
(cleared? buffer-cleared? buffer-cleared?-set!)
|
|
(min buffer-min buffer-min-set!)
|
|
(pos buffer-pos buffer-pos-set!)
|
|
(row buffer-row buffer-row-set!)
|
|
(max-row buffer-max-row buffer-max-row-set!)
|
|
(col buffer-col buffer-col-set!)
|
|
(gap buffer-gap buffer-gap-set!)
|
|
(start buffer-start buffer-start-set!)
|
|
(width buffer-width buffer-width-set!)
|
|
(string buffer-string buffer-string-set!)
|
|
(kill-ring buffer-kill-ring buffer-kill-ring-set!)
|
|
(history buffer-history buffer-history-set!)
|
|
(complete? buffer-complete? buffer-complete?-set!)
|
|
(single-line? buffer-single-line? buffer-single-line?-set!))
|
|
|
|
(define default-buffer-size 256)
|
|
(define default-buffer-width 80)
|
|
|
|
(define (make-buffer)
|
|
(%make-buffer #f #f 0 0 0 0 0 default-buffer-size 0 default-buffer-width
|
|
(make-string default-buffer-size) '() #f #f))
|
|
|
|
(define (buffer->string buf)
|
|
(let ((str (buffer-string buf)))
|
|
(string-append (substring str (buffer-min buf) (buffer-pos buf))
|
|
(substring str (buffer-gap buf) (string-length str)))))
|
|
|
|
(define (buffer-right-length buf)
|
|
(- (string-length (buffer-string buf)) (buffer-gap buf)))
|
|
(define (buffer-length buf)
|
|
(+ (buffer-pos buf) (buffer-right-length buf)))
|
|
(define (buffer-free-space buf)
|
|
(- (buffer-gap buf) (buffer-pos buf)))
|
|
|
|
(define (buffer-clamp buf n)
|
|
(max (buffer-min buf) (min n (buffer-length buf))))
|
|
|
|
(define (buffer-resize buf n)
|
|
(cond ((<= (buffer-free-space buf) n)
|
|
(let* ((right-len (buffer-right-length buf))
|
|
(new-len (* 2 (max n (buffer-length buf))))
|
|
(new-gap (- new-len right-len))
|
|
(new (make-string new-len))
|
|
(old (buffer-string buf)))
|
|
(string-copy! new 0 old 0 (buffer-pos buf))
|
|
(string-copy! new new-gap old (buffer-gap buf) (string-length old))
|
|
(buffer-string-set! buf new)
|
|
(buffer-gap-set! buf new-gap)))))
|
|
|
|
;; Adapted from fmt-unicode. TODO: convert to char-sets.
|
|
(define low-non-spacing-chars '#u8(
|
|
#xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff #xff 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
#x78 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 #xfe #xff #xff #xff #xff #xff #x1f 0 0 0 0 0 0 0
|
|
0 0 #x3f 0 0 0 0 0 0 #xf8 #xff #x01 0 0 #x01 0
|
|
0 0 0 0 0 0 0 0 0 0 #xc0 #xff #xff #x3f 0 0
|
|
0 0 #x02 0 0 0 #xff #xff #xff #x07 0 0 0 0 0 0
|
|
0 0 0 0 #xc0 #xff #x01 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
#x06 0 0 0 0 0 0 #x10 #xfe #x21 #x1e 0 #x0c 0 0 0
|
|
#x02 0 0 0 0 0 0 #x10 #x1e #x20 0 0 #x0c 0 0 0
|
|
#x06 0 0 0 0 0 0 #x10 #xfe #x3f 0 0 0 0 #x03 0
|
|
#x06 0 0 0 0 0 0 #x30 #xfe #x21 0 0 #x0c 0 0 0
|
|
#x02 0 0 0 0 0 0 #x90 #x0e #x20 #x40 0 0 0 0 0
|
|
#x04 0 0 0 0 0 0 0 0 #x20 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 #xc0 #xc1 #xff #x7f 0 0 0 0 0
|
|
0 0 0 0 0 0 0 #x10 #x40 #x30 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 #x0e #x20 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 #x04 #x7c 0 0 0 0 0
|
|
0 0 0 0 0 0 #xf2 #x07 #x80 #x7f 0 0 0 0 0 0
|
|
0 0 0 0 0 0 #xf2 #x1f 0 #x3f 0 0 0 0 0 0
|
|
0 0 0 #x03 0 0 #xa0 #x02 0 0 0 0 0 0 #xfe #x7f
|
|
#xdf 0 #xff #xff #xff #xff #xff #x1f #x40 0 0 0 0 0 0 0
|
|
0 0 0 0 0 #xe0 #xfd #x02 0 0 0 #x03 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 #x1c 0 0 0 #x1c 0 0 0 #x0c 0 0 0 #x0c 0
|
|
0 0 0 0 0 0 #x80 #x3f #x40 #xfe #x0f #x20 0 0 0 0
|
|
0 #x38 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 #x02 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 #x87 #x01 #x04 #x0e 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
|
0 0 0 0 0 0 0 0 0 0 #xff #x1f #xe2 #x07))
|
|
|
|
(define (unicode-char-width c)
|
|
(let ((ci (char->integer c)))
|
|
(cond
|
|
;; hand-checked ranges from EastAsianWidth.txt
|
|
((<= #x1100 ci #x115F) 2) ; Hangul
|
|
((<= #x2E80 ci #x4DB5) 2) ; CJK
|
|
((<= #x4E00 ci #xA4C6) 2)
|
|
((<= #xAC00 ci #xD7A3) 2) ; Hangul
|
|
((<= #xF900 ci #xFAD9) 2) ; CJK compat
|
|
((<= #xFE10 ci #xFE6B) 2)
|
|
((<= #xFF01 ci #xFF60) 2)
|
|
((<= #xFFE0 ci #xFFE6) 2)
|
|
((<= #x20000 ci #x30000) 2)
|
|
;; non-spacing mark (Mn) ranges from UnicodeData.txt
|
|
((<= #x0300 ci #x20fd) ; #x3029
|
|
;; inlined bit-vector-ref for portability
|
|
(let* ((i (- ci #x0300))
|
|
(byte (quotient i 8))
|
|
(off (remainder i 8)))
|
|
(if (zero? (bitwise-and (bytevector-u8-ref low-non-spacing-chars byte)
|
|
(arithmetic-shift 1 off)))
|
|
1
|
|
0)))
|
|
((<= #x302A ci #x302F) 0)
|
|
((<= #x3099 ci #x309A) 0)
|
|
((= #xFB1E ci) 0)
|
|
((<= #xFE00 ci #xFE23) 0)
|
|
((<= #x1D167 ci #x1D169) 0)
|
|
((<= #x1D17B ci #x1D182) 0)
|
|
((<= #x1D185 ci #x1D18B) 0)
|
|
((<= #x1D1AA ci #x1D1AD) 0)
|
|
((<= #xE0100 ci #xE01EF) 0)
|
|
(else 1))))
|
|
|
|
(define (unicode-string-width str . o)
|
|
(let ((start (if (pair? o) (car o) 0))
|
|
(end (if (and (pair? o) (pair? (cdr o)))
|
|
(cadr o)
|
|
(string-length str))))
|
|
(let lp1 ((i start) (width 0))
|
|
(if (>= i end)
|
|
width
|
|
(let ((c (string-ref str i)))
|
|
(cond
|
|
;; ANSI escapes
|
|
((and (= 27 (char->integer c)) ; esc
|
|
(< (+ i 1) end)
|
|
(eqv? #\[ (string-ref str (+ i 1))))
|
|
(let lp2 ((i (+ i 2)))
|
|
(cond ((>= i end) width)
|
|
((memv (string-ref str i) '(#\m #\newline))
|
|
(lp1 (+ i 1) width))
|
|
(else (lp2 (+ i 1))))))
|
|
;; unicode characters
|
|
((>= (char->integer c) #x80)
|
|
(lp1 (+ i 1) (+ width (unicode-char-width c))))
|
|
;; normal ASCII
|
|
(else (lp1 (+ i 1) (+ width 1)))))))))
|
|
|
|
(define (buffer-update-position! buf)
|
|
(let ((pos (buffer-pos buf))
|
|
(gap (buffer-gap buf))
|
|
(str (buffer-string buf))
|
|
(end (string-length (buffer-string buf)))
|
|
(width (buffer-width buf)))
|
|
(cond
|
|
((buffer-single-line? buf)
|
|
;; The "start" is the last left-most column of the buffer when
|
|
;; we overflow and need to scroll horizontally. This defaults
|
|
;; to 0 and increments as we move past the last column. We
|
|
;; update it when we find that (via movement or insertion) the
|
|
;; point would no longer be visible from "start" to the end of
|
|
;; the line, by shifting the start to the rightmost column that
|
|
;; would show the point. Thus, after scrolling off the
|
|
;; beginning of the buffer, successive movements left will first
|
|
;; go to the 0th column, then scroll to the start one character
|
|
;; at a time. A beginning-of-line command will restore the
|
|
;; "start" to 0 immediately.
|
|
;; We assume no embedded newlines in this case.
|
|
(let ((start (buffer-start buf))
|
|
(min-width (unicode-string-width str 0 (buffer-min buf))))
|
|
(cond
|
|
((> start pos)
|
|
;; We've moved back before the current start - reset to pos.
|
|
(buffer-start-set! buf pos))
|
|
((> (+ 1 min-width (unicode-string-width str start pos))
|
|
(buffer-width buf))
|
|
;; The edited text is wider than the screen - scroll the
|
|
;; start so that pos fits on the end.
|
|
;; TODO: This isn't correct for wide characters, need to
|
|
;; loop checking individual widths.
|
|
(buffer-start-set!
|
|
buf
|
|
(max 0 (- (+ 1 min-width (unicode-string-width str 0 pos))
|
|
(buffer-width buf))))))
|
|
;; Compute the current column as the width of the prompt plus
|
|
;; the width of the visible buffer from start to pos.
|
|
(let* ((vis-width (unicode-string-width str (buffer-start buf) pos))
|
|
(col (+ min-width vis-width)))
|
|
(buffer-col-set! buf col))))
|
|
(else
|
|
;; Otherwise, in a multi-line editor we need to scan for
|
|
;; newlines to determine the current (relative) row and column.
|
|
;; TODO: Handle ANSI escapes.
|
|
(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))
|
|
(else
|
|
(let ((off (unicode-char-width (string-ref str i))))
|
|
(if (>= (+ col off) width)
|
|
(lp (+ i 1) (+ row 1) 0)
|
|
(lp (+ i 1) row (+ col off)))))))))))
|
|
|
|
(define (buffer-clear buf out)
|
|
(cond
|
|
((not (buffer-cleared? buf))
|
|
;; goto start of input
|
|
(terminal-goto-col out 0)
|
|
(if (positive? (buffer-row buf))
|
|
(terminal-up out (buffer-row buf)))
|
|
;; clear below
|
|
(terminal-clear-below out)
|
|
(buffer-cleared?-set! buf #t))))
|
|
|
|
(define (buffer-draw buf out)
|
|
(let* ((gap (buffer-gap buf))
|
|
(str (buffer-string buf))
|
|
(end (string-length str))
|
|
(old-row (buffer-row buf))
|
|
(old-col (buffer-col buf)))
|
|
;; update position and clear the current input
|
|
(buffer-clear buf out)
|
|
(buffer-update-position! buf)
|
|
(let ((left (if (buffer-single-line? buf)
|
|
(buffer-start buf)
|
|
(buffer-min buf)))
|
|
(right
|
|
(if (buffer-single-line? buf)
|
|
(min end (+ (buffer-gap buf)
|
|
(- (buffer-width buf) (buffer-col 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))
|
|
(flush-output-port out)
|
|
(buffer-cleared?-set! buf #f)))
|
|
|
|
(define (buffer-refresh buf out)
|
|
(cond ((buffer-refresh? buf)
|
|
(buffer-draw buf out)
|
|
(buffer-refresh?-set! buf #f))))
|
|
|
|
(define (buffer-goto! buf out n)
|
|
(let ((pos (buffer-pos buf))
|
|
(gap (buffer-gap buf))
|
|
(str (buffer-string buf))
|
|
(n (buffer-clamp buf n)))
|
|
(cond ((not (= n pos))
|
|
(buffer-update-position! buf) ;; necesary?
|
|
(if (< n pos)
|
|
(string-copy! str (- gap (- pos n)) str n pos)
|
|
(string-copy! str pos str gap (+ gap (- n pos))))
|
|
(buffer-pos-set! buf n)
|
|
(buffer-gap-set! buf (+ gap (- n pos)))
|
|
(cond
|
|
((not (buffer-refresh? buf))
|
|
(let ((old-row (buffer-row buf))
|
|
(old-start (buffer-start buf)))
|
|
(buffer-update-position! buf)
|
|
(cond
|
|
((not (= old-start (buffer-start buf)))
|
|
(buffer-refresh?-set! buf #t))
|
|
(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)
|
|
(let ((len (if (char? x) 1 (string-length x)))
|
|
(pos (buffer-pos buf)))
|
|
(buffer-resize buf len)
|
|
(if (char? x)
|
|
(string-set! (buffer-string buf) pos x)
|
|
(string-copy! (buffer-string buf) pos x 0 len))
|
|
(buffer-pos-set! buf (+ (buffer-pos buf) len))
|
|
(cond
|
|
((buffer-refresh? buf))
|
|
((and (= (buffer-gap buf) (string-length (buffer-string buf)))
|
|
(< (+ (buffer-col buf) len) (buffer-width buf))
|
|
(if (char? x)
|
|
(not (eqv? x #\newline))
|
|
(not (string-index #\newline x))))
|
|
;; fast path - append to end of buffer w/o wrapping to next line
|
|
(display x out)
|
|
(flush-output-port out)
|
|
(buffer-col-set! buf (+ (buffer-col buf) len))
|
|
(buffer-cleared?-set! buf #f))
|
|
(else
|
|
(buffer-refresh?-set! buf #t)))))
|
|
|
|
(define (buffer-delete! buf out start end)
|
|
(let ((pos (buffer-pos buf))
|
|
(gap (buffer-gap buf))
|
|
(str (buffer-string buf))
|
|
(start (buffer-clamp buf start))
|
|
(end (buffer-clamp buf end)))
|
|
(if (not (buffer-refresh? buf))
|
|
(if (and (= start pos) (>= end (buffer-length buf)))
|
|
(terminal-clear-below out)
|
|
(buffer-refresh?-set! buf #t)))
|
|
(cond ((< end pos)
|
|
(string-copy! str start str end pos)
|
|
(buffer-pos-set! buf (+ start (- pos end))))
|
|
((> start gap)
|
|
(string-copy! str start str gap (+ gap (- end start)))
|
|
(buffer-gap-set! buf (+ gap (- end start))))
|
|
(else
|
|
(buffer-pos-set! buf (min pos start))
|
|
(buffer-gap-set! buf (max gap (+ pos (- gap pos) (- end pos))))))))
|
|
|
|
(define (buffer-skip buf pred)
|
|
(let* ((str (buffer-string buf)) (end (string-length str)))
|
|
(let lp ((i (buffer-gap buf)))
|
|
(if (or (>= i end) (not (pred (string-ref str i))))
|
|
(+ (- i (buffer-gap buf)) (buffer-pos buf))
|
|
(lp (+ i 1))))))
|
|
|
|
(define (buffer-skip-reverse buf pred)
|
|
(let ((str (buffer-string buf)))
|
|
(let lp ((i (- (buffer-pos buf) 1)))
|
|
(if (or (< i 0) (not (pred (string-ref str i)))) i (lp (- i 1))))))
|
|
|
|
(define (buffer-previous-word buf)
|
|
(let ((i (buffer-skip-reverse buf char-word-constituent?)))
|
|
(substring (buffer-string buf) (+ i 1) (buffer-pos buf))))
|
|
|
|
(define (buffer-format-list buf out words)
|
|
(let ((width (buffer-width buf)))
|
|
(define (write-rows num-cols widths)
|
|
(let lp ((ls words) (i 0))
|
|
(cond
|
|
((pair? ls)
|
|
(let ((diff (- (vector-ref widths i) (string-length (car ls)))))
|
|
(display (car ls) out)
|
|
(if (= (+ i 1) num-cols)
|
|
(newline out)
|
|
(display (make-string (+ 1 diff) #\space) out))
|
|
(lp (cdr ls) (modulo (+ i 1) num-cols))))
|
|
((< i num-cols)
|
|
(newline out)))))
|
|
(let try-cols ((num-cols (length words)))
|
|
(cond
|
|
((<= num-cols 1)
|
|
(newline out)
|
|
(for-each (lambda (x) (display x out) (newline out)) words))
|
|
(else
|
|
(let ((widths (make-vector num-cols 0)))
|
|
(let lp ((ls words) (i 0) (avail (- num-cols 1)))
|
|
(cond
|
|
((null? ls)
|
|
(write-rows num-cols widths))
|
|
(else
|
|
(let ((diff (- (string-length (car ls)) (vector-ref widths i))))
|
|
(if (positive? diff)
|
|
(let ((avail (+ avail diff)))
|
|
(cond
|
|
((> avail width)
|
|
(try-cols (- num-cols 1)))
|
|
(else
|
|
(vector-set! widths i (string-length (car ls)))
|
|
(lp (cdr ls) (modulo (+ i 1) num-cols) avail))))
|
|
(lp (cdr ls) (modulo (+ i 1) num-cols) avail))))))))))))
|
|
|
|
(define (buffer-make-completer generate)
|
|
(lambda (ch buf out return)
|
|
(let* ((word (buffer-previous-word buf))
|
|
(ls (generate buf word)))
|
|
(cond
|
|
((null? ls)
|
|
(command/beep ch buf out return))
|
|
((= 1 (length ls))
|
|
(buffer-insert! buf out (substring (car ls) (string-length word))))
|
|
(else
|
|
(newline out)
|
|
(buffer-format-list buf out ls)
|
|
(buffer-draw buf out))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; keymaps
|
|
|
|
(define keymap? pair?)
|
|
|
|
(define (make-keymap . o)
|
|
(cons (make-vector 256 #f) (and (pair? o) (car o))))
|
|
|
|
(define (make-sparse-keymap . o)
|
|
(cons '() (and (pair? o) (car o))))
|
|
|
|
(define (make-printable-keymap)
|
|
(let* ((keymap (make-keymap command/self-insert))
|
|
(v (car keymap)))
|
|
(do ((i #x20 (+ i 1))) ((= i #x7F) keymap)
|
|
(vector-set! v i command/self-insert))))
|
|
|
|
(define (make-standard-escape-bracket-keymap)
|
|
(let* ((keymap (make-keymap))
|
|
(v (car keymap)))
|
|
(vector-set! v 65 command/backward-history)
|
|
(vector-set! v 66 command/forward-history)
|
|
(vector-set! v 67 command/forward-char)
|
|
(vector-set! v 68 command/backward-char)
|
|
keymap))
|
|
|
|
(define (make-standard-escape-keymap)
|
|
(let* ((keymap (make-keymap))
|
|
(v (car keymap)))
|
|
(vector-set! v 8 command/backward-delete-word)
|
|
(vector-set! v 91 (make-standard-escape-bracket-keymap))
|
|
(vector-set! v 98 command/backward-word)
|
|
(vector-set! v 100 command/forward-delete-word)
|
|
(vector-set! v 102 command/forward-word)
|
|
(vector-set! v 127 command/backward-delete-word)
|
|
keymap))
|
|
|
|
(define (make-standard-keymap . o)
|
|
(let* ((keymap (make-printable-keymap))
|
|
(v (car keymap))
|
|
(catch-control-c? (and (pair? o) (car o))))
|
|
(vector-set! v 0 command/enter) ;; for telnet
|
|
(vector-set! v 1 command/beginning-of-line)
|
|
(vector-set! v 2 command/backward-char)
|
|
(vector-set! v 3 (if catch-control-c? command/cancel command/quit))
|
|
(vector-set! v 4 command/forward-delete-char)
|
|
(vector-set! v 5 command/end-of-line)
|
|
(vector-set! v 6 command/forward-char)
|
|
(vector-set! v 8 command/backward-delete-char)
|
|
(vector-set! v 10 command/enter)
|
|
(vector-set! v 11 command/forward-delete-line)
|
|
(vector-set! v 12 command/refresh)
|
|
(vector-set! v 13 command/skip)
|
|
(vector-set! v 14 command/forward-history)
|
|
(vector-set! v 16 command/backward-history)
|
|
(vector-set! v 21 command/backward-delete-line)
|
|
(vector-set! v 27 (make-standard-escape-keymap))
|
|
(vector-set! v 127 command/backward-delete-char)
|
|
keymap))
|
|
|
|
(define (keymap-lookup keymap n)
|
|
(let ((table (car keymap)))
|
|
(or (if (vector? table)
|
|
(and (< -1 n (vector-length table)) (vector-ref table n))
|
|
(cond ((assv n table) => cdr) (else #f)))
|
|
(if (keymap? (cdr keymap))
|
|
(keymap-lookup (cdr keymap) n)
|
|
(cdr keymap)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; commands
|
|
|
|
(define (command/self-insert ch buf out return)
|
|
(buffer-insert! buf out ch))
|
|
|
|
(define (command/enter ch buf out return)
|
|
(protect (exn
|
|
((and (exception? exn)
|
|
(eq? 'read-incomplete (exception-kind exn)))
|
|
(command/self-insert ch buf out return))
|
|
(else
|
|
(buffer-clear buf out)
|
|
(print-exception exn out)
|
|
(buffer-draw buf out)))
|
|
(cond
|
|
(((buffer-complete? buf) buf)
|
|
(command/end-of-line ch buf out return)
|
|
(display "\r\n" out)
|
|
(flush-output-port out)
|
|
(return))
|
|
(else
|
|
(command/self-insert ch buf out return)))))
|
|
|
|
(define (command/cancel ch buf out return)
|
|
(command/end-of-line ch buf out return)
|
|
(display "^C" out)
|
|
(newline out)
|
|
(buffer-delete! buf out 0 (buffer-length buf))
|
|
(buffer-draw buf out))
|
|
|
|
(define (command/quit ch buf out return)
|
|
(command/end-of-line ch buf out return)
|
|
(display "^C" out)
|
|
(newline out)
|
|
(stty out '(icanon isig echo))
|
|
(return '^C))
|
|
|
|
(define (command/beep ch buf out return)
|
|
(write-char (integer->char 7) out))
|
|
|
|
(define (command/skip ch buf out return)
|
|
#f)
|
|
|
|
(define (command/refresh ch buf out return)
|
|
(buffer-draw buf out))
|
|
|
|
(define (command/beginning-of-line ch buf out return)
|
|
(buffer-goto! buf out 0))
|
|
|
|
(define (command/end-of-line ch buf out return)
|
|
(buffer-goto! buf out (buffer-length buf)))
|
|
|
|
(define (command/forward-char ch buf out return)
|
|
(buffer-goto! buf out (+ (buffer-pos buf) 1)))
|
|
|
|
(define (command/backward-char ch buf out return)
|
|
(buffer-goto! buf out (- (buffer-pos buf) 1)))
|
|
|
|
(define (command/forward-delete-char ch buf out return)
|
|
(cond
|
|
((zero? (- (buffer-length buf) (buffer-min buf)))
|
|
(newline out)
|
|
(return 'eof))
|
|
(else
|
|
(buffer-delete! buf out (buffer-pos buf) (+ (buffer-pos buf) 1)))))
|
|
|
|
(define (command/backward-delete-char ch buf out return)
|
|
(buffer-delete! buf out (- (buffer-pos buf) 1) (buffer-pos buf)))
|
|
|
|
(define (command/forward-delete-line ch buf out return)
|
|
(buffer-delete! buf out (buffer-pos buf) (buffer-length buf)))
|
|
|
|
(define (command/backward-delete-line ch buf out return)
|
|
(buffer-delete! buf out 0 (buffer-pos buf)))
|
|
|
|
(define (command/backward-history ch buf out return)
|
|
(let ((history (buffer-history buf)))
|
|
(cond
|
|
((and (history? history) (pair? (history-past history)))
|
|
(if (null? (history-future history))
|
|
(history-insert! history (buffer->string buf)))
|
|
(cond
|
|
((pair? (cdr (history-past history)))
|
|
(buffer-delete! buf out 0 (buffer-length buf))
|
|
(buffer-insert! buf out (history-prev! history))))))))
|
|
|
|
(define (command/forward-history ch buf out return)
|
|
(let ((history (buffer-history buf)))
|
|
(cond
|
|
((and (history? history) (pair? (history-future history)))
|
|
(buffer-delete! buf out 0 (buffer-length buf))
|
|
(let ((res (buffer-insert! buf out (history-next! history))))
|
|
(if (null? (history-future history))
|
|
(history-past-set! history (cdr (history-past history))))
|
|
res)))))
|
|
|
|
(define (command/forward-word ch buf out return)
|
|
(buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
|
|
(buffer-goto! buf out (buffer-skip buf char-word-constituent?)))
|
|
|
|
(define (command/backward-word ch buf out return)
|
|
(buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
|
|
(buffer-goto! buf out (+ (buffer-skip-reverse buf char-word-constituent?) 1)))
|
|
|
|
(define (command/forward-delete-word ch buf out return)
|
|
(let ((start (buffer-pos buf)))
|
|
(buffer-goto! buf out (buffer-skip buf char-non-word-constituent?))
|
|
(buffer-delete! buf out start (buffer-skip buf char-word-constituent?))))
|
|
|
|
(define (command/backward-delete-word ch buf out return)
|
|
(let ((end (buffer-pos buf)))
|
|
(buffer-goto! buf out (buffer-skip-reverse buf char-non-word-constituent?))
|
|
(let ((start (buffer-skip-reverse buf char-word-constituent?)))
|
|
(buffer-delete! buf out (+ start 1) end))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; line-editing
|
|
|
|
(define standard-keymap (make-standard-keymap))
|
|
(define standard-cancel-keymap (make-standard-keymap #t))
|
|
|
|
(define (get-key ls key . o)
|
|
(let ((x (memq key ls)))
|
|
(if (and x (pair? (cdr x))) (cadr x) (and (pair? o) (car o)))))
|
|
|
|
(define (with-leading-ports ls proc)
|
|
(if (and (pair? ls) (input-port? (car ls)))
|
|
(if (and (pair? (cdr ls)) (output-port? (cadr ls)))
|
|
(proc (car ls) (cadr ls) (cddr ls))
|
|
(proc (car ls) (current-output-port) (cdr ls)))
|
|
(proc (current-input-port) (current-output-port) ls)))
|
|
|
|
(define (make-line-editor . args)
|
|
(let* ((prompter (get-key args 'prompt: "> "))
|
|
(history (get-key args 'history:))
|
|
(complete? (get-key args 'complete?: (lambda (buf) #t)))
|
|
(completion (get-key args 'completion: #f))
|
|
(terminal-width (get-key args 'terminal-width:))
|
|
(single-line? (get-key args 'single-line?: #f))
|
|
(fresh-line (get-key args 'fresh-line: #f))
|
|
(no-stty? (get-key args 'no-stty?: #f))
|
|
(hidden? (get-key args 'hidden?: #f))
|
|
(keymap0 (get-key args 'keymap:
|
|
(if (get-key args 'catch-control-c?: #f)
|
|
standard-cancel-keymap
|
|
standard-keymap)))
|
|
(keymap (if completion
|
|
(cons (list (cons 9 completion)) keymap0)
|
|
keymap0))
|
|
(buf (or (get-key args 'buffer: #f) (make-buffer))))
|
|
(lambda (in out)
|
|
(let* ((width (or terminal-width (get-terminal-width out) 80))
|
|
(prompt (if (procedure? prompter) (prompter) prompter))
|
|
(done? #f)
|
|
(tmp-out (if hidden? (open-output-string) out))
|
|
(return (lambda o (set! done? (if (pair? o) (car o) #t)))))
|
|
;; Maybe start at a fresh line.
|
|
(cond
|
|
((and fresh-line (not (at-first-column? in out)))
|
|
(if (string? fresh-line) (display fresh-line out))
|
|
(newline out)))
|
|
;; Clear buffer and reset prompt.
|
|
(buffer-refresh?-set! buf #t)
|
|
(buffer-min-set! buf 0)
|
|
(buffer-delete! buf out 0 (buffer-length buf))
|
|
(buffer-width-set! buf width)
|
|
(buffer-insert! buf out prompt)
|
|
(buffer-min-set! buf (string-length prompt))
|
|
(buffer-history-set! buf history)
|
|
(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)
|
|
(flush-output-port out)
|
|
((if no-stty? (lambda (out f) (f)) with-raw-io)
|
|
out
|
|
(lambda ()
|
|
(let lp ((kmap keymap))
|
|
(let ((ch (read-char in)))
|
|
(if (eof-object? ch)
|
|
(let ((res (buffer->string buf)))
|
|
(if (equal? res "") ch res))
|
|
(let ((x (keymap-lookup kmap (char->integer ch))))
|
|
(cond
|
|
((keymap? x)
|
|
(lp x))
|
|
((procedure? x)
|
|
(protect (exn (else
|
|
(buffer-clear buf out)
|
|
(print-exception exn out)
|
|
(buffer-draw buf out)))
|
|
(x ch buf tmp-out return))
|
|
(flush-output-port tmp-out)
|
|
(buffer-refresh buf tmp-out)
|
|
(if done?
|
|
(and (not (eq? done? 'eof)) (buffer->string buf))
|
|
(lp keymap)))
|
|
(else
|
|
;;(command/beep ch buf out return)
|
|
(lp keymap)))))))))))))
|
|
|
|
(define (edit-line . args)
|
|
(with-leading-ports
|
|
args
|
|
(lambda (in out rest) ((apply make-line-editor rest) in out))))
|
|
|
|
(define (edit-line-repl . args)
|
|
(with-leading-ports
|
|
args
|
|
(lambda (in out rest)
|
|
(let ((eval (get-key rest 'eval: (lambda (x) x)))
|
|
(print (get-key rest 'write: write))
|
|
(history (or (get-key rest 'history:) (make-history))))
|
|
(let ((edit-line
|
|
(apply make-line-editor 'no-stty?: #t 'history: history rest)))
|
|
((if (get-key args 'no-stty?:) (lambda (out f) (f)) with-raw-io)
|
|
out
|
|
(lambda ()
|
|
(let lp ()
|
|
(let ((line (edit-line in out)))
|
|
(if (pair? (history-future history))
|
|
(history-past-set! history (cdr (history-past history))))
|
|
(history-commit! history line)
|
|
(print (eval line) out)
|
|
(newline out)
|
|
(lp))))))))))
|