146 lines
4.1 KiB
Racket
146 lines
4.1 KiB
Racket
#lang racket/base
|
|
(require racket/match
|
|
racket/contract/base
|
|
racket/list
|
|
racket/async-channel
|
|
racket/system
|
|
ansi
|
|
(submod ansi/lcd-terminal event-structs)
|
|
ansi/private/tty-raw-extension
|
|
unix-signals
|
|
lux/chaos
|
|
raart/draw)
|
|
(provide (all-from-out (submod ansi/lcd-terminal event-structs)))
|
|
|
|
(struct term (f in out))
|
|
|
|
(define default-tty "/dev/tty")
|
|
|
|
#;
|
|
(define stty-minus-f-arg-string
|
|
(case (system-type 'os)
|
|
((macosx) "-f")
|
|
(else "-F")))
|
|
#;
|
|
(define (open-term #:tty [tty default-tty])
|
|
(system* "/bin/stty"
|
|
stty-minus-f-arg-string
|
|
tty
|
|
"raw"
|
|
"-echo")
|
|
(define-values (in out)
|
|
(open-input-output-file tty #:exists 'update))
|
|
(term tty in out))
|
|
#;
|
|
(define (close-term t)
|
|
(match-define (term f in out) t)
|
|
(close-input-port in)
|
|
(close-output-port out)
|
|
(system* "/bin/stty"
|
|
stty-minus-f-arg-string
|
|
f
|
|
"cooked"
|
|
"echo"))
|
|
|
|
(define (open-term)
|
|
(tty-raw!)
|
|
(term #f (current-input-port) (current-output-port)))
|
|
(define (close-term t)
|
|
(tty-restore!))
|
|
|
|
(define (with-term f #:tty [tty default-tty])
|
|
(define t (open-term #:tty tty))
|
|
(define (close!) (close-term t))
|
|
(with-handlers ([exn:fail? (λ (x) (close!) (raise x))])
|
|
(begin0 (f t) (close!))))
|
|
|
|
(define (display/flush v op)
|
|
(display v op)
|
|
(flush-output op))
|
|
|
|
(define (display/term t v)
|
|
(define op (term-out t))
|
|
(unless (port-closed? op)
|
|
(display/flush v op)))
|
|
|
|
;; Lux
|
|
(define x11-mouse-on
|
|
(string-append (set-mode x11-focus-event-mode)
|
|
(set-mode x11-any-event-mouse-tracking-mode)
|
|
(set-mode x11-extended-mouse-tracking-mode)))
|
|
(define x11-mouse-off
|
|
(string-append (reset-mode x11-extended-mouse-tracking-mode)
|
|
(reset-mode x11-any-event-mouse-tracking-mode)
|
|
(reset-mode x11-focus-event-mode)))
|
|
(define (make-raart #:mouse? [mouse? #f])
|
|
(define alternate? #t)
|
|
|
|
(define t (open-term))
|
|
(define ch (make-async-channel))
|
|
;; Initialize term
|
|
(when alternate?
|
|
(display/term t (set-mode alternate-screen-mode)))
|
|
(when mouse?
|
|
(display/term t x11-mouse-on)
|
|
(plumber-add-flush! (current-plumber)
|
|
(lambda (handle)
|
|
(display/term t x11-mouse-off))))
|
|
;; Register for window change events
|
|
;; XXX some way to force this to be first
|
|
(display/term t (device-request-screen-size))
|
|
(capture-signal! 'SIGWINCH)
|
|
(define sig-th
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(define s (read-signal))
|
|
(match (lookup-signal-name s)
|
|
['SIGWINCH (display/term t (device-request-screen-size))
|
|
(loop)])))))
|
|
;; Listen for input
|
|
(define input-th
|
|
(thread
|
|
(λ ()
|
|
(let loop ()
|
|
(define v (lex-lcd-input (term-in t) #:utf-8? #t))
|
|
(unless (eof-object? v)
|
|
(async-channel-put ch v)
|
|
(loop))))))
|
|
;; Return
|
|
(*term alternate? mouse? t ch sig-th input-th 24 80))
|
|
|
|
(struct *term
|
|
(alternate? mouse? t ch sig-th input-th [rows #:mutable] [cols #:mutable])
|
|
#:methods gen:chaos
|
|
[(define (chaos-event c)
|
|
(handle-evt (*term-ch c)
|
|
(match-lambda
|
|
[(and e (screen-size-report rows cols))
|
|
(set-*term-rows! c rows)
|
|
(set-*term-cols! c cols)
|
|
e]
|
|
[e e])))
|
|
(define (chaos-output! c o)
|
|
(when o
|
|
(draw (crop 0 (add1 (*term-cols c))
|
|
0 (add1 (*term-rows c))
|
|
o)
|
|
#:output (term-out (*term-t c)))))
|
|
(define (chaos-label! c l)
|
|
(display/term (*term-t c) (xterm-set-window-title l)))
|
|
(define (chaos-stop! c)
|
|
(define t (*term-t c))
|
|
(when (*term-mouse? c)
|
|
(display/term t x11-mouse-off))
|
|
(when (*term-alternate? c)
|
|
(display/term t (reset-mode alternate-screen-mode)))
|
|
(kill-thread (*term-sig-th c))
|
|
(kill-thread (*term-input-th c))
|
|
(release-signal! 'SIGWINCH)
|
|
(close-term t))])
|
|
|
|
(provide
|
|
(contract-out
|
|
[make-raart
|
|
(->* () () chaos?)]))
|