Stage 2 (core): keymap engine + fuzzy minibuffer + command controller
ober
cc80e0f1117dc23e745d2f5291d4e1590f053405
--- a/.build.yml +++ b/.build.yml @@ -83,5 +83,25 @@ tasks: export JERBOA_HOME="$HOME/jerboa" SCHEME="$(command -v scheme)" export JERBOA_BROWSER_LIB="$PWD/qt-webengine/build/libjerboa_browser.so" make test-buffers - # Stage all harness snapshots (stage0 + stage1) as a downloadable artifact. + - test-keymap: | + cd jerboa-browser + # Stage 2 keymap engine unit tests (pure Scheme; no Qt, no display). + export JERBOA_HOME="$HOME/jerboa" SCHEME="$(command -v scheme)" + make test-keymap + - test-minibuffer: | + cd jerboa-browser + # Stage 2 fuzzy + minibuffer unit tests (pure Scheme; no Qt, no display). + export JERBOA_HOME="$HOME/jerboa" SCHEME="$(command -v scheme)" + make test-minibuffer + - test-commands: | + cd jerboa-browser + # Stage 2 keymap+minibuffer+command controller functional tests + # (offscreen, hermetic): synthetic key tokens drive real buffer state. + export QT_QPA_PLATFORM=offscreen JWB_TEST_NO_NETWORK=1 + export QTWEBENGINE_DISABLE_SANDBOX=1 + export QTWEBENGINE_CHROMIUM_FLAGS="--no-sandbox --disable-gpu" + export JERBOA_HOME="$HOME/jerboa" SCHEME="$(command -v scheme)" + export JERBOA_BROWSER_LIB="$PWD/qt-webengine/build/libjerboa_browser.so" + make test-commands + # Stage all harness snapshots (stage0 + stage1 + stage2) as an artifact. tar czf gui-snapshots.tar.gz test-artifacts --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ JERBOA_HOME ?= $(realpath $(CURDIR)/../jerboa) SCHEME ?= $(JERBOA_HOME)/.chez/bin/scheme LIBDIRS := $(CURDIR)/scheme:$(JERBOA_HOME)/lib -.PHONY: binary test test-gui test-buffers repl clean help +.PHONY: binary test test-keymap test-minibuffer test-commands test-gui test-buffers repl clean help .DEFAULT_GOAL := help # Build the self-contained native ./jerboa-browser (Chez + boot + (browser)). @@ -14,6 +14,19 @@ binary: test: JERBOA_HOME=$(JERBOA_HOME) $(SCHEME) -q --libdirs $(LIBDIRS) --script scheme/browser-test.ss +# Pure-Scheme unit tests for the keymap engine (no Qt, no display needed). +test-keymap: + JERBOA_HOME=$(JERBOA_HOME) $(SCHEME) -q --libdirs $(LIBDIRS) --script scheme/browser-keymap-test.ss + +# Pure-Scheme unit tests for fuzzy completion + the minibuffer state machine. +test-minibuffer: + JERBOA_HOME=$(JERBOA_HOME) $(SCHEME) -q --libdirs $(LIBDIRS) --script scheme/browser-minibuffer-test.ss + +# Stage 2 keymap+minibuffer+command controller functional tests (offscreen). +test-commands: + QT_QPA_PLATFORM=offscreen JERBOA_HOME=$(JERBOA_HOME) \ + $(SCHEME) -q --libdirs $(LIBDIRS) --script scheme/browser-commands-test.ss + # Offline Qt GUI / snapshot harness (headless). Writes PNGs to ./test-artifacts. test-gui: QT_QPA_PLATFORM=offscreen JERBOA_HOME=$(JERBOA_HOME) \ new file mode 100644 --- /dev/null +++ b/scheme/browser-commands-test.ss @@ -0,0 +1,230 @@ +#!chezscheme +;;; browser-commands-test.ss — Stage 2 functional tests for the keymap + +;;; minibuffer + command controller wired to a real (offscreen) session. +;;; +;;; This is the nyxt-feel proof: synthetic key TOKENS are fed to the same +;;; `app-feed-token!` the GUI's Qt key-event filter calls, and we assert the +;;; window's buffer state changed — e.g. `C-x b`, type a buffer label, RET → +;;; the current buffer really switched. Three layers: +;;; - pure: the emacs keymap resolves the documented chords; the command +;;; registry lists/looks up commands (no Qt needed). +;;; - functional: a real BrowserWindow + buffers, driven entirely by key +;;; tokens through the controller (offscreen, hermetic — empty-URL buffers +;;; get distinct "buffer <id>" labels, so no network is required). +;;; - snapshot: grab the window with the prompt-buffer open (IHDR-verified). +;;; +;;; Run: QT_QPA_PLATFORM=offscreen make test-commands +;;; Exits 0 on success, 1 on any failed case. + +(import (chezscheme) (browser) (browser buffers) + (browser keymap) (browser minibuffer) (browser commands)) + +;;; ─── tiny test framework (shared shape with the other test files) ───────── +(define *pass* 0) +(define *fail* 0) +(define *test-name* "(none)") + +(define-syntax test-group + (syntax-rules () + [(_ name body ...) + (begin (display "\n=== ") (display name) (display " ===\n") + (flush-output-port (current-output-port)) + body ...)])) + +(define (run-test-case name thunk) + (set! *test-name* name) + (let ((ok (guard (e (#t + (set! *fail* (+ *fail* 1)) + (display " FAIL: ") (display name) (newline) + (display " error: ") + (display (if (message-condition? e) (condition-message e) + (format "~s" e))) + (newline) (flush-output-port (current-output-port)) #f)) + (thunk) #t))) + (when ok + (set! *pass* (+ *pass* 1)) + (display " pass: ") (display name) (newline) + (flush-output-port (current-output-port))))) + +(define-syntax test-case + (syntax-rules () [(_ name body ...) (run-test-case name (lambda () body ...))])) + +(define-syntax check + (syntax-rules (=> ?) + [(_ expr => expected) + (let ((got expr) (exp expected)) + (unless (equal? got exp) + (error 'check (format "~a: expected ~s, got ~s" *test-name* exp got))))] + [(_ expr ? pred) + (let ((got expr)) + (unless (pred got) + (error 'check (format "~a: predicate failed for ~s" *test-name* got))))])) + +;;; ─── PNG inspection (signature + IHDR dimensions) ────────────────────────── +(define png-magic '#vu8(137 80 78 71 13 10 26 10)) +(define (read-file-bytes path) + (and (file-exists? path) + (call-with-port (open-file-input-port path) get-bytevector-all))) +(define (png-file? bv) + (and (bytevector? bv) (>= (bytevector-length bv) 8) + (let loop ((i 0)) + (or (= i 8) + (and (= (bytevector-u8-ref bv i) (bytevector-u8-ref png-magic i)) + (loop (+ i 1))))))) +(define (be32 bv off) + (+ (* (bytevector-u8-ref bv off) 16777216) (* (bytevector-u8-ref bv (+ off 1)) 65536) + (* (bytevector-u8-ref bv (+ off 2)) 256) (bytevector-u8-ref bv (+ off 3)))) +(define (png-dimensions bv) + (and (bytevector? bv) (>= (bytevector-length bv) 24) (cons (be32 bv 16) (be32 bv 20)))) + +;;; ─── setup (offscreen) ───────────────────────────────────────────────────── +(unless (getenv "QT_QPA_PLATFORM") (setenv "QT_QPA_PLATFORM" "offscreen")) +(define artifacts-dir (or (getenv "JWB_TEST_ARTIFACTS") "test-artifacts")) +(unless (file-exists? artifacts-dir) (mkdir artifacts-dir)) +(define (artifact name) (string-append artifacts-dir "/" name)) + +;; Open a session with `n` empty-URL buffers (labels "buffer 0".."buffer n-1") +;; plus a controller, run body, then tear the session down. `bufs` is taken from +;; session-buffer-list (append order) — not the map result — because Chez's `map` +;; does not guarantee left-to-right application, which would scramble identities. +(define-syntax with-fresh + (syntax-rules () + [(_ (app s bufs n) body ...) + (let ((s (open-browser-session))) + (do ((i 0 (+ i 1))) ((= i n)) (session-open-buffer s "")) + (let ((bufs (session-buffer-list s)) + (app (make-browser-app s))) + body ... + (close-browser-session! s)))])) + +;;; ─── pure: the emacs keyscheme resolves the documented chords ────────────── +(test-group "emacs-keymap bindings" + (define km (emacs-keymap)) + (test-case "single-key commands" + (check (keymap-ref km "C-l") => 'set-url) + (check (keymap-ref km "C-r") => 'reload-current-buffer) + (check (keymap-ref km "M-x") => 'execute-command) + (check (keymap-ref km "M-n") => 'switch-buffer-next) + (check (keymap-ref km "M-p") => 'switch-buffer-previous) + (check (keymap-ref km "C-`") => 'switch-buffer-last)) + (test-case "C-x is a prefix; its sub-bindings resolve" + (check (keymap? (keymap-ref km "C-x")) => #t) + (let ((sub (keymap-ref km "C-x"))) + (check (keymap-ref sub "b") => 'switch-buffer) + (check (keymap-ref sub "k") => 'delete-buffer) + (check (keymap-ref sub "C-c") => 'quit) + (check (keymap-ref sub "C-k") => 'delete-current-buffer)))) + +(test-group "command registry" + (test-case "known commands resolve with docs" + (check (command? (command-ref 'switch-buffer)) => #t) + (check (string? (command-doc (command-ref 'switch-buffer))) => #t) + (check (command-ref 'no-such-command) => #f)) + (test-case "command-names lists the verbs (sorted strings)" + (let ((ns (command-names))) + (check (member "switch-buffer" ns) ? (lambda (x) x)) + (check (member "execute-command" ns) ? (lambda (x) x)) + (check (member "set-url" ns) ? (lambda (x) x))))) + +;;; ─── functional: key tokens drive real buffer state ─────────────────────── +(test-group "C-x b → switch-buffer prompt" + (test-case "the chord opens the prompt-buffer over the buffer list" + (with-fresh (app s bufs 3) + (check (app-feed-token! app "C-x") => 'pending) + (check (app-feed-token! app "b") => '(ran . switch-buffer)) + (check (minibuffer? (app-minibuffer app)) => #t) + (check (minibuffer-prompt (app-minibuffer app)) => "Switch to buffer: ") + (check (minibuffer-candidate-count (app-minibuffer app)) => 3))) + (test-case "type a label + RET switches the current buffer" + (with-fresh (app s bufs 3) + (check (session-current-index s) => 2) ; last opened is focused + (app-feed-token! app "C-x") (app-feed-token! app "b") + (app-type! app "0") ; filters to "buffer 0" + (check (minibuffer-selected-string (app-minibuffer app)) => "buffer 0") + (check (app-feed-token! app "RET") => 'accepted) + (check (app-minibuffer app) => #f) ; prompt closed + (check (session-current-index s) => 0) + (check (eq? (session-current-buffer s) (car bufs)) => #t)))) + +(test-group "prompt abort + chord abort (C-g / escape)" + (test-case "C-g closes an open prompt" + (with-fresh (app s bufs 2) + (app-feed-token! app "C-x") (app-feed-token! app "b") + (check (minibuffer? (app-minibuffer app)) => #t) + (check (app-feed-token! app "C-g") => 'abort) + (check (app-minibuffer app) => #f))) + (test-case "escape also aborts" + (with-fresh (app s bufs 2) + (app-feed-token! app "C-x") (app-feed-token! app "b") + (check (app-feed-token! app "escape") => 'abort) + (check (app-minibuffer app) => #f))) + (test-case "a stray key aborts a pending chord; the next key still works" + (with-fresh (app s bufs 2) + (check (app-feed-token! app "C-x") => 'pending) + (check (app-feed-token! app "z") => 'unbound) ; not bound under C-x → reset + (check (app-feed-token! app "C-l") => '(ran . set-url)) ; dispatcher recovered + (check (minibuffer-prompt (app-minibuffer app)) => "URL: ")))) + +(test-group "M-x execute-command" + (test-case "run switch-buffer-next by name" + (with-fresh (app s bufs 3) + (check (session-current-index s) => 2) + (check (app-feed-token! app "M-x") => '(ran . execute-command)) + (app-type! app "switch-buffer-next") + (check (minibuffer-selected-string (app-minibuffer app)) => "switch-buffer-next") + (app-feed-token! app "RET") + (check (app-minibuffer app) => #f) + (check (session-current-index s) => 0)))) ; (2+1) mod 3 + +(test-group "direct buffer-motion chords" + (test-case "M-n / M-p / C-` cycle the current buffer" + (with-fresh (app s bufs 3) + (check (session-current-index s) => 2) + (check (app-feed-token! app "M-n") => '(ran . switch-buffer-next)) + (check (session-current-index s) => 0) + (app-feed-token! app "M-n") + (check (session-current-index s) => 1) + (app-feed-token! app "M-p") + (check (session-current-index s) => 0) + (app-feed-token! app "C-`") ; switch-buffer-last + (check (session-current-index s) => 2)))) + +(test-group "buffer creation + deletion via keys" + (test-case "C-t opens and focuses a new buffer" + (with-fresh (app s bufs 1) + (check (session-buffer-count s) => 1) + (check (app-feed-token! app "C-t") => '(ran . make-buffer-focus)) + (check (session-buffer-count s) => 2) + (check (session-current-index s) => 1))) + (test-case "C-x C-k deletes the current buffer" + (with-fresh (app s bufs 3) + (app-feed-token! app "C-x") + (check (app-feed-token! app "C-k") => '(ran . delete-current-buffer)) + (check (session-buffer-count s) => 2)))) + +(test-group "quit" + (test-case "C-x C-c sets the quit flag" + (with-fresh (app s bufs 1) + (check (app-should-quit? app) => #f) + (app-feed-token! app "C-x") + (app-feed-token! app "C-c") + (check (app-should-quit? app) => #t)))) + +;;; ─── snapshot: the window with the prompt-buffer open ────────────────────── +(test-group "snapshot: open minibuffer" + (test-case "grab the chrome while the switch-buffer prompt is open" + (with-fresh (app s bufs 3) + (browser-window-resize (session-window s) 900 650) + (app-feed-token! app "C-x") (app-feed-token! app "b") + (app-type! app "buf") ; prompt shows "Switch to buffer: buf" + (check (minibuffer? (app-minibuffer app)) => #t) + (let ((path (artifact "stage2-minibuffer.png"))) + (check (browser-ok? (browser-window-grab-png (session-window s) path)) => #t) + (let ((bv (read-file-bytes path))) + (check (png-file? bv) => #t) + (check (png-dimensions bv) => '(900 . 650))))))) + +(newline) +(display "browser-commands-test: ") (display *pass*) (display " passed, ") +(display *fail*) (display " failed") (newline) +(exit (if (zero? *fail*) 0 1)) new file mode 100644 --- /dev/null +++ b/scheme/browser-keymap-test.ss @@ -0,0 +1,213 @@ +#!chezscheme +;;; browser-keymap-test.ss — unit tests for (browser keymap). +;;; +;;; Pure Scheme: needs no Qt and no display, so it runs anywhere (no offscreen +;;; platform required). Covers token canonicalization, the Qt-event→token +;;; mapping (the bridge the GUI and tests share), the keymap tree, and the +;;; chord dispatcher (feed "C-x" then "b" → run switch-buffer). +;;; +;;; Run: make test-keymap (or: scheme --script … with JERBOA_HOME set) +;;; Exits 0 on success, 1 on any failed case. + +(import (chezscheme) (browser keymap)) + +;;; ─── tiny test framework (shared shape with the other test files) ───────── +(define *pass* 0) +(define *fail* 0) +(define *test-name* "(none)") + +(define-syntax test-group + (syntax-rules () + [(_ name body ...) + (begin (display "\n=== ") (display name) (display " ===\n") + (flush-output-port (current-output-port)) + body ...)])) + +(define (run-test-case name thunk) + (set! *test-name* name) + (let ((ok (guard (e (#t + (set! *fail* (+ *fail* 1)) + (display " FAIL: ") (display name) (newline) + (display " error: ") + (display (if (message-condition? e) (condition-message e) + (format "~s" e))) + (newline) (flush-output-port (current-output-port)) #f)) + (thunk) #t))) + (when ok + (set! *pass* (+ *pass* 1)) + (display " pass: ") (display name) (newline) + (flush-output-port (current-output-port))))) + +(define-syntax test-case + (syntax-rules () [(_ name body ...) (run-test-case name (lambda () body ...))])) + +(define-syntax check + (syntax-rules (=> ?) + [(_ expr => expected) + (let ((got expr) (exp expected)) + (unless (equal? got exp) + (error 'check (format "~a: expected ~s, got ~s" *test-name* exp got))))] + [(_ expr ? pred) + (let ((got expr)) + (unless (pred got) + (error 'check (format "~a: predicate failed for ~s" *test-name* got))))])) + +;; Build a token from a Qt event the way the GUI's event filter will. +(define (tok key mods text) (qt-event->token key mods text)) +(define C qt-mod-control) +(define M qt-mod-alt) +(define S qt-mod-shift) +(define META qt-mod-meta) + +;;; ─── token canonicalization ─────────────────────────────────────────────── +(test-group "canonical-token" + (test-case "plain base unchanged" + (check (canonical-token "b") => "b") + (check (canonical-token "x") => "x")) + (test-case "single modifier preserved" + (check (canonical-token "C-x") => "C-x") + (check (canonical-token "M-x") => "M-x")) + (test-case "modifiers reordered to canonical C M S s H" + (check (canonical-token "M-C-x") => "C-M-x") + (check (canonical-token "S-C-tab") => "C-S-tab") + (check (canonical-token "s-M-C-a") => "C-M-s-a")) + (test-case "literal hyphen base survives (C-- is ctrl + '-')" + (check (canonical-token "C--") => "C--") + (check (canonical-token "M--") => "M--")) + (test-case "punctuation base survives" + (check (canonical-token "M-<") => "M-<") + (check (canonical-token "C-x") => "C-x"))) + +(test-group "parse-key-spec (chords split on spaces)" + (test-case "single press" + (check (parse-key-spec "C-l") => '("C-l"))) + (test-case "two-press chord" + (check (parse-key-spec "C-x b") => '("C-x" "b")) + (check (parse-key-spec "C-x C-+") => '("C-x" "C-+"))) + (test-case "reorders within each press" + (check (parse-key-spec "C-x M-C-k") => '("C-x" "C-M-k")))) + +;;; ─── Qt event → token (the bridge) ───────────────────────────────────────── +(test-group "qt-event->token" + (test-case "bare lowercase letter" + (check (tok #x42 0 "b") => "b")) ; Qt sends 'B' code; no shift → b + (test-case "shifted letter folds shift into the glyph" + (check (tok #x42 S "B") => "B")) ; not "S-b" + (test-case "control + letter" + (check (tok #x58 C "") => "C-x")) ; ctrl suppresses text → use code + (test-case "meta/alt + letter (both map to M-)" + (check (tok #x58 M "x") => "M-x") + (check (tok #x58 META "x") => "M-x")) + (test-case "control + meta + letter, canonical order" + (check (tok #x4b (bitwise-ior C M) "") => "C-M-k")) + (test-case "digit" + (check (tok #x30 0 "0") => "0") + (check (tok #x30 C "" ) => "C-0")) + (test-case "named keys: RET / tab / escape / arrows" + (check (tok #x01000004 0 "") => "RET") + (check (tok #x01000005 0 "") => "RET") ; Enter (keypad) folds to RET + (check (tok #x01000001 0 "") => "tab") + (check (tok #x01000000 0 "") => "escape") + (check (tok #x01000012 0 "") => "left") + (check (tok #x01000013 0 "") => "up")) + (test-case "control + named key keeps the modifier" + (check (tok #x01000004 C "") => "C-RET")) + (test-case "shift + multi-char named key keeps S-" + (check (tok #x01000001 S "") => "S-tab")) + (test-case "single-char punctuation folds shift (M-< not M-S-<)" + (check (tok #x3c (bitwise-ior M S) "<") => "M-<") + (check (tok #x3e (bitwise-ior M S) ">") => "M->")) + (test-case "zoom keys: C-+ C-= C-- C-0" + (check (tok #x2b C "") => "C-+") + (check (tok #x3d C "") => "C-=") + (check (tok #x2d C "") => "C--") + (check (tok #x30 C "") => "C-0")) + (test-case "uninterpretable event → #f" + (check (tok #x01000020 0 "") => #f))) ; a bare modifier-ish code, no text + +;;; ─── keymap tree ──────────────────────────────────────────────────────────── +(test-group "keymap tree (define-key! / keymap-ref)" + (test-case "single binding resolves to its command symbol" + (let ((km (new-keymap))) + (define-key! km "C-l" 'set-url) + (check (keymap-ref km "C-l") => 'set-url) + (check (keymap-ref km "C-r") => #f))) + (test-case "chord builds an intermediate sub-keymap" + (let ((km (new-keymap))) + (define-key! km "C-x b" 'switch-buffer) + (check (keymap? (keymap-ref km "C-x")) => #t) + (check (keymap-ref (keymap-ref km "C-x") "b") => 'switch-buffer))) + (test-case "two chords share a prefix node" + (let ((km (new-keymap))) + (define-key! km "C-x b" 'switch-buffer) + (define-key! km "C-x k" 'delete-buffer) + (let ((sub (keymap-ref km "C-x"))) + (check (keymap-ref sub "b") => 'switch-buffer) + (check (keymap-ref sub "k") => 'delete-buffer)))) + (test-case "rebinding a key overwrites" + (let ((km (new-keymap))) + (define-key! km "C-l" 'old) + (define-key! km "C-l" 'set-url) + (check (keymap-ref km "C-l") => 'set-url)))) + +;;; ─── chord dispatcher ──────────────────────────────────────────────────────── +(define (mk-emacsish) + (let ((km (new-keymap))) + (define-key! km "C-l" 'set-url) + (define-key! km "M-x" 'execute-command) + (define-key! km "C-x b" 'switch-buffer) + (define-key! km "C-x k" 'delete-buffer) + (define-key! km "C-x C-c" 'quit) + km)) + +(test-group "dispatcher-feed!" + (test-case "single key fires immediately" + (let ((d (make-key-dispatcher (mk-emacsish)))) + (check (dispatcher-feed! d "C-l") => '(run . set-url)))) + (test-case "chord: prefix pends, then fires" + (let ((d (make-key-dispatcher (mk-emacsish)))) + (check (dispatcher-feed! d "C-x") => 'pending) + (check (dispatcher-feed! d "b") => '(run . switch-buffer)))) + (test-case "nested control chord C-x C-c → quit" + (let ((d (make-key-dispatcher (mk-emacsish)))) + (check (dispatcher-feed! d "C-x") => 'pending) + (check (dispatcher-feed! d "C-c") => '(run . quit)))) + (test-case "unbound key after prefix resets and reports unbound" + (let ((d (make-key-dispatcher (mk-emacsish)))) + (check (dispatcher-feed! d "C-x") => 'pending) + (check (dispatcher-feed! d "z") => 'unbound) + ;; after a miss the dispatcher is back at root: a fresh single key works + (check (dispatcher-feed! d "C-l") => '(run . set-url)))) + (test-case "unbound single key" + (let ((d (make-key-dispatcher (mk-emacsish)))) + (check (dispatcher-feed! d "C-q") => 'unbound))) + (test-case "prefix echo string tracks the chord, clears on fire" + (let ((d (make-key-dispatcher (mk-emacsish)))) + (check (dispatcher-prefix-string d) => "") + (dispatcher-feed! d "C-x") + (check (dispatcher-prefix-string d) => "C-x ") + (dispatcher-feed! d "b") + (check (dispatcher-prefix-string d) => ""))) + (test-case "reset! aborts a pending chord" + (let ((d (make-key-dispatcher (mk-emacsish)))) + (dispatcher-feed! d "C-x") + (dispatcher-reset! d) + (check (dispatcher-prefix-string d) => "") + (check (dispatcher-feed! d "C-l") => '(run . set-url))))) + +;;; ─── end-to-end: a real Qt key sequence drives the dispatcher ─────────────── +(test-group "Qt events → tokens → dispatch (full path)" + (test-case "C-x then b (as Qt events) switches buffer" + (let ((d (make-key-dispatcher (mk-emacsish)))) + ;; Ctrl+X: key code 'X'=#x58, ctrl held, text empty (ctrl suppresses text) + (check (dispatcher-feed! d (tok #x58 C "")) => 'pending) + ;; b: key code 'B'=#x42, no mods + (check (dispatcher-feed! d (tok #x42 0 "b")) => '(run . switch-buffer)))) + (test-case "M-x (as a Qt event) → execute-command" + (let ((d (make-key-dispatcher (mk-emacsish)))) + (check (dispatcher-feed! d (tok #x58 M "x")) => '(run . execute-command))))) + +(newline) +(display "browser-keymap-test: ") (display *pass*) (display " passed, ") +(display *fail*) (display " failed") (newline) +(exit (if (zero? *fail*) 0 1)) new file mode 100644 --- /dev/null +++ b/scheme/browser-minibuffer-test.ss @@ -0,0 +1,192 @@ +#!chezscheme +;;; browser-minibuffer-test.ss — unit tests for (browser fuzzy) + (browser +;;; minibuffer). Pure Scheme: no Qt, no display. +;;; +;;; Run: make test-minibuffer +;;; Exits 0 on success, 1 on any failed case. + +(import (chezscheme) (browser fuzzy) (browser minibuffer)) + +;;; ─── tiny test framework (shared shape with the other test files) ───────── +(define *pass* 0) +(define *fail* 0) +(define *test-name* "(none)") + +(define-syntax test-group + (syntax-rules () + [(_ name body ...) + (begin (display "\n=== ") (display name) (display " ===\n") + (flush-output-port (current-output-port)) + body ...)])) + +(define (run-test-case name thunk) + (set! *test-name* name) + (let ((ok (guard (e (#t + (set! *fail* (+ *fail* 1)) + (display " FAIL: ") (display name) (newline) + (display " error: ") + (display (if (message-condition? e) (condition-message e) + (format "~s" e))) + (newline) (flush-output-port (current-output-port)) #f)) + (thunk) #t))) + (when ok + (set! *pass* (+ *pass* 1)) + (display " pass: ") (display name) (newline) + (flush-output-port (current-output-port))))) + +(define-syntax test-case + (syntax-rules () [(_ name body ...) (run-test-case name (lambda () body ...))])) + +(define-syntax check + (syntax-rules (=> ?) + [(_ expr => expected) + (let ((got expr) (exp expected)) + (unless (equal? got exp) + (error 'check (format "~a: expected ~s, got ~s" *test-name* exp got))))] + [(_ expr ? pred) + (let ((got expr)) + (unless (pred got) + (error 'check (format "~a: predicate failed for ~s" *test-name* got))))])) + +;;; ─── fuzzy matching ─────────────────────────────────────────────────────── +(test-group "fuzzy-match? (subsequence, case-insensitive)" + (test-case "subsequence matches" + (check (fuzzy-match? "swb" "switch-buffer") => #t) + (check (fuzzy-match? "sb" "switch-buffer") => #t) + (check (fuzzy-match? "" "anything") => #t)) + (test-case "case-insensitive" + (check (fuzzy-match? "SWB" "switch-buffer") => #t) + (check (fuzzy-match? "swb" "Switch-Buffer") => #t)) + (test-case "non-subsequence fails" + (check (fuzzy-match? "xyz" "switch-buffer") => #f) + (check (fuzzy-match? "bws" "switch-buffer") => #f) ; wrong order + (check (fuzzy-match? "swbb" "switch-buffer") => #f))) ; one b too many in order? has 2 b's + +(test-group "fuzzy-score (ranking)" + (test-case "match yields a number, miss yields #f" + (check (number? (fuzzy-score "sw" "switch-buffer")) => #t) + (check (fuzzy-score "zz" "switch-buffer") => #f)) + (test-case "prefix beats mid-string match" + (check (> (fuzzy-score "sw" "switch-buffer") + (fuzzy-score "sw" "delete-when-swapped")) => #t)) + (test-case "word-boundary match beats buried match" + ;; "sb" hits two word-starts in switch-buffer (s…, b…) → high + (check (> (fuzzy-score "sb" "switch-buffer") + (fuzzy-score "sb" "subbookkeeper")) => #t)) + (test-case "shorter candidate wins on equal structure" + (check (> (fuzzy-score "ab" "ab") (fuzzy-score "ab" "abxxxxxxxx")) => #t))) + +(test-group "fuzzy-filter" + (define cmds '("switch-buffer" "delete-buffer" "set-url" "set-url-new-buffer" + "reload-current-buffer" "execute-command")) + (test-case "empty query returns all in source order" + (check (fuzzy-filter "" cmds) => cmds)) + (test-case "filters to matches only" + (check (fuzzy-filter "xyz" cmds) => '())) + (test-case "ranks best match first" + (check (car (fuzzy-filter "swb" cmds)) => "switch-buffer")) + (test-case "set-url ranks set-url first over the longer variant" + (check (car (fuzzy-filter "seturl" cmds)) => "set-url")) + (test-case "all returned candidates actually match" + (check (for-all (lambda (c) (fuzzy-match? "buf" c)) (fuzzy-filter "buf" cmds)) => #t)) + (test-case "key proc extracts the match string from a record-ish candidate" + (let ((pairs '((1 . "switch-buffer") (2 . "execute-command") (3 . "set-url")))) + (check (map cdr (fuzzy-filter "exec" pairs cdr)) => '("execute-command"))))) + +;;; ─── minibuffer state machine ───────────────────────────────────────────── +(define (cmd-mb) + (open-minibuffer "M-x " '("switch-buffer" "delete-buffer" "reload-current-buffer" + "set-url" "execute-command"))) + +(test-group "minibuffer: open + filter on type" + (test-case "opens showing all candidates, selection at top" + (let ((mb (cmd-mb))) + (check (minibuffer-candidate-count mb) => 5) + (check (minibuffer-selection mb) => 0) + (check (minibuffer-input mb) => ""))) + (test-case "typing filters and snaps selection to top" + (let ((mb (cmd-mb))) + (minibuffer-self-insert! mb #\s) + (minibuffer-self-insert! mb #\w) + (minibuffer-self-insert! mb #\b) + (check (minibuffer-input mb) => "swb") + (check (minibuffer-selected-string mb) => "switch-buffer") + (check (minibuffer-selection mb) => 0))) + (test-case "backspace widens the filter again" + (let ((mb (cmd-mb))) + (minibuffer-set-input! mb "zzz") + (check (minibuffer-candidate-count mb) => 0) + (check (minibuffer-selected mb) => #f) + (minibuffer-backspace! mb) (minibuffer-backspace! mb) (minibuffer-backspace! mb) + (check (minibuffer-input mb) => "") + (check (minibuffer-candidate-count mb) => 5)))) + +(test-group "minibuffer: selection movement (wraps)" + (test-case "C-n / C-p move and wrap" + (let ((mb (cmd-mb))) + (check (minibuffer-selection mb) => 0) + (minibuffer-next! mb) (check (minibuffer-selection mb) => 1) + (minibuffer-previous! mb) (check (minibuffer-selection mb) => 0) + (minibuffer-previous! mb) (check (minibuffer-selection mb) => 4) ; wrap to last + (minibuffer-next! mb) (check (minibuffer-selection mb) => 0))) ; wrap to first + (test-case "movement is a no-op when there are no candidates" + (let ((mb (cmd-mb))) + (minibuffer-set-input! mb "zzz") + (minibuffer-next! mb) + (check (minibuffer-selection mb) => -1)))) + +(test-group "minibuffer: result semantics" + (test-case "RET on a filtered list yields the selected candidate" + (let ((mb (cmd-mb))) + (minibuffer-set-input! mb "reload") + (check (minibuffer-result mb) => "reload-current-buffer"))) + (test-case "no-candidate prompt returns the raw typed text (set-url style)" + (let ((mb (open-minibuffer "URL: " '()))) + (minibuffer-set-input! mb "example.com") + (check (minibuffer-selected mb) => #f) + (check (minibuffer-result mb) => "example.com")))) + +(test-group "minibuffer-handle-key! (token-driven, as the GUI/keymap feeds it)" + (test-case "type then RET accepts the selection" + (let ((mb (cmd-mb)) (result #f)) + (minibuffer-handle-key! mb "s") + (minibuffer-handle-key! mb "w") + (minibuffer-handle-key! mb "b") + (let ((r (minibuffer-handle-key! mb "RET"))) + (check (pair? r) => #t) + (check (car r) => 'accept) + (check (cdr r) => "switch-buffer")))) + (test-case "C-n before RET picks the next candidate" + (let ((mb (cmd-mb))) + (minibuffer-handle-key! mb "C-n") ; move to index 1 + (let ((r (minibuffer-handle-key! mb "RET"))) + (check (cdr r) => "delete-buffer")))) + (test-case "C-g aborts" + (let ((mb (cmd-mb))) + (check (minibuffer-handle-key! mb "C-g") => 'abort))) + (test-case "escape aborts" + (let ((mb (cmd-mb))) + (check (minibuffer-handle-key! mb "escape") => 'abort))) + (test-case "space self-inserts" + (let ((mb (open-minibuffer "Q: " '("a b c" "abc")))) + (minibuffer-handle-key! mb "a") + (minibuffer-handle-key! mb "space") + (check (minibuffer-input mb) => "a ") + (check (minibuffer-selected-string mb) => "a b c")))) + +(test-group "minibuffer rendering" + (test-case "render shows prompt + input" + (let ((mb (cmd-mb))) + (minibuffer-set-input! mb "sw") + (check (minibuffer-render mb) => "M-x sw"))) + (test-case "candidate strings mark the selection with >" + (let ((mb (cmd-mb))) + (minibuffer-set-input! mb "buffer") + (let ((lines (minibuffer-candidate-strings mb 10))) + (check (> (length lines) 0) => #t) + (check (char=? (string-ref (car lines) 0) #\>) => #t))))) + +(newline) +(display "browser-minibuffer-test: ") (display *pass*) (display " passed, ") +(display *fail*) (display " failed") (newline) +(exit (if (zero? *fail*) 0 1)) new file mode 100644 --- /dev/null +++ b/scheme/browser/commands.ss @@ -0,0 +1,257 @@ +#!chezscheme +;;; (browser commands) — the command table, the emacs keyscheme, and the app +;;; controller that ties keymap + minibuffer + session together. +;;; +;;; This is where nyxt's feel comes together: every interactive verb is a named +;;; command (so M-x can list+run them all), the emacs keymap binds key chords to +;;; those names, and the `app` controller routes each canonical key token — +;;; either to the chord dispatcher (top level) or to the open prompt-buffer +;;; (minibuffer). Commands that need input (switch-buffer, set-url, M-x) open a +;;; fuzzy prompt and register an action to run on RET. +;;; +;;; The controller is pure dispatch logic over (browser buffers) + the window +;;; chrome, so the offscreen functional tests drive the exact code the GUI's Qt +;;; key-event filter will call (`app-feed-token!`). + +(library (browser commands) + (export + make-browser-app app? app-session app-keymap app-dispatcher + app-minibuffer app-echo app-should-quit? + app-feed-token! app-type! app-render! + emacs-keymap buffer-label + register-command! command-ref command-names + command? command-name command-doc command-proc + run-command-by-name) + + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (except (jerboa prelude) meta atom?) + (browser) + (browser buffers) + (browser keymap) + (browser minibuffer)) + + ;; --- string helpers ----------------------------------------------------- + (def (substr? hay needle) + (let ((hn (string-length hay)) (nn (string-length needle))) + (let loop ((i 0)) + (cond ((> (+ i nn) hn) #f) + ((string=? (substring hay i (+ i nn)) needle) #t) + (else (loop (+ i 1))))))) + + (def (about? u) (and (>= (string-length u) 6) (string=? (substring u 0 6) "about:"))) + + ;; Bare host (news.ycombinator.com) gets an https scheme; about: / full URLs + ;; pass through untouched. + (def (normalize-url u) + (if (or (substr? u "://") (about? u)) u (string-append "https://" u))) + + ;; --- command registry --------------------------------------------------- + ;; A command is a named, documented thunk-of-app. The registry is keyed by the + ;; command symbol; M-x lists names (strings) and runs by name. + (defstruct command (name doc proc)) + (def *commands* (make-eq-hashtable)) + + (def (register-command! name doc proc) + (hashtable-set! *commands* name (make-command name doc proc))) + (def (command-ref name) (hashtable-ref *commands* name #f)) + (def (command-names) + (list-sort string<? + (map symbol->string (vector->list (hashtable-keys *commands*))))) + + ;; --- the app controller ------------------------------------------------- + ;; session : the (browser buffers) session (window + buffers) + ;; keymap : the root keymap (emacs scheme) + ;; dispatcher : chord dispatcher walking `keymap` + ;; minibuffer : the open prompt, or #f when none + ;; prompt-action : (app result) -> _, run when the open prompt accepts (RET) + ;; echo : last echo-area message (status/debug; shown in Stage 6) + ;; quit : set #t by the quit command + (defstruct app (session keymap dispatcher minibuffer prompt-action echo quit)) + + (def (make-browser-app session) + (let* ((km (emacs-keymap)) (d (make-key-dispatcher km))) + (make-app session km d #f #f "" #f))) + + (def (app-should-quit? app) (and (app-quit app) #t)) + (def (app-window app) (session-window (app-session app))) + + ;; Reflect controller state into the window chrome: show the prompt line while + ;; a minibuffer is open (hide it otherwise) and refresh the status line. + (def (app-render! app) + (let ((mb (app-minibuffer app)) (win (app-window app))) + (if mb + (browser-window-set-minibuffer win (minibuffer-render mb) #t) + (browser-window-set-minibuffer win "" #f)) + (session-update-status! (app-session app)))) + + (def (open-prompt! app prompt candidates key action) + (app-minibuffer-set! app (open-minibuffer prompt candidates key)) + (app-prompt-action-set! app action)) + (def (close-prompt! app) + (app-minibuffer-set! app #f) + (app-prompt-action-set! app #f)) + + ;; --- key routing -------------------------------------------------------- + ;; Feed one canonical key token (e.g. "C-x", "b", "RET"). When a prompt is + ;; open the token drives the minibuffer; otherwise it walks the chord tree. + ;; Returns a status for the tests/GUI: + ;; 'pending | 'unbound | 'continue | 'abort | 'accepted | (cons 'ran NAME) + (def (app-feed-token! app token) + (let ((r (if (app-minibuffer app) + (feed-minibuffer app token) + (feed-command app token)))) + (app-render! app) + r)) + + (def (feed-command app token) + (let ((r (dispatcher-feed! (app-dispatcher app) token))) + (cond + ((eq? r 'pending) + (app-echo-set! app (dispatcher-prefix-string (app-dispatcher app))) + 'pending) + ((eq? r 'unbound) + (app-echo-set! app (string-append token " is undefined")) + 'unbound) + (else ; (cons 'run NAME) + (app-echo-set! app "") + (run-command app (cdr r)) + (cons 'ran (cdr r)))))) + + (def (feed-minibuffer app token) + (let ((res (minibuffer-handle-key! (app-minibuffer app) token))) + (cond + ((eq? res 'continue) 'continue) + ((eq? res 'abort) (close-prompt! app) (app-echo-set! app "Quit") 'abort) + (else ; (cons 'accept VALUE) + (let ((action (app-prompt-action app)) (value (cdr res))) + (close-prompt! app) + (when action (action app value)) + 'accepted))))) + + (def (run-command app name) + (let ((c (command-ref name))) + (when c ((command-proc c) app)))) + + (def (run-command-by-name app name) + (let ((sym (string->symbol name))) + (if (command-ref sym) + (run-command app sym) + (app-echo-set! app (string-append "No command: " name))))) + + ;; Type a literal string into the app, one self-insert token per char (used by + ;; tests to fill a prompt: (app-type! app "swb")). + (def (app-type! app str) + (string-for-each (lambda (ch) (app-feed-token! app (string ch))) str)) + + ;; --- command implementations -------------------------------------------- + (def (buffer-label b) + (let ((title (buffer-title b)) (url (buffer-url b))) + (cond ((> (string-length title) 0) title) + ((> (string-length url) 0) url) + (else (string-append "buffer " (number->string (buffer-id b))))))) + + (def (current-view app) + (let ((b (session-current-buffer (app-session app)))) + (and b (buffer-view b)))) + + ;; --- the emacs keyscheme (from nyxt source/mode/base.lisp) --------------- + ;; Defined before the command registrations below because an R6RS library body + ;; must place every definition ahead of any (register-command! …) expression. + (def emacs-bindings + '(("C-l" . set-url) + ("M-l" . set-url-new-buffer) + ("C-r" . reload-current-buffer) + ("C-x b" . switch-buffer) + ("C-x C-b" . switch-buffer) ; list-buffers ≈ switch for now + ("M-n" . switch-buffer-next) + ("M-p" . switch-buffer-previous) + ("C-`" . switch-buffer-last) + ("C-t" . make-buffer-focus) + ("C-x k" . delete-buffer) + ("C-x C-k" . delete-current-buffer) + ("M-x" . execute-command) + ("C-b" . history-backwards) + ("C-f" . history-forwards) + ("C-x C-c" . quit) + ("C-g" . keyboard-quit))) + + (def (emacs-keymap) + (let ((km (new-keymap))) + (for-each (lambda (b) (define-key! km (car b) (cdr b))) emacs-bindings) + km)) + + (register-command! 'switch-buffer "Switch to a buffer (fuzzy)." + (lambda (app) + (let ((s (app-session app))) + (open-prompt! app "Switch to buffer: " (session-buffer-list s) buffer-label + (lambda (app buf) (when (buffer? buf) (session-switch! s buf))))))) + + (register-command! 'delete-buffer "Close a buffer chosen from the list (fuzzy)." + (lambda (app) + (let ((s (app-session app))) + (open-prompt! app "Delete buffer: " (session-buffer-list s) buffer-label + (lambda (app buf) (when (buffer? buf) (session-close-buffer! s buf))))))) + + (register-command! 'delete-current-buffer "Close the current buffer." + (lambda (app) + (let* ((s (app-session app)) (b (session-current-buffer s))) + (when b (session-close-buffer! s b))))) + + (register-command! 'make-buffer-focus "Open a new buffer and focus it." + (lambda (app) (session-open-buffer (app-session app) "about:blank"))) + + (register-command! 'set-url "Load a URL in the current buffer." + (lambda (app) + (open-prompt! app "URL: " '() (lambda (x) x) + (lambda (app url) + (let ((v (current-view app))) + (when (and v (string? url) (> (string-length url) 0)) + (browser-load v (normalize-url url)))))))) + + (register-command! 'set-url-new-buffer "Open a URL in a new buffer." + (lambda (app) + (open-prompt! app "URL (new buffer): " '() (lambda (x) x) + (lambda (app url) + (when (and (string? url) (> (string-length url) 0)) + (session-open-buffer (app-session app) (normalize-url url))))))) + + (register-command! 'reload-current-buffer "Reload the current buffer." + (lambda (app) (let ((v (current-view app))) (when v (browser-reload v))))) + + (register-command! 'history-backwards "Go back in the current buffer's history." + (lambda (app) (let ((v (current-view app))) (when v (browser-back v))))) + + (register-command! 'history-forwards "Go forward in the current buffer's history." + (lambda (app) (let ((v (current-view app))) (when v (browser-forward v))))) + + (register-command! 'switch-buffer-next "Switch to the next buffer (cyclic)." + (lambda (app) (session-switch-next! (app-session app)))) + (register-command! 'switch-buffer-previous "Switch to the previous buffer (cyclic)." + (lambda (app) (session-switch-previous! (app-session app)))) + (register-command! 'switch-buffer-last "Switch to the most recently opened buffer." + (lambda (app) (session-switch-last! (app-session app)))) + + (register-command! 'execute-command "Run a command by name (fuzzy)." + (lambda (app) + (open-prompt! app "M-x " (command-names) (lambda (x) x) + (lambda (app name) (run-command-by-name app name))))) + + (register-command! 'keyboard-quit "Abort the current chord / prompt." + (lambda (app) + (dispatcher-reset! (app-dispatcher app)) + (app-echo-set! app "Quit"))) + + (register-command! 'quit "Quit the browser." + (lambda (app) + (app-quit-set! app #t) + (guard (e (#t #f)) (browser-quit)))) + + ) ; library (browser commands) new file mode 100644 --- /dev/null +++ b/scheme/browser/fuzzy.ss @@ -0,0 +1,84 @@ +#!chezscheme +;;; (browser fuzzy) — nyxt-style fuzzy completion scoring + filtering. +;;; +;;; A query matches a candidate when its characters appear, in order, somewhere +;;; in the candidate (a case-insensitive subsequence) — so "swb" matches +;;; "switch-buffer". The score rewards matches at word boundaries (start of the +;;; string or just after a separator like - _ / . space) and consecutive runs, +;;; and lightly penalises longer candidates, so the best/shortest match floats +;;; to the top — the behaviour you feel in nyxt's prompt-buffer. +;;; +;;; Pure Scheme, no Qt: `(browser minibuffer)` and the tests use it directly. + +(library (browser fuzzy) + (export fuzzy-match? fuzzy-score fuzzy-filter) + + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (except (jerboa prelude) meta atom?)) + + ;; Characters that mark a word boundary; a query char landing right after one + ;; (or at index 0) scores like the start of a "word". + (def sep-chars (string->list " -_/.\\:#?&=@%+")) + (def (sep? c) (and (memv c sep-chars) #t)) + + ;; Score `cand` against `query`. Returns a number (higher is better) when + ;; `query` is a case-insensitive subsequence of `cand`, or #f when it is not. + ;; An empty query trivially matches with score 0 (the caller decides ordering). + ;; The scan is greedy-leftmost — which is exact for the match/no-match + ;; decision, and a good-enough heuristic for ranking. + (def (fuzzy-score query cand) + (let* ((q (string-downcase query)) + (c (string-downcase cand))