Run coreutils top inside vterm with virtual PTY
ober
a4bb160da83593105566f29aced928f918b1c660
--- a/lib/jerboa-emacs/qt/commands-config.sls +++ b/lib/jerboa-emacs/qt/commands-config.sls @@ -947,10 +947,16 @@ (verbose-log! "cmd-terminal-send: mode=" (symbol->string mode) " pty-pid=" (let ([p (terminal-state-pty-pid ts)]) - (if p (number->string p) "none")) + (cond + [(integer? p) (number->string p)] + [(symbol? p) (symbol->string p)] + [else "none"])) " pty-master=" (let ([m (terminal-state-pty-master ts)]) - (if m (number->string m) "none"))) + (cond + [(integer? m) (number->string m)] + [(box? m) "virtual"] + [else "none"]))) (case mode [(sync) (when (and (string? output) @@ -1005,7 +1011,12 @@ (echo-message! (app-state-echo app) "Terminal exited"))] - [(eq? output 'top) (cmd-top app)])]))))))) + [(eq? output 'top) + (vterm-start-top! + ts + ed + (app-state-frame app) + new-cwd)])]))))))) (def (cmd-term-interrupt app) "Send SIGINT to running PTY process, or cancel current input." (let* ([buf (current-qt-buffer app)] --- a/lib/jerboa-emacs/qt/commands-shell.sls +++ b/lib/jerboa-emacs/qt/commands-shell.sls @@ -69,14 +69,16 @@ cmd-define-abbrev cmd-delete-horizontal-space cmd-consult-line cmd-consult-grep cmd-consult-buffer cmd-consult-outline *top-buffer-name* *top-active* - top-capture-output top-refresh! cmd-top cmd-top-quit) + top-capture-output top-refresh! cmd-top cmd-top-quit + vterm-start-top! top-input-quit?) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name sort sort!) (std sugar) (chez-scintilla constants) (std sort) - (std srfi srfi-13) (std text base64) + (std srfi srfi-13) (std text base64) (std misc channel) (jerboa-emacs qt sci-shim) (jerboa-emacs core) + (only (jerboa-emacs vtscreen) new-vtscreen) (only (jerboa-emacs async) schedule-periodic! @@ -2206,6 +2208,67 @@ (def (cmd-top-quit app) "Stop the top refresh timer." (cancel-periodic! 'top-refresh) (set! *top-active* #f) (echo-message! (app-state-echo app) "top stopped")) + (def (vterm-start-top! ts ed _fr cmd-string) + "Run coreutils top inside the current vterm buffer using a virtual PTY.\n Uses alt-screen + row-diff rendering for performant, flicker-free display.\n Input (q/C-c to quit) flows through terminal-send-input! via the input box." + (let* ([esc (string (integer->char 27))] + [alt-screen-on (string-append esc "[?1049h")] + [alt-screen-off (string-append esc "[?1049l")] + [clear-home (string-append esc "[2J" esc "[H")] + [ch (make-channel)] + [input-box (box "")] + [vt (new-vtscreen 24 80)]) + (terminal-state-pty-master-set! ts input-box) + (terminal-state-pty-pid-set! ts 'top) + (terminal-state-pty-channel-set! ts ch) + (terminal-state-vtscreen-set! ts vt) + (let ([thread (spawn + (lambda () + (with-catch + (lambda (e) (channel-put ch (cons 'done -1))) + (lambda () + (channel-put ch (cons 'data alt-screen-on)) + (let loop () + (channel-put ch (cons 'data clear-home)) + (let ([output (top-capture-output)]) + (channel-put ch (cons 'data output))) + (let ([pending (unbox input-box)]) + (set-box! input-box "") + (if (top-input-quit? pending) + (begin + (channel-put + ch + (cons 'data alt-screen-off)) + (channel-put ch (cons 'done 0))) + (let delay ([remaining 30]) + (if (<= remaining 0) + (loop) + (begin + (thread-sleep! 0.1) + (let ([p (unbox input-box)]) + (if (top-input-quit? p) + (begin + (set-box! + input-box + "") + (channel-put + ch + (cons + 'data + alt-screen-off)) + (channel-put + ch + (cons 'done 0))) + (delay (- remaining + 1))))))))))))))]) + (terminal-state-pty-thread-set! ts thread)))) + (def (top-input-quit? str) + "Check if input string contains q or C-c (quit signal for top)." + (let ([len (string-length str)]) + (let scan ([i 0]) + (and (< i len) + (or (char=? (string-ref str i) #\q) + (char=? (string-ref str i) (integer->char 3)) + (scan (+ i 1))))))) (define-syntax *auto-indent* (identifier-syntax [id (vector-ref *auto-indent*--cell 0)] @@ -2358,46 +2421,4 @@ (define-syntax *top-active* (identifier-syntax [id (vector-ref *top-active*--cell 0)] - [(set! id val) (vector-set! *top-active*--cell 0 val)])) - (builtin-register! - "top" - (lambda (args env) - (call/cc - (lambda (k) - (parameterize ([exit-handler (lambda (code) (k code))]) - (if (member "-b" args) - (begin (apply cu-top-main args) 0) - (let ([in (current-input-port)]) - (let loop () - (with-catch - (lambda (e) (void)) - (lambda () - (call/cc - (lambda (k2) - (parameterize ([exit-handler - (lambda (code) (k2 (void)))]) - (apply - cu-top-main - (append (list "-b" "-n" "1") args))))))) - (let check () - (if (and (input-port? in) (char-ready? in)) - (let ([ch (read-char in)]) - (cond - [(eof-object? ch) (k 0)] - [(char=? ch #\q) (k 0)] - [(char=? ch (integer->char 3)) (k 0)] - [else (check)])) - (void))) - (let delay-loop ([remaining 30]) - (when (> remaining 0) - (thread-sleep! 0.1) - (if (and (input-port? in) (char-ready? in)) - (let ([ch (read-char in)]) - (cond - [(eof-object? ch) (k 0)] - [(char=? ch #\q) (k 0)] - [(char=? ch (integer->char 3)) (k 0)] - [else (delay-loop (- remaining 1))])) - (delay-loop (- remaining 1))))) - (loop))))))) - 0))) + [(set! id val) (vector-set! *top-active*--cell 0 val)]))) --- a/src/jerboa-emacs/core.ss +++ b/src/jerboa-emacs/core.ss @@ -2168,9 +2168,10 @@ ;; Time window in milliseconds for second key of chord. ;; Emacs key-chord.el uses 100ms for two-key and 200ms for same-key chords. -;; We use 300ms by default because Qt key event delivery adds latency. -(def *chord-timeout* 150) -(defvar! 'chord-timeout 150 "Milliseconds to wait for second key of a chord" +;; We use 500ms by default because Shift+key chords require pressing a modifier +;; key first, which adds significant latency vs simultaneous unmodified keys. +(def *chord-timeout* 500) +(defvar! 'chord-timeout 500 "Milliseconds to wait for second key of a chord" setter: (lambda (v) (set! *chord-timeout* v)) type: 'integer type-args: '(50 . 1000) group: 'keybindings) --- a/src/jerboa-emacs/qt/commands-config.ss +++ b/src/jerboa-emacs/qt/commands-config.ss @@ -779,9 +779,13 @@ modified so the next save uses the new encoding." (let-values (((mode output new-cwd) (terminal-execute-async! input ts rows cols))) (verbose-log! "cmd-terminal-send: mode=" (symbol->string mode) " pty-pid=" (let ((p (terminal-state-pty-pid ts))) - (if p (number->string p) "none")) + (cond ((integer? p) (number->string p)) + ((symbol? p) (symbol->string p)) + (else "none"))) " pty-master=" (let ((m (terminal-state-pty-master ts))) - (if m (number->string m) "none"))) + (cond ((integer? m) (number->string m)) + ((box? m) "virtual") + (else "none")))) (case mode ((sync) (when (and (string? output) (> (string-length output) 0)) @@ -824,8 +828,9 @@ modified so the next save uses the new encoding." (qt-buffer-kill! buf) (echo-message! (app-state-echo app) "Terminal exited"))) ((eq? output 'top) - ;; Redirect to in-process top buffer (flicker-free) - (cmd-top app))))))))))) + ;; Run coreutils top inside this vterm using virtual PTY + (vterm-start-top! ts ed (app-state-frame app) new-cwd)) + ))))))))) (def (cmd-term-interrupt app) "Send SIGINT to running PTY process, or cancel current input." --- a/src/jerboa-emacs/qt/commands-shell.ss +++ b/src/jerboa-emacs/qt/commands-shell.ss @@ -9,8 +9,10 @@ :std/sort :std/srfi/13 :std/text/base64 + :std/misc/channel :jerboa-emacs/qt/sci-shim :jerboa-emacs/core + (only-in :jerboa-emacs/vtscreen new-vtscreen) (only-in :jerboa-emacs/async schedule-periodic! cancel-periodic!) (only-in :jsh/registry builtin-lookup builtin-register!) (rename-in :jerboa-coreutils/top (main cu-top-main)) @@ -1845,8 +1847,9 @@ SPC = page down, DEL = page up, q = quit view-mode." (qt-plain-text-edit-ensure-cursor-visible! ed)))))))))) ;;;============================================================================ -;;; In-process top: uses coreutils top in batch mode, renders into a buffer. -;;; Bypasses PTY/vtscreen pipeline for flicker-free display. +;;; In-process top: runs coreutils top in batch mode inside the vterm. +;;; Uses virtual PTY (box for input, channel for output) with vtscreen +;;; alt-screen rendering for performant, flicker-free display. ;;;============================================================================ (def *top-buffer-name* "*top*") @@ -1911,53 +1914,66 @@ SPC = page down, DEL = page up, q = quit view-mode." (set! *top-active* #f) (echo-message! (app-state-echo app) "top stopped")) -;; Register `top` as a jsh builtin for vterm. -;; The coreutils top opens /dev/tty for interactive input, which doesn't -;; work inside vterm (different fd from the PTY). This builtin runs top -;; in batch mode with a loop, using current-input-port (the PTY) for -;; quit detection (q or C-c). -(builtin-register! "top" - (lambda (args env) - (call/cc - (lambda (k) - (parameterize ((exit-handler (lambda (code) (k code)))) - (if (member "-b" args) - ;; User explicitly asked for batch mode — pass through - (begin (apply cu-top-main args) 0) - ;; Interactive-style: batch mode + loop + PTY input for quit - (let ((in (current-input-port))) - (let loop () - ;; Run one batch iteration - (with-catch - (lambda (e) (void)) - (lambda () - (call/cc - (lambda (k2) - (parameterize ((exit-handler (lambda (code) (k2 (void))))) - (apply cu-top-main - (append (list "-b" "-n" "1") args))))))) - ;; Check for quit: q or C-c (char 3) - (let check () - (if (and (input-port? in) (char-ready? in)) - (let ((ch (read-char in))) - (cond - ((eof-object? ch) (k 0)) - ((char=? ch #\q) (k 0)) - ((char=? ch (integer->char 3)) (k 0)) ;; C-c - (else (check)))) ;; drain other chars - (void))) - ;; Sleep 3 seconds, polling for quit every 100ms - (let delay-loop ((remaining 30)) - (when (> remaining 0) - (thread-sleep! 0.1) - (if (and (input-port? in) (char-ready? in)) - (let ((ch (read-char in))) - (cond - ((eof-object? ch) (k 0)) - ((char=? ch #\q) (k 0)) - ((char=? ch (integer->char 3)) (k 0)) - (else (delay-loop (- remaining 1))))) - (delay-loop (- remaining 1))))) - (loop))))))) - 0)) +(def (vterm-start-top! ts ed _fr cmd-string) + "Run coreutils top inside the current vterm buffer using a virtual PTY. + Uses alt-screen + row-diff rendering for performant, flicker-free display. + Input (q/C-c to quit) flows through terminal-send-input! via the input box." + (let* ((esc (string (integer->char 27))) + (alt-screen-on (string-append esc "[?1049h")) + (alt-screen-off (string-append esc "[?1049l")) + (clear-home (string-append esc "[2J" esc "[H")) + (ch (make-channel)) + (input-box (box "")) + (vt (new-vtscreen 24 80))) + ;; Set up virtual PTY state — input-box as master, 'top as pid + (set! (terminal-state-pty-master ts) input-box) + (set! (terminal-state-pty-pid ts) 'top) + (set! (terminal-state-pty-channel ts) ch) + (set! (terminal-state-vtscreen ts) vt) + ;; Spawn background thread that loops coreutils top + (let ((thread + (spawn + (lambda () + (with-catch + (lambda (e) (channel-put ch (cons 'done -1))) + (lambda () + ;; Switch to alt screen + (channel-put ch (cons 'data alt-screen-on)) + (let loop () + ;; Clear screen + cursor home + (channel-put ch (cons 'data clear-home)) + ;; Capture top -b -n 1 output + (let ((output (top-capture-output))) + (channel-put ch (cons 'data output))) + ;; Check input box for quit chars (q or C-c) + (let ((pending (unbox input-box))) + (set-box! input-box "") + (if (top-input-quit? pending) + ;; Quit: restore normal screen, signal done + (begin + (channel-put ch (cons 'data alt-screen-off)) + (channel-put ch (cons 'done 0))) + ;; Sleep ~3 seconds, polling input every 100ms + (let delay ((remaining 30)) + (if (<= remaining 0) + (loop) + (begin + (thread-sleep! 0.1) + (let ((p (unbox input-box))) + (if (top-input-quit? p) + (begin + (set-box! input-box "") + (channel-put ch (cons 'data alt-screen-off)) + (channel-put ch (cons 'done 0))) + (delay (- remaining 1)))))))))))))))) + (set! (terminal-state-pty-thread ts) thread)))) + +(def (top-input-quit? str) + "Check if input string contains q or C-c (quit signal for top)." + (let ((len (string-length str))) + (let scan ((i 0)) + (and (< i len) + (or (char=? (string-ref str i) #\q) + (char=? (string-ref str i) (integer->char 3)) + (scan (+ i 1))))))) --- a/src/jerboa-emacs/terminal.ss +++ b/src/jerboa-emacs/terminal.ss @@ -678,10 +678,10 @@ ;; export updates env vars in-process (PTY child won't propagate back) ((string-prefix? "export " trimmed) (terminal-handle-export! trimmed ts)) - ;; top: redirect to in-process buffer rendering (no PTY flicker) + ;; top: run coreutils top inside vterm (not a separate buffer) ((or (string=? trimmed "top") (string-prefix? "top " trimmed)) - (values 'special 'top #f)) + (values 'special 'top trimmed)) (else ;; ALL commands go through PTY async to avoid blocking the UI thread. ;; gsh-capture runs synchronously and can deadlock the Chez SMP GC @@ -735,22 +735,31 @@ (and (terminal-state-pty-pid ts) #t)) (def (terminal-interrupt! ts) - "Send SIGINT to the PTY child process group." - (let ((pid (terminal-state-pty-pid ts))) - (when pid - (pty-kill! pid 2)))) ;; SIGINT = 2 + "Send SIGINT to the PTY child process group. + For virtual PTY (coreutils top), sends C-c via input box instead." + (let ((pid (terminal-state-pty-pid ts)) + (master (terminal-state-pty-master ts))) + (cond + ((and pid (integer? pid)) (pty-kill! pid 2)) + ((box? master) + ;; Virtual PTY: inject C-c into input box + (set-box! master (string-append (unbox master) (string (integer->char 3)))))))) (def (terminal-resize! ts rows cols) "Notify PTY child of window size change." (let ((master (terminal-state-pty-master ts))) - (when master + (when (and master (integer? master)) (pty-resize! master rows cols)))) (def (terminal-send-input! ts str) - "Send keystrokes to PTY child's stdin." + "Send keystrokes to PTY child's stdin. + Supports real PTY (integer fd) or virtual PTY (box for input queueing)." (let ((master (terminal-state-pty-master ts))) - (when master - (pty-write master str)))) + (cond + ((integer? master) (pty-write master str)) + ((box? master) + ;; Virtual PTY (e.g. coreutils top): queue input in box + (set-box! master (string-append (unbox master) str)))))) (def (terminal-cleanup-pty! ts) "Clean up PTY resources: kill child, close fd, terminate reader thread." @@ -760,7 +769,7 @@ (ch (terminal-state-pty-channel ts))) (when thread (with-catch (lambda (_e) (void)) (lambda () (thread-terminate! thread)))) - (when (and master pid) + (when (and master pid (integer? master)) (pty-close! master pid)) (when ch (with-catch (lambda (_e) (void)) (lambda () (channel-close ch))))