Sprint 1 Tier 1: Add qt/keymap and qt/buffer modules
ober
6e74beed3c34af533e840d6a4dfb392ffc1350da
new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/qt/buffer.sls @@ -0,0 +1,54 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jerboa-emacs/qt/buffer.ss + +(library (jerboa-emacs qt buffer) + (export qt-buffer-create! qt-buffer-kill! qt-buffer-attach!) + (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) (jerboa-emacs core) + (jerboa core) (jerboa runtime)) + (def (qt-buffer-create! name editor (file-path #f)) + "Create buffer with a new Scintilla document." + (verbose-log! + "qt-buffer-create! name=" + name + " file=" + (or file-path "#f")) + (let* ([doc (sci-send editor SCI_CREATEDOCUMENT 0 0)] + [buf (make-buffer name file-path doc #f #f #f #f)]) + (doc-editor-register! doc editor) + (doc-buffer-register! doc buf) + (buffer-list-add! buf) + (verbose-log! "qt-buffer-create! done name=" name) + buf)) + (def (qt-buffer-kill! buf) + "Release the Scintilla document and remove from buffer list.\n For image buffers, also destroys the pixmap." + (let* ([doc (buffer-doc-pointer buf)] + [ed (hash-get *doc-editor-map* doc)]) + (when ed (sci-send ed SCI_RELEASEDOCUMENT 0 doc)) + (let ([state (hash-get *image-buffer-state* buf)]) + (when state + (qt-pixmap-destroy! (car state)) + (hash-remove! *image-buffer-state* buf))) + (hash-remove! *doc-editor-map* doc) + (hash-remove! *doc-buffer-map* doc) + (buffer-list-remove! buf))) + (def (qt-buffer-attach! editor buf) + "Switch editor to display this buffer's document.\n Re-applies the document's read-only state after swap because QScintilla\n may have a widget-level readOnly flag that persists across document switches.\n Runs post-buffer-attach-hook to handle image/text display toggling." + (verbose-log! "qt-buffer-attach! buf=" (buffer-name buf)) + (let ([doc (buffer-doc-pointer buf)]) + (verbose-log! "qt-buffer-attach! SCI_SETDOCPOINTER begin") + (sci-send editor SCI_SETDOCPOINTER 0 doc) + (verbose-log! "qt-buffer-attach! SCI_SETDOCPOINTER done") + (doc-editor-register! doc editor) + (let ([ro (sci-send editor SCI_GETREADONLY)]) + (sci-send editor SCI_SETREADONLY ro)) + (verbose-log! + "qt-buffer-attach! post-buffer-attach-hook begin") + (run-hooks! 'post-buffer-attach-hook editor buf) + (verbose-log! + "qt-buffer-attach! done buf=" + (buffer-name buf))))) new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/qt/keymap.sls @@ -0,0 +1,108 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jerboa-emacs/qt/keymap.ss + +(library (jerboa-emacs qt keymap) + (export + qt-key-event->string + qt-key-state-feed! + normalize-qt-mods) + (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) (jerboa-emacs core) + (jerboa core) (jerboa runtime)) + (def macos-platform? (file-exists? "/System/Library")) + (def (normalize-qt-mods mods) + "Normalize Qt modifier bitmask for cross-platform Emacs key behavior.\n On macOS, physical Ctrl → QT_MOD_META; we remap it to QT_MOD_CTRL so\n physical Ctrl works as the C- prefix, matching Emacs conventions." + (if (and macos-platform? + (not (zero? (bitwise-and mods QT_MOD_META)))) + (bitwise-ior + (bitwise-and mods (bitwise-not QT_MOD_META)) + QT_MOD_CTRL) + mods)) + (def (qt-key-event->string code mods text) + "Convert Qt key code + modifiers to Emacs key string.\n Returns #f for bare modifier keys (Shift, Ctrl, Alt, etc.) that should be ignored." + (if (and (>= code 16777248) (<= code 16777254)) + #f + (let ([ctrl? (not (zero? (bitwise-and mods QT_MOD_CTRL)))] + [alt? (not (zero? (bitwise-and mods QT_MOD_ALT)))] + [shift? (not (zero? (bitwise-and mods QT_MOD_SHIFT)))]) + (cond + [(= code QT_KEY_F1) "<f1>"] + [(= code QT_KEY_F2) "<f2>"] + [(= code QT_KEY_F3) "<f3>"] + [(= code QT_KEY_F4) "<f4>"] + [(= code QT_KEY_F5) "<f5>"] + [(= code QT_KEY_F6) "<f6>"] + [(= code QT_KEY_F7) "<f7>"] + [(= code QT_KEY_F8) "<f8>"] + [(= code QT_KEY_F9) "<f9>"] + [(= code QT_KEY_F10) "<f10>"] + [(= code QT_KEY_F11) "<f11>"] + [(= code QT_KEY_F12) "<f12>"] + [(= code QT_KEY_UP) (if alt? "M-<up>" "<up>")] + [(= code QT_KEY_DOWN) (if alt? "M-<down>" "<down>")] + [(= code QT_KEY_LEFT) (if alt? "M-<left>" "<left>")] + [(= code QT_KEY_RIGHT) (if alt? "M-<right>" "<right>")] + [(= code QT_KEY_HOME) "<home>"] + [(= code QT_KEY_END) "<end>"] + [(= code QT_KEY_PAGE_UP) "<prior>"] + [(= code QT_KEY_PAGE_DOWN) "<next>"] + [(= code QT_KEY_DELETE) "<delete>"] + [(= code QT_KEY_INSERT) "<insert>"] + [(= code QT_KEY_ESCAPE) "ESC"] + [(or (= code QT_KEY_RETURN) (= code QT_KEY_ENTER)) + (if ctrl? "C-m" "C-m")] + [(= code QT_KEY_TAB) (if ctrl? "C-i" "TAB")] + [(= code QT_KEY_BACKSPACE) (if alt? "M-DEL" "DEL")] + [(= code QT_KEY_SPACE) + (cond + [(and ctrl? alt?) "C-M-SPC"] + [ctrl? "C-@"] + [alt? "M-SPC"] + [else "SPC"])] + [(and ctrl? (>= code QT_KEY_A) (<= code QT_KEY_Z)) + (let ([ch (string + (integer->char (+ (- code QT_KEY_A) 97)))]) + (if alt? + (string-append "C-M-" ch) + (string-append "C-" ch)))] + [(and ctrl? (= code QT_KEY_SPACE)) "C-@"] + [(and alt? (= (string-length text) 1)) + (string-append "M-" text)] + [(and (= (string-length text) 1) (not ctrl?) (not alt?)) + text] + [else (string-append "<key-" (number->string code) ">")])))) + (def (qt-key-state-feed! state code mods text) + "Feed a Qt key event into the keymap state machine.\n Returns (values action data new-state) — same protocol as TUI version." + (let ([key-str (qt-key-event->string code mods text)]) + (if (not key-str) + (values 'ignore #f state) + (let ([binding (keymap-lookup + (key-state-keymap state) + key-str)]) + (cond + [(hash-table? binding) + (values + 'prefix + key-str + (make-key-state + binding + (append + (key-state-prefix-keys state) + (list key-str))))] + [(symbol? binding) + (values 'command binding (make-initial-key-state))] + [(and (null? (key-state-prefix-keys state)) + (= (string-length text) 1) + (> (char->integer (string-ref text 0)) 31) + (not (not (zero? (bitwise-and mods QT_MOD_CTRL)))) + (not (not (zero? (bitwise-and mods QT_MOD_ALT))))) + (values 'self-insert text (make-initial-key-state))] + [else + (values + 'undefined + key-str + (make-initial-key-state))])))))) new file mode 100644 --- /dev/null +++ b/src/jerboa-emacs/qt/buffer.ss @@ -0,0 +1,66 @@ +;;; -*- Gerbil -*- +;;; Qt document management for jerboa-emacs +;;; +;;; Ported from gerbil-emacs/qt/buffer.ss +;;; Uses Scintilla document model for multi-buffer support. +;;; Each buffer owns a Scintilla document (preserves undo history per buffer). + +(export qt-buffer-create! + qt-buffer-kill! + qt-buffer-attach!) + +(import :std/sugar + :jerboa-emacs/qt/sci-shim + :jerboa-emacs/core) + +;;;============================================================================ +;;; Qt buffer operations +;;;============================================================================ + +(def (qt-buffer-create! name editor (file-path #f)) + "Create buffer with a new Scintilla document." + (verbose-log! "qt-buffer-create! name=" name " file=" (or file-path "#f")) + (let* ((doc (sci-send editor SCI_CREATEDOCUMENT 0 0)) + (buf (make-buffer name file-path doc #f #f #f #f))) + (doc-editor-register! doc editor) + (doc-buffer-register! doc buf) + (buffer-list-add! buf) + (verbose-log! "qt-buffer-create! done name=" name) + buf)) + +(def (qt-buffer-kill! buf) + "Release the Scintilla document and remove from buffer list. + For image buffers, also destroys the pixmap." + (let* ((doc (buffer-doc-pointer buf)) + (ed (hash-get *doc-editor-map* doc))) + (when ed + (sci-send ed SCI_RELEASEDOCUMENT 0 doc)) + ;; Clean up image buffer state if applicable + (let ((state (hash-get *image-buffer-state* buf))) + (when state + (qt-pixmap-destroy! (car state)) + (hash-remove! *image-buffer-state* buf))) + (hash-remove! *doc-editor-map* doc) + (hash-remove! *doc-buffer-map* doc) + (buffer-list-remove! buf))) + +(def (qt-buffer-attach! editor buf) + "Switch editor to display this buffer's document. + Re-applies the document's read-only state after swap because QScintilla + may have a widget-level readOnly flag that persists across document switches. + Runs post-buffer-attach-hook to handle image/text display toggling." + (verbose-log! "qt-buffer-attach! buf=" (buffer-name buf)) + (let ((doc (buffer-doc-pointer buf))) + (verbose-log! "qt-buffer-attach! SCI_SETDOCPOINTER begin") + (sci-send editor SCI_SETDOCPOINTER 0 doc) + (verbose-log! "qt-buffer-attach! SCI_SETDOCPOINTER done") + (doc-editor-register! doc editor) + ;; Force QScintilla widget to sync with the new document's read-only state. + ;; Without this, viewing a read-only buffer (e.g. *Buffer List*) makes all + ;; subsequent buffers uneditable. + (let ((ro (sci-send editor SCI_GETREADONLY))) + (sci-send editor SCI_SETREADONLY ro)) + (verbose-log! "qt-buffer-attach! post-buffer-attach-hook begin") + ;; Toggle image/editor display via hook (set up in qt/app.ss) + (run-hooks! 'post-buffer-attach-hook editor buf) + (verbose-log! "qt-buffer-attach! done buf=" (buffer-name buf)))) new file mode 100644 --- /dev/null +++ b/src/jerboa-emacs/qt/keymap.ss @@ -0,0 +1,138 @@ +;;; -*- Gerbil -*- +;;; Qt key event adapter for jerboa-emacs +;;; +;;; Ported from gerbil-emacs/qt/keymap.ss +;;; Converts Qt key events to the same "C-x", "M-f", "<up>" string format +;;; used by the shared keymap in core.ss. + +(export qt-key-event->string + qt-key-state-feed! + normalize-qt-mods) + +(import :std/sugar + :jerboa-emacs/qt/sci-shim + :jerboa-emacs/core) + +;;;============================================================================ +;;; Platform detection and modifier normalization +;;;============================================================================ + +;; On macOS, Qt maps physical Ctrl → Qt::MetaModifier and Command → Qt::ControlModifier. +;; Detect macOS by checking for /System/Library (exists on all macOS, not on Linux/Windows). +(def macos-platform? (file-exists? "/System/Library")) + +(def (normalize-qt-mods mods) + "Normalize Qt modifier bitmask for cross-platform Emacs key behavior. + On macOS, physical Ctrl → QT_MOD_META; we remap it to QT_MOD_CTRL so + physical Ctrl works as the C- prefix, matching Emacs conventions." + (if (and macos-platform? + (not (zero? (bitwise-and mods QT_MOD_META)))) + (bitwise-ior (bitwise-and mods (bitwise-not QT_MOD_META)) + QT_MOD_CTRL) + mods)) + +;;;============================================================================ +;;; Qt key event -> Emacs key string conversion +;;;============================================================================ + +(def (qt-key-event->string code mods text) + "Convert Qt key code + modifiers to Emacs key string. + Returns #f for bare modifier keys (Shift, Ctrl, Alt, etc.) that should be ignored." + (if (and (>= code #x01000020) (<= code #x01000026)) + #f ;; Bare modifier keys — ignore + (let ((ctrl? (not (zero? (bitwise-and mods QT_MOD_CTRL)))) + (alt? (not (zero? (bitwise-and mods QT_MOD_ALT)))) + (shift? (not (zero? (bitwise-and mods QT_MOD_SHIFT))))) + (cond + ;; Function keys + ((= code QT_KEY_F1) "<f1>") + ((= code QT_KEY_F2) "<f2>") + ((= code QT_KEY_F3) "<f3>") + ((= code QT_KEY_F4) "<f4>") + ((= code QT_KEY_F5) "<f5>") + ((= code QT_KEY_F6) "<f6>") + ((= code QT_KEY_F7) "<f7>") + ((= code QT_KEY_F8) "<f8>") + ((= code QT_KEY_F9) "<f9>") + ((= code QT_KEY_F10) "<f10>") + ((= code QT_KEY_F11) "<f11>") + ((= code QT_KEY_F12) "<f12>") + ;; Navigation keys + ((= code QT_KEY_UP) (if alt? "M-<up>" "<up>")) + ((= code QT_KEY_DOWN) (if alt? "M-<down>" "<down>")) + ((= code QT_KEY_LEFT) (if alt? "M-<left>" "<left>")) + ((= code QT_KEY_RIGHT) (if alt? "M-<right>" "<right>")) + ((= code QT_KEY_HOME) "<home>") + ((= code QT_KEY_END) "<end>") + ((= code QT_KEY_PAGE_UP) "<prior>") + ((= code QT_KEY_PAGE_DOWN) "<next>") + ((= code QT_KEY_DELETE) "<delete>") + ((= code QT_KEY_INSERT) "<insert>") + ;; ESC + ((= code QT_KEY_ESCAPE) "ESC") + ;; Return/Enter + ((or (= code QT_KEY_RETURN) (= code QT_KEY_ENTER)) + (if ctrl? "C-m" "C-m")) + ;; Tab + ((= code QT_KEY_TAB) + (if ctrl? "C-i" "TAB")) + ;; Backspace + ((= code QT_KEY_BACKSPACE) + (if alt? "M-DEL" "DEL")) + ;; Space + ((= code QT_KEY_SPACE) + (cond + ((and ctrl? alt?) "C-M-SPC") + (ctrl? "C-@") ;; C-SPC = C-@ in Emacs + (alt? "M-SPC") + (else "SPC"))) + ;; Ctrl+letter (A-Z) + ((and ctrl? (>= code QT_KEY_A) (<= code QT_KEY_Z)) + (let ((ch (string (integer->char (+ (- code QT_KEY_A) 97))))) + (if alt? + (string-append "C-M-" ch) + (string-append "C-" ch)))) + ;; Ctrl+special keys + ((and ctrl? (= code QT_KEY_SPACE)) "C-@") + ;; Alt + printable character from text + ((and alt? (= (string-length text) 1)) + (string-append "M-" text)) + ;; Regular printable character from text + ((and (= (string-length text) 1) (not ctrl?) (not alt?)) + text) + ;; Unknown key + (else + (string-append "<key-" (number->string code) ">")))))) + +;;;============================================================================ +;;; Qt key state machine — feeds Qt key events into keymap +;;;============================================================================ + +(def (qt-key-state-feed! state code mods text) + "Feed a Qt key event into the keymap state machine. + Returns (values action data new-state) — same protocol as TUI version." + (let ((key-str (qt-key-event->string code mods text))) + ;; Bare modifier keys return #f — ignore them + (if (not key-str) + (values 'ignore #f state) + (let ((binding (keymap-lookup (key-state-keymap state) key-str))) + (cond + ;; Sub-keymap -> enter prefix mode + ((hash-table? binding) + (values 'prefix key-str + (make-key-state binding + (append (key-state-prefix-keys state) + (list key-str))))) + ;; Command symbol -> execute + ((symbol? binding) + (values 'command binding (make-initial-key-state))) + ;; No binding, top level, printable text -> self-insert + ((and (null? (key-state-prefix-keys state)) + (= (string-length text) 1) + (> (char->integer (string-ref text 0)) 31) + (not (not (zero? (bitwise-and mods QT_MOD_CTRL)))) + (not (not (zero? (bitwise-and mods QT_MOD_ALT))))) + (values 'self-insert text (make-initial-key-state))) + ;; No binding -> undefined + (else + (values 'undefined key-str (make-initial-key-state))))))))