Add Qt GUI automation bridge for remote testing via debug REPL
ober
b7f52d0cbc7b79e693b9dbe06d1b54ad774c1ad4
--- a/lib/jerboa-emacs/qt/app.sls +++ b/lib/jerboa-emacs/qt/app.sls @@ -90,7 +90,7 @@ start-debug-repl! stop-debug-repl! debug-repl-bind!) - (jerboa core) (jerboa runtime)) + (jerboa-emacs qt automation) (jerboa core) (jerboa runtime)) (def *vterm-render-interval-ms* 33) (def *pty-batch-budget* 65536) (def *vterm-scrollback-limit* 100000) @@ -2254,7 +2254,22 @@ (lambda () (let* ([fr (app-state-frame app)] [buf (qt-current-buffer fr)]) - (if buf (buffer-name buf) "#<none>")))))))) + (if buf (buffer-name buf) "#<none>")))) + (cons + 'send-keys! + (lambda keys (apply automation-send-keys! app keys))) + (cons + 'screenshot! + (lambda (path) (automation-screenshot! app path))) + (cons 'app-state (lambda () (automation-state app))) + (cons + 'wait-echo! + (lambda (pat ms) + (automation-wait! + app + (lambda (state) + (let ([mb (cdr (assq 'minibuffer state))]) mb)) + ms))))))) (schedule-periodic! 'treesitter-reparse 150 @@ -2292,6 +2307,7 @@ (setenv "QT_ACCESSIBILITY" "0") (let ([qt-app (qt-app-create)]) (set! *qt-app-ref* qt-app) + (automation-set-qt-app! qt-app) (try (qt-do-init! qt-app args) (qt-app-exec! qt-app *master-timer-tick-fn*) (lsp-stop!) (stop-ipc-server!) (stop-debug-repl!) new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/qt/automation.sls @@ -0,0 +1,219 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jerboa-emacs/qt/automation.ss + +(library (jerboa-emacs qt automation) + (export automation-send-keys! automation-screenshot! + automation-state automation-wait! automation-set-qt-app! + emacs-key->qt-event) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (std sugar) (jerboa-emacs qt sci-shim) + (except (chez-qt qt) QT_MOD_NONE QT_MOD_SHIFT QT_MOD_CONTROL + QT_MOD_ALT QT_MOD_META QT_KEY_ESCAPE QT_KEY_BACKSPACE + QT_KEY_RETURN QT_KEY_ENTER QT_KEY_DELETE QT_KEY_TAB + QT_KEY_BACKTAB QT_KEY_INSERT QT_KEY_HOME QT_KEY_END + QT_KEY_LEFT QT_KEY_RIGHT QT_KEY_UP QT_KEY_DOWN + QT_KEY_PAGE_UP QT_KEY_PAGE_DOWN QT_KEY_SPACE QT_KEY_F1 + QT_KEY_F2 QT_KEY_F3 QT_KEY_F4 QT_KEY_F5 QT_KEY_F6 QT_KEY_F7 + QT_KEY_F8 QT_KEY_F9 QT_KEY_F10 QT_KEY_F11 QT_KEY_F12 + QT_CURSOR_UP QT_CURSOR_DOWN QT_CURSOR_START QT_CURSOR_END + QT_CURSOR_START_OF_BLOCK QT_CURSOR_END_OF_BLOCK + QT_CURSOR_NEXT_CHAR QT_CURSOR_NEXT_WORD + QT_CURSOR_PREVIOUS_CHAR QT_CURSOR_PREVIOUS_WORD + qt-plain-text-edit-create qt-plain-text-edit-set-text! + qt-plain-text-edit-text qt-plain-text-edit-append! + qt-plain-text-edit-clear! qt-plain-text-edit-set-read-only! + qt-plain-text-edit-read-only? + qt-plain-text-edit-set-placeholder! + qt-plain-text-edit-line-count + qt-plain-text-edit-set-max-block-count! + qt-plain-text-edit-cursor-line + qt-plain-text-edit-cursor-column + qt-plain-text-edit-set-line-wrap! + qt-plain-text-edit-cursor-position + qt-plain-text-edit-set-cursor-position! + qt-plain-text-edit-move-cursor! + qt-plain-text-edit-select-all! + qt-plain-text-edit-selected-text + qt-plain-text-edit-selection-start + qt-plain-text-edit-selection-end + qt-plain-text-edit-set-selection! + qt-plain-text-edit-has-selection? + qt-plain-text-edit-insert-text! + qt-plain-text-edit-remove-selected-text! + qt-plain-text-edit-undo! qt-plain-text-edit-redo! + qt-plain-text-edit-can-undo? qt-plain-text-edit-cut! + qt-plain-text-edit-copy! qt-plain-text-edit-paste! + qt-plain-text-edit-text-length qt-plain-text-edit-text-range + qt-plain-text-edit-line-from-position + qt-plain-text-edit-line-end-position + qt-plain-text-edit-find-text + qt-plain-text-edit-ensure-cursor-visible! + qt-plain-text-edit-center-cursor! qt-text-document-create + qt-plain-text-document-create qt-text-document-destroy! + qt-plain-text-edit-document qt-plain-text-edit-set-document! + qt-text-document-modified? qt-text-document-set-modified! + qt-syntax-highlighter-create qt-syntax-highlighter-destroy! + qt-syntax-highlighter-add-rule! + qt-syntax-highlighter-add-keywords! + qt-syntax-highlighter-add-multiline-rule! + qt-syntax-highlighter-clear-rules! + qt-syntax-highlighter-rehighlight! + qt-line-number-area-create qt-line-number-area-destroy! + qt-line-number-area-set-visible! + qt-line-number-area-set-bg-color! + qt-line-number-area-set-fg-color!) + (jerboa-emacs core) (jerboa-emacs qt window) + (jerboa-emacs qt echo) (jerboa core) (jerboa runtime)) + (def (emacs-key->qt-event key-str) + (let ([special (emacs-special-key key-str)]) + (if special + (values (car special) (cdr special) "") + (let parse ([s key-str] [mods 0]) + (cond + [(and (>= (string-length s) 2) + (string=? (substring s 0 2) "C-")) + (parse + (substring s 2 (string-length s)) + (bitwise-ior mods QT_MOD_CTRL))] + [(and (>= (string-length s) 2) + (string=? (substring s 0 2) "M-")) + (parse + (substring s 2 (string-length s)) + (bitwise-ior mods QT_MOD_ALT))] + [(and (>= (string-length s) 2) + (string=? (substring s 0 2) "S-")) + (parse + (substring s 2 (string-length s)) + (bitwise-ior mods QT_MOD_SHIFT))] + [(emacs-special-key s) => + (lambda (pair) + (values (car pair) (bitwise-ior mods (cdr pair)) ""))] + [(= (string-length s) 1) + (let* ([ch (string-ref s 0)] [code (char->qt-key ch)]) + (values code mods (string ch)))] + [else (error "automation: unrecognized key" key-str)]))))) + (def (char->qt-key ch) + (let ([c (char->integer ch)]) + (cond + [(and (>= c 97) (<= c 122)) (- c 32)] + [(and (>= c 65) (<= c 90)) c] + [(and (>= c 48) (<= c 57)) c] + [(= c 32) QT_KEY_SPACE] + [else c]))) + (def (emacs-special-key name) + (cond + [(string=? name "RET") (cons QT_KEY_RETURN 0)] + [(string=? name "TAB") (cons QT_KEY_TAB 0)] + [(string=? name "ESC") (cons QT_KEY_ESCAPE 0)] + [(string=? name "SPC") (cons QT_KEY_SPACE 0)] + [(string=? name "DEL") (cons QT_KEY_BACKSPACE 0)] + [(string=? name "<delete>") (cons QT_KEY_DELETE 0)] + [(string=? name "<return>") (cons QT_KEY_RETURN 0)] + [(string=? name "<tab>") (cons QT_KEY_TAB 0)] + [(string=? name "<escape>") (cons QT_KEY_ESCAPE 0)] + [(string=? name "<backspace>") (cons QT_KEY_BACKSPACE 0)] + [(string=? name "<home>") (cons QT_KEY_HOME 0)] + [(string=? name "<end>") (cons QT_KEY_END 0)] + [(string=? name "<insert>") (cons QT_KEY_INSERT 0)] + [(string=? name "<left>") (cons QT_KEY_LEFT 0)] + [(string=? name "<right>") (cons QT_KEY_RIGHT 0)] + [(string=? name "<up>") (cons QT_KEY_UP 0)] + [(string=? name "<down>") (cons QT_KEY_DOWN 0)] + [(string=? name "<prior>") (cons QT_KEY_PAGE_UP 0)] + [(string=? name "<next>") (cons QT_KEY_PAGE_DOWN 0)] + [(string=? name "<f1>") (cons QT_KEY_F1 0)] + [(string=? name "<f2>") (cons QT_KEY_F2 0)] + [(string=? name "<f3>") (cons QT_KEY_F3 0)] + [(string=? name "<f4>") (cons QT_KEY_F4 0)] + [(string=? name "<f5>") (cons QT_KEY_F5 0)] + [(string=? name "<f6>") (cons QT_KEY_F6 0)] + [(string=? name "<f7>") (cons QT_KEY_F7 0)] + [(string=? name "<f8>") (cons QT_KEY_F8 0)] + [(string=? name "<f9>") (cons QT_KEY_F9 0)] + [(string=? name "<f10>") (cons QT_KEY_F10 0)] + [(string=? name "<f11>") (cons QT_KEY_F11 0)] + [(string=? name "<f12>") (cons QT_KEY_F12 0)] + [else #f])) + (def (automation-send-keys! app . key-strings) + (let* ([fr (app-state-frame app)] + [ed (qt-current-editor fr)]) + (when ed + (for-each + (lambda (ks) + (if (or (<= (string-length ks) 1) + (emacs-special-key ks) + (and (>= (string-length ks) 3) + (or (string=? (substring ks 0 2) "C-") + (string=? (substring ks 0 2) "M-") + (string=? (substring ks 0 2) "S-")))) + (send-one-key! app ks) + (let loop ([i 0]) + (when (< i (string-length ks)) + (send-one-key! app (string (string-ref ks i))) + (loop (+ i 1)))))) + key-strings)))) + (def (send-one-key! app key-str) + (let-values ([(code mods text) + (emacs-key->qt-event key-str)]) + (let* ([fr (app-state-frame app)] + [target (if *minibuffer-active?* + (and *mb-input* *mb-input*) + (qt-current-editor fr))]) + (when target + (qt-send-key-press! target code mods text) + (qt-send-key-release! target code mods text))))) + (def (automation-screenshot! app path) + (let* ([fr (app-state-frame app)] + [main-win (qt-frame-main-win fr)]) + (if main-win (qt-widget-screenshot! main-win path) #f))) + (def (automation-state app) + (let* ([fr (app-state-frame app)] + [buf (qt-current-buffer fr)] + [ed (qt-current-editor fr)] + [ks (app-state-key-state app)] + [wins (qt-frame-windows fr)]) + (list (cons 'buffer (if buf (buffer-name buf) "#<none>")) + (cons + 'point + (if ed (qt-plain-text-edit-cursor-position ed) 0)) + (cons + 'key-state + (let ([prefix (key-state-prefix-keys ks)]) + (if (null? prefix) + "normal" + (string-append + "prefix: " + (apply + string-append + (map (lambda (k) (string-append k " ")) prefix)))))) + (cons 'minibuffer *minibuffer-active?*) + (cons + 'minibuffer-text + (if (and *minibuffer-active?* *mb-input*) + (qt-line-edit-text *mb-input*) + "")) + (cons 'windows (length wins)) + (cons + 'mode + (if buf + (let ([lang (buffer-lexer-lang buf)]) + (if lang (symbol->string lang) "fundamental")) + "none"))))) + (def (automation-wait! app predicate timeout-ms) + (let ([start (current-time-ms)]) + (let loop () + (let ([state (automation-state app)]) + (cond + [(predicate state) #t] + [(> (- (current-time-ms) start) timeout-ms) #f] + [else (qt-app-process-events! *qt-app-ref*) (loop)]))))) + (def (current-time-ms) + (let ([t (current-time)]) + (+ (* (time-second t) 1000) + (quotient (time-nanosecond t) 1000000)))) + (def *qt-app-ref* #f) + (def (automation-set-qt-app! app) (set! *qt-app-ref* app))) --- a/lib/jerboa-emacs/qt/echo.sls +++ b/lib/jerboa-emacs/qt/echo.sls @@ -7,7 +7,7 @@ qt-echo-read-string-with-completion qt-echo-read-file-with-completion qt-echo-read-file-with-narrowing qt-echo-read-with-narrowing - qt-minibuffer-init! *minibuffer-active?*) + qt-minibuffer-init! *minibuffer-active?* *mb-input*) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -45,7 +45,7 @@ (qt-label-set-text! label "")))) (def *mb-container* #f) (def *mb-prompt* #f) - (def *mb-input* #f) + (define *mb-input*--cell (vector #f)) (def *mb-echo-label* #f) (def *mb-qt-app* #f) (def *mb-editor* #f) @@ -677,4 +677,8 @@ [(set! id val) (vector-set! *minibuffer-active?*--cell 0 - val)]))) + val)])) + (define-syntax *mb-input* + (identifier-syntax + [id (vector-ref *mb-input*--cell 0)] + [(set! id val) (vector-set! *mb-input*--cell 0 val)]))) --- a/src/jerboa-emacs/qt/app.ss +++ b/src/jerboa-emacs/qt/app.ss @@ -85,7 +85,8 @@ :jerboa-emacs/ipc :jerboa-emacs/vtscreen (only-in :jerboa-emacs/editor-extra-web *aggressive-indent-mode*) - (only-in :jerboa-emacs/debug-repl start-debug-repl! stop-debug-repl! debug-repl-bind!)) + (only-in :jerboa-emacs/debug-repl start-debug-repl! stop-debug-repl! debug-repl-bind!) + :jerboa-emacs/qt/automation) ;;;============================================================================ ;;; Vterm render throttle — skip intermediate renders during fast output @@ -1751,7 +1752,21 @@ (lambda () (let* ((fr (app-state-frame app)) (buf (qt-current-buffer fr))) - (if buf (buffer-name buf) "#<none>")))))))) + (if buf (buffer-name buf) "#<none>")))) + ;; Automation bridge (for Claude) + (cons 'send-keys! + (lambda keys (apply automation-send-keys! app keys))) + (cons 'screenshot! + (lambda (path) (automation-screenshot! app path))) + (cons 'app-state + (lambda () (automation-state app))) + (cons 'wait-echo! + (lambda (pat ms) + (automation-wait! app + (lambda (state) + (let ((mb (cdr (assq 'minibuffer state)))) + mb)) + ms))))))) ;; Tree-sitter debounced re-highlight — re-parse when buffer content changes. ;; Tracks last-known text length per buffer to detect modifications. (schedule-periodic! 'treesitter-reparse 150 @@ -1807,6 +1822,7 @@ (setenv "QT_ACCESSIBILITY" "0") (let ((qt-app (qt-app-create))) (set! *qt-app-ref* qt-app) + (automation-set-qt-app! qt-app) (try ;; Run initialization synchronously before entering the event loop. ;; The primordial thread is pinned to processor 0, so it will always new file mode 100644 --- /dev/null +++ b/src/jerboa-emacs/qt/automation.ss @@ -0,0 +1,280 @@ +;;; -*- Gerbil -*- +;;; Qt GUI automation bridge for jemacs +;;; +;;; Provides functions for Claude (via the debug REPL) to interact with +;;; the running Qt editor: send real key events, take screenshots, and +;;; query application state. + +(export automation-send-keys! + automation-screenshot! + automation-state + automation-wait! + automation-set-qt-app! + emacs-key->qt-event) + +(import :std/sugar + :jerboa-emacs/qt/sci-shim + (except-in :chez-qt/qt + ;; Exclude Qt constants re-exported by sci-shim + QT_MOD_NONE QT_MOD_SHIFT QT_MOD_CONTROL QT_MOD_ALT QT_MOD_META + QT_KEY_ESCAPE QT_KEY_BACKSPACE QT_KEY_RETURN QT_KEY_ENTER QT_KEY_DELETE + QT_KEY_TAB QT_KEY_BACKTAB QT_KEY_INSERT QT_KEY_HOME QT_KEY_END + QT_KEY_LEFT QT_KEY_RIGHT QT_KEY_UP QT_KEY_DOWN + QT_KEY_PAGE_UP QT_KEY_PAGE_DOWN QT_KEY_SPACE + QT_KEY_F1 QT_KEY_F2 QT_KEY_F3 QT_KEY_F4 QT_KEY_F5 QT_KEY_F6 + QT_KEY_F7 QT_KEY_F8 QT_KEY_F9 QT_KEY_F10 QT_KEY_F11 QT_KEY_F12 + QT_CURSOR_UP QT_CURSOR_DOWN QT_CURSOR_START QT_CURSOR_END + QT_CURSOR_START_OF_BLOCK QT_CURSOR_END_OF_BLOCK + QT_CURSOR_NEXT_CHAR QT_CURSOR_NEXT_WORD + QT_CURSOR_PREVIOUS_CHAR QT_CURSOR_PREVIOUS_WORD + qt-plain-text-edit-create qt-plain-text-edit-set-text! + qt-plain-text-edit-text qt-plain-text-edit-append! + qt-plain-text-edit-clear! qt-plain-text-edit-set-read-only! + qt-plain-text-edit-read-only? qt-plain-text-edit-set-placeholder! + qt-plain-text-edit-line-count qt-plain-text-edit-set-max-block-count! + qt-plain-text-edit-cursor-line qt-plain-text-edit-cursor-column + qt-plain-text-edit-set-line-wrap! + qt-plain-text-edit-cursor-position qt-plain-text-edit-set-cursor-position! + qt-plain-text-edit-move-cursor! qt-plain-text-edit-select-all! + qt-plain-text-edit-selected-text qt-plain-text-edit-selection-start + qt-plain-text-edit-selection-end qt-plain-text-edit-set-selection! + qt-plain-text-edit-has-selection? qt-plain-text-edit-insert-text! + qt-plain-text-edit-remove-selected-text! + qt-plain-text-edit-undo! qt-plain-text-edit-redo! + qt-plain-text-edit-can-undo? qt-plain-text-edit-cut! + qt-plain-text-edit-copy! qt-plain-text-edit-paste! + qt-plain-text-edit-text-length qt-plain-text-edit-text-range + qt-plain-text-edit-line-from-position qt-plain-text-edit-line-end-position + qt-plain-text-edit-find-text + qt-plain-text-edit-ensure-cursor-visible! qt-plain-text-edit-center-cursor! + qt-text-document-create qt-plain-text-document-create + qt-text-document-destroy! + qt-plain-text-edit-document qt-plain-text-edit-set-document! + qt-text-document-modified? qt-text-document-set-modified! + qt-syntax-highlighter-create qt-syntax-highlighter-destroy! + qt-syntax-highlighter-add-rule! qt-syntax-highlighter-add-keywords! + qt-syntax-highlighter-add-multiline-rule! + qt-syntax-highlighter-clear-rules! qt-syntax-highlighter-rehighlight! + qt-line-number-area-create qt-line-number-area-destroy! + qt-line-number-area-set-visible! + qt-line-number-area-set-bg-color! qt-line-number-area-set-fg-color!) + :jerboa-emacs/core + :jerboa-emacs/qt/window + :jerboa-emacs/qt/echo) + +;;;============================================================================ +;;; Emacs key notation → Qt key event conversion +;;;============================================================================ + +;;; Parse an Emacs-style key string into (values qt-key-code qt-modifiers qt-text). +;;; Examples: +;;; "C-x" → (values 88 #x04000000 "x") +;;; "M-x" → (values 88 #x08000000 "x") +;;; "C-M-a" → (values 65 #x0c000000 "a") +;;; "a" → (values 65 0 "a") +;;; "RET" → (values #x01000004 0 "") +;;; "<f1>" → (values #x01000030 0 "") +(def (emacs-key->qt-event key-str) + (let ((special (emacs-special-key key-str))) + (if special + ;; Special key name (RET, TAB, ESC, <f1>, <up>, etc.) + (values (car special) (cdr special) "") + ;; Parse modifier prefixes: C- M- S- + (let parse ((s key-str) (mods 0)) + (cond + ((and (>= (string-length s) 2) (string=? (substring s 0 2) "C-")) + (parse (substring s 2 (string-length s)) + (bitwise-ior mods QT_MOD_CTRL))) + ((and (>= (string-length s) 2) (string=? (substring s 0 2) "M-")) + (parse (substring s 2 (string-length s)) + (bitwise-ior mods QT_MOD_ALT))) + ((and (>= (string-length s) 2) (string=? (substring s 0 2) "S-")) + (parse (substring s 2 (string-length s)) + (bitwise-ior mods QT_MOD_SHIFT))) + ;; After stripping prefixes, check for remaining special names + ((emacs-special-key s) + => (lambda (pair) (values (car pair) (bitwise-ior mods (cdr pair)) ""))) + ;; Single character + ((= (string-length s) 1) + (let* ((ch (string-ref s 0)) + (code (char->qt-key ch))) + (values code mods (string ch)))) + (else + (error "automation: unrecognized key" key-str))))))) + +;;; Map a character to a Qt key code. +(def (char->qt-key ch) + (let ((c (char->integer ch))) + (cond + ;; Letters a-z → Qt::Key_A (65) through Qt::Key_Z (90) + ((and (>= c 97) (<= c 122)) (- c 32)) + ;; Uppercase A-Z → Qt::Key_A through Qt::Key_Z + ((and (>= c 65) (<= c 90)) c) + ;; Digits 0-9 → Qt::Key_0 (48) through Qt::Key_9 (57) + ((and (>= c 48) (<= c 57)) c) + ;; Space + ((= c 32) QT_KEY_SPACE) + ;; Common punctuation — Qt uses ASCII code points + (else c)))) + +;;; Lookup table for special key names. +(def (emacs-special-key name) + (cond + ((string=? name "RET") (cons QT_KEY_RETURN 0)) + ((string=? name "TAB") (cons QT_KEY_TAB 0)) + ((string=? name "ESC") (cons QT_KEY_ESCAPE 0)) + ((string=? name "SPC") (cons QT_KEY_SPACE 0)) + ((string=? name "DEL") (cons QT_KEY_BACKSPACE 0)) + ((string=? name "<delete>") (cons QT_KEY_DELETE 0)) + ((string=? name "<return>") (cons QT_KEY_RETURN 0)) + ((string=? name "<tab>") (cons QT_KEY_TAB 0)) + ((string=? name "<escape>") (cons QT_KEY_ESCAPE 0)) + ((string=? name "<backspace>") (cons QT_KEY_BACKSPACE 0)) + ((string=? name "<home>") (cons QT_KEY_HOME 0)) + ((string=? name "<end>") (cons QT_KEY_END 0)) + ((string=? name "<insert>") (cons QT_KEY_INSERT 0)) + ((string=? name "<left>") (cons QT_KEY_LEFT 0)) + ((string=? name "<right>") (cons QT_KEY_RIGHT 0)) + ((string=? name "<up>") (cons QT_KEY_UP 0)) + ((string=? name "<down>") (cons QT_KEY_DOWN 0)) + ((string=? name "<prior>") (cons QT_KEY_PAGE_UP 0)) + ((string=? name "<next>") (cons QT_KEY_PAGE_DOWN 0)) + ((string=? name "<f1>") (cons QT_KEY_F1 0)) + ((string=? name "<f2>") (cons QT_KEY_F2 0)) + ((string=? name "<f3>") (cons QT_KEY_F3 0)) + ((string=? name "<f4>") (cons QT_KEY_F4 0)) + ((string=? name "<f5>") (cons QT_KEY_F5 0)) + ((string=? name "<f6>") (cons QT_KEY_F6 0)) + ((string=? name "<f7>") (cons QT_KEY_F7 0)) + ((string=? name "<f8>") (cons QT_KEY_F8 0)) + ((string=? name "<f9>") (cons QT_KEY_F9 0)) + ((string=? name "<f10>") (cons QT_KEY_F10 0)) + ((string=? name "<f11>") (cons QT_KEY_F11 0)) + ((string=? name "<f12>") (cons QT_KEY_F12 0)) + (else #f))) + +;;;============================================================================ +;;; Send keys +;;;============================================================================ + +;;; Send a sequence of Emacs key strings as real Qt key events. +;;; Each string is parsed and sent as a press+release pair. +;;; Multi-character strings that aren't recognized as key names are +;;; sent as individual character presses (for typing text). +;;; +;;; Usage: +;;; (automation-send-keys! app "C-x" "2") ; C-x 2 (split window) +;;; (automation-send-keys! app "M-x") ; open M-x +;;; (automation-send-keys! app "find-file" "RET") ; type + enter +(def (automation-send-keys! app . key-strings) + (let* ((fr (app-state-frame app)) + (ed (qt-current-editor fr))) + (when ed + (for-each + (lambda (ks) + (if (or (<= (string-length ks) 1) + (emacs-special-key ks) + ;; Modifier prefix pattern: C-x, M-x, C-M-x, S-<f1>, etc. + (and (>= (string-length ks) 3) + (or (string=? (substring ks 0 2) "C-") + (string=? (substring ks 0 2) "M-") + (string=? (substring ks 0 2) "S-")))) + ;; Single key event + (send-one-key! app ks) + ;; Multi-char string: send each character individually + (let loop ((i 0)) + (when (< i (string-length ks)) + (send-one-key! app (string (string-ref ks i))) + (loop (+ i 1)))))) + key-strings)))) + +;;; Send a single key event (press + release) to the focused widget. +;;; If the minibuffer is active, sends to the minibuffer input widget instead. +(def (send-one-key! app key-str) + (let-values (((code mods text) (emacs-key->qt-event key-str))) + (let* ((fr (app-state-frame app)) + (target (if *minibuffer-active?* + (and *mb-input* *mb-input*) + (qt-current-editor fr)))) + (when target + (qt-send-key-press! target code mods text) + (qt-send-key-release! target code mods text))))) + +;;;============================================================================ +;;; Screenshot +;;;============================================================================ + +;;; Capture the main window as a PNG screenshot. +;;; Returns #t on success, #f on failure. +(def (automation-screenshot! app path) + (let* ((fr (app-state-frame app)) + (main-win (qt-frame-main-win fr))) + (if main-win + (qt-widget-screenshot! main-win path) + #f))) + +;;;============================================================================ +;;; State query +;;;============================================================================ + +;;; Return an alist describing the current application state. +(def (automation-state app) + (let* ((fr (app-state-frame app)) + (buf (qt-current-buffer fr)) + (ed (qt-current-editor fr)) + (ks (app-state-key-state app)) + (wins (qt-frame-windows fr))) + (list + (cons 'buffer (if buf (buffer-name buf) "#<none>")) + (cons 'point (if ed (qt-plain-text-edit-cursor-position ed) 0)) + (cons 'key-state + (let ((prefix (key-state-prefix-keys ks))) + (if (null? prefix) + "normal" + (string-append "prefix: " (apply string-append + (map (lambda (k) (string-append k " ")) prefix)))))) + (cons 'minibuffer *minibuffer-active?*) + (cons 'minibuffer-text + (if (and *minibuffer-active?* *mb-input*) + (qt-line-edit-text *mb-input*) + "")) + (cons 'windows (length wins)) + (cons 'mode (if buf + (let ((lang (buffer-lexer-lang buf))) + (if lang (symbol->string lang) "fundamental")) + "none"))))) + +;;;============================================================================ +;;; Wait for condition +;;;============================================================================ + +;;; Poll until predicate returns true on the state alist, or timeout. +;;; Pumps the Qt event loop between checks. +;;; Returns #t if predicate matched, #f on timeout. +;;; +;;; Usage: +;;; (automation-wait! app +;;; (lambda (state) (cdr (assq 'minibuffer state))) +;;; 2000) ; wait up to 2 seconds for minibuffer to appear +(def (automation-wait! app predicate timeout-ms) + (let ((start (current-time-ms))) + (let loop () + (let ((state (automation-state app))) + (cond + ((predicate state) #t) + ((> (- (current-time-ms) start) timeout-ms) #f) + (else + (qt-app-process-events! *qt-app-ref*) + (loop))))))) + +;;; Simple wall-clock millisecond timer. +(def (current-time-ms) + (let ((t (current-time))) + (+ (* (time-second t) 1000) + (quotient (time-nanosecond t) 1000000)))) + +;;; Global reference to the Qt app (set from app.ss during init). +(def *qt-app-ref* #f) + +(def (automation-set-qt-app! app) + (set! *qt-app-ref* app)) --- a/src/jerboa-emacs/qt/echo.ss +++ b/src/jerboa-emacs/qt/echo.ss @@ -11,7 +11,8 @@ qt-echo-read-file-with-narrowing qt-echo-read-with-narrowing qt-minibuffer-init! - *minibuffer-active?*) + *minibuffer-active?* + *mb-input*) (import :std/sugar :std/sort --- a/vendor/chez-qt-ffi-static.ss +++ b/vendor/chez-qt-ffi-static.ss @@ -213,10 +213,12 @@ ffi-qt-install-key-handler ffi-qt-install-key-handler-consuming ffi-qt-last-key-code ffi-qt-last-key-modifiers ffi-qt-last-key-text ffi-qt-last-key-autorepeat + ffi-qt-send-key-event ;; Pixmap ffi-qt-pixmap-load ffi-qt-pixmap-width ffi-qt-pixmap-height ffi-qt-pixmap-is-null ffi-qt-pixmap-scaled ffi-qt-pixmap-destroy + ffi-qt-pixmap-save ffi-qt-widget-grab ffi-qt-label-set-pixmap ;; Icon @@ -1652,6 +1654,8 @@ (foreign-procedure "qt_last_key_text" () string)) (define ffi-qt-last-key-autorepeat (foreign-procedure "qt_last_key_autorepeat" () int)) + (define ffi-qt-send-key-event + (foreign-procedure "qt_send_key_event" (void* int int int string) void)) ;; ----------------------------------------------------------------------- ;; Pixmap @@ -1669,6 +1673,10 @@ (foreign-procedure "qt_pixmap_scaled" (void* int int int) void*)) (define ffi-qt-pixmap-destroy (foreign-procedure "qt_pixmap_destroy" (void*) void)) + (define ffi-qt-pixmap-save + (foreign-procedure "qt_pixmap_save" (void* string string) int)) + (define ffi-qt-widget-grab + (foreign-procedure "qt_widget_grab" (void*) void*)) ;; ----------------------------------------------------------------------- ;; Icon --- a/vendor/chez-qt-qt.ss +++ b/vendor/chez-qt-qt.ss @@ -213,10 +213,12 @@ qt-on-key-press! qt-on-key-press-consuming! qt-last-key-code qt-last-key-modifiers qt-last-key-text qt-last-key-autorepeat? + qt-send-key-press! qt-send-key-release! ;; Pixmap qt-pixmap-load qt-pixmap-width qt-pixmap-height qt-pixmap-null? qt-pixmap-scaled qt-pixmap-destroy! + qt-pixmap-save! qt-widget-grab qt-widget-screenshot! qt-label-set-pixmap! ;; Icon @@ -1560,6 +1562,11 @@ (define (qt-last-key-text) (ffi-qt-last-key-text)) (define (qt-last-key-autorepeat?) (not (zero? (ffi-qt-last-key-autorepeat)))) + (define (qt-send-key-press! w key mods text) + (ffi-qt-send-key-event w 0 key mods text)) + (define (qt-send-key-release! w key mods text) + (ffi-qt-send-key-event w 1 key mods text)) + ;; ----------------------------------------------------------------------- ;; Pixmap ;; ----------------------------------------------------------------------- @@ -1570,6 +1577,14 @@ (define (qt-pixmap-null? p) (not (zero? (ffi-qt-pixmap-is-null p)))) (define (qt-pixmap-scaled p w h mode) (ffi-qt-pixmap-scaled p w h mode)) (define (qt-pixmap-destroy! p) (ffi-qt-pixmap-destroy p)) + (define (qt-pixmap-save! pm path) + (= 1 (ffi-qt-pixmap-save pm path "PNG"))) + (define (qt-widget-grab w) (ffi-qt-widget-grab w)) + (define (qt-widget-screenshot! w path) + (let ((pm (qt-widget-grab w))) + (let ((ok (qt-pixmap-save! pm path))) + (qt-pixmap-destroy! pm) + ok))) ;; ----------------------------------------------------------------------- ;; Icon --- a/vendor/qt_shim.cpp +++ b/vendor/qt_shim.cpp @@ -2212,6 +2212,24 @@ extern "C" int qt_last_key_autorepeat(void) { QT_RETURN(int, s_last_key_autorepeat); } +extern "C" void qt_send_key_event(qt_widget_t w, int type, int key, int modifiers, const char* text) { + QT_NULL_CHECK_VOID(w); + // Capture primitives by value; construct QKeyEvent inside the lambda + // because QKeyEvent is non-copyable in Qt6. + int etype_int = type; + int key_int = key; + int mods_int = modifiers; + std::string text_str(text ? text : ""); + QT_VOID( + QEvent::Type etype = (etype_int == 0) ? QEvent::KeyPress : QEvent::KeyRelease; + QKeyEvent ev(etype, + static_cast<Qt::Key>(key_int), + static_cast<Qt::KeyboardModifiers>(mods_int), + QString::fromStdString(text_str)); + QApplication::sendEvent(static_cast<QWidget*>(w), &ev) + ); +} + // ============================================================ // Pixmap // ============================================================ @@ -2249,6 +2267,16 @@ extern "C" void qt_pixmap_destroy(qt_pixmap_t p) { QT_VOID(delete static_cast<QPixmap*>(p)); } +extern "C" int qt_pixmap_save(qt_pixmap_t p, const char* path, const char* format) { + QT_NULL_CHECK_RET(p, 0); + QT_RETURN(int, static_cast<QPixmap*>(p)->save(QString::fromUtf8(path), format) ? 1 : 0); +} + +extern "C" qt_pixmap_t qt_widget_grab(qt_widget_t w) { + QT_NULL_CHECK_RET(w, nullptr); + QT_RETURN(qt_pixmap_t, new QPixmap(static_cast<QWidget*>(w)->grab())); +} + extern "C" void qt_label_set_pixmap(qt_label_t label, qt_pixmap_t pixmap) { QT_NULL_CHECK_VOID(label); QT_VOID(static_cast<QLabel*>(label)->setPixmap(*static_cast<QPixmap*>(pixmap))); --- a/vendor/qt_shim.h +++ b/vendor/qt_shim.h @@ -353,6 +353,7 @@ int qt_last_key_code(void); int qt_last_key_modifiers(void); const char* qt_last_key_text(void); int qt_last_key_autorepeat(void); +void qt_send_key_event(qt_widget_t w, int type, int key, int modifiers, const char* text); /* ========== Phase 7: Images, Icons, Radio Buttons, GroupBox ========== */ @@ -369,6 +370,8 @@ int qt_pixmap_height(qt_pixmap_t p); int qt_pixmap_is_null(qt_pixmap_t p); qt_pixmap_t qt_pixmap_scaled(qt_pixmap_t p, int w, int h); void qt_pixmap_destroy(qt_pixmap_t p); +int qt_pixmap_save(qt_pixmap_t p, const char* path, const char* format); +qt_pixmap_t qt_widget_grab(qt_widget_t w); void qt_label_set_pixmap(qt_label_t label, qt_pixmap_t pixmap); /* --- Icon --- */