Port gerbil-emacs source to Gerbil-like jemacs source
ober
e042893a425cf60d1168932301876a33c233a88f
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +# Generated by jerbuild — do not edit +lib/jemacs/ +src/.jerbuild-hashes + +# Compiled Chez artifacts +lib/**/*.so +lib/**/*.wpo --- a/Makefile +++ b/Makefile @@ -1,13 +1,24 @@ SCHEME = scheme -LIBDIRS = --libdirs lib:$(HOME)/mine/jerboa/lib:$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla/src +JERBOA = $(HOME)/mine/jerboa +JSH = $(HOME)/mine/jerboa-shell/src +LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla/src +JERBUILD = $(SCHEME) --libdirs $(JERBOA)/lib --script $(JERBOA)/jerbuild.ss export LD_LIBRARY_PATH := $(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(LD_LIBRARY_PATH) export CHEZ_SCINTILLA_LIB := $(HOME)/mine/chez-scintilla -.PHONY: all test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test clean +.PHONY: all build rebuild test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test clean clean-generated -all: test +all: build test -test: test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 +# Generate lib/jemacs/*.sls from src/jemacs/*.ss (incremental) +build: + $(JERBUILD) src/ lib/ + +# Force regenerate all +rebuild: + $(JERBUILD) src/ lib/ --force + +test: build test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test-tier0: $(SCHEME) $(LIBDIRS) --script tests/test-tier0.ss @@ -26,3 +37,7 @@ test-tier5: clean: find lib -name '*.so' -delete 2>/dev/null; true + +clean-generated: + rm -rf lib/jemacs/ + rm -f src/.jerbuild-hashes new file mode 100644 --- /dev/null +++ b/src/jemacs/async.ss @@ -0,0 +1,414 @@ +;;; -*- Gerbil -*- +;;; Async infrastructure for jemacs SMP +;;; +;;; Provides a unified UI action queue, async process runners, +;;; async file I/O, and a periodic task scheduler. +;;; Background threads push thunks via ui-queue-push!; a master timer +;;; drains them on the UI thread. +;;; +;;; SMP Thread Pinning: +;;; Gambit SMP can migrate green threads between OS-level Virtual Processors +;;; via work-stealing. For Qt apps, the UI thread must stay on processor 0 +;;; (the main OS thread) so Qt widget operations happen on the correct pthread. +;;; Use pin-thread-to-processor0! to pin critical threads, and +;;; spawn/name/pinned to spawn a green thread pre-pinned to processor 0. + +(export + ;; UI action queue + ui-queue-push! + ui-queue-drain! + + ;; SMP thread pinning + pin-thread-to-processor0! + spawn/name/pinned + + ;; Async command runner + async-process! + async-process-stream! + + ;; Async file I/O + async-read-file! + async-write-file! + + ;; Async eval (background thunk → UI callback) + async-eval! + + ;; Periodic task scheduler + schedule-periodic! + master-timer-tick! + current-time-ms + + ;; Background services + *file-index* + start-file-indexer! + stop-file-indexer! + file-index-lookup + *git-status-cache* + start-git-watcher! + stop-git-watcher! + *flycheck-trigger* + flycheck-trigger! + start-flycheck-watcher! + stop-flycheck-watcher!) + +(import :std/misc/channel + :std/misc/atom + :std/sugar + :std/srfi/13 + :jemacs/core) + +;;;============================================================================ +;;; SMP Thread Pinning +;;;============================================================================ + +(def (pin-thread-to-processor0! thread) + "Pin a green thread to processor 0 (no-op on Chez — no thread pinning API)." + #f) + + + + + + + +(def (spawn/name/pinned name thunk) + "Spawn a named green thread pinned to processor 0. + The thread is pinned before starting so it never runs on any other processor. + Use for threads that must stay on the main OS thread (Qt UI operations)." + (let ((t (make-thread thunk name))) + (pin-thread-to-processor0! t) + (thread-start! t) + t)) + +;;;============================================================================ +;;; UI Action Queue +;;;============================================================================ + +;; Buffered channel for UI actions. Background threads push thunks here; +;; the master timer drains them on the UI thread. +(def *ui-queue* (make-channel 4096)) + +(def (ui-queue-push! thunk) + "Push a UI action from any thread. Non-blocking (buffered channel)." + (channel-try-put *ui-queue* thunk)) + +(def (ui-queue-drain!) + "Drain all pending UI actions. Called from the master timer on the UI thread. + Processes up to 64 actions per tick to avoid starving the event loop." + (let loop ((n 0)) + (when (< n 64) + (let ((action (channel-try-get *ui-queue*))) + (when action + (with-catch + (lambda (e) (jemacs-log! "UI queue error: " (format "~a" e))) + action) + (loop (+ n 1))))))) + +;;;============================================================================ +;;; Periodic Task Scheduler +;;;============================================================================ + +;; Each task: (name interval-ms last-run-ms thunk) +(def *scheduled-tasks* []) + +(def (current-time-ms) + "Current wall-clock time in milliseconds." + (inexact->exact (floor (* (time->seconds (current-time)) 1000)))) + +(def (schedule-periodic! name interval-ms thunk) + "Register a periodic task to run at the given interval. + Tasks are run by master-timer-tick! on the UI thread." + (set! *scheduled-tasks* + (cons [name interval-ms 0 thunk] *scheduled-tasks*))) + +(def (master-timer-tick!) + "Master timer callback: drain the UI queue, then run periodic tasks. + Should be called from a single Qt timer at ~16-50ms interval." + ;; 1. Drain async UI queue + (ui-queue-drain!) + ;; 2. Run periodic tasks whose interval has elapsed + (let ((now (current-time-ms))) + (set! *scheduled-tasks* + (map (lambda (task) + (let ((name (car task)) + (interval (cadr task)) + (last (caddr task)) + (thunk (cadddr task))) + (if (>= (- now last) interval) + (begin + (with-catch + (lambda (e) + (jemacs-log! "Timer error in " name ": " + (format "~a" e))) + thunk) + [name interval now thunk]) + task))) + *scheduled-tasks*)))) + +;;;============================================================================ +;;; Async Process Runner +;;;============================================================================ + +(def (async-process! cmd + callback: callback + on-error: (on-error #f) + stdin-text: (stdin-text #f)) + "Run shell command in background thread, deliver result string to callback on UI thread." + (spawn/name 'async-process + (lambda () + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (if on-error (on-error e) + (jemacs-log! "async-process error: " (format "~a" e)))))) + (lambda () + (let ((proc (open-process + [path: "/bin/sh" + arguments: ["-c" cmd] + stdin-redirection: (if stdin-text #t #f) + stdout-redirection: #t + stderr-redirection: #t]))) + (when stdin-text + (display stdin-text proc) + (force-output proc) + (close-output-port proc)) + ;; Read all output + (let ((out (read-line proc #f))) + (close-port proc) + (let ((result (or out ""))) + (ui-queue-push! (lambda () (callback result))))))))))) + +(def (async-process-stream! cmd + on-line: on-line + on-done: (on-done #f) + on-error: (on-error #f)) + "Run shell command in background, deliver each line to on-line callback on UI thread. + Calls on-done (no args) when the process finishes." + (spawn/name 'async-process-stream + (lambda () + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (if on-error (on-error e) + (jemacs-log! "async-process-stream error: " (format "~a" e)))))) + (lambda () + (let ((proc (open-process + [path: "/bin/sh" + arguments: ["-c" cmd] + stdout-redirection: #t + stderr-redirection: #t]))) + (let loop () + (let ((line (read-line proc))) + (if (eof-object? line) + (begin + (close-port proc) + (when on-done + (ui-queue-push! on-done))) + (begin + (ui-queue-push! (lambda () (on-line line))) + (loop))))))))))) + +;;;============================================================================ +;;; Async File I/O +;;;============================================================================ + +(def (async-read-file! path callback) + "Read file in background thread, deliver string (or #f on error) to callback on UI thread." + (spawn/name 'async-read-file + (lambda () + (let ((content (with-catch (lambda (e) #f) + (lambda () + (call-with-input-file path + (lambda (port) (read-line port #f))))))) + (ui-queue-push! (lambda () (callback content))))))) + +(def (async-write-file! path content callback) + "Write string to file in background thread, call callback with #t (success) or #f (error) on UI thread." + (spawn/name 'async-write-file + (lambda () + (let ((ok (with-catch (lambda (e) #f) + (lambda () + (call-with-output-file path + (lambda (port) (display content port))) + #t)))) + (ui-queue-push! (lambda () (callback ok))))))) + +;;;============================================================================ +;;; Async Eval +;;;============================================================================ + +(def (async-eval! thunk callback) + "Evaluate thunk in background thread, deliver result to callback on UI thread." + (spawn/name 'async-eval + (lambda () + (let ((result (with-catch + (lambda (e) (values 'error e)) + thunk))) + (ui-queue-push! (lambda () (callback result))))))) + +;;;============================================================================ +;;; Background Services +;;;============================================================================ + +;;; 8.1 File Indexer — builds file index for fast find-file completion + +(def *file-index* (atom (make-hash-table))) +(def *file-indexer-thread* #f) + +(def (build-file-index root-dir) + "Walk directory tree and build a hash of basename -> full-path list." + (let ((index (make-hash-table))) + (with-catch + (lambda (e) index) + (lambda () + (let walk ((dir root-dir)) + (for-each + (lambda (entry) + (let ((path (path-expand entry dir))) + (with-catch + (lambda (e) #f) + (lambda () + (let ((info (file-info path))) + (if (eq? 'directory (file-info-type info)) + ;; Skip hidden directories + (unless (string-prefix? "." entry) + (walk path)) + ;; Index the file + (let* ((name (path-strip-directory path)) + (existing (or (hash-get index name) []))) + (hash-put! index name (cons path existing))))))))) + (directory-files dir))) + index)))) + +(def (start-file-indexer! root-dir) + "Start background file indexer that re-indexes every 30 seconds." + (stop-file-indexer!) + (set! *file-indexer-thread* + (spawn/name 'file-indexer + (lambda () + (let loop () + (let ((index (build-file-index root-dir))) + (atom-reset! *file-index* index)) + (thread-sleep! 30) + (loop)))))) + +(def (stop-file-indexer!) + "Stop the file indexer background thread." + (when *file-indexer-thread* + (with-catch (lambda (e) #f) + (lambda () (thread-interrupt! *file-indexer-thread* + (lambda () (raise 'stop))))) + (set! *file-indexer-thread* #f))) + +(def (file-index-lookup name) + "Look up a filename in the index. Returns list of full paths." + (or (hash-get (atom-deref *file-index*) name) [])) + +;;; 8.2 Git Status Watcher — polls git status for modeline + +(def *git-status-cache* (atom (make-hash-table))) +(def *git-watcher-thread* #f) + +(def (parse-git-status-line line) + "Parse one line of git status --porcelain output into (status . file)." + (when (>= (string-length line) 4) + (let ((status (substring line 0 2)) + (file (substring line 3 (string-length line)))) + (cons (string-trim-both status) file)))) + +(def (start-git-watcher! dir (on-update #f)) + "Poll git status in background every 5 seconds. + Optional on-update callback is called on UI thread with the status hash." + (stop-git-watcher!) + (set! *git-watcher-thread* + (spawn/name 'git-watcher + (lambda () + (let loop () + (with-catch + (lambda (e) #f) + (lambda () + (let* ((proc (open-process + [path: "/usr/bin/git" + arguments: ["status" "--porcelain" "-b"] + directory: dir + stdout-redirection: #t + stderr-redirection: #t])) + (lines (let rd ((acc [])) + (let ((line (read-line proc))) + (if (eof-object? line) + (reverse acc) + (rd (cons line acc))))))) + (close-port proc) + (let ((status (make-hash-table)) + (modified 0) (staged 0) (untracked 0)) + (for-each + (lambda (line) + (when (>= (string-length line) 3) + (let ((xy (substring line 0 2))) + (cond + ((string-prefix? "##" xy) + (hash-put! status 'branch + (substring line 3 (string-length line)))) + ((string-contains xy "?") + (set! untracked (+ untracked 1))) + ((or (string-contains xy "M") + (string-contains xy "D")) + (set! modified (+ modified 1))) + ((or (string-contains xy "A") + (string-contains xy "R")) + (set! staged (+ staged 1))))))) + lines) + (hash-put! status 'modified modified) + (hash-put! status 'staged staged) + (hash-put! status 'untracked untracked) + (atom-reset! *git-status-cache* status) + (when on-update + (ui-queue-push! (lambda () (on-update status)))))))) + (thread-sleep! 5) + (loop)))))) + +(def (stop-git-watcher!) + "Stop the git status watcher." + (when *git-watcher-thread* + (with-catch (lambda (e) #f) + (lambda () (thread-interrupt! *git-watcher-thread* + (lambda () (raise 'stop))))) + (set! *git-watcher-thread* #f))) + +;;; 8.3 Flycheck Watcher — runs linter on save via channel trigger + +(def *flycheck-trigger* (make-channel 64)) +(def *flycheck-watcher-thread* #f) + +(def (flycheck-trigger! path) + "Trigger a flycheck run for the given file path." + (channel-try-put *flycheck-trigger* path)) + +(def (start-flycheck-watcher! lint-fn on-result) + "Start flycheck watcher. lint-fn: (path) -> error-list. + on-result: (path errors) called on UI thread." + (stop-flycheck-watcher!) + (set! *flycheck-watcher-thread* + (spawn/name 'flycheck-watcher + (lambda () + (let loop () + (let ((path (channel-get *flycheck-trigger*))) + (when (string? path) + (with-catch + (lambda (e) + (jemacs-log! "flycheck error: " (format "~a" e))) + (lambda () + (let ((errors (lint-fn path))) + (ui-queue-push! + (lambda () (on-result path errors)))))))) + (loop)))))) + +(def (stop-flycheck-watcher!) + "Stop the flycheck watcher." + (when *flycheck-watcher-thread* + (with-catch (lambda (e) #f) + (lambda () (thread-interrupt! *flycheck-watcher-thread* + (lambda () (raise 'stop))))) + (set! *flycheck-watcher-thread* #f))) new file mode 100644 --- /dev/null +++ b/src/jemacs/buffer.ss @@ -0,0 +1,68 @@ +;;; -*- Gerbil -*- +;;; TUI buffer management for jemacs +;;; +;;; Each buffer owns a Scintilla document pointer (via SCI_CREATEDOCUMENT/ +;;; SCI_ADDREFDOCUMENT/SCI_RELEASEDOCUMENT). Switching buffers calls +;;; SCI_SETDOCPOINTER on the editor widget. +;;; +;;; Buffer struct, list management, and constants are in core.ss. + +(export + buffer::t make-buffer buffer? + buffer-name buffer-name-set! + buffer-file-path buffer-file-path-set! + buffer-doc-pointer buffer-doc-pointer-set! + buffer-mark buffer-mark-set! + buffer-modified buffer-modified-set! + buffer-lexer-lang buffer-lexer-lang-set! + buffer-backup-done? buffer-backup-done?-set! + *buffer-list* + buffer-list + buffer-list-add! + buffer-list-remove! + buffer-by-name + buffer-create! + buffer-create-from-editor! + buffer-kill! + buffer-attach! + buffer-scratch-name) + +(import :std/sugar + :chez-scintilla/constants + :chez-scintilla/scintilla + :jemacs/core) + +;;;============================================================================ +;;; Buffer creation (Scintilla-specific) +;;;============================================================================ + +(def (buffer-create! name editor (file-path #f)) + "Create a new buffer with a fresh Scintilla document." + (let* ((doc (send-message editor SCI_CREATEDOCUMENT 0 0)) + (buf (make-buffer name file-path doc #f #f #f #f))) + (buffer-list-add! buf) + buf)) + +(def (buffer-create-from-editor! name editor) + "Create a buffer wrapping the editor's current document. + Adds a reference so the buffer owns the document independently." + (let ((doc (send-message editor SCI_GETDOCPOINTER))) + (send-message editor SCI_ADDREFDOCUMENT 0 doc) + (let ((buf (make-buffer name #f doc #f #f #f #f))) + (buffer-list-add! buf) + buf))) + +;;;============================================================================ +;;; Buffer operations (Scintilla-specific) +;;;============================================================================ + +(def (buffer-kill! editor buf) + "Release the buffer's document and remove from the buffer list." + (send-message editor SCI_RELEASEDOCUMENT 0 (buffer-doc-pointer buf)) + (buffer-list-remove! buf)) + +(def (buffer-attach! editor buf) + "Switch editor to display this buffer's document. + Runs post-buffer-attach-hook to restore per-buffer settings (e.g. highlighting)." + (send-message editor SCI_SETDOCPOINTER 0 (buffer-doc-pointer buf)) + (run-hooks! 'post-buffer-attach-hook editor buf)) new file mode 100644 --- /dev/null +++ b/src/jemacs/chat.ss @@ -0,0 +1,113 @@ +;;; -*- Gerbil -*- +;;; AI Chat mode: interact with Claude CLI from a buffer +;;; +;;; Spawns `claude -p` in print mode for each prompt and streams +;;; the response into the chat buffer. Uses --continue for follow-up +;;; messages to maintain conversation context. + +(export chat-buffer? + *chat-state* + (struct-out chat-state) + chat-start! + chat-send! + chat-read-available + chat-stop! + chat-busy?) + +(import :std/sugar + :std/srfi/13 + :jemacs/core) + +;;;============================================================================ +;;; Chat state +;;;============================================================================ + +(def (chat-buffer? buf) + "Check if this buffer is an AI chat buffer." + (eq? (buffer-lexer-lang buf) 'chat)) + +;; Maps chat buffers to their chat-state structs +(def *chat-state* (make-hash-table-eq)) + +(defstruct chat-state + (process ; Gambit process port or #f when idle + prompt-pos ; integer: byte position where current input starts + busy? ; #t when waiting for AI response + continue? ; #t after first message (use --continue) + cwd) ; working directory for claude CLI context + transparent: #t) + +;;;============================================================================ +;;; Chat operations +;;;============================================================================ + +(def (chat-start! cwd) + "Create a new chat state (no subprocess yet — spawned per prompt)." + (make-chat-state #f 0 #f #f (or cwd (current-directory)))) + +(def (chat-busy? cs) + "Check if chat is waiting for a response." + (chat-state-busy? cs)) + +(def (chat-send! cs input) + "Send a prompt to Claude CLI. Spawns claude -p as a subprocess." + (when (and (not (chat-state-busy? cs)) + (> (string-length (string-trim input)) 0)) + (let* ((args (if (chat-state-continue? cs) + ["-p" "--continue" "--output-format" "text" + "--no-session-persistence" input] + ["-p" "--output-format" "text" + "--no-session-persistence" input])) + (proc (open-process + (list path: "claude" + arguments: args + directory: (chat-state-cwd cs) + stdin-redirection: #t + stdout-redirection: #t + stderr-redirection: #t + pseudo-terminal: #f)))) + ;; Close stdin immediately — claude -p reads prompt from args + (close-output-port proc) + (set! (chat-state-process cs) proc) + (set! (chat-state-busy? cs) #t) + (set! (chat-state-continue? cs) #t)))) + +(def (chat-read-available cs) + "Read all available output from the claude process (non-blocking). + Returns a string chunk, 'done if process finished, or #f if nothing available." + (let ((proc (chat-state-process cs))) + (if (and proc (chat-state-busy? cs)) + (if (char-ready? proc) + (let ((out (open-output-string))) + (let loop () + (when (char-ready? proc) + (let ((ch (read-char proc))) + (if (eof-object? ch) + ;; Process finished + (begin + (with-catch void (lambda () (process-status proc))) + (set! (chat-state-process cs) #f) + (set! (chat-state-busy? cs) #f)) + (begin + (write-char ch out) + (loop)))))) + (let ((s (get-output-string out))) + (if (and (string=? s "") (not (chat-state-busy? cs))) + 'done + (if (string=? s "") + #f + (if (chat-state-busy? cs) + s + ;; Got final chunk + EOF in same read + (cons s 'done)))))) + #f) + #f))) + +(def (chat-stop! cs) + "Stop any running claude process." + (let ((proc (chat-state-process cs))) + (when proc + (with-catch void (lambda () (close-output-port proc))) + (with-catch void (lambda () (process-status proc))) + (set! (chat-state-process cs) #f) + (set! (chat-state-busy? cs) #f)))) new file mode 100644 --- /dev/null +++ b/src/jemacs/core.ss @@ -0,0 +1,2428 @@ +;;; -*- Gerbil -*- +;;; Shared core for jemacs +;;; +;;; Backend-agnostic logic: keymap data structures, command registry, +;;; echo state, buffer metadata, app state, file I/O helpers. +;;; No Scintilla or TUI imports — this module is pure logic. + +(export + ;; Keymap data structures + make-keymap + keymap-bind! + keymap-lookup + keymap-entries + (struct-out key-state) + make-initial-key-state + *global-keymap* + *ctrl-x-map* + *meta-g-map* + *help-map* + *ctrl-x-r-map* + *ctrl-c-map* + *ctrl-c-l-map* + *ctrl-c-m-map* + *lsp-server-command* + *meta-s-map* + *ctrl-x-4-map* + *ctrl-x-5-map* + *ctrl-x-p-map* + *all-commands* + setup-default-bindings! + + ;; Mode keymaps + *mode-keymaps* + *buffer-name-mode-map* + mode-keymap-set! + mode-keymap-get + mode-keymap-lookup + setup-mode-keymaps! + + ;; App state + (struct-out app-state) + new-app-state + get-prefix-arg + + ;; Frame management state (virtual frames — save/restore window configs) + *frame-list* + *current-frame-idx* + frame-count + + ;; Command registry + register-command! + find-command + execute-command! + *command-docs* + register-command-doc! + command-doc + command-name->description + find-keybinding-for-command + setup-command-docs! + + ;; Echo state (pure state mutations) + (struct-out echo-state) + make-initial-echo-state + echo-message! + echo-error! + echo-clear! + notification-push! + notification-get-recent + *notification-log* + + ;; Buffer metadata (struct + list, no FFI) + (struct-out buffer) + *buffer-list* + buffer-list + buffer-list-add! + buffer-list-remove! + buffer-by-name + buffer-scratch-name + + ;; Key lossage + key-lossage-record! + key-lossage->string + + ;; Shared editor flags + *electric-indent-mode* + + ;; Shared helpers + brace-char? + safe-string-trim + safe-string-trim-both + + ;; Hooks + ;; *post-buffer-attach-hook* removed — now uses (add-hook! 'post-buffer-attach-hook ...) + *hooks* + add-hook! + remove-hook! + run-hooks! + + ;; File I/O helpers + read-file-as-string + write-string-to-file + + ;; Dired (directory listing) shared logic + *dired-entries* + dired-buffer? + strip-trailing-slash + dired-format-listing + + ;; Runtime error log file + init-jemacs-log! + jemacs-log! + + ;; Verbose hang-diagnosis log (~/.jemacs-verbose.log) + init-verbose-log! + verbose-log! + + ;; Captured output logs + append-error-log! append-output-log! + get-error-log get-output-log + clear-error-log! clear-output-log! + has-captured-output? + + ;; REPL shared logic + repl-buffer? + *repl-state* + eval-expression-string + ensure-gerbil-eval! + load-user-file! + load-user-string! + + ;; Fuzzy matching + fuzzy-match? + fuzzy-score + fuzzy-filter-sort + + ;; Helm mode flag + *helm-mode* + + ;; Key translation map + *key-translation-map* + key-translate! + key-translate-char + + ;; Key-chord system + *chord-map* + *chord-first-chars* + *chord-timeout* + *chord-mode* + key-chord-define-global + chord-lookup + chord-start-char? + + ;; Repeat-mode (transient repeat maps) + repeat-mode? + repeat-mode-set! + *repeat-maps* + active-repeat-map + active-repeat-map-set! + register-repeat-map! + register-default-repeat-maps! + repeat-map-for-command + repeat-map-lookup + repeat-map-hint + clear-repeat-map! + + ;; Image buffer support + *editor-window-map* + *image-buffer-state* + image-buffer? + find-defun-boundaries + + ;; Face system (from :jemacs/face) + face::t make-face face? + face-fg face-fg-set! face-bg face-bg-set! + face-bold face-bold-set! face-italic face-italic-set! + face-underline face-underline-set! + new-face + *faces* + define-face! + face-get + face-ref + set-face-attribute! + face-clear! + *default-font-family* + *default-font-size* + set-default-font! + get-default-font + parse-hex-color + rgb->hex + define-standard-faces! + ;; Init file convenience API + set-frame-font + + ;; Theme system (from :jemacs/themes) + *themes* + register-theme! + theme-get + theme-names + theme-dark + theme-light + theme-solarized-dark + theme-solarized-light + theme-monokai + theme-gruvbox-dark + theme-gruvbox-light + theme-dracula + theme-nord + theme-zenburn + + ;; Customize system (from :jemacs/customize) + defvar! + custom-get + custom-set! + custom-reset! + custom-describe + custom-list-group + custom-list-all + custom-groups + custom-registered? + *custom-registry* + defhook! + hook-doc + hook-list-all + + ;; Paredit strict mode + *paredit-strict-mode* + + ;; Quit flag (C-g subprocess interruption) + (struct-out keyboard-quit-exception) + *quit-flag* + quit-flag-set! + quit-flag-clear! + quit-flag?) + +(import :std/sugar + :std/sort + :std/srfi/13 + (only-in :std/srfi/19 current-date date->string) + :std/misc/rwlock + :jsh/startup + :jsh/expander + :jemacs/customize + :jemacs/face + :jemacs/themes) + +;;;============================================================================ +;;; Quit flag (C-g subprocess interruption) +;;;============================================================================ + +(defstruct keyboard-quit-exception () final: #t) + +(def *quit-flag* #f) + +(def (quit-flag-set!) + (set! *quit-flag* #t)) + +(def (quit-flag-clear!) + (set! *quit-flag* #f)) + +(def (quit-flag?) + *quit-flag*) + +;;;============================================================================ +;;; Keymap data structure +;;;============================================================================ + +(def (make-keymap) + (make-hash-table)) + +(def (keymap-bind! km key-str value) + (hash-put! km key-str value)) + +(def (keymap-lookup km key-str) + (hash-get km key-str)) + +(def (keymap-entries km) + "Return list of (key . value) for all entries in a keymap." + (hash->list km)) + +;;;============================================================================ +;;; Key state machine for multi-key sequences +;;;============================================================================ + +(defstruct key-state + (keymap ; current keymap to look up in + prefix-keys) ; list of accumulated key strings (for echo display) + transparent: #t) + +;;; Global keymaps +(def *global-keymap* (make-keymap)) +(def *ctrl-x-map* (make-keymap)) +(def *ctrl-x-r-map* (make-keymap)) +(def *ctrl-c-map* (make-keymap)) +(def *ctrl-c-l-map* (make-keymap)) +(def *ctrl-c-m-map* (make-keymap)) +(def *lsp-server-command* "gerbil-lsp") ;; overridable via ~/.jemacs-init +(defvar! 'lsp-server-command "gerbil-lsp" "Command to launch the LSP server" + setter: (lambda (v) (set! *lsp-server-command* v)) + type: 'string group: 'lsp) +(def *meta-g-map* (make-keymap)) +(def *help-map* (make-keymap)) +(def *meta-s-map* (make-keymap)) +(def *ctrl-x-4-map* (make-keymap)) +(def *ctrl-x-5-map* (make-keymap)) +(def *ctrl-x-p-map* (make-keymap)) + +;;;============================================================================ +;;; Mode keymaps — per-mode key bindings +;;;============================================================================ + +;; Maps mode-symbol -> keymap hash table +(def *mode-keymaps* (make-hash-table)) + +;; Maps buffer name patterns -> mode symbol for special buffers +(def *buffer-name-mode-map* + (make-hash-table)) + +(def (mode-keymap-set! mode-sym km) + "Register a keymap for a mode symbol." + (hash-put! *mode-keymaps* mode-sym km)) + +(def (mode-keymap-get mode-sym) + "Get the keymap for a mode symbol, or #f." + (hash-get *mode-keymaps* mode-sym)) + +(def (mode-keymap-lookup buf key-str) + "Look up KEY-STR in the buffer's mode keymap. Returns command symbol or #f. + Checks lexer-lang first, then buffer name for special buffers." + (let* ((lang (buffer-lexer-lang buf)) + (km (or (hash-get *mode-keymaps* lang) + (hash-get *buffer-name-mode-map* (buffer-name buf))))) + (and km (keymap-lookup km key-str)))) + +(def (setup-mode-keymaps!) + "Initialize mode-specific keybindings for special buffer types." + ;; Buffer name -> mode mapping for special buffers + (for-each + (lambda (pair) + (hash-put! *buffer-name-mode-map* (car pair) (cdr pair))) + '(("*compilation*" . compilation) ("*Grep*" . grep) ("*Occur*" . occur) + ("*calendar*" . calendar) ("*eww*" . eww) ("*Magit*" . magit) + ("*Magit: Commit*" . magit-commit) ("*Magit Log*" . magit-log) + ("*Magit Commit*" . magit-commit-view) ("*Magit Stash*" . magit-stash) + ("*Magit Stash Diff*" . magit-stash-diff) ("*Org Capture*" . org-capture) + ("*IBBuffer*" . ibuffer))) + + ;; Dired mode + (let ((km (make-keymap))) + (for-each (lambda (p) (keymap-bind! km (car p) (cdr p)))