84 lines
2.6 KiB
Racket
84 lines
2.6 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/port)
|
|
|
|
(provide cook-io)
|
|
|
|
(define clear-to-eol "\033[2K")
|
|
(define kill-line (string-append "\r" clear-to-eol))
|
|
|
|
(struct buffer (chars consume-next-linefeed?) #:transparent)
|
|
|
|
(define (buffer-empty? b)
|
|
(null? (buffer-chars b)))
|
|
|
|
(define (buffer-adjust b new-chars)
|
|
(struct-copy buffer b
|
|
[chars new-chars]
|
|
[consume-next-linefeed? #f]))
|
|
|
|
(define (buffer-contents b)
|
|
(list->string (reverse (buffer-chars b))))
|
|
|
|
(define (update-buffer b key prompt k-eof k-complete k-ongoing)
|
|
(case key
|
|
((#\backspace #\rubout) ;; backspace = ^H = code 8; delete = code 127
|
|
(if (buffer-empty? b)
|
|
(k-ongoing b "")
|
|
(k-ongoing (buffer-adjust b (cdr (buffer-chars b))) "\b \b")))
|
|
((#\return) (k-complete (buffer-contents b) (buffer '() #t)))
|
|
((#\newline) (if (buffer-consume-next-linefeed? b)
|
|
(k-ongoing (struct-copy buffer b [consume-next-linefeed? #f]) "")
|
|
(k-complete (buffer-contents b) (buffer '() #f))))
|
|
((#\page) (k-ongoing b (string-append kill-line prompt (buffer-contents b))))
|
|
((#\004) ;; control-D, UNIX EOF
|
|
(if (buffer-empty? b)
|
|
(k-eof)
|
|
(k-ongoing b "")))
|
|
((#\033) ;; escape
|
|
(k-ongoing (buffer '() #f) (string-append kill-line prompt)))
|
|
(else (if (char-iso-control? key)
|
|
(k-ongoing b "")
|
|
(k-ongoing (buffer-adjust b (cons key (buffer-chars b))) (string key))))))
|
|
|
|
(define (cook-io raw-in raw-out prompt)
|
|
(define-values (cooked-in cooked-out) (make-pipe))
|
|
(thread
|
|
(lambda ()
|
|
(let loop ((b (buffer '() #f)))
|
|
(if (port-closed? cooked-out)
|
|
;; our job here is
|
|
'done
|
|
(let ((s (read-string 1 raw-in)))
|
|
(if (eof-object? s)
|
|
(begin (close-output-port cooked-out)
|
|
(loop b))
|
|
(begin (update-buffer b (string-ref s 0) prompt
|
|
(lambda ()
|
|
(close-output-port cooked-out)
|
|
(close-input-port raw-in))
|
|
(lambda (line new-b)
|
|
(write-string "\r\n" raw-out)
|
|
(write-string line cooked-out)
|
|
(newline cooked-out)
|
|
(loop new-b))
|
|
(lambda (new-b feedback)
|
|
(write-string feedback raw-out)
|
|
(loop new-b))))))))))
|
|
(values cooked-in (cook-output raw-out)))
|
|
|
|
(define (cook-output raw-out)
|
|
(define-values (cooked-in cooked-out) (make-pipe))
|
|
(thread
|
|
(lambda ()
|
|
(define buffer (make-bytes 4096))
|
|
(let loop ()
|
|
(define count (read-bytes-avail! buffer cooked-in))
|
|
(if (eof-object? count)
|
|
(begin (close-input-port cooked-in)
|
|
(close-output-port raw-out))
|
|
(let ((raw-data (regexp-replace* #"\n" (subbytes buffer 0 count) #"\r\n")))
|
|
(write-bytes raw-data raw-out)
|
|
(loop))))))
|
|
cooked-out)
|