Add tree-sitter integration for syntax highlighting
ober
feecfaca96f77228902583f6dc9f5148ca34897a
--- a/Dockerfile +++ b/Dockerfile @@ -188,6 +188,52 @@ RUN git clone --depth 1 --branch ${CHEZ_TAG} \ make install && \ rm -rf /tmp/ChezScheme +# ── Phase 5.5: Build tree-sitter + grammars (static) ────────────────── +ARG TS_VERSION=0.24.7 +RUN git clone --depth 1 --branch v${TS_VERSION} \ + https://github.com/tree-sitter/tree-sitter /tmp/tree-sitter && \ + cd /tmp/tree-sitter && \ + cc -c -O2 -Ilib/include lib/src/lib.c -o lib/src/lib.o && \ + ar rcs /opt/tree-sitter-lib/libtree-sitter.a lib/src/lib.o && \ + mkdir -p /opt/tree-sitter-include/tree_sitter && \ + cp lib/include/tree_sitter/api.h /opt/tree-sitter-include/tree_sitter/ && \ + rm -rf /tmp/tree-sitter + +# Build tree-sitter grammar static archives +RUN mkdir -p /opt/tree-sitter-grammars && \ + build_grammar() { \ + name=$1; repo=$2; tag=$3; subdir=${4:-.}; \ + git clone --depth 1 --branch "$tag" \ + "https://github.com/$repo" /tmp/ts-$name 2>/dev/null && \ + cd /tmp/ts-$name/$subdir && \ + SRC_DIR=src && \ + gcc -c -O2 -I/opt/tree-sitter-include -I$SRC_DIR \ + $SRC_DIR/parser.c -o parser.o && \ + if [ -f $SRC_DIR/scanner.c ]; then \ + gcc -c -O2 -I/opt/tree-sitter-include -I$SRC_DIR \ + $SRC_DIR/scanner.c -o scanner.o && \ + ar rcs /opt/tree-sitter-grammars/libtree-sitter-$name.a parser.o scanner.o; \ + else \ + ar rcs /opt/tree-sitter-grammars/libtree-sitter-$name.a parser.o; \ + fi && \ + cd / && rm -rf /tmp/ts-$name; \ + } && \ + build_grammar c tree-sitter/tree-sitter-c v0.23.5 && \ + build_grammar cpp tree-sitter/tree-sitter-cpp v0.23.6 && \ + build_grammar python tree-sitter/tree-sitter-python v0.23.6 && \ + build_grammar javascript tree-sitter/tree-sitter-javascript v0.23.1 && \ + build_grammar rust tree-sitter/tree-sitter-rust v0.23.3 && \ + build_grammar go tree-sitter/tree-sitter-go v0.23.4 && \ + build_grammar bash tree-sitter/tree-sitter-bash v0.23.3 && \ + build_grammar json tree-sitter/tree-sitter-json v0.24.8 && \ + build_grammar ruby tree-sitter/tree-sitter-ruby v0.23.1 && \ + build_grammar java tree-sitter/tree-sitter-java v0.23.5 && \ + build_grammar css tree-sitter/tree-sitter-css v0.23.2 && \ + build_grammar html tree-sitter/tree-sitter-html v0.23.2 && \ + build_grammar lua tree-sitter-grammars/tree-sitter-lua v0.3.0 && \ + build_grammar scheme 6cdh/tree-sitter-scheme master && \ + echo "Grammars built:" && ls /opt/tree-sitter-grammars/ + # ── Phase 6: Gerbil/Chez dependencies ────────────────────────────────── ENV PKG_CONFIG_PATH=/opt/qt6-static/lib/pkgconfig ENV SCHEME=/opt/chez/bin/scheme --- a/Makefile +++ b/Makefile @@ -310,6 +310,11 @@ build-jemacs-qt-static: check-root JEMACS_STATIC=1 /opt/chez/bin/scheme --libdirs /src/lib \ --compile-imported-libraries --script /src/vendor/jerboa-compile-repl-socket.ss && \ rm -f /src/lib/jerboa/*.wpo && \ + echo "Building tree-sitter shim + queries..." && \ + gcc -c -O2 -I/opt/tree-sitter-include -o /tmp/jemacs-build/treesitter_shim.o \ + /src/support/treesitter_shim.c -Wall && \ + gcc -c -O2 -o /tmp/jemacs-build/treesitter_queries.o \ + /src/support/treesitter_queries.c -Wall && \ JEMACS_STATIC=1 \ CHEZ_DIR=$(CHEZ_MUSL_DIR) \ JERBOA_DIR=/deps/jerboa/lib \ @@ -320,6 +325,11 @@ build-jemacs-qt-static: check-root CHEZ_QT_DIR=/deps/chez-qt \ CHEZ_QT_SHIM_DIR=/deps/gerbil-qt/vendor \ COREUTILS_DIR=/deps/coreutils \ + TREE_SITTER_INCLUDE=/opt/tree-sitter-include \ + TREE_SITTER_LIB=/opt/tree-sitter-lib \ + TREE_SITTER_GRAMMARS=/opt/tree-sitter-grammars \ + TREE_SITTER_SHIM_OBJ=/tmp/jemacs-build/treesitter_shim.o \ + TREE_SITTER_QUERIES_OBJ=/tmp/jemacs-build/treesitter_queries.o \ PKG_CONFIG_PATH=/opt/qt6-static/lib/pkgconfig \ /opt/chez/bin/scheme \ --libdirs lib:/deps/jerboa/lib:/deps/jsh/src:/deps/coreutils:/deps/gherkin/src:/deps/chez-pcre2:/deps/chez-scintilla/src:/deps/chez-qt \ --- a/build-binary-qt.ss +++ b/build-binary-qt.ss @@ -281,7 +281,11 @@ ;; Qt-specific modules (map (lambda (m) (format "lib/jerboa-emacs/qt/~a.so" m)) '(;; Foundation - "sci-shim" "keymap" "buffer" "echo" + "sci-shim" "keymap")) + ;; treesitter must come before qt/buffer (which imports it) + (list "lib/jerboa-emacs/treesitter.so") + (map (lambda (m) (format "lib/jerboa-emacs/qt/~a.so" m)) + '("buffer" "echo" "image" "magit" "highlight" "modeline" "window" "lsp-client" "helm-qt" @@ -510,15 +514,27 @@ echo OK" "-lQt6Widgets -lQt6Gui -lQt6Core")) (qt-plugins (format "~a/qt_static_plugins.o" qt-shim-dir)) (libqt-shim (format "~a/libqt_shim.a" qt-shim-dir)) + ;; Tree-sitter objects and libraries + (ts-shim-obj (or (getenv "TREE_SITTER_SHIM_OBJ") "")) + (ts-queries-obj (or (getenv "TREE_SITTER_QUERIES_OBJ") "")) + (ts-lib-dir (or (getenv "TREE_SITTER_LIB") "/opt/tree-sitter-lib")) + (ts-gram-dir (or (getenv "TREE_SITTER_GRAMMARS") "/opt/tree-sitter-grammars")) + (ts-link (format "~a ~a -L~a -ltree-sitter \ +-L~a -ltree-sitter-c -ltree-sitter-cpp -ltree-sitter-python \ +-ltree-sitter-javascript -ltree-sitter-rust -ltree-sitter-go \ +-ltree-sitter-bash -ltree-sitter-json -ltree-sitter-ruby \ +-ltree-sitter-java -ltree-sitter-css -ltree-sitter-html \ +-ltree-sitter-lua -ltree-sitter-scheme" + ts-shim-obj ts-queries-obj ts-lib-dir ts-gram-dir)) (cmd (format "g++ -static -Wl,--export-dynamic -o jemacs-qt \ jemacs-qt-main.o jemacs-qt-chez-shim.o jemacs-qt-pcre2-shim.o jemacs-qt-jsh-ffi.o \ jemacs-qt-embed-crypto.o jemacs-qt-ssh-agent-stub.o \ jemacs-qt-pty-shim.o jemacs-qt-vterm-shim.o jemacs-qt-repl-shim.o jemacs-qt-jerboa-landlock.o jemacs-qt-sci-stubs.o \ qt_static_symbols.o \ -~a ~a ~a ~a \ +~a ~a ~a ~a ~a \ -L~a -lkernel -llz4 -lz \ -lvterm -lm -ldl -lpthread -luuid -lncurses -lstdc++ 2>&1" - libqt-shim qt-plugins qt-libs pcre2-libs + libqt-shim qt-plugins ts-link qt-libs pcre2-libs chez-dir))) (printf " ~a~n" cmd) (unless (= 0 (system cmd)) --- a/lib/jerboa-emacs/qt/app.sls +++ b/lib/jerboa-emacs/qt/app.sls @@ -78,10 +78,10 @@ (jerboa-emacs qt keymap) (jerboa-emacs qt buffer) (jerboa-emacs qt window) (jerboa-emacs qt modeline) (jerboa-emacs qt echo) (jerboa-emacs qt highlight) - (jerboa-emacs qt image) (jerboa-emacs qt commands) - (jerboa-emacs qt lsp-client) (jerboa-emacs qt commands-lsp) - (jerboa-emacs qt menubar) (jerboa-emacs ipc) - (jerboa-emacs vtscreen) + (jerboa-emacs treesitter) (jerboa-emacs qt image) + (jerboa-emacs qt commands) (jerboa-emacs qt lsp-client) + (jerboa-emacs qt commands-lsp) (jerboa-emacs qt menubar) + (jerboa-emacs ipc) (jerboa-emacs vtscreen) (only (jerboa-emacs editor-extra-web) *aggressive-indent-mode*) @@ -1395,11 +1395,25 @@ (not (chord-lookup ch1 ch2))) - (void) + (begin + (verbose-log! + "CHORD-AUTOREPEAT ignored ch=" + (string ch1)) + (void)) (let ([chord-cmd (and ch2 (chord-lookup ch1 ch2))]) + (verbose-log! "CHORD-RESOLVE ch1=" + (string ch1) " ch2=" + (if ch2 + (string ch2) + "#f") + " cmd=" + (if chord-cmd + (symbol->string + chord-cmd) + "#f")) (qt-timer-stop! *chord-timer*) (set! *chord-pending-char* @@ -1460,9 +1474,12 @@ cur-buf) (gsh-eshell-buffer? cur-buf))))) - (verbose-log! - "CHORD-PENDING ch=" - (string (string-ref text 0))) + (verbose-log! "CHORD-PENDING ch=" + (string (string-ref text 0)) + " timeout=" + (number->string + *chord-timeout*) + "ms") (set! *chord-pending-char* (string-ref text 0)) (set! *chord-pending-code* code) @@ -1861,6 +1878,11 @@ (qt-on-timeout! *chord-timer* (lambda () + (verbose-log! + "CHORD-TIMEOUT fired pending=" + (if *chord-pending-char* + (string *chord-pending-char*) + "#f")) (when *chord-pending-char* (let ([saved-code *chord-pending-code*] [saved-mods *chord-pending-mods*] @@ -1948,6 +1970,24 @@ args)))]) (when repl-info (start-debug-repl! (car repl-info)))) (schedule-periodic! + 'treesitter-reparse + 150 + (lambda () + (let* ([fr (app-state-frame app)] + [buf (qt-current-buffer fr)] + [state (and buf (ts-buffer-state buf))]) + (when state + (let ([ed (qt-current-editor fr)]) + (when ed + (let* ([text (qt-plain-text-edit-text ed)] + [new-ver (and text (string-length text))] + [old-ver (ts-state-version state)]) + (when (and new-ver (not (= new-ver old-ver))) + (with-catch + (lambda (e) (void)) + (lambda () (ts-buffer-reparse! buf text ed))) + (ts-state-version-set! state new-ver))))))))) + (schedule-periodic! 'ipc 200 (lambda () --- a/lib/jerboa-emacs/qt/buffer.sls +++ b/lib/jerboa-emacs/qt/buffer.sls @@ -9,8 +9,8 @@ getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) (std sugar) (chez-scintilla constants) - (jerboa-emacs qt sci-shim) (jerboa-emacs core) (jerboa core) - (jerboa runtime)) + (jerboa-emacs qt sci-shim) (jerboa-emacs core) + (jerboa-emacs treesitter) (jerboa core) (jerboa runtime)) (def (qt-buffer-create! name editor (file-path #f)) "Create buffer with a new Scintilla document." (verbose-log! @@ -34,6 +34,7 @@ (when state (qt-pixmap-destroy! (car state)) (hash-remove! *image-buffer-state* buf))) + (ts-buffer-cleanup! buf) (hash-remove! *doc-editor-map* doc) (hash-remove! *doc-buffer-map* doc) (buffer-list-remove! buf))) --- a/lib/jerboa-emacs/qt/highlight.sls +++ b/lib/jerboa-emacs/qt/highlight.sls @@ -9,7 +9,8 @@ qt-highlight-search-matches! qt-clear-search-highlights! qt-enable-code-folding! detect-language qt-org-table-separator? *search-highlight-active* - *qt-show-paren-enabled* *qt-delete-selection-enabled*) + *qt-show-paren-enabled* *qt-delete-selection-enabled* + ts-setup-styles!) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -22,6 +23,7 @@ pregexp-split) (std misc string) (jerboa-emacs qt sci-shim) (jerboa-emacs core) (jerboa-emacs async) + (jerboa-emacs treesitter) (only (jerboa-emacs org-parse) org-heading-line? org-heading-stars-of-line org-comment-line? org-keyword-line? org-table-line? org-block-begin? @@ -467,6 +469,135 @@ (face-fg-rgb 'font-lock-operator-face)]) (sci-send ed SCI_STYLESETFORE 10 (rgb->sci r g b))) (sci-send/string ed SCI_SETKEYWORDS *perl-keywords* 0)) + (def (ts-setup-styles! ed) + "Configure Scintilla style IDs 90-108 with face colors for tree-sitter." + (let-values ([(r g b) + (face-fg-rgb 'font-lock-keyword-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-keyword* + (rgb->sci r g b)) + (when (face-has-bold? 'font-lock-keyword-face) + (sci-send ed SCI_STYLESETBOLD *ts-style-keyword* 1))) + (let-values ([(r g b) (face-fg-rgb 'font-lock-string-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-string* + (rgb->sci r g b))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-comment-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-comment* + (rgb->sci r g b)) + (when (face-has-italic? 'font-lock-comment-face) + (sci-send ed SCI_STYLESETITALIC *ts-style-comment* 1))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-function-name-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-function* + (rgb->sci r g b))) + (let-values ([(r g b) (face-fg-rgb 'font-lock-type-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-type* + (rgb->sci r g b))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-variable-name-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-variable* + (rgb->sci r g b))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-constant-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-constant* + (rgb->sci r g b)) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-number* + (rgb->sci r g b))) + (sci-send ed SCI_STYLESETFORE *ts-style-operator* 14211288) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-variable-name-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-property* + (rgb->sci r g b))) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-punctuation* + 8421504) + (let-values ([(r g b) (face-fg-rgb 'font-lock-type-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-attribute* + (rgb->sci r g b)) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-constructor* + (rgb->sci r g b))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-constant-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-namespace* + (rgb->sci r g b))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-keyword-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-tag* + (rgb->sci r g b))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-constant-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-escape* + (rgb->sci r g b)) + (sci-send ed SCI_STYLESETBOLD *ts-style-escape* 1)) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-function-name-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-label* + (rgb->sci r g b))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-builtin-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-builtin* + (rgb->sci r g b))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-preprocessor-face)]) + (sci-send + ed + SCI_STYLESETFORE + *ts-style-preproc* + (rgb->sci r g b))) + (let loop ([s 90]) + (when (<= s 108) + (sci-send ed SCI_STYLESETBACK s 1579032) + (loop (+ s 1))))) (def (qt-setup-highlighting! app buf) (let* ([lang (or (detect-language (buffer-file-path buf)) (let ([path (buffer-file-path buf)]) @@ -497,53 +628,74 @@ (qt-setup-org-styles! ed) (let ([text (qt-plain-text-edit-text ed)]) (qt-org-highlight-buffer-async! ed text))) - (when (and ed lexer-name) - (buffer-lexer-lang-set! buf lang) - (apply-base-theme! ed) - (if (member - lexer-name - '("lisp" "rust" "diff" "perl" "haskell" "props")) + (let ([ts-name (and lang + (not (eq? lang 'org)) + (language->ts-name lang))]) + (if (and ed + ts-name + (with-catch + (lambda (e) #f) + (lambda () (ts-buffer-init! buf ts-name)))) (begin - (sci-send/string ed SCI_SETLEXERLANGUAGE lexer-name) - (sci-send ed SCI_COLOURISE 0 -1)) - (qt-scintilla-set-lexer-language! ed lexer-name)) - (case lang - [(scheme lisp) (setup-lisp-styles! ed)] - [(c) (setup-cpp-styles! ed *c-keywords* *c-types*)] - [(javascript) - (setup-cpp-styles! ed *js-keywords* *js-builtins*)] - [(go) (setup-cpp-styles! ed *go-keywords* *go-types*)] - [(rust) (setup-cpp-styles! ed *rust-keywords* *rust-types*)] - [(java haskell swift elixir) - (setup-cpp-styles! ed *java-keywords* *java-types*)] - [(zig nix) (setup-cpp-styles! ed *c-keywords* *c-types*)] - [(python) (setup-python-styles! ed)] - [(shell) (setup-bash-styles! ed)] - [(ruby) (setup-ruby-styles! ed)] - [(lua) (setup-lua-styles! ed)] - [(sql) (setup-sql-styles! ed)] - [(perl) (setup-perl-styles! ed)] - [(json yaml xml css markdown makefile diff toml) - (let-values ([(r g b) - (face-fg-rgb 'font-lock-comment-face)]) - (for-each - (lambda (s) - (sci-send ed SCI_STYLESETFORE s (rgb->sci r g b)) - (when (face-has-italic? 'font-lock-comment-face) - (sci-send ed SCI_STYLESETITALIC s 1))) - '(1 2 3))) - (let-values ([(r g b) - (face-fg-rgb 'font-lock-keyword-face)]) - (sci-send ed SCI_STYLESETFORE 5 (rgb->sci r g b)) - (when (face-has-bold? 'font-lock-keyword-face) - (sci-send ed SCI_STYLESETBOLD 5 1))) - (let-values ([(r g b) (face-fg-rgb 'font-lock-string-face)]) - (sci-send ed SCI_STYLESETFORE 6 (rgb->sci r g b)) - (sci-send ed SCI_STYLESETFORE 7 (rgb->sci r g b))) - (let-values ([(r g b) (face-fg-rgb 'font-lock-number-face)]) - (sci-send ed SCI_STYLESETFORE 4 (rgb->sci r g b)))] - [else (void)]) - (qt-enable-code-folding! ed)))) + (buffer-lexer-lang-set! buf lang) + (apply-base-theme! ed) + (sci-send ed 4033 0) + (ts-setup-styles! ed) + (let ([text (qt-plain-text-edit-text ed)]) + (when (and text (> (string-length text) 0)) + (ts-buffer-reparse! buf text ed))) + (qt-enable-code-folding! ed)) + (when (and ed lexer-name) + (buffer-lexer-lang-set! buf lang) + (apply-base-theme! ed) + (if (member + lexer-name + '("lisp" "rust" "diff" "perl" "haskell" "props")) + (begin + (sci-send/string ed SCI_SETLEXERLANGUAGE lexer-name) + (sci-send ed SCI_COLOURISE 0 -1)) + (qt-scintilla-set-lexer-language! ed lexer-name)) + (case lang + [(scheme lisp) (setup-lisp-styles! ed)] + [(c) (setup-cpp-styles! ed *c-keywords* *c-types*)] + [(javascript) + (setup-cpp-styles! ed *js-keywords* *js-builtins*)] + [(go) (setup-cpp-styles! ed *go-keywords* *go-types*)] + [(rust) + (setup-cpp-styles! ed *rust-keywords* *rust-types*)] + [(java haskell swift elixir) + (setup-cpp-styles! ed *java-keywords* *java-types*)] + [(zig nix) + (setup-cpp-styles! ed *c-keywords* *c-types*)] + [(python) (setup-python-styles! ed)] + [(shell) (setup-bash-styles! ed)] + [(ruby) (setup-ruby-styles! ed)] + [(lua) (setup-lua-styles! ed)] + [(sql) (setup-sql-styles! ed)] + [(perl) (setup-perl-styles! ed)] + [(json yaml xml css markdown makefile diff toml) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-comment-face)]) + (for-each + (lambda (s) + (sci-send ed SCI_STYLESETFORE s (rgb->sci r g b)) + (when (face-has-italic? 'font-lock-comment-face) + (sci-send ed SCI_STYLESETITALIC s 1))) + '(1 2 3))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-keyword-face)]) + (sci-send ed SCI_STYLESETFORE 5 (rgb->sci r g b)) + (when (face-has-bold? 'font-lock-keyword-face) + (sci-send ed SCI_STYLESETBOLD 5 1))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-string-face)]) + (sci-send ed SCI_STYLESETFORE 6 (rgb->sci r g b)) + (sci-send ed SCI_STYLESETFORE 7 (rgb->sci r g b))) + (let-values ([(r g b) + (face-fg-rgb 'font-lock-number-face)]) + (sci-send ed SCI_STYLESETFORE 4 (rgb->sci r g b)))] + [else (void)]) + (qt-enable-code-folding! ed)))))) (def (qt-enable-code-folding! ed) "Enable code folding margin and markers for QScintilla editor.\n Sets up margin 2 as fold margin with box-tree style markers.\n QScintilla lexers compute fold levels automatically." (sci-send ed SCI_SETMARGINTYPEN 2 SC_MARGIN_SYMBOL) --- a/src/jerboa-emacs/qt/app.ss +++ b/src/jerboa-emacs/qt/app.ss @@ -76,6 +76,7 @@ :jerboa-emacs/qt/modeline :jerboa-emacs/qt/echo :jerboa-emacs/qt/highlight + :jerboa-emacs/treesitter :jerboa-emacs/qt/image :jerboa-emacs/qt/commands :jerboa-emacs/qt/lsp-client @@ -1133,9 +1134,14 @@ ;; If not a valid chord, it's auto-repeat — ignore and keep waiting. (if (and ch2 (char=? ch1 ch2) (= code saved-code) (not (chord-lookup ch1 ch2))) - (void) ;; ignore auto-repeat, timer keeps running + (begin + (verbose-log! "CHORD-AUTOREPEAT ignored ch=" (string ch1)) + (void)) ;; ignore auto-repeat, timer keeps running ;; Real second key — resolve the chord (let ((chord-cmd (and ch2 (chord-lookup ch1 ch2)))) + (verbose-log! "CHORD-RESOLVE ch1=" (string ch1) + " ch2=" (if ch2 (string ch2) "#f") + " cmd=" (if chord-cmd (symbol->string chord-cmd) "#f")) (qt-timer-stop! *chord-timer*) (set! *chord-pending-char* #f) (if chord-cmd @@ -1167,7 +1173,8 @@ (not (or (terminal-buffer? cur-buf) (shell-buffer? cur-buf) (gsh-eshell-buffer? cur-buf))))) - (verbose-log! "CHORD-PENDING ch=" (string (string-ref text 0))) + (verbose-log! "CHORD-PENDING ch=" (string (string-ref text 0)) + " timeout=" (number->string *chord-timeout*) "ms") (set! *chord-pending-char* (string-ref text 0)) (set! *chord-pending-code* code) (set! *chord-pending-mods* mods) @@ -1477,6 +1484,8 @@ (qt-timer-set-single-shot! *chord-timer* #t) (qt-on-timeout! *chord-timer* (lambda () + (verbose-log! "CHORD-TIMEOUT fired pending=" + (if *chord-pending-char* (string *chord-pending-char*) "#f")) (when *chord-pending-char* (let ((saved-code *chord-pending-code*) (saved-mods *chord-pending-mods*) @@ -1561,6 +1570,24 @@ (cons (string->number repl-port-env) args))))) (when repl-info (start-debug-repl! (car repl-info)))) + ;; 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 + (lambda () + (let* ((fr (app-state-frame app)) + (buf (qt-current-buffer fr)) + (state (and buf (ts-buffer-state buf)))) + (when state + (let ((ed (qt-current-editor fr))) + (when ed + (let* ((text (qt-plain-text-edit-text ed)) + (new-ver (and text (string-length text))) + (old-ver (ts-state-version state))) + (when (and new-ver (not (= new-ver old-ver))) + (with-catch (lambda (e) (void)) + (lambda () (ts-buffer-reparse! buf text ed))) + (set! (ts-state-version state) new-ver))))))))) + (schedule-periodic! 'ipc 200 (lambda () (for-each (lambda (f) (qt-open-file! app f)) --- a/src/jerboa-emacs/qt/buffer.ss +++ b/src/jerboa-emacs/qt/buffer.ss @@ -12,7 +12,8 @@ (import :std/sugar :chez-scintilla/constants :jerboa-emacs/qt/sci-shim - :jerboa-emacs/core) + :jerboa-emacs/core + :jerboa-emacs/treesitter) ;;;============================================================================ ;;; Qt buffer operations @@ -41,6 +42,8 @@ (when state (qt-pixmap-destroy! (car state)) (hash-remove! *image-buffer-state* buf))) + ;; Clean up tree-sitter state if applicable + (ts-buffer-cleanup! buf) (hash-remove! *doc-editor-map* doc) (hash-remove! *doc-buffer-map* doc) (buffer-list-remove! buf))) --- a/src/jerboa-emacs/qt/highlight.ss +++ b/src/jerboa-emacs/qt/highlight.ss @@ -17,7 +17,8 @@ qt-org-table-separator? *search-highlight-active* *qt-show-paren-enabled* - *qt-delete-selection-enabled*) + *qt-delete-selection-enabled* + ts-setup-styles!) (import :std/sugar :chez-scintilla/constants @@ -27,6 +28,7 @@ :jerboa-emacs/qt/sci-shim :jerboa-emacs/core :jerboa-emacs/async + :jerboa-emacs/treesitter (only-in :jerboa-emacs/org-parse org-heading-line? org-heading-stars-of-line org-comment-line? org-keyword-line? @@ -552,6 +554,57 @@ (sci-send/string ed SCI_SETKEYWORDS *perl-keywords* 0)) ;;;============================================================================ +;;; Tree-sitter style setup (uses face system from this module) +;;;============================================================================ + +(def (ts-setup-styles! ed) + "Configure Scintilla style IDs 90-108 with face colors for tree-sitter." + (let-values (((r g b) (face-fg-rgb 'font-lock-keyword-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-keyword* (rgb->sci r g b)) + (when (face-has-bold? 'font-lock-keyword-face) + (sci-send ed SCI_STYLESETBOLD *ts-style-keyword* 1))) + (let-values (((r g b) (face-fg-rgb 'font-lock-string-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-string* (rgb->sci r g b))) + (let-values (((r g b) (face-fg-rgb 'font-lock-comment-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-comment* (rgb->sci r g b)) + (when (face-has-italic? 'font-lock-comment-face) + (sci-send ed SCI_STYLESETITALIC *ts-style-comment* 1))) + (let-values (((r g b) (face-fg-rgb 'font-lock-function-name-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-function* (rgb->sci r g b))) + (let-values (((r g b) (face-fg-rgb 'font-lock-type-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-type* (rgb->sci r g b))) + (let-values (((r g b) (face-fg-rgb 'font-lock-variable-name-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-variable* (rgb->sci r g b))) + (let-values (((r g b) (face-fg-rgb 'font-lock-constant-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-constant* (rgb->sci r g b)) + (sci-send ed SCI_STYLESETFORE *ts-style-number* (rgb->sci r g b))) + (sci-send ed SCI_STYLESETFORE *ts-style-operator* #xd8d8d8) + (let-values (((r g b) (face-fg-rgb 'font-lock-variable-name-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-property* (rgb->sci r g b))) + (sci-send ed SCI_STYLESETFORE *ts-style-punctuation* #x808080) + (let-values (((r g b) (face-fg-rgb 'font-lock-type-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-attribute* (rgb->sci r g b)) + (sci-send ed SCI_STYLESETFORE *ts-style-constructor* (rgb->sci r g b))) + (let-values (((r g b) (face-fg-rgb 'font-lock-constant-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-namespace* (rgb->sci r g b))) + (let-values (((r g b) (face-fg-rgb 'font-lock-keyword-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-tag* (rgb->sci r g b))) + (let-values (((r g b) (face-fg-rgb 'font-lock-constant-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-escape* (rgb->sci r g b)) + (sci-send ed SCI_STYLESETBOLD *ts-style-escape* 1)) + (let-values (((r g b) (face-fg-rgb 'font-lock-function-name-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-label* (rgb->sci r g b))) + (let-values (((r g b) (face-fg-rgb 'font-lock-builtin-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-builtin* (rgb->sci r g b))) + (let-values (((r g b) (face-fg-rgb 'font-lock-preprocessor-face))) + (sci-send ed SCI_STYLESETFORE *ts-style-preproc* (rgb->sci r g b))) + ;; Set background for all tree-sitter styles + (let loop ((s 90)) + (when (<= s 108) + (sci-send ed SCI_STYLESETBACK s #x181818) + (loop (+ s 1))))) + +;;;============================================================================ ;;; Main setup and teardown ;;;============================================================================ @@ -581,73 +634,93 @@ ;; Apply full-buffer org highlighting in background (let ((text (qt-plain-text-edit-text ed))) (qt-org-highlight-buffer-async! ed text))) - (when (and ed lexer-name) - ;; Store language in buffer - (set! (buffer-lexer-lang buf) lang) - ;; Reset to dark theme base - (apply-base-theme! ed) - ;; Set lexer language — QScintilla has wrapper classes for common languages, - ;; but not for lisp, rust, diff, perl, haskell, props. - ;; For those, use SCI_SETLEXERLANGUAGE to invoke Lexilla directly. - (if (member lexer-name '("lisp" "rust" "diff" "perl" "haskell" "props")) + ;; Try tree-sitter first, fall back to Lexilla + (let ((ts-name (and lang (not (eq? lang 'org)) (language->ts-name lang)))) + (if (and ed ts-name + (with-catch (lambda (e) #f) + (lambda () (ts-buffer-init! buf ts-name)))) + ;; Tree-sitter available — use it (begin - ;; No QsciLexer wrapper — use raw Scintilla message and force colorize - (sci-send/string ed SCI_SETLEXERLANGUAGE lexer-name) - (sci-send ed SCI_COLOURISE 0 -1)) - (qt-scintilla-set-lexer-language! ed lexer-name)) - ;; Apply lexer-specific styles and keywords - (case lang - ((scheme lisp) - (setup-lisp-styles! ed)) - ((c) - (setup-cpp-styles! ed *c-keywords* *c-types*)) - ((javascript) - (setup-cpp-styles! ed *js-keywords* *js-builtins*)) - ((go) - (setup-cpp-styles! ed *go-keywords* *go-types*)) - ((rust) - (setup-cpp-styles! ed *rust-keywords* *rust-types*)) - ((java haskell swift elixir) - (setup-cpp-styles! ed *java-keywords* *java-types*)) - ((zig nix) - (setup-cpp-styles! ed *c-keywords* *c-types*)) - ((python) - (setup-python-styles! ed)) - ((shell) - (setup-bash-styles! ed)) - ((ruby) - (setup-ruby-styles! ed)) - ((lua) - (setup-lua-styles! ed)) - ((sql) - (setup-sql-styles! ed)) - ((perl) - (setup-perl-styles! ed)) - ;; For json, yaml, xml, css, markdown, makefile, diff, toml: - ;; The lexer handles tokenization; we just set basic comment/string colors - ((json yaml xml css markdown makefile diff toml) - ;; Comments: styles 1-3 for most lexers - (let-values (((r g b) (face-fg-rgb 'font-lock-comment-face))) - (for-each (lambda (s) - (sci-send ed SCI_STYLESETFORE s (rgb->sci r g b)) - (when (face-has-italic? 'font-lock-comment-face) - (sci-send ed SCI_STYLESETITALIC s 1))) - '(1 2 3))) - ;; Keywords: style 5 - (let-values (((r g b) (face-fg-rgb 'font-lock-keyword-face))) - (sci-send ed SCI_STYLESETFORE 5 (rgb->sci r g b)) - (when (face-has-bold? 'font-lock-keyword-face) - (sci-send ed SCI_STYLESETBOLD 5 1))) - ;; Strings: styles 6-7 - (let-values (((r g b) (face-fg-rgb 'font-lock-string-face))) - (sci-send ed SCI_STYLESETFORE 6 (rgb->sci r g b)) - (sci-send ed SCI_STYLESETFORE 7 (rgb->sci r g b))) - ;; Numbers: style 4 - (let-values (((r g b) (face-fg-rgb 'font-lock-number-face))) - (sci-send ed SCI_STYLESETFORE 4 (rgb->sci r g b)))) - (else (void))) - ;; Enable code folding margin for all code files - (qt-enable-code-folding! ed)))) + (set! (buffer-lexer-lang buf) lang) + (apply-base-theme! ed) + ;; Disable built-in lexer + (sci-send ed 4033 0) + ;; Set up tree-sitter styles + (ts-setup-styles! ed) + ;; Initial full parse + highlight + (let ((text (qt-plain-text-edit-text ed))) + (when (and text (> (string-length text) 0)) + (ts-buffer-reparse! buf text ed))) + ;; Enable code folding + (qt-enable-code-folding! ed)) + ;; No tree-sitter — fall back to Lexilla + (when (and ed lexer-name) + ;; Store language in buffer + (set! (buffer-lexer-lang buf) lang) + ;; Reset to dark theme base + (apply-base-theme! ed) + ;; Set lexer language — QScintilla has wrapper classes for common languages, + ;; but not for lisp, rust, diff, perl, haskell, props. + ;; For those, use SCI_SETLEXERLANGUAGE to invoke Lexilla directly. + (if (member lexer-name '("lisp" "rust" "diff" "perl" "haskell" "props")) + (begin + ;; No QsciLexer wrapper — use raw Scintilla message and force colorize + (sci-send/string ed SCI_SETLEXERLANGUAGE lexer-name) + (sci-send ed SCI_COLOURISE 0 -1)) + (qt-scintilla-set-lexer-language! ed lexer-name)) + ;; Apply lexer-specific styles and keywords + (case lang + ((scheme lisp) + (setup-lisp-styles! ed)) + ((c) + (setup-cpp-styles! ed *c-keywords* *c-types*)) + ((javascript) + (setup-cpp-styles! ed *js-keywords* *js-builtins*)) + ((go) + (setup-cpp-styles! ed *go-keywords* *go-types*)) + ((rust) + (setup-cpp-styles! ed *rust-keywords* *rust-types*)) + ((java haskell swift elixir) + (setup-cpp-styles! ed *java-keywords* *java-types*)) + ((zig nix) + (setup-cpp-styles! ed *c-keywords* *c-types*)) + ((python) + (setup-python-styles! ed)) + ((shell) + (setup-bash-styles! ed)) + ((ruby) + (setup-ruby-styles! ed)) + ((lua) + (setup-lua-styles! ed)) + ((sql) + (setup-sql-styles! ed)) + ((perl) + (setup-perl-styles! ed)) + ;; For json, yaml, xml, css, markdown, makefile, diff, toml: + ;; The lexer handles tokenization; we just set basic comment/string colors + ((json yaml xml css markdown makefile diff toml) + ;; Comments: styles 1-3 for most lexers + (let-values (((r g b) (face-fg-rgb 'font-lock-comment-face))) + (for-each (lambda (s) + (sci-send ed SCI_STYLESETFORE s (rgb->sci r g b)) + (when (face-has-italic? 'font-lock-comment-face) + (sci-send ed SCI_STYLESETITALIC s 1))) + '(1 2 3))) + ;; Keywords: style 5 + (let-values (((r g b) (face-fg-rgb 'font-lock-keyword-face))) + (sci-send ed SCI_STYLESETFORE 5 (rgb->sci r g b)) + (when (face-has-bold? 'font-lock-keyword-face) + (sci-send ed SCI_STYLESETBOLD 5 1))) + ;; Strings: styles 6-7 + (let-values (((r g b) (face-fg-rgb 'font-lock-string-face))) + (sci-send ed SCI_STYLESETFORE 6 (rgb->sci r g b)) + (sci-send ed SCI_STYLESETFORE 7 (rgb->sci r g b))) + ;; Numbers: style 4 + (let-values (((r g b) (face-fg-rgb 'font-lock-number-face))) + (sci-send ed SCI_STYLESETFORE 4 (rgb->sci r g b)))) + (else (void))) + ;; Enable code folding margin for all code files + (qt-enable-code-folding! ed)))))) ;;;============================================================================ ;;; Code folding margin setup new file mode 100644 --- /dev/null +++ b/src/jerboa-emacs/treesitter.ss @@ -0,0 +1,464 @@ +;;; -*- Gerbil -*- +;;; treesitter.ss — Tree-sitter incremental parsing and syntax highlighting. +;;; +;;; Provides FFI bindings to the tree-sitter C library via treesitter_shim.c. +;;; Manages per-buffer parser/tree state and highlight query execution. + +(export ts-parser-create + ts-parser-delete! + ts-parse-string! + ts-parse-incremental! + ts-tree-delete! + ts-highlight-buffer! + ts-highlight-range! + ts-tree-changed-ranges + ts-get-highlight-query + ts-get-highlight-query-len + ts-query-create + ts-query-delete! + ;; Per-buffer state + ts-buffer-init! + ts-buffer-cleanup! + ts-buffer-reparse! + ts-buffer-state + (struct-out ts-state) + *buffer-ts-state* + ;; Language mapping + language->ts-name + ;; Capture -> style + ts-capture->style-id + ;; Style IDs + *ts-style-keyword* *ts-style-string* *ts-style-comment* + *ts-style-function* *ts-style-type* *ts-style-variable* + *ts-style-constant* *ts-style-number* *ts-style-operator* + *ts-style-property* *ts-style-punctuation* *ts-style-attribute* + *ts-style-namespace* *ts-style-constructor* *ts-style-tag* + *ts-style-escape* *ts-style-label* *ts-style-builtin* + *ts-style-preproc*) + +(import :std/sugar + :std/srfi/13 + :chez-scintilla/constants + :jerboa-emacs/core + :jerboa-emacs/qt/sci-shim) + +;;;============================================================================ +;;; Load the C shim shared library +;;;============================================================================ + +(define static-build? + (let ((v (getenv "JEMACS_STATIC"))) + (and v (not (string=? v "")) (not (string=? v "0"))))) + +(define ts-shim-loaded + (if static-build? + #f ;; symbols already linked in via Sforeign_symbol registration + (with-catch + (lambda (e) #f) + (lambda () + (load-shared-object + (let ((dir (or (getenv "JERBOA_EMACS_SUPPORT") + (string-append (or (getenv "HOME") ".") "/mine/jerboa-emacs/support")))) + (string-append dir "/treesitter_shim.so"))))))) + +;;;============================================================================ +;;; FFI bindings +;;;============================================================================ + +;; Parser lifecycle +(define ffi-ts-parser-new + (foreign-procedure "ts_shim_parser_new" () void*)) +(define ffi-ts-parser-delete + (foreign-procedure "ts_shim_parser_delete" (void*) void)) +(define ffi-ts-parser-set-language + (foreign-procedure "ts_shim_parser_set_language" (void* string) int)) + +;; Parsing +(define ffi-ts-parse-string + (foreign-procedure "ts_shim_parse_string" (void* void* string int) void*)) +(define ffi-ts-parse-incremental + (foreign-procedure "ts_shim_parse_incremental" + (void* void* string int int int int int int int int int int) void*)) +(define ffi-ts-tree-delete + (foreign-procedure "ts_shim_tree_delete" (void*) void)) + +;; Node slots +(define ffi-ts-tree-root-node + (foreign-procedure "ts_shim_tree_root_node" (void* int) void)) +(define ffi-ts-node-start-byte + (foreign-procedure "ts_shim_node_start_byte" (int) int)) +(define ffi-ts-node-end-byte + (foreign-procedure "ts_shim_node_end_byte" (int) int)) +(define ffi-ts-node-type + (foreign-procedure "ts_shim_node_type" (int) string)) +(define ffi-ts-node-is-null + (foreign-procedure "ts_shim_node_is_null" (int) int)) + +;; Query +(define ffi-ts-query-new + (foreign-procedure "ts_shim_query_new" (string string int u8* u8*) void*)) +(define ffi-ts-query-delete + (foreign-procedure "ts_shim_query_delete" (void*) void)) + +;; Query cursor +(define ffi-ts-query-cursor-new + (foreign-procedure "ts_shim_query_cursor_new" () void*)) +(define ffi-ts-query-cursor-delete + (foreign-procedure "ts_shim_query_cursor_delete" (void*) void)) +(define ffi-ts-query-cursor-exec + (foreign-procedure "ts_shim_query_cursor_exec" (void* void* int) void)) +(define ffi-ts-query-cursor-set-byte-range + (foreign-procedure "ts_shim_query_cursor_set_byte_range" (void* int int) void)) + +;; Batch highlight captures +(define ffi-ts-highlight-captures + (foreign-procedure "ts_shim_highlight_captures" (void* void* u8* int) int)) + +;; Capture name lookup +(define ffi-ts-query-capture-name + (foreign-procedure "ts_shim_query_capture_name" (void* int) string)) + +;; Changed ranges +(define ffi-ts-tree-changed-ranges + (foreign-procedure "ts_shim_tree_changed_ranges" (void* void* u8* int) int)) + +;; Embedded queries +(define ffi-ts-get-highlight-query + (foreign-procedure "ts_shim_get_highlight_query" (string) string)) +(define ffi-ts-get-highlight-query-len + (foreign-procedure "ts_shim_get_highlight_query_len" (string) int)) + +;;;============================================================================ +;;; High-level Scheme API +;;;============================================================================ + +(def (ts-parser-create lang-name) + "Create a parser configured for the given language. + Returns parser pointer or #f." + (let ((p (ffi-ts-parser-new))) + (if (= 1 (ffi-ts-parser-set-language p lang-name)) + p + (begin (ffi-ts-parser-delete p) #f)))) + +(def (ts-parser-delete! parser) + (when parser (ffi-ts-parser-delete parser))) + +(def (ts-parse-string! parser old-tree text) + "Parse text string. Returns new tree pointer." + (ffi-ts-parse-string parser (or old-tree 0) text (string-length text))) + +(def (ts-parse-incremental! parser old-tree text + start-byte old-end-byte new-end-byte + start-row start-col + old-end-row old-end-col + new-end-row new-end-col) + "Apply an edit and re-parse incrementally. Returns new tree pointer." + (ffi-ts-parse-incremental parser (or old-tree 0) text (string-length text)