211 lines
6.8 KiB
Racket
211 lines
6.8 KiB
Racket
#lang racket/base
|
|
|
|
(provide gen:tty
|
|
tty?
|
|
tty-shutdown!!
|
|
tty-pending-screen
|
|
set-tty-pending-screen!
|
|
tty-rows
|
|
tty-columns
|
|
tty-last-row
|
|
tty-last-column
|
|
tty-cursor-row
|
|
tty-cursor-column
|
|
tty-display
|
|
tty-newline
|
|
tty-clear
|
|
tty-clear-to-eol
|
|
tty-reset
|
|
tty-goto
|
|
tty-set-pen!
|
|
tty-default-pen
|
|
tty-pen
|
|
tty-flush
|
|
tty-set-title!
|
|
tty-next-key
|
|
tty-next-key-evt
|
|
tty-input-available-evt
|
|
|
|
(struct-out pen)
|
|
|
|
register-tty-backend!
|
|
default-tty
|
|
|
|
(struct-out screen)
|
|
make-screen
|
|
copy-screen
|
|
screen-last-row
|
|
screen-last-column
|
|
screen-goto
|
|
screen-putc
|
|
screen-puts
|
|
screen-clear-to-eol
|
|
|
|
;; From ansi. TODO: better color & keyboard abstractions
|
|
(struct-out key)
|
|
(rename-out [ansi:color-black color-black]
|
|
[ansi:color-red color-red]
|
|
[ansi:color-green color-green]
|
|
[ansi:color-yellow color-yellow]
|
|
[ansi:color-blue color-blue]
|
|
[ansi:color-magenta color-magenta]
|
|
[ansi:color-cyan color-cyan]
|
|
[ansi:color-white color-white]))
|
|
|
|
(require racket/match)
|
|
(require racket/generic)
|
|
(require (only-in racket/vector vector-copy))
|
|
(require (prefix-in ansi: (only-in ansi
|
|
color-black
|
|
color-red
|
|
color-green
|
|
color-yellow
|
|
color-blue
|
|
color-magenta
|
|
color-cyan
|
|
color-white)))
|
|
(require (only-in ansi struct:key key key? key-value key-modifiers))
|
|
|
|
;; A Color is a Nat. TODO: better color abstraction.
|
|
|
|
(define-generics tty
|
|
(tty-shutdown!! tty)
|
|
(tty-pending-screen tty)
|
|
(set-tty-pending-screen! tty s)
|
|
(tty-reset tty)
|
|
(tty-flush tty)
|
|
(tty-set-title! tty title)
|
|
(tty-next-key tty)
|
|
|
|
;; Do not retain the events returned by these functions across
|
|
;; actual input from the tty! See comment in editor-sit-for, and
|
|
;; implementations of these functions in display-gui.rkt. (The
|
|
;; fragility of the pushback in display-gui.rkt is the cause of this
|
|
;; restriction.)
|
|
(tty-next-key-evt tty)
|
|
(tty-input-available-evt tty)
|
|
)
|
|
|
|
(define (tty-rows t) (screen-rows (tty-pending-screen t)))
|
|
(define (tty-columns t) (screen-columns (tty-pending-screen t)))
|
|
|
|
(define (tty-last-row t) (- (tty-rows t) 1))
|
|
(define (tty-last-column t) (- (tty-columns t) 1))
|
|
|
|
(define (tty-cursor-row t) (screen-cursor-row (tty-pending-screen t)))
|
|
(define (tty-cursor-column t) (screen-cursor-column (tty-pending-screen t)))
|
|
|
|
(define (tty-display t . strings)
|
|
(for [(str strings)]
|
|
(screen-puts (tty-pending-screen t) str)))
|
|
|
|
(define (tty-newline t)
|
|
(define s (tty-pending-screen t))
|
|
(screen-clear-to-eol s)
|
|
(screen-putc s #\return)
|
|
(screen-putc s #\newline))
|
|
|
|
(define (tty-clear t)
|
|
(define s (tty-pending-screen t))
|
|
(set-tty-pending-screen! t (make-screen (screen-rows s) (screen-columns s) (screen-pen s)))
|
|
t)
|
|
|
|
(define (tty-clear-to-eol t) (screen-clear-to-eol (tty-pending-screen t)))
|
|
(define (tty-goto t row col) (screen-goto (tty-pending-screen t) row col))
|
|
(define (tty-set-pen! t p) (set-screen-pen! (tty-pending-screen t) p))
|
|
(define (tty-pen t) (screen-pen (tty-pending-screen t)))
|
|
|
|
(define tty-default-pen 'default)
|
|
|
|
(struct pen (foreground-color ;; Color
|
|
background-color ;; Color
|
|
bold? ;; Boolean
|
|
italic? ;; Boolean
|
|
) #:prefab)
|
|
|
|
(struct backend (name ;; Symbol
|
|
priority ;; Integer
|
|
factory ;; (-> TTY)
|
|
)
|
|
#:prefab)
|
|
|
|
(struct screen (rows ;; Nat
|
|
columns ;; Nat
|
|
[cursor-row #:mutable] ;; Nat
|
|
[cursor-column #:mutable] ;; Nat
|
|
[pen #:mutable] ;; Pen
|
|
contents ;; (Vector[rows] (Vector[columns] (Cons Pen Character)))
|
|
) #:prefab)
|
|
|
|
(define (screen-last-row s) (- (screen-rows s) 1))
|
|
(define (screen-last-column s) (- (screen-columns s) 1))
|
|
|
|
(define (make-screen rows columns pen)
|
|
(define contents (for/vector ((row rows)) (make-vector columns (cons pen 'empty))))
|
|
(screen rows columns 0 0 pen contents))
|
|
|
|
(define (copy-screen s)
|
|
(match-define (screen rows columns cursor-row cursor-column pen contents) s)
|
|
(define new-contents (for/vector ((row rows)) (vector-copy (vector-ref contents row))))
|
|
(screen rows columns cursor-row cursor-column pen new-contents))
|
|
|
|
(define (screen-goto s row0 column0)
|
|
(define row (max 0 (min (screen-last-row s) row0)))
|
|
(define column (max 0 (min (screen-last-column s) column0)))
|
|
(set-screen-cursor-row! s row)
|
|
(set-screen-cursor-column! s column)
|
|
s)
|
|
|
|
(define (non-empty? ch) (not (equal? ch 'empty)))
|
|
|
|
(define (screen-putc s ch)
|
|
(match ch
|
|
[#\return
|
|
(screen-goto s (screen-cursor-row s) 0)]
|
|
[#\newline
|
|
(screen-goto s (+ (screen-cursor-row s) 1) (screen-cursor-column s))]
|
|
[#\tab
|
|
(for ((i (- 8 (modulo (screen-cursor-column s) 8)))) (screen-putc s #\space))]
|
|
[(and (? non-empty?) (? char-iso-control?))
|
|
(screen-puts s (format "[~x]" (char->integer ch)))]
|
|
[_
|
|
(when (< (screen-cursor-column s) (screen-columns s))
|
|
(vector-set! (vector-ref (screen-contents s) (screen-cursor-row s))
|
|
(screen-cursor-column s)
|
|
(cons (screen-pen s) ch)))
|
|
(set-screen-cursor-column! s (+ (screen-cursor-column s) 1))]))
|
|
|
|
(define (screen-puts s str)
|
|
(for ((ch str)) (screen-putc s ch)))
|
|
|
|
(define (screen-clear-to-eol s)
|
|
(define start-column (screen-cursor-column s))
|
|
(define pen (screen-pen s))
|
|
(set-screen-pen! s tty-default-pen)
|
|
(for ((i (max 0 (- (screen-columns s) (screen-cursor-column s)))))
|
|
(screen-putc s 'empty))
|
|
(set-screen-pen! s pen)
|
|
(screen-goto s (screen-cursor-row s) start-column)
|
|
s)
|
|
|
|
(define *tty-backends* '())
|
|
|
|
(define (register-tty-backend! name factory #:priority [priority 0])
|
|
(set! *tty-backends* (cons (backend name priority factory)
|
|
(filter (lambda (b) (not (eq? (backend-name b) name)))
|
|
*tty-backends*)))
|
|
(set! *tty-backends* (sort *tty-backends* > #:key backend-priority)))
|
|
|
|
(define *default-tty* #f)
|
|
(define (default-tty)
|
|
(when (not *default-tty*)
|
|
(let loop ((backends *tty-backends*))
|
|
(match backends
|
|
['() (error 'default-tty "No available tty backends")]
|
|
[(cons (backend name _priority factory) rest)
|
|
(define t (factory))
|
|
(if t
|
|
(set! *default-tty* t)
|
|
(loop rest))])))
|
|
*default-tty*)
|