-
-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathlux-chaos.rkt
205 lines (184 loc) · 6.19 KB
/
lux-chaos.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
#lang racket/base
(require racket/match
racket/contract/base
racket/list
racket/set
racket/async-channel
racket/system
net/base64
ansi
unix-signals
lux/chaos
raart/draw
raart/buffer
(submod raart/buffer internal)
struct-define
"kitty.rkt")
(struct term (f in out))
(define-syntax-rule (define-stty-term open-term close-term)
(begin
(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" "pass8" "-echo")
(define-values (in out)
(open-input-output-file tty #:exists 'update))
(file-stream-buffer-mode in 'none)
(file-stream-buffer-mode out 'none)
(term tty in out))
(define (close-term t)
(match-define (term tty in out) t)
(close-input-port in)
(close-output-port out)
(system* "/bin/stty" stty-minus-f-arg-string tty
"sane"))))
(define-syntax-rule (define-stdin-term open-term close-term)
(begin
(require ansi/private/tty-raw-extension)
(define (open-term #:tty [tty #f])
(when tty
(error 'open-term "Custom tty not supported in this version"))
(tty-raw!)
(term #f (current-input-port) (current-output-port)))
(define (close-term t)
(tty-restore!))))
#;(define-stty-term open-term close-term)
(define-stdin-term open-term close-term)
(define (display/term t v)
(define op (term-out t))
(unless (port-closed? op)
(display v op)
(flush-output 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 (convert-key v)
(match v
[(key value mods)
(format "~a~a~a~a~a"
(if (set-member? mods 'super) "s-" "")
(if (set-member? mods 'meta) "M-" "")
(if (set-member? mods 'control) "C-" "")
(if (set-member? mods 'shift) "S-" "")
(if (char? value)
value
(format "<~a>" value)))]
[_ v]))
(define (make-raart #:mouse? [mouse? #f])
(define alternate? #t)
(define ch (make-async-channel))
(*term alternate? mouse? #f #f ch #f #f #f #f))
(define-struct-define term-define *term)
(struct *term
(alternate? mouse? t buf ch sig-th input-th rows cols)
#:mutable
#:methods gen:chaos
[(define (chaos-event c)
(term-define c)
(handle-evt ch
(match-lambda
[(and e (screen-size-report new-rows new-cols))
(set! rows new-rows)
(set! cols new-cols)
(buffer-resize! buf rows cols)
e]
[e e])))
(define (chaos-output! c o)
(when o
(draw (*term-buf c) o)))
(define (chaos-label! c l)
(display/term (*term-t c) (xterm-set-window-title l)))
(define (chaos-start! c)
(term-define c)
(set! t (open-term))
(set! rows 24)
(set! cols 80)
(set! buf (make-cached-buffer rows cols #:output (term-out t)))
;; Save the current title and colors
(when (term-is-kitty?)
(display/term t "\e[?2017h")
(display/term t "\e]30001\e\\"))
(display/term t "\e[22t")
;; 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))))
;; Listen for input
(set! input-th
(thread
(λ ()
(define iport (term-in t))
(define (std-lex1)
(lex-lcd-input iport #:utf-8? #t))
(define (kitty-lex1)
(cond
[(regexp-try-match #rx#"^\e_K([prt])(.)(..?)\e\\\\" iport)
=> (match-lambda
[(list lexeme type mods-b64 key-b64)
(cond
[(bytes=? type #"p")
(key (kitty-key-lookup key-b64)
(kitty-mods-lookup mods-b64))]
[else
(kitty-lex1)])])]
[else
(std-lex1)]))
(define lex1 (if (term-is-kitty?) kitty-lex1 std-lex1))
(let loop ()
(define v (lex1))
(unless (eof-object? v)
(when (or (any-mouse-event? v)
(screen-size-report? v)
(key? v))
(async-channel-put ch (convert-key v)))
(loop))))))
;; Register for window change events
(display/term t (device-request-screen-size))
(set! sig-th
(thread
(λ ()
(let loop ()
(define s (read-signal))
(match (lookup-signal-name s)
['SIGWINCH (display/term t (device-request-screen-size))
(loop)])))))
(capture-signal! 'SIGWINCH)
(void))
(define (chaos-stop! c)
(term-define c)
(release-signal! 'SIGWINCH)
(kill-thread sig-th)
(kill-thread input-th)
(when mouse?
(display/term t x11-mouse-off))
(when alternate?
(display/term t (reset-mode alternate-screen-mode)))
(display/term t "\e[?12l\e[?25h")
;; Restore the old title
(display/term t "\e[23t")
(when (term-is-kitty?)
(display/term t "\e]30101\e\\")
(display/term t "\e[?2017l"))
(close-term t))])
(provide
(struct-out screen-size-report)
(struct-out any-mouse-event)
(struct-out mouse-focus-event)
(struct-out mouse-event)
(contract-out
[make-raart
(->* () (#:mouse? boolean?) chaos?)]))