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