Add flicker-free top via coreutils builtin, bypass PTY pipeline
ober
ae6cff7588159ae67921785d543a558a3c1bda18
--- a/Makefile +++ b/Makefile @@ -1,8 +1,9 @@ SCHEME = scheme JERBOA = $(HOME)/mine/jerboa JSH = vendor/jerboa-shell/src +COREUTILS = $(HOME)/mine/jerboa-coreutils/lib GHERKIN = $(HOME)/mine/gherkin/src -LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(GHERKIN):$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla/src:$(HOME)/mine/chez-qt +LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(COREUTILS):$(GHERKIN):$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla/src:$(HOME)/mine/chez-qt JERBUILD = $(SCHEME) --libdirs $(JERBOA)/lib --script $(JERBOA)/jerbuild.ss export LD_LIBRARY_PATH := .:$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(HOME)/mine/chez-qt:vendor/jerboa-shell:$(LD_LIBRARY_PATH) export CHEZ_SCINTILLA_LIB := $(HOME)/mine/chez-scintilla --- a/lib/jerboa-emacs/async.sls +++ b/lib/jerboa-emacs/async.sls @@ -6,11 +6,12 @@ (export ui-queue-push! ui-queue-drain! spawn-worker pin-thread-to-processor0! async-process! async-process-stream! async-read-file! async-write-file! - async-eval! schedule-periodic! master-timer-tick! - current-time-ms *file-index* start-file-indexer! - stop-file-indexer! file-index-lookup *git-status-cache* - start-git-watcher! stop-git-watcher! flycheck-trigger! - start-flycheck-watcher! stop-flycheck-watcher!) + async-eval! schedule-periodic! cancel-periodic! + master-timer-tick! current-time-ms *file-index* + start-file-indexer! stop-file-indexer! file-index-lookup + *git-status-cache* start-git-watcher! stop-git-watcher! + flycheck-trigger! start-flycheck-watcher! + stop-flycheck-watcher!) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -100,7 +101,17 @@ (def (schedule-periodic! name interval-ms thunk) "Register a periodic task to run at the given interval.\n Tasks are run by master-timer-tick! on the UI thread." (set! *scheduled-tasks* + (filter + (lambda (t) (not (eq? (car t) name))) + *scheduled-tasks*)) + (set! *scheduled-tasks* (cons (list name interval-ms 0 thunk) *scheduled-tasks*))) + (def (cancel-periodic! name) + "Remove a periodic task by name." + (set! *scheduled-tasks* + (filter + (lambda (t) (not (eq? (car t) name))) + *scheduled-tasks*))) (def (master-timer-tick!) "Master timer callback: drain the UI queue, then run periodic tasks.\n Should be called from a single Qt timer at ~16-50ms interval." (ui-queue-drain!) --- a/lib/jerboa-emacs/qt/commands-aliases.sls +++ b/lib/jerboa-emacs/qt/commands-aliases.sls @@ -725,6 +725,8 @@ (register-command! 'info-elisp-manual cmd-info-elisp-manual) (register-command! 'report-bug cmd-report-bug) (register-command! 'memory-report cmd-memory-report) + (register-command! 'top cmd-top) + (register-command! 'top-quit cmd-top-quit) (register-command! 'view-echo-area-messages cmd-view-echo-area-messages) --- a/lib/jerboa-emacs/qt/commands-config.sls +++ b/lib/jerboa-emacs/qt/commands-config.sls @@ -1004,7 +1004,8 @@ (qt-buffer-kill! buf) (echo-message! (app-state-echo app) - "Terminal exited"))])]))))))) + "Terminal exited"))] + [(eq? output 'top) (cmd-top app)])]))))))) (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 @@ -68,7 +68,8 @@ *abbrevs-path* abbrevs-save! abbrevs-load! cmd-abbrev-mode cmd-define-abbrev cmd-delete-horizontal-space cmd-consult-line cmd-consult-grep cmd-consult-buffer - cmd-consult-outline) + cmd-consult-outline *top-buffer-name* *top-active* + top-capture-output top-refresh! cmd-top cmd-top-quit) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -76,6 +77,11 @@ (std sugar) (chez-scintilla constants) (std sort) (std srfi srfi-13) (std text base64) (jerboa-emacs qt sci-shim) (jerboa-emacs core) + (only + (jerboa-emacs async) + schedule-periodic! + cancel-periodic!) + (only (jsh registry) builtin-lookup) (only (jerboa-emacs persist) theme-settings-save! theme-settings-load! mx-history-save! mx-history-load! *auto-fill-mode* *fill-column* *abbrev-table* @@ -2145,6 +2151,56 @@ (qt-plain-text-edit-set-cursor-position! ed pos) (qt-plain-text-edit-ensure-cursor-visible! ed)))))))))) + (define *top-buffer-name*--cell (vector "*top*")) + (define *top-active*--cell (vector #f)) + (def (top-capture-output) + "Run coreutils top in batch mode (-b -n 1) and capture output as a string.\n Uses builtin-lookup to get the jsh-registered handler." + (let ([handler (builtin-lookup "top")]) + (if handler + (let ([output (with-output-to-string + (lambda () + (with-catch + (lambda (e) (display "top: error\n")) + (lambda () + (handler '("-b" "-n" "1") #f)))))]) + output) + "top: command not available (coreutils not registered)\n"))) + (def (top-refresh! app) + "Refresh the *top* buffer with current coreutils top output." + (let* ([ed (current-qt-editor app)] + [buf (current-qt-buffer app)]) + (when (and buf + (string=? (buffer-name buf) *top-buffer-name*)) + (let ([output (top-capture-output)] + [cursor-pos (qt-plain-text-edit-cursor-position ed)]) + (qt-widget-set-updates-enabled! ed #f) + (qt-plain-text-edit-set-text! ed output) + (when (< cursor-pos (string-length output)) + (qt-plain-text-edit-set-cursor-position! ed cursor-pos)) + (qt-widget-set-updates-enabled! ed #t))))) + (def (cmd-top app) + "Display process list (top) in a buffer, refreshing every 3 seconds.\n Uses coreutils top in batch mode — no PTY, no flicker." + (let* ([ed (current-qt-editor app)] + [fr (app-state-frame app)] + [buf (qt-buffer-create! *top-buffer-name* ed #f)]) + (qt-buffer-attach! ed buf) + (qt-edit-window-buffer-set! (qt-current-window fr) buf) + (qt-plain-text-edit-set-read-only! ed #t) + (let ([output (top-capture-output)]) + (qt-plain-text-edit-set-text! ed output) + (qt-text-document-set-modified! (buffer-doc-pointer buf) #f) + (qt-plain-text-edit-set-cursor-position! ed 0)) + (set! *top-active* app) + (schedule-periodic! + 'top-refresh + 3000 + (lambda () (when *top-active* (top-refresh! *top-active*)))) + (echo-message! + (app-state-echo app) + "top: press q or switch buffer to stop"))) + (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")) (define-syntax *auto-indent* (identifier-syntax [id (vector-ref *auto-indent*--cell 0)] @@ -2286,4 +2342,15 @@ (define-syntax *abbrevs-path* (identifier-syntax [id (vector-ref *abbrevs-path*--cell 0)] - [(set! id val) (vector-set! *abbrevs-path*--cell 0 val)]))) + [(set! id val) (vector-set! *abbrevs-path*--cell 0 val)])) + (define-syntax *top-buffer-name* + (identifier-syntax + [id (vector-ref *top-buffer-name*--cell 0)] + [(set! id val) (vector-set! + *top-buffer-name*--cell + 0 + val)])) + (define-syntax *top-active* + (identifier-syntax + [id (vector-ref *top-active*--cell 0)] + [(set! id val) (vector-set! *top-active*--cell 0 val)]))) --- a/src/jerboa-emacs/async.ss +++ b/src/jerboa-emacs/async.ss @@ -41,6 +41,7 @@ ;; Periodic task scheduler schedule-periodic! + cancel-periodic! master-timer-tick! current-time-ms @@ -171,9 +172,17 @@ (def (schedule-periodic! name interval-ms thunk) "Register a periodic task to run at the given interval. Tasks are run by master-timer-tick! on the UI thread." + ;; Remove any existing task with the same name first + (set! *scheduled-tasks* + (filter (lambda (t) (not (eq? (car t) name))) *scheduled-tasks*)) (set! *scheduled-tasks* (cons [name interval-ms 0 thunk] *scheduled-tasks*))) +(def (cancel-periodic! name) + "Remove a periodic task by name." + (set! *scheduled-tasks* + (filter (lambda (t) (not (eq? (car t) name))) *scheduled-tasks*))) + (def (master-timer-tick!) "Master timer callback: drain the UI queue, then run periodic tasks. Should be called from a single Qt timer at ~16-50ms interval." --- a/src/jerboa-emacs/qt/commands-aliases.ss +++ b/src/jerboa-emacs/qt/commands-aliases.ss @@ -531,6 +531,8 @@ (register-command! 'info-elisp-manual cmd-info-elisp-manual) (register-command! 'report-bug cmd-report-bug) (register-command! 'memory-report cmd-memory-report) + (register-command! 'top cmd-top) + (register-command! 'top-quit cmd-top-quit) (register-command! 'view-echo-area-messages cmd-view-echo-area-messages) ;; Spelling (register-command! 'ispell-word cmd-ispell-word) --- a/src/jerboa-emacs/qt/commands-config.ss +++ b/src/jerboa-emacs/qt/commands-config.ss @@ -822,7 +822,10 @@ modified so the next save uses the new encoding." (set! (qt-edit-window-buffer (qt-current-window fr)) other)) (hash-remove! *terminal-state* buf) (qt-buffer-kill! buf) - (echo-message! (app-state-echo app) "Terminal exited")))))))))))) + (echo-message! (app-state-echo app) "Terminal exited"))) + ((eq? output 'top) + ;; Redirect to in-process top buffer (flicker-free) + (cmd-top app))))))))))) (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 @@ -11,6 +11,8 @@ :std/text/base64 :jerboa-emacs/qt/sci-shim :jerboa-emacs/core + (only-in :jerboa-emacs/async schedule-periodic! cancel-periodic!) + (only-in :jsh/registry builtin-lookup) (only-in :jerboa-emacs/persist theme-settings-save! theme-settings-load! mx-history-save! mx-history-load! *auto-fill-mode* *fill-column* @@ -1841,3 +1843,67 @@ SPC = page down, DEL = page up, q = quit view-mode." (qt-plain-text-edit-set-cursor-position! ed pos) (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. +;;;============================================================================ + +(def *top-buffer-name* "*top*") +(def *top-active* #f) ;; the app when top is running, or #f + +(def (top-capture-output) + "Run coreutils top in batch mode (-b -n 1) and capture output as a string. + Uses builtin-lookup to get the jsh-registered handler." + (let ((handler (builtin-lookup "top"))) + (if handler + (let ((output (with-output-to-string + (lambda () + (with-catch + (lambda (e) (display "top: error\n")) + (lambda () (handler '("-b" "-n" "1") #f))))))) + output) + "top: command not available (coreutils not registered)\n"))) + +(def (top-refresh! app) + "Refresh the *top* buffer with current coreutils top output." + (let* ((ed (current-qt-editor app)) + (buf (current-qt-buffer app))) + (when (and buf (string=? (buffer-name buf) *top-buffer-name*)) + (let ((output (top-capture-output)) + (cursor-pos (qt-plain-text-edit-cursor-position ed))) + (qt-widget-set-updates-enabled! ed #f) + (qt-plain-text-edit-set-text! ed output) + ;; Restore cursor position if possible + (when (< cursor-pos (string-length output)) + (qt-plain-text-edit-set-cursor-position! ed cursor-pos)) + (qt-widget-set-updates-enabled! ed #t))))) + +(def (cmd-top app) + "Display process list (top) in a buffer, refreshing every 3 seconds. + Uses coreutils top in batch mode — no PTY, no flicker." + (let* ((ed (current-qt-editor app)) + (fr (app-state-frame app)) + (buf (qt-buffer-create! *top-buffer-name* ed #f))) + (qt-buffer-attach! ed buf) + (set! (qt-edit-window-buffer (qt-current-window fr)) buf) + (qt-plain-text-edit-set-read-only! ed #t) + ;; Initial render + (let ((output (top-capture-output))) + (qt-plain-text-edit-set-text! ed output) + (qt-text-document-set-modified! (buffer-doc-pointer buf) #f) + (qt-plain-text-edit-set-cursor-position! ed 0)) + ;; Set up periodic refresh + (set! *top-active* app) + (schedule-periodic! 'top-refresh 3000 + (lambda () + (when *top-active* + (top-refresh! *top-active*)))) + (echo-message! (app-state-echo app) + "top: press q or switch buffer to stop"))) + +(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")) + --- a/src/jerboa-emacs/terminal.ss +++ b/src/jerboa-emacs/terminal.ss @@ -678,6 +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) + ((or (string=? trimmed "top") + (string-prefix? "top " trimmed)) + (values 'special 'top #f)) (else ;; ALL commands go through PTY async to avoid blocking the UI thread. ;; gsh-capture runs synchronously and can deadlock the Chez SMP GC