283 lines
9.5 KiB
Racket
283 lines
9.5 KiB
Racket
#lang racket/base
|
|
(require racket/generic
|
|
racket/match
|
|
racket/contract/base
|
|
(prefix-in A: ansi)
|
|
struct-define)
|
|
|
|
(define-generics buffer
|
|
(buffer-resize! buffer rows cols)
|
|
(buffer-start! buffer rows cols)
|
|
(buffer-commit! buffer #:cursor? [cursor?]))
|
|
|
|
(define symbol->style
|
|
`#hasheq([normal . ,A:style-normal]
|
|
[bold . ,A:style-bold]
|
|
[inverse . ,A:style-inverse]
|
|
[underline . ,A:style-underline]))
|
|
(define style/c (apply or/c (hash-keys symbol->style)))
|
|
|
|
(define symbol->color
|
|
`#hasheq(
|
|
[black . 0] [red . 1] [green . 2] [yellow . 3]
|
|
[blue . 4] [magenta . 5] [cyan . 6] [white . 7]
|
|
[brblack . 8] [brred . 9] [brgreen . 10] [bryellow . 11]
|
|
[brblue . 12] [brmagenta . 13] [brcyan . 14] [brwhite . 15]))
|
|
(define color/c (apply or/c #f (hash-keys symbol->color)))
|
|
|
|
(define (select-style* s)
|
|
(A:select-graphic-rendition (hash-ref symbol->style s)))
|
|
(define (select-text-color* c)
|
|
(if c
|
|
(A:select-xterm-256-text-color (hash-ref symbol->color c))
|
|
(A:select-graphic-rendition A:style-default-text-color)))
|
|
(define (select-background-color* c)
|
|
(if c
|
|
(A:select-xterm-256-background-color (hash-ref symbol->color c))
|
|
(A:select-graphic-rendition A:style-default-background-color)))
|
|
|
|
(define (make-terminal-buffer term-rows term-cols
|
|
#:clear? [clear? #t]
|
|
#:output [op (current-output-port)])
|
|
(terminal-buffer clear? op term-rows term-cols))
|
|
(define-struct-define terminal-buffer-define terminal-buffer)
|
|
(struct terminal-buffer (clear? op [term-rows #:mutable] [term-cols #:mutable])
|
|
#:methods gen:buffer
|
|
[(define (buffer-resize! buf new-rows new-cols)
|
|
(terminal-buffer-define buf)
|
|
(set! term-rows new-rows)
|
|
(set! term-cols new-cols))
|
|
(define (buffer-start! buf draw-rows draw-cols)
|
|
(terminal-buffer-define buf)
|
|
(define-syntax-rule
|
|
(maybe-update last-X X select-X)
|
|
(unless (eq? last-X X)
|
|
(display (select-X X) op)
|
|
(set! last-X X)))
|
|
|
|
(display (A:dec-soft-terminal-reset) op)
|
|
(when (terminal-buffer-clear? buf)
|
|
(display (A:clear-screen/home) op))
|
|
(display (A:hide-cursor) op)
|
|
(define last-s 'normal)
|
|
(define last-f #f)
|
|
(define last-b #f)
|
|
(define cur-r 1)
|
|
(define cur-c 1)
|
|
(values
|
|
term-rows term-cols
|
|
(λ (s f b r c ch)
|
|
(cond
|
|
[(or (< r 0)
|
|
(<= term-rows r)
|
|
(< c 0)
|
|
(<= term-cols c))
|
|
#f]
|
|
[else
|
|
(maybe-update last-s s select-style*)
|
|
(maybe-update last-f f select-text-color*)
|
|
(maybe-update last-b b select-background-color*)
|
|
|
|
(define tr (add1 r))
|
|
(define tc (add1 c))
|
|
(unless (and (= cur-r tr)
|
|
(= cur-c tc))
|
|
(display (A:goto tr tc) op)
|
|
(set! cur-r tr)
|
|
(set! cur-c tc))
|
|
|
|
(when ch
|
|
(display ch op)
|
|
(set! cur-c (add1 cur-c)))
|
|
|
|
#t]))))
|
|
(define (buffer-commit! buf #:cursor? [cursor? #t])
|
|
(terminal-buffer-define buf)
|
|
(when cursor? (display (A:show-cursor) op))
|
|
(flush-output op))])
|
|
|
|
(struct output-cell (s f b ch) #:mutable #:transparent)
|
|
(define (clear-cell! c)
|
|
(set-output-cell-s! c 'normal)
|
|
(set-output-cell-f! c #f)
|
|
(set-output-cell-b! c #f)
|
|
(set-output-cell-ch! c #f))
|
|
(define (default-cell) (output-cell 'normal #f #f #f))
|
|
|
|
(struct cells (rows cols vec) #:mutable)
|
|
(define (maybe-make-cells old new-rows new-cols)
|
|
(match-define (cells old-rows old-cols vec) old)
|
|
;; XXX support shrinking/growing while preserving information
|
|
(if (and (= old-rows new-rows)
|
|
(= old-cols new-cols))
|
|
old
|
|
(make-cells new-rows new-cols)))
|
|
(define (make-cells rows cols)
|
|
(cells rows cols
|
|
(build-vector
|
|
rows
|
|
(λ (r)
|
|
(build-vector cols (λ (c) (default-cell)))))))
|
|
(define (clear-cells! cs)
|
|
(match-define (cells _ _ vec) cs)
|
|
(for* ([row (in-vector vec)]
|
|
[cell (in-vector row)])
|
|
(clear-cell! cell)))
|
|
(define (draw-cell! cs)
|
|
(match-define (cells ok-rows ok-cols vec) cs)
|
|
(λ (s f b r c ch)
|
|
(cond
|
|
[(or (< r 0)
|
|
(<= ok-rows r)
|
|
(< c 0)
|
|
(<= ok-cols c))
|
|
#f]
|
|
[else
|
|
(define oc (vector-ref (vector-ref vec r) c))
|
|
(set-output-cell-s! oc s)
|
|
(set-output-cell-f! oc f)
|
|
(set-output-cell-b! oc b)
|
|
(when ch
|
|
(set-output-cell-ch! oc ch))
|
|
#t])))
|
|
|
|
(define (make-output-buffer #:output [op (current-output-port)])
|
|
(output-buffer op (make-cells 0 0)))
|
|
(define-struct-define output-buffer-define output-buffer)
|
|
(struct output-buffer (op [cells #:mutable])
|
|
#:methods gen:buffer
|
|
[(define (buffer-resize! buf new-rows new-cols)
|
|
(output-buffer-define buf)
|
|
(set! cells (maybe-make-cells cells new-rows new-cols)))
|
|
(define (buffer-start! buf draw-rows draw-cols)
|
|
(output-buffer-define buf)
|
|
(buffer-resize! buf draw-rows draw-cols)
|
|
(clear-cells! cells)
|
|
(values draw-rows draw-cols (draw-cell! cells)))
|
|
(define (buffer-commit! buf #:cursor? [cursor? #t])
|
|
(output-buffer-define buf)
|
|
(for/fold ([last-s 'normal] [last-f #f] [last-b #f])
|
|
([row (in-vector (cells-vec cells))])
|
|
(begin0
|
|
(for/fold ([last-s last-s] [last-f last-f] [last-b last-b])
|
|
([oc (in-vector row)])
|
|
(match-define (output-cell s f b ch) oc)
|
|
(unless (eq? last-s s)
|
|
(display (select-style* s) op))
|
|
(unless (eq? last-f f)
|
|
(display (select-text-color* f) op))
|
|
(unless (eq? last-b b)
|
|
(display (select-background-color* b) op))
|
|
(display (or ch #\space) op)
|
|
(values s f b))
|
|
(newline op)))
|
|
(flush-output op)
|
|
(void))])
|
|
|
|
(define (make-cached-buffer term-rows term-cols
|
|
#:output [op (current-output-port)])
|
|
(define (mk-term clear?)
|
|
(make-terminal-buffer term-rows term-cols
|
|
#:clear? clear?
|
|
#:output op))
|
|
(cached-buffer
|
|
#t
|
|
(mk-term #f) (mk-term #t)
|
|
term-rows term-cols
|
|
(make-cells term-rows term-cols)
|
|
(make-cells term-rows term-cols)
|
|
0 0))
|
|
(define-struct-define cached-buffer-define cached-buffer)
|
|
(struct cached-buffer
|
|
([clear-next? #:mutable]
|
|
term-nclear term-yclear
|
|
[term-rows #:mutable] [term-cols #:mutable]
|
|
[cur-cells #:mutable] [new-cells #:mutable]
|
|
[last-row #:mutable] [last-col #:mutable])
|
|
#:methods gen:buffer
|
|
[(define/generic super-buffer-resize! buffer-resize!)
|
|
(define/generic super-buffer-start! buffer-start!)
|
|
(define/generic super-buffer-commit! buffer-commit!)
|
|
|
|
(define (buffer-resize! buf new-rows new-cols)
|
|
(cached-buffer-define buf)
|
|
(set! clear-next? #t)
|
|
(set! cur-cells (maybe-make-cells cur-cells new-rows new-cols))
|
|
(set! new-cells (maybe-make-cells new-cells new-rows new-cols))
|
|
(super-buffer-resize! term-nclear new-rows new-cols)
|
|
(super-buffer-resize! term-yclear new-rows new-cols)
|
|
(set! term-rows new-rows)
|
|
(set! term-cols new-cols)
|
|
(clear-cells! cur-cells))
|
|
(define (buffer-start! buf draw-rows draw-cols)
|
|
(cached-buffer-define buf)
|
|
(clear-cells! new-cells)
|
|
(define dc (draw-cell! new-cells))
|
|
(values term-rows term-cols
|
|
(λ (s f b r c ch)
|
|
(set! last-row r)
|
|
(set! last-col c)
|
|
(dc s f b r c ch))))
|
|
(define (buffer-commit! buf #:cursor? [cursor? #t])
|
|
(cached-buffer-define buf)
|
|
(define inner-buf (if clear-next? term-yclear term-nclear))
|
|
(set! clear-next? #f)
|
|
(define-values (ok-rows ok-cols draw!)
|
|
(super-buffer-start! inner-buf term-rows term-cols))
|
|
(for ([cur-row (in-vector (cells-vec cur-cells))]
|
|
[new-row (in-vector (cells-vec new-cells))]
|
|
[r (in-naturals)])
|
|
(for ([cur-cell (in-vector cur-row)]
|
|
[new-cell (in-vector new-row)]
|
|
[c (in-naturals)])
|
|
(unless (equal? cur-cell new-cell)
|
|
(match-define (output-cell _ _ _ cur-ch) cur-cell)
|
|
(match-define (output-cell s f b new-ch) new-cell)
|
|
(draw! s f b r c (or new-ch #\space)))))
|
|
(draw! 'normal #f #f last-row last-col #f)
|
|
(super-buffer-commit! inner-buf #:cursor? cursor?)
|
|
(swap! new-cells cur-cells))])
|
|
|
|
(define-syntax-rule (swap! x y)
|
|
(let ([tmp x])
|
|
(set! x y)
|
|
(set! y tmp)))
|
|
|
|
(module+ internal
|
|
(provide
|
|
(contract-out
|
|
[buffer-resize!
|
|
(-> buffer?
|
|
exact-nonnegative-integer? exact-nonnegative-integer?
|
|
void?)]
|
|
[buffer-start!
|
|
(-> buffer?
|
|
exact-nonnegative-integer? exact-nonnegative-integer?
|
|
(values exact-nonnegative-integer?
|
|
exact-nonnegative-integer?
|
|
(-> style/c color/c color/c
|
|
exact-nonnegative-integer?
|
|
exact-nonnegative-integer?
|
|
(or/c char? #f)
|
|
boolean?)))]
|
|
[buffer-commit!
|
|
(->* (buffer?) (#:cursor? boolean?) void?)])))
|
|
|
|
(provide
|
|
(contract-out
|
|
[color/c contract?]
|
|
[style/c contract?]
|
|
[buffer? (-> any/c boolean?)]
|
|
[make-terminal-buffer
|
|
(->* (exact-nonnegative-integer? exact-nonnegative-integer?)
|
|
(#:clear? boolean? #:output output-port?)
|
|
buffer?)]
|
|
[make-output-buffer
|
|
(->* () (#:output output-port?) buffer?)]
|
|
[make-cached-buffer
|
|
(->* (exact-nonnegative-integer? exact-nonnegative-integer?)
|
|
(#:output output-port?)
|
|
buffer?)]))
|
|
|
|
|