278 lines
11 KiB
Racket
278 lines
11 KiB
Racket
#lang racket/base
|
|
;; Implicitly provides a factory via display.rkt's `register-tty-backend!`.
|
|
|
|
(provide (struct-out terminal))
|
|
|
|
(require racket/set)
|
|
(require racket/match)
|
|
(require (only-in racket/vector vector-copy))
|
|
(require (prefix-in ansi: ansi))
|
|
(require "display.rkt")
|
|
(require "diff.rkt")
|
|
|
|
(struct terminal (input ;; InputPort
|
|
output ;; OutputPort
|
|
[displayed-screen #:mutable] ;; Screen
|
|
[pending-screen #:mutable] ;; Screen
|
|
[utf-8-input? #:mutable] ;; Boolean
|
|
[displayed-title #:mutable] ;; (Option String)
|
|
[pending-title #:mutable] ;; (Option String)
|
|
)
|
|
#:methods gen:tty
|
|
[(define (tty-shutdown!! t) (terminal-shutdown t))
|
|
(define (tty-pending-screen t) (terminal-pending-screen t))
|
|
(define (set-tty-pending-screen! t s) (set-terminal-pending-screen! t s))
|
|
(define (tty-reset t) (reset t))
|
|
(define (tty-flush t) (terminal-flush t))
|
|
(define (tty-set-title! t title) (set-terminal-pending-title! t title))
|
|
(define (tty-next-key t) (terminal-next-key t))
|
|
(define (tty-next-key-evt t) (terminal-next-key-evt t))
|
|
(define (tty-input-available-evt t) (terminal-input t))])
|
|
|
|
(define *stdin-tty* #f)
|
|
(define (stdin-tty)
|
|
(when (not *stdin-tty*)
|
|
(ansi:tty-raw!)
|
|
(set! *stdin-tty*
|
|
(terminal
|
|
(current-input-port)
|
|
(current-output-port)
|
|
(make-screen 24 80 tty-default-pen)
|
|
(make-screen 24 80 tty-default-pen)
|
|
(match (getenv "RMACS_UTF8_INPUT")
|
|
[(or #f "yes" "true" "1") #t]
|
|
[(or "no" "false" "0") #f]
|
|
[v (error 'RMACS_UTF8_INPUT
|
|
"Environment variable RMACS_UTF8_INPUT value ~v invalid: must be in ~v"
|
|
v
|
|
(list "yes" "true" "1" "no" "false" "0"))])
|
|
#f
|
|
#f))
|
|
(reset *stdin-tty*)
|
|
(plumber-add-flush! (current-plumber)
|
|
(lambda (h)
|
|
(terminal-shutdown *stdin-tty*))))
|
|
*stdin-tty*)
|
|
|
|
(define (terminal-shutdown t)
|
|
(output t
|
|
(ansi:select-graphic-rendition ansi:style-normal)
|
|
(ansi:goto (tty-rows t) 1)
|
|
"\n")
|
|
(flush t)
|
|
(ansi:tty-restore!))
|
|
|
|
(define (collect-position-report tty)
|
|
(let loop ()
|
|
(sync/timeout 0.5
|
|
(handle-evt (terminal-input tty)
|
|
(lambda (p)
|
|
(match (ansi:lex-lcd-input p)
|
|
[(? ansi:position-report? r) r]
|
|
[_ (loop)]))))))
|
|
|
|
(define (reset tty)
|
|
(output tty
|
|
(ansi:clear-screen)
|
|
(ansi:goto 999 999)
|
|
(ansi:position-report-request))
|
|
(flush tty)
|
|
(define report (or (collect-position-report tty)
|
|
(ansi:position-report 24 80))) ;; TODO: have a more flexible fallback
|
|
(define rows (ansi:position-report-row report))
|
|
(define columns (ansi:position-report-column report))
|
|
(set-pen tty tty-default-pen #:force #t)
|
|
(clear tty)
|
|
(flush tty)
|
|
(set-terminal-displayed-screen! tty (make-screen rows columns tty-default-pen))
|
|
(set-terminal-pending-screen! tty (make-screen rows columns tty-default-pen))
|
|
tty)
|
|
|
|
(define (set-pen tty p #:force [force #f])
|
|
(when (or force (not (equal? p (screen-pen (terminal-displayed-screen tty)))))
|
|
(match p
|
|
[(pen fgcolor bgcolor bold? italic?)
|
|
(output tty
|
|
(apply ansi:select-graphic-rendition
|
|
`(,@(if bold? (list ansi:style-bold) (list))
|
|
,@(if italic? (list ansi:style-italic/inverse) (list))
|
|
,(ansi:style-text-color fgcolor)
|
|
,(ansi:style-background-color bgcolor))))]
|
|
['default
|
|
(output tty (ansi:select-graphic-rendition ansi:style-normal))])
|
|
(set-screen-pen! (terminal-displayed-screen tty) p))
|
|
tty)
|
|
|
|
(define (clear tty)
|
|
(output tty (ansi:clear-screen/home))
|
|
(set-screen-cursor-row! (terminal-displayed-screen tty) 0)
|
|
(set-screen-cursor-column! (terminal-displayed-screen tty) 0)
|
|
tty)
|
|
|
|
(define (color-near-cursor s row-delta column-delta)
|
|
(define r (max 0 (min (- (screen-rows s) 1) (+ (screen-cursor-row s) row-delta))))
|
|
(define c (max 0 (min (- (screen-columns s) 1) (+ (screen-cursor-column s) column-delta))))
|
|
(car (vector-ref (vector-ref (screen-contents s) r) c)))
|
|
|
|
(define (vector-delete! v base count fill)
|
|
(vector-copy! v base v (+ base count) (vector-length v))
|
|
(for ((i (in-range (- (vector-length v) count) (vector-length v)))) (vector-set! v i fill)))
|
|
|
|
(define (vector-insert! v base count fill)
|
|
(vector-copy! v (+ base count) v base (- (vector-length v) count))
|
|
(for ((i (in-range base (+ base count)))) (vector-set! v i fill)))
|
|
|
|
(define (delete-lines tty n)
|
|
(define s (terminal-displayed-screen tty))
|
|
(set-pen tty tty-default-pen)
|
|
(output tty (ansi:delete-lines n))
|
|
(define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
|
|
(vector-delete! (screen-contents s) (screen-cursor-row s) n blank-line)
|
|
tty)
|
|
|
|
(define (insert-lines tty n)
|
|
(define s (terminal-displayed-screen tty))
|
|
(set-pen tty tty-default-pen)
|
|
(output tty (ansi:insert-lines n))
|
|
(define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
|
|
(vector-insert! (screen-contents s) (screen-cursor-row s) n blank-line)
|
|
tty)
|
|
|
|
(define (delete-columns tty n)
|
|
(define s (terminal-displayed-screen tty))
|
|
(set-pen tty tty-default-pen)
|
|
(output tty (ansi:delete-characters n))
|
|
(define blank-cell (cons (screen-pen s) 'empty))
|
|
(define line (vector-ref (screen-contents s) (screen-cursor-row s)))
|
|
(vector-delete! line (screen-cursor-column s) n blank-cell)
|
|
tty)
|
|
|
|
(define (insert-columns tty n)
|
|
(define s (terminal-displayed-screen tty))
|
|
(set-pen tty (color-near-cursor s 0 -1))
|
|
(output tty (ansi:insert-characters n))
|
|
(define blank-cell (cons (screen-pen s) 'empty))
|
|
(define line (vector-ref (screen-contents s) (screen-cursor-row s)))
|
|
(vector-insert! line (screen-cursor-column s) n blank-cell)
|
|
tty)
|
|
|
|
(define (output tty . items)
|
|
(for ((i items)) (display i (terminal-output tty))))
|
|
|
|
(define (flush tty)
|
|
(flush-output (terminal-output tty)))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
;; Display to buffered screen
|
|
|
|
(define (goto-if-needed s row column)
|
|
(cond
|
|
[(and (= (screen-cursor-row s) row) (= (screen-cursor-column s) column))
|
|
""]
|
|
[(= (screen-cursor-row s) row)
|
|
(begin0 (ansi:goto-column (+ column 1))
|
|
(set-screen-cursor-column! s column))]
|
|
[else
|
|
(begin0 (ansi:goto (+ row 1) (+ column 1))
|
|
(set-screen-cursor-row! s row)
|
|
(set-screen-cursor-column! s column))]))
|
|
|
|
(define (advance-cursor! tty s)
|
|
(set-screen-cursor-column! s (+ (screen-cursor-column s) 1))
|
|
(when (= (screen-cursor-column s) (screen-columns s))
|
|
(when (< (screen-cursor-row s) (- (screen-rows s) 1))
|
|
(output tty "\r\n"))
|
|
(set-screen-cursor-column! s 0)
|
|
(set-screen-cursor-row! s (+ (screen-cursor-row s) 1))))
|
|
|
|
;; Answers #t when an edit to a line would produce a visible effect.
|
|
(define (interesting-change? old-line new-line column right-margin)
|
|
(for/or [(i (in-range column right-margin))]
|
|
(not (equal? (vector-ref old-line i) (vector-ref new-line i)))))
|
|
|
|
(define (non-empty? ch) (not (equal? ch 'empty)))
|
|
|
|
(define (repair-span! tty old new-line row first-col cell-count)
|
|
(define trailing-empty-count
|
|
(for/fold [(empty-count 0)] [(column (in-range first-col (+ first-col cell-count)))]
|
|
(match-define (cons new-pen new-ch) (vector-ref new-line column))
|
|
(if (non-empty? new-ch)
|
|
(begin (set-pen tty new-pen)
|
|
(output tty (goto-if-needed old row column) new-ch)
|
|
(advance-cursor! tty old)
|
|
0)
|
|
(+ empty-count 1))))
|
|
(when (and (positive? trailing-empty-count) (= (+ first-col cell-count) (tty-columns tty)))
|
|
(output tty (ansi:clear-to-eol))))
|
|
|
|
(define (repair-line! tty old new row)
|
|
(define columns (screen-columns new))
|
|
(define old-line (vector-ref (screen-contents old) row))
|
|
(define new-line (vector-ref (screen-contents new) row))
|
|
(define patches (diff-indices old-line new-line))
|
|
(if (<= (length patches) 3)
|
|
(apply-patch! patches
|
|
(lambda (first-col cols-to-remove)
|
|
(when (interesting-change? old-line new-line first-col columns)
|
|
(output tty (goto-if-needed old row first-col))
|
|
(delete-columns tty cols-to-remove)))
|
|
(lambda (first-col cols-to-insert cell-count)
|
|
(when (interesting-change? old-line new-line first-col columns)
|
|
(output tty (goto-if-needed old row first-col))
|
|
(when (and (positive? cols-to-insert)
|
|
(interesting-change? old-line
|
|
new-line
|
|
(+ first-col cols-to-insert)
|
|
columns))
|
|
(insert-columns tty cols-to-insert))
|
|
(repair-span! tty old new-line row first-col cell-count))))
|
|
(repair-span! tty old new-line row 0 columns)))
|
|
|
|
(define (terminal-flush t)
|
|
(define old (terminal-displayed-screen t))
|
|
(define new (terminal-pending-screen t))
|
|
(apply-patch! (diff-indices (screen-contents old) (screen-contents new))
|
|
(lambda (first-row lines-to-remove)
|
|
(output t (goto-if-needed old first-row (screen-cursor-column old)))
|
|
(delete-lines t lines-to-remove))
|
|
(lambda (first-row lines-to-insert line-count)
|
|
(when (positive? lines-to-insert)
|
|
(output t (goto-if-needed old first-row (screen-cursor-column old)))
|
|
(insert-lines t lines-to-insert))
|
|
(for ((row (in-range first-row (+ first-row line-count))))
|
|
(repair-line! t old new row))))
|
|
(output t (goto-if-needed old (screen-cursor-row new) (screen-cursor-column new)))
|
|
(let ((new-title (terminal-pending-title t)))
|
|
(when (not (equal? new-title (terminal-displayed-title t)))
|
|
(when new-title (output t (ansi:xterm-set-window-title new-title)))
|
|
(set-terminal-displayed-title! t new-title)))
|
|
(flush t)
|
|
(set-terminal-displayed-screen! t (struct-copy screen new [pen (screen-pen old)]))
|
|
(set-terminal-pending-screen! t (copy-screen new))
|
|
t)
|
|
|
|
;;---------------------------------------------------------------------------
|
|
;; Input
|
|
|
|
(define (has-control-modifier? modifiers)
|
|
(set-member? modifiers 'control))
|
|
|
|
(define (terminal-next-key tty)
|
|
(define k (ansi:lex-lcd-input (terminal-input tty) #:utf-8? (terminal-utf-8-input? tty)))
|
|
(match k
|
|
[(ansi:key #\tab modifiers) (ansi:key 'tab modifiers)]
|
|
[(ansi:key #\I (? has-control-modifier? ms)) (ansi:key 'tab (set-remove ms 'control))]
|
|
[(ansi:key #\M (? has-control-modifier? ms)) (ansi:key 'return (set-remove ms 'control))]
|
|
[(ansi:key #\[ (? has-control-modifier? ms)) ;; ESC
|
|
(or (sync/timeout 0.5
|
|
(handle-evt (terminal-next-key-evt tty)
|
|
(lambda (k) (ansi:add-modifier 'meta k))))
|
|
(ansi:key 'escape (set-remove ms 'control)))]
|
|
[_ k]))
|
|
|
|
(define (terminal-next-key-evt tty)
|
|
(handle-evt (terminal-input tty)
|
|
(lambda (_) (terminal-next-key tty))))
|
|
|
|
(register-tty-backend! 'terminal stdin-tty)
|