Add lux support

draw.rkt

@@ -16,7 +16,8 @@
            [underline . ,A:style-underline]))
 (define current-fg (make-parameter 'default))
 (define current-bg (make-parameter 'default))
-(define current-display-drawing-parameters? (make-parameter #t))
+(define current-display-drawing-parameters?
+  (make-parameter (current-output-port)))
 (define symbol->color
   `#hasheq(
            [black   .  0] [red       .  1] [green   .  2] [yellow   . 3]
@@ -32,8 +33,9 @@
     (A:select-graphic-rendition A:style-default-background-color)
     (A:select-xterm-256-background-color (hash-ref symbol->color c))))
 (define (set-drawing-parameters!)
-  (when (current-display-drawing-parameters?)
+  (cond
-    (display (get-drawing-parameters))))
+    [(current-display-drawing-parameters?)
+     => (λ (op) (display (get-drawing-parameters) op))]))
 (define (get-drawing-parameters)
   (string-append
    (A:select-graphic-rendition (hash-ref symbol->style (current-style)))
@@ -45,39 +47,43 @@
 ;; ! : (row col char -> void) row col -> bool
 (struct raart (w h !))
 
-(define (draw x [row 1] [col 1]
+(define (draw x
+              #:output [op (current-output-port)]
               #:clear? [clear? #t])
   (match-define (raart w h !) x)
-  (display (A:dec-soft-terminal-reset))
+  (display (A:dec-soft-terminal-reset) op)
   (when clear?
-    (display (A:clear-screen/home)))
+    (display (A:clear-screen/home) op))
-  (set-drawing-parameters!)
+  (parameterize ([current-display-drawing-parameters? op])
-  (! (λ (r c ch)
+    (set-drawing-parameters!)
-       (display (A:goto r c))
+    (! (λ (r c ch)
-       (display ch)
+         (display (A:goto r c) op)
-       #t)
+         (when ch (display ch op))
-     row col)
+         #t)
-  (display (A:goto (+ row h) (+ col w))))
+       1 1))
+  (flush-output op))
 
-(define (draw-here x)
+(define (draw-here x #:output [op (current-output-port)])
   (match-define (raart w h !) x)
   (define init-dp (get-drawing-parameters))
   (define def (cons init-dp #\space))
   (define rows (build-vector h (λ (i) (make-vector w def))))
-  (! (λ (r c ch)
+  (parameterize ([current-display-drawing-parameters? #f])
-       (vector-set! (vector-ref rows r) c
+    (! (λ (r c ch)
-                    (cons (get-drawing-parameters) ch))
+         (vector-set! (vector-ref rows r) c
-       #t)
+                      (cons (get-drawing-parameters) ch))
-     0 0)
+         #t)
+       0 0))
   (for/fold ([last-dp init-dp]) ([r (in-vector rows)])
     (begin0
         (for/fold ([last-dp last-dp]) ([dp*ch (in-vector r)])
           (match-define (cons this-dp ch) dp*ch)
           (unless (string=? this-dp last-dp)
-            (display this-dp))
+            (display this-dp op))
-          (display ch)
+          (display ch op)
           this-dp)
-      (newline)))
+      (newline op)))
+  (flush-output op)
   (void))
 
 (define-syntax (with-maybe-parameterize stx)
@@ -334,6 +340,12 @@
                (when ? (f))
                ?)))
 
+(define (place-cursor-after x cr cc)
+  (match-define (raart w h !) x)
+  (raart w h (λ (d r c)
+               (strict-or (! d r c)
+                          (d cr cc #f)))))
+
 (define style/c (apply or/c (hash-keys symbol->style)))
 (define color/c (apply or/c (hash-keys symbol->color)))
 (define valign/c (or/c 'top 'center 'bottom))
@@ -341,13 +353,14 @@
 (provide
  (contract-out
   [raart? (-> any/c boolean?)]
-  [draw-here (-> raart? void?)]
   [draw
    (->* (raart?)
-        (exact-positive-integer?
+        (#:output output-port?
-         exact-positive-integer?
          #:clear? boolean?)
         void?)]
+  [draw-here
+   (->* (raart?) (#:output output-port?)
+        void?)]
   [style/c contract?]
   [style (-> style/c raart? raart?)]
   [color/c contract?]
@@ -404,5 +417,8 @@
               raart?)]
   [text-rows (-> (listof (listof any/c))
                  (listof (listof raart?)))]
-  [if-drawn (-> (-> any) raart? raart?)])
+  [if-drawn (-> (-> any) raart? raart?)]
+  [place-cursor-after
+   (-> raart? exact-positive-integer? exact-positive-integer?
+       raart?)])
  place-at*)

lux-chaos.rkt

@@ -0,0 +1,143 @@
+#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 #:alternate? [alternate? #f]
+                    #:mouse? [mouse? #f])
+  (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
+  (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 80 24))
+
+(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 (*term-cols c)
+                   0 (*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
+   (->* () (#:alternate? boolean?) chaos?)]))

main.rkt

@@ -1,2 +1,3 @@
 #lang reprovide
 "draw.rkt"
+"lux-chaos.rkt"

size.rkt

@@ -1,92 +1,9 @@
 #lang racket/base
-(require racket/match
-         racket/list
-         racket/system
-         ansi)
 
-(define stty-minus-f-arg-string
+;; xxx Do the rune thing as well (and think about mouse events)
-  (case (system-type 'os)
-    ((macosx) "-f")
-    (else     "-F")))
 
-(define (read-until ip char)
+;; xxx cool to support images (iterm2, urxvt, kitty, etc, but seem to
-  (define byte (char->integer char))
+;; all be broken in tmux)
-  (apply bytes
-         (let loop ()
-           (match (read-byte ip)
-             [(== byte) empty]
-             [next (cons next (loop))]))))
-
-(define (bytes->number bs)
-  (string->number (bytes->string/utf-8 bs)))
-
-(define default-tty "/dev/tty")
-(struct term (f in out))
-(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 (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 (with-term* t f)
-  (if t (f t) (with-term f)))
-
-(define (screen-size [t #f])
-  (with-term* t
-    (λ (t)
-      (match-define (term _ in out) t)
-      (write-bytes #"\e[18t" out) (flush-output out)
-      (match (read-until in #\;)
-        [#"\e[8"
-         (define row-s (read-until in #\;))
-         (define col-s (read-until in #\t))
-         (values (bytes->number row-s)
-                 (bytes->number col-s))]
-        [x (error 'screen-size "Something weird happened, got ~e" x)]))))
-
-(define (cursor-position [t #f])
-  (with-term* t
-    (λ (t)
-      (match-define (term _ in out) t)
-      (display (position-report-request) out) (flush-output out)
-      (match (read-bytes 2 in)
-        [#"\e["
-         (define row-s (read-until in #\;))
-         (define col-s (read-until in #\R))
-         (values (bytes->number row-s)
-                 (bytes->number col-s))]
-        [x (error 'cursor-position "Something weird happened, got ~e" x)]))))
-
-;; xxx xterm-set-window-title
-#;(begin
-    (display (A:set-mode A:alternate-screen-mode))
-    (display (A:reset-mode A:alternate-screen-mode)))
-
-;; xxx Do I make a 'lux chaos' for this?
-;;
-;;     Or do I do the rune thing and make a separation between the
-;;     commands and the keys? Also, how should the mouse events fit
-;;     into that?
 
 ;; xxx render xexpr-like thing
 ;; xxx text... (fit text inside a width)
@@ -95,8 +12,5 @@
 ;; xxx make a "Web" browser
 ;; xxx use if-drawn to figure out what links are on screen
 
-(module+ main
+;; xxx interactable thing --- figure out pos&dimensions on screen for
-  (with-term
+;; supporting mouse
-    (λ (t)
-      (screen-size t)
-      (cursor-position t))))