Render which-key bindings as Qt list
ober
e5c30ee6f8cf46d337a47ed777770ec1cbf9474e
--- a/src/jerboa-emacs/qt/app.ss +++ b/src/jerboa-emacs/qt/app.ss @@ -4,7 +4,8 @@ (export qt-main qt-open-file! qt-do-init! qt-call-with-key-handler-errors qt-drop-payload-file-paths qt-handle-drop-text! - qt-show-context-menu!) + qt-show-context-menu! + which-key-binding-candidates) (import :std/sugar :std/misc/string @@ -422,24 +423,27 @@ (def *which-key-pending-keymap* #f) (def *which-key-pending-prefix* #f) -(def (which-key-format-bindings km prefix-str) - "Format keymap bindings for which-key display. - Shows key → Description pairs with human-readable command names." +(def (which-key-binding-candidates km) + "Return key/description rows for the which-key prefix popup." (let* ((entries (keymap-entries km)) (describe (lambda (cmd) (cond ((hash-table? cmd) "+prefix") ((symbol? cmd) (command-name->description cmd)) - (else "?")))) - (strs (let loop ((es entries) (acc [])) - (if (null? es) (reverse acc) - (let* ((e (car es)) - (key (car e)) - (val (cdr e)) - (desc (describe val))) - (loop (cdr es) - (cons (string-append key " → " desc) acc))))))) - (string-append prefix-str "- " (string-join strs " ")))) + (else "?"))))) + (let loop ((es entries) (acc [])) + (if (null? es) (reverse acc) + (let* ((e (car es)) + (key (car e)) + (val (cdr e)) + (desc (describe val))) + (loop (cdr es) + (cons (string-append key " -> " desc) acc))))))) + +(def (which-key-format-bindings km prefix-str) + "Format keymap bindings for legacy echo display." + (string-append prefix-str "- " + (string-join (which-key-binding-candidates km) " "))) ;; Key-chord state — detect two rapid keystrokes as a chord (def *chord-timer* #f) @@ -1360,7 +1364,8 @@ ;; Cancel which-key timer on any non-prefix action (when (and *which-key-timer* (not (eq? action 'prefix))) (qt-timer-stop! *which-key-timer*) - (set! *which-key-pending-keymap* #f)) + (set! *which-key-pending-keymap* #f) + (qt-echo-hide-list!)) ;; Describe-key interception: if pending, show what the key does ;; instead of executing it (except for prefix keys which continue building) (if (and *qt-describe-key-pending* (not (eq? action 'prefix))) @@ -1530,6 +1535,7 @@ (if (string=? acc "") (car keys) (string-append acc " " (car keys)))))))) + (qt-echo-hide-list!) (echo-message! (app-state-echo app) (string-append prefix-str "-")) ;; Start which-key timer if mode is enabled @@ -2124,10 +2130,9 @@ (when (and *which-key-pending-keymap* (not (null? (key-state-prefix-keys (app-state-key-state app))))) - (echo-message! (app-state-echo app) - (which-key-format-bindings - *which-key-pending-keymap* - *which-key-pending-prefix*))))) + (qt-echo-show-list! + (string-append *which-key-pending-prefix* "-") + (which-key-binding-candidates *which-key-pending-keymap*))))) (qt-startup-trace "which-key timer done") ;; Key-chord timer (one-shot, replays pending key on timeout) --- a/src/jerboa-emacs/qt/echo.ss +++ b/src/jerboa-emacs/qt/echo.ss @@ -15,6 +15,8 @@ qt-minibuffer-history-record! qt-minibuffer-history-select qt-minibuffer-history-for + qt-echo-show-list! + qt-echo-hide-list! *minibuffer-active?* *mb-input*) @@ -345,6 +347,26 @@ (qt-widget-set-updates-enabled! *mb-list* #t))) (def *mb-narrowing-prompt* "") ; Base prompt text for narrowing +(def (qt-echo-show-list! title items) + "Show ITEMS in the echo-area list widget without entering minibuffer input." + (when (and *mb-list* (not *minibuffer-active?*)) + (qt-list-widget-clear! *mb-list*) + (for-each + (lambda (item) + (qt-list-widget-add-item! *mb-list* item)) + (take items (min *mb-max-visible* (length items)))) + (when (> (length items) 0) + (qt-list-widget-set-current-row! *mb-list* 0)) + (qt-widget-show! *mb-list*) + (when *mb-echo-label* + (qt-label-set-text! *mb-echo-label* title)))) + +(def (qt-echo-hide-list!) + "Hide the echo-area list widget unless the minibuffer owns it." + (when (and *mb-list* (not *minibuffer-active?*)) + (qt-list-widget-clear! *mb-list*) + (qt-widget-hide! *mb-list*))) + (def (narrowing-move-selection! delta) "Move the narrowing list selection by delta rows (positive = down)." (when (and *mb-narrowing?* (> (vector-length *mb-filtered*) 0)) --- a/tests/test-qt-part2.ss +++ b/tests/test-qt-part2.ss @@ -19,7 +19,8 @@ (jerboa-emacs qt window) (only (jerboa-emacs qt app) qt-call-with-key-handler-errors qt-open-file! - qt-drop-payload-file-paths qt-handle-drop-text!) + qt-drop-payload-file-paths qt-handle-drop-text! + which-key-binding-candidates) (only (jerboa-emacs qt echo) qt-minibuffer-history-reset! qt-minibuffer-history-record! @@ -177,6 +178,14 @@ (execute-command! app 'toggle-context-menu-mode) (check (qt-context-menu-mode-enabled?) => #t))) +(test-case "group46f which-key rows are list friendly" + (let ((km (make-keymap))) + (keymap-bind! km "f" 'find-file) + (keymap-bind! km "4" (make-keymap)) + (let ((rows (which-key-binding-candidates km))) + (check (member "f -> Find file" rows) ? pair?) + (check (member "4 -> +prefix" rows) ? pair?)))) + (test-case "group47 scroll commands page the Scintilla viewport" (let-values (((ed w app) (make-qt-test-app "part2-47"))) (qt-plain-text-edit-set-text! ed (qt-test-lines 80))