Port jerboa-emacs to jerbuild transpilation (Gerbil .ss → Chez R6RS .sls)
ober
428bd84124a0b4557608827922aae9f3ec0aa410
--- a/.gitignore +++ b/.gitignore @@ -1,5 +1,7 @@ # Generated by jerbuild — do not edit -lib/jemacs/ +lib/jerboa-emacs/*.sls +!lib/jerboa-emacs/pty.sls +!lib/jerboa-emacs/debug-repl.sls src/.jerbuild-hashes # Compiled Chez artifacts --- a/Makefile +++ b/Makefile @@ -1,9 +1,10 @@ SCHEME = scheme 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 +GHERKIN = $(HOME)/mine/gherkin/src +LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(GHERKIN):$(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 LD_LIBRARY_PATH := $(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(HOME)/mine/jerboa-shell:$(LD_LIBRARY_PATH) export CHEZ_SCINTILLA_LIB := $(HOME)/mine/chez-scintilla .PHONY: all build rebuild test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test clean clean-generated deleted file mode 100644 --- a/lib/jerboa-emacs/async.sls +++ /dev/null @@ -1,329 +0,0 @@ -#!chezscheme -;;; async.sls — Async infrastructure for jemacs SMP -;;; -;;; Ported from gerbil-emacs/async.ss -;;; Provides a unified UI action queue, async process runners, -;;; async file I/O, and a periodic task scheduler. -;;; UPGRADE: Uses jerboa native threads (no Gambit SMP pinning needed — -;;; Chez uses native OS threads, so any thread can make UI calls if synchronized). - -(library (jerboa-emacs async) - (export - ;; UI action queue - ui-queue-push! - ui-queue-drain! - - ;; 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 (except (chezscheme) - make-hash-table hash-table? iota 1+ 1- sort sort! atom?) - (jerboa core) - (jerboa runtime) - (std sugar) - (std srfi srfi-13) - (only (std misc string) string-split) - (std misc channel) - (std misc atom) - (std misc process) - (only (jerboa prelude) path-strip-directory) - (only (std misc thread) thread-sleep!) - (jerboa-emacs core)) - - ;;;============================================================================ - ;;; UI Action Queue - ;;;============================================================================ - - (def *ui-queue* (make-channel 4096)) - - (def (ui-queue-push! thunk) - (with-catch - (lambda (e) (void)) - (lambda () (channel-put *ui-queue* thunk)))) - - (def (ui-queue-drain!) - (let loop ((n 0)) - (when (< n 64) - (let-values (((action ok) (channel-try-get *ui-queue*))) - (when ok - (with-catch - (lambda (e) (jemacs-log! (string-append "UI queue error: " (format "~a" e)))) - (lambda () (action))) - (loop (+ n 1))))))) - - ;;;============================================================================ - ;;; Periodic Task Scheduler - ;;;============================================================================ - - (def *scheduled-tasks* '()) - - (def (current-time-ms) - (let ((t (current-time))) - (+ (* (time-second t) 1000) - (quotient (time-nanosecond t) 1000000)))) - - (def (schedule-periodic! name interval-ms thunk) - (set! *scheduled-tasks* - (cons (list name interval-ms 0 thunk) *scheduled-tasks*))) - - (def (master-timer-tick!) - (ui-queue-drain!) - (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! (string-append "Timer error in " - (if (string? name) name (symbol->string name)) - ": " (format "~a" e)))) - thunk) - (list name interval now thunk)) - task))) - *scheduled-tasks*)))) - - ;;;============================================================================ - ;;; Async Process Runner - ;;;============================================================================ - - (def (async-process! cmd callback . rest) - (let ((on-error (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) #f)) - (stdin-text (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest)) (pair? (cdddr rest))) - (cadddr rest) #f))) - (fork-thread - (lambda () - (with-catch - (lambda (e) - (ui-queue-push! - (lambda () - (if on-error (on-error e) - (jemacs-log! (string-append "async-process error: " (format "~a" e))))))) - (lambda () - (let ((result (run-process (list "/bin/sh" "-c" cmd)))) - (ui-queue-push! (lambda () (callback result)))))))))) - - (def (async-process-stream! cmd on-line . rest) - (let ((on-done (if (pair? rest) (car rest) #f)) - (on-error (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) #f))) - (fork-thread - (lambda () - (with-catch - (lambda (e) - (ui-queue-push! - (lambda () - (if on-error (on-error e) - (jemacs-log! (string-append "async-process-stream error: " (format "~a" e))))))) - (lambda () - (let ((pp (open-process (list "/bin/sh" "-c" cmd)))) - (let ((stdout (process-port-rec-stdout-port pp))) - (let loop () - (let ((line (get-line stdout))) - (if (eof-object? line) - (begin - (close-port stdout) - (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) - (fork-thread - (lambda () - (let ((content (with-catch (lambda (e) #f) - (lambda () - (call-with-input-file path - (lambda (port) (get-string-all port))))))) - (ui-queue-push! (lambda () (callback content))))))) - - (def (async-write-file! path content callback) - (fork-thread - (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) - (fork-thread - (lambda () - (let ((result (with-catch - (lambda (e) (cons 'error e)) - thunk))) - (ui-queue-push! (lambda () (callback result))))))) - - ;;;============================================================================ - ;;; Background Services - ;;;============================================================================ - - ;;; File Indexer — builds file index for fast find-file completion - - (def *file-index* (atom (make-hash-table))) - (def (file-index) *file-index*) - (def *file-indexer-thread* #f) - - (def (build-file-index root-dir) - (let ((index (make-hash-table))) - (with-catch - (lambda (e) index) - (lambda () - (let walk ((dir root-dir)) - (for-each - (lambda (entry) - (let ((path (string-append dir "/" entry))) - (with-catch - (lambda (e) #f) - (lambda () - (if (file-directory? path) - (unless (and (> (string-length entry) 0) - (char=? (string-ref entry 0) #\.)) - (walk path)) - (let* ((name (path-strip-directory path)) - (existing (or (hash-get index name) '()))) - (hash-put! index name (cons path existing)))))))) - (directory-list dir))) - index)))) - - (def (start-file-indexer! root-dir) - (stop-file-indexer!) - (set! *file-indexer-thread* - (fork-thread - (lambda () - (let loop () - (let ((index (build-file-index root-dir))) - (atom-reset! *file-index* index)) - (thread-sleep! 30) - (loop)))))) - - (def (stop-file-indexer!) - (when *file-indexer-thread* - ;; No clean way to interrupt — just abandon - (set! *file-indexer-thread* #f))) - - (def (file-index-lookup name) - (or (hash-get (atom-deref *file-index*) name) '())) - - ;;; Git Status Watcher — polls git status for modeline - - (def *git-status-cache* (atom (make-hash-table))) - (def (git-status-cache) *git-status-cache*) - (def *git-watcher-thread* #f) - - (def (start-git-watcher! dir . rest) - (let ((on-update (if (pair? rest) (car rest) #f))) - (stop-git-watcher!) - (set! *git-watcher-thread* - (fork-thread - (lambda () - (let loop () - (with-catch - (lambda (e) #f) - (lambda () - (let* ((output (run-process (list "git" "status" "--porcelain" "-b") - 'directory: dir)) - (lines (string-split output #\newline)) - (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!) - (when *git-watcher-thread* - (set! *git-watcher-thread* #f))) - - ;;; Flycheck Watcher — runs linter on save via channel trigger - - (def *flycheck-trigger* (make-channel 64)) - (def (flycheck-trigger) *flycheck-trigger*) - (def *flycheck-watcher-thread* #f) - - (def (flycheck-trigger! path) - (with-catch - (lambda (e) (void)) - (lambda () (channel-put *flycheck-trigger* path)))) - - (def (start-flycheck-watcher! lint-fn on-result) - (stop-flycheck-watcher!) - (set! *flycheck-watcher-thread* - (fork-thread - (lambda () - (let loop () - (let ((path (channel-get *flycheck-trigger*))) - (when (string? path) - (with-catch - (lambda (e) - (jemacs-log! (string-append "flycheck error: " (format "~a" e)))) - (lambda () - (let ((errors (lint-fn path))) - (ui-queue-push! - (lambda () (on-result path errors)))))))) - (loop)))))) - - (def (stop-flycheck-watcher!) - (when *flycheck-watcher-thread* - (set! *flycheck-watcher-thread* #f))) - - ) ;; end library deleted file mode 100644 --- a/lib/jerboa-emacs/buffer.sls +++ /dev/null @@ -1,41 +0,0 @@ -#!chezscheme -(library (jerboa-emacs buffer) - (export - buffer-create! - buffer-create-from-editor! - buffer-kill! - buffer-attach!) - (import (except (chezscheme) - make-hash-table hash-table? iota 1+ 1- sort sort!) - (jerboa core) - (jerboa runtime) - (jerboa-emacs core) - (chez-scintilla constants) - (chez-scintilla scintilla)) - - (define buffer-create! - (case-lambda - ((name editor) - (buffer-create! name editor #f)) - ((name editor file-path) - (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)))) - - (define (buffer-create-from-editor! name editor) - (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))) - - (define (buffer-kill! editor buf) - (send-message editor SCI_RELEASEDOCUMENT 0 (buffer-doc-pointer buf)) - (buffer-list-remove! buf)) - - (define (buffer-attach! editor buf) - (send-message editor SCI_SETDOCPOINTER 0 (buffer-doc-pointer buf)) - (run-hooks! 'post-buffer-attach-hook editor buf)) - -) ;; end library deleted file mode 100644 --- a/lib/jerboa-emacs/chat.sls +++ /dev/null @@ -1,112 +0,0 @@ -#!chezscheme -;;; chat.sls — AI Chat mode: interact with Claude CLI from a buffer -;;; -;;; Ported from gerbil-emacs/chat.ss -;;; Spawns `claude -p` in print mode for each prompt and streams -;;; the response into the chat buffer. - -(library (jerboa-emacs chat) - (export chat-buffer? - chat-state-map - chat-state? chat-state-process chat-state-process-set! - chat-state-prompt-pos chat-state-prompt-pos-set! - chat-state-busy? chat-state-busy?-set! - chat-state-continue? chat-state-continue?-set! - chat-state-cwd - make-chat-state - chat-start! - chat-send! - chat-read-available - chat-stop! - chat-busy?) - (import (except (chezscheme) - make-hash-table hash-table? iota 1+ 1- sort sort!) - (jerboa core) - (jerboa runtime) - (std sugar) - (std srfi srfi-13) - (std misc process) - (jerboa-emacs core)) - - ;;;============================================================================ - ;;; Chat state - ;;;============================================================================ - - (def (chat-buffer? buf) - (eq? (buffer-lexer-lang buf) 'chat)) - - (def *chat-state* (make-hash-table-eq)) - (def (chat-state-map) *chat-state*) - - (defstruct chat-state (process prompt-pos busy? continue? cwd)) - - ;;;============================================================================ - ;;; Chat operations - ;;;============================================================================ - - (def (chat-start! cwd) - (make-chat-state #f 0 #f #f (or cwd (current-directory)))) - - (def (chat-busy? cs) - (chat-state-busy? cs)) - - (def (chat-send! cs input) - (when (and (not (chat-state-busy? cs)) - (> (string-length (string-trim input)) 0)) - (let* ((args (if (chat-state-continue? cs) - (list "claude" "-p" "--continue" "--output-format" "text" - "--no-session-persistence" input) - (list "claude" "-p" "--output-format" "text" - "--no-session-persistence" input))) - (pp (open-process args))) - ;; Close stdin immediately — claude -p reads prompt from args - (let ((stdin (process-port-rec-stdin-port pp))) - (when stdin (close-port stdin))) - (chat-state-process-set! cs pp) - (chat-state-busy?-set! cs #t) - (chat-state-continue?-set! cs #t)))) - - (def (chat-read-available cs) - (let ((pp (chat-state-process cs))) - (if (and pp (chat-state-busy? cs)) - (let ((stdout (process-port-rec-stdout-port pp))) - (if (input-port-ready? stdout) - (let ((out (open-output-string))) - (let loop () - (when (input-port-ready? stdout) - (let ((ch (read-char stdout))) - (if (eof-object? ch) - ;; Process finished - (begin - (with-catch void (lambda () (close-port stdout))) - (chat-state-process-set! cs #f) - (chat-state-busy?-set! 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 - (cons s 'done)))))) - #f)) - #f))) - - (def (chat-stop! cs) - (let ((pp (chat-state-process cs))) - (when pp - (with-catch void - (lambda () - (let ((stdin (process-port-rec-stdin-port pp))) - (when stdin (close-port stdin))))) - (with-catch void - (lambda () - (let ((stdout (process-port-rec-stdout-port pp))) - (when stdout (close-port stdout))))) - (chat-state-process-set! cs #f) - (chat-state-busy?-set! cs #f)))) - - ) ;; end library deleted file mode 100644 --- a/lib/jerboa-emacs/core.sls +++ /dev/null @@ -1,2013 +0,0 @@ -#!chezscheme -;;; core.sls — Shared core for jemacs -;;; -;;; Ported from gerbil-emacs/core.ss -;;; 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. - -(library (jerboa-emacs core) - (export - ;; Quit flag - keyboard-quit-exception? make-keyboard-quit-exception - quit-flag-set! quit-flag-clear! quit-flag? - - ;; Keymap data structures - make-keymap keymap-bind! keymap-lookup keymap-entries - key-state? make-key-state - key-state-keymap key-state-keymap-set! - key-state-prefix-keys key-state-prefix-keys-set! - make-initial-key-state - - ;; Global keymaps - *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 lsp-server-command-set! - *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! - - ;; Echo state - echo-state? make-echo-state - echo-state-message echo-state-message-set! - echo-state-error? echo-state-error?-set! - make-initial-echo-state - echo-message! echo-error! echo-clear! - notification-push! notification-get-recent - notification-log - - ;; Hooks - *hooks* add-hook! remove-hook! run-hooks! - - ;; Buffer metadata - buffer? make-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-add! buffer-list-remove! - buffer-by-name buffer-scratch-name - - ;; App state - app-state? make-app-state - app-state-frame app-state-frame-set! - app-state-echo app-state-echo-set! - app-state-key-state app-state-key-state-set! - app-state-running app-state-running-set! - app-state-last-search app-state-last-search-set! - app-state-kill-ring app-state-kill-ring-set! - app-state-kill-ring-idx app-state-kill-ring-idx-set! - app-state-last-yank-pos app-state-last-yank-pos-set! - app-state-last-yank-len app-state-last-yank-len-set! - app-state-last-compile app-state-last-compile-set! - app-state-bookmarks app-state-bookmarks-set! - app-state-rect-kill app-state-rect-kill-set! - app-state-dabbrev-state app-state-dabbrev-state-set! - app-state-macro-recording app-state-macro-recording-set! - app-state-macro-last app-state-macro-last-set! - app-state-macro-named app-state-macro-named-set! - app-state-mark-ring app-state-mark-ring-set! - app-state-registers app-state-registers-set! - app-state-last-command app-state-last-command-set! - app-state-prefix-arg app-state-prefix-arg-set! - app-state-prefix-digit-mode? app-state-prefix-digit-mode?-set! - app-state-key-handler app-state-key-handler-set! - app-state-winner-history app-state-winner-history-set! - app-state-winner-history-idx app-state-winner-history-idx-set! - app-state-tabs app-state-tabs-set! - app-state-current-tab-idx app-state-current-tab-idx-set! - app-state-key-lossage app-state-key-lossage-set! - new-app-state get-prefix-arg - - ;; Frame management - frame-list frame-list-set! - current-frame-idx current-frame-idx-set! - frame-count - - ;; Key lossage - key-lossage-record! key-lossage->string - - ;; 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! - - ;; Shared helpers - electric-indent-mode? electric-indent-mode-set! - brace-char? safe-string-trim safe-string-trim-both - - ;; File I/O - read-file-as-string write-string-to-file - - ;; Dired - *dired-entries* - dired-buffer? strip-trailing-slash dired-format-listing - - ;; Logging - init-jemacs-log! jemacs-log! - init-verbose-log! verbose-log! - - ;; Captured output - append-error-log! append-output-log! - get-error-log get-output-log - clear-error-log! clear-output-log! - has-captured-output? - - ;; REPL - repl-buffer? *repl-state* - eval-expression-string - load-user-file! load-user-string! - - ;; Fuzzy matching - fuzzy-match? fuzzy-score fuzzy-filter-sort - - ;; Paredit strict mode - paredit-strict-mode? paredit-strict-mode-set! - - ;; Helm mode - helm-mode? helm-mode-set! - - ;; Key translation - *key-translation-map* - key-translate! key-translate-char - - ;; Key-chord - *chord-map* *chord-first-chars* - chord-timeout chord-timeout-set! - chord-mode? chord-mode-set! - key-chord-define-global chord-lookup chord-start-char? - - ;; Repeat-mode - 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 - *editor-window-map* *image-buffer-state* - image-buffer? - find-defun-boundaries - - ;; Re-exports from face - face? make-face face-fg face-bg face-bold face-italic face-underline - new-face 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! set-frame-font - load-theme! current-theme-name - face-fg-rgb face-bg-rgb face-has-bold? face-has-italic? face-has-underline? - - ;; Re-exports from 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 - - ;; Re-exports from 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) - - (import (except (chezscheme) - make-hash-table hash-table? iota 1+ 1- sort sort!) - (jerboa core) - (jerboa runtime) - (std sugar) - (std sort) - (std string) - (only (std srfi srfi-19) current-date date->string) - (std misc rwlock) - (jerboa-emacs customize) - (jerboa-emacs face) - (jerboa-emacs themes)) - - ;;;============================================================================ - ;;; Quit flag (C-g subprocess interruption) - ;;;============================================================================ - - (defstruct keyboard-quit-exception ()) - - (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) - (hash->list km)) - - ;;;============================================================================ - ;;; Key state machine for multi-key sequences - ;;;============================================================================ - - (defstruct key-state (keymap prefix-keys)) - - ;;; 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* "chez-lsp") - (def (lsp-server-command) *lsp-server-command*) - (def (lsp-server-command-set! v) (set! *lsp-server-command* v)) - (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 - ;;;============================================================================ - - (def *mode-keymaps* (make-hash-table)) - (def *buffer-name-mode-map* (make-hash-table)) - - (def (mode-keymap-set! mode-sym km) - (hash-put! *mode-keymaps* mode-sym km)) - - (def (mode-keymap-get mode-sym) - (hash-get *mode-keymaps* mode-sym)) - - (def (mode-keymap-lookup buf key-str) - (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!) - ;; 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))) - '(("n" . next-line) ("p" . previous-line) ("g" . revert-buffer) - ("d" . dired-do-delete) ("R" . dired-do-rename) ("C" . dired-do-copy) - ("+" . dired-create-directory) ("q" . kill-buffer-cmd) ("^" . dired) - ("m" . dired-mark) ("u" . dired-unmark) ("U" . dired-unmark-all) - ("t" . dired-toggle-marks) ("D" . dired-do-delete-marked) ("x" . dired-do-delete-marked))) - (mode-keymap-set! 'dired km)) - - ;; Compilation mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("n" . next-error) ("p" . previous-error) ("g" . recompile) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'compilation km)) - - ;; Grep results mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("n" . next-grep-result) ("p" . previous-grep-result) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'grep km)) - - ;; Buffer list mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("n" . next-line) ("p" . previous-line) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'buffer-list km)) - - ;; IBBuffer mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("d" . ibuffer-mark-delete) ("s" . ibuffer-mark-save) - ("u" . ibuffer-unmark) ("x" . ibuffer-execute) ("RET" . ibuffer-goto-buffer) - ("/" . ibuffer-filter-name) ("S" . ibuffer-sort-name) ("z" . ibuffer-sort-size) - ("t" . ibuffer-toggle-marks) ("g" . ibuffer-refresh) - ("n" . next-line) ("p" . previous-line) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'ibuffer km)) - - ;; Occur mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("n" . next-line) ("p" . previous-line) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'occur km)) - - ;; Calendar mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("p" . calendar-prev-month) ("n" . calendar-next-month) - ("<" . calendar-prev-year) (">" . calendar-next-year) - ("." . calendar-today) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'calendar km)) - - ;; EWW browser mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("g" . eww) ("l" . eww-back) ("r" . eww-reload) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'eww km)) - - ;; Magit mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("s" . magit-stage) ("S" . magit-stage-all) ("u" . magit-unstage) - ("c" . magit-commit) ("a" . magit-amend) ("d" . magit-diff) - ("l" . magit-log) ("b" . magit-branch) ("B" . magit-blame) - ("f" . magit-fetch) ("F" . magit-pull) ("P" . magit-push) - ("r" . magit-rebase) ("m" . magit-merge) ("z" . magit-stash) - ("Z" . magit-stash-pop) ("x" . magit-cherry-pick) ("X" . magit-revert-commit) - ("w" . magit-worktree) ("k" . magit-checkout) ("g" . magit-status) - ("n" . next-line) ("p" . previous-line) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'magit km)) - - ;; Magit commit mode - (let ((km (make-keymap))) - (keymap-bind! km "C-c C-c" 'magit-commit-finalize) - (keymap-bind! km "C-c C-k" 'magit-commit-abort) - (mode-keymap-set! 'magit-commit km)) - - ;; Magit log mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("RET" . magit-log-show-commit) ("n" . next-line) ("p" . previous-line) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'magit-log km)) - - ;; Magit commit/diff view (shared by stash-diff) - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("n" . next-line) ("p" . previous-line) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'magit-commit-view km) - (mode-keymap-set! 'magit-stash-diff km)) - - ;; Magit stash list - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("RET" . magit-stash-show) ("n" . next-line) ("p" . previous-line) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'magit-stash km)) - - ;; Image mode - (let ((km (make-keymap))) - (for-each (lambda (p) (keymap-bind! km (car p) (cdr p))) - '(("+" . image-zoom-in) ("=" . image-zoom-in) ("-" . image-zoom-out) - ("0" . image-zoom-fit) ("1" . image-zoom-reset) ("q" . kill-buffer-cmd))) - (mode-keymap-set! 'image km)) - - ;; Org capture mode - (let ((km (make-keymap))) - (keymap-bind! km "C-c C-c" 'org-capture-finalize) - (keymap-bind! km "C-c C-k" 'org-capture-abort) - (mode-keymap-set! 'org-capture km))) - - (def (make-initial-key-state) - (make-key-state *global-keymap* '())) - - ;;;============================================================================ - ;;; Default Emacs-like keybindings - ;;;============================================================================ - - (def (setup-default-bindings!) - ;; C-x prefix - (keymap-bind! *global-keymap* "C-x" *ctrl-x-map*) - - ;; Navigation - (keymap-bind! *global-keymap* "C-f" 'forward-char) - (keymap-bind! *global-keymap* "C-b" 'backward-char) - (keymap-bind! *global-keymap* "C-n" 'next-line) - (keymap-bind! *global-keymap* "C-p" 'previous-line) - (keymap-bind! *global-keymap* "C-a" 'beginning-of-line) - (keymap-bind! *global-keymap* "C-e" 'end-of-line) - (keymap-bind! *global-keymap* "C-v" 'scroll-down) - (keymap-bind! *global-keymap* "C-l" 'recenter-top-bottom) - - ;; Arrow keys and navigation - (keymap-bind! *global-keymap* "<up>" 'previous-line) - (keymap-bind! *global-keymap* "<down>" 'next-line) - (keymap-bind! *global-keymap* "<left>" 'backward-char) - (keymap-bind! *global-keymap* "<right>" 'forward-char) - (keymap-bind! *global-keymap* "<home>" 'beginning-of-line) - (keymap-bind! *global-keymap* "<end>" 'end-of-line) - (keymap-bind! *global-keymap* "<prior>" 'scroll-up) - (keymap-bind! *global-keymap* "<next>" 'scroll-down) - (keymap-bind! *global-keymap* "<delete>" 'delete-char) - - ;; Alt/Meta navigation - (keymap-bind! *global-keymap* "M-f" 'forward-word) - (keymap-bind! *global-keymap* "M-b" 'backward-word) - (keymap-bind! *global-keymap* "M-v" 'scroll-up) - (keymap-bind! *global-keymap* "M-<" 'beginning-of-buffer) - (keymap-bind! *global-keymap* "M->" 'end-of-buffer) - - ;; Editing - (keymap-bind! *global-keymap* "C-d" 'delete-char) - (keymap-bind! *global-keymap* "DEL" 'backward-delete-char) - (keymap-bind! *global-keymap* "C-h" 'backward-delete-char) - (keymap-bind! *global-keymap* "C-k" 'kill-line) - (keymap-bind! *global-keymap* "C-y" 'yank) - (keymap-bind! *global-keymap* "C-w" 'kill-region) - (keymap-bind! *global-keymap* "M-w" 'copy-region) - (keymap-bind! *global-keymap* "C-_" 'undo) - (keymap-bind! *global-keymap* "C-/" 'undo) - (keymap-bind! *global-keymap* "C-m" 'newline) - (keymap-bind! *global-keymap* "C-j" 'newline) - (keymap-bind! *global-keymap* "C-o" 'open-line) - - ;; Mark - (keymap-bind! *global-keymap* "C-@" 'set-mark) - - ;; Search - (keymap-bind! *global-keymap* "C-s" 'search-forward) - (keymap-bind! *global-keymap* "C-r" 'search-backward) - - ;; Function keys - (keymap-bind! *global-keymap* "<f11>" 'uncomment-region) - (keymap-bind! *global-keymap* "<f12>" 'comment-region) - - ;; Universal argument - (keymap-bind! *global-keymap* "C-u" 'universal-argument) - - ;; Digit arguments - (keymap-bind! *global-keymap* "M-0" 'digit-argument-0) - (keymap-bind! *global-keymap* "M-1" 'digit-argument-1) - (keymap-bind! *global-keymap* "M-2" 'digit-argument-2) - (keymap-bind! *global-keymap* "M-3" 'digit-argument-3) - (keymap-bind! *global-keymap* "M-4" 'digit-argument-4) - (keymap-bind! *global-keymap* "M-5" 'digit-argument-5) - (keymap-bind! *global-keymap* "M-6" 'digit-argument-6) - (keymap-bind! *global-keymap* "M-7" 'digit-argument-7) - (keymap-bind! *global-keymap* "M-8" 'digit-argument-8) - (keymap-bind! *global-keymap* "M-9" 'digit-argument-9) - (keymap-bind! *global-keymap* "M--" 'negative-argument) - - ;; Misc - (keymap-bind! *global-keymap* "C-g" 'keyboard-quit) - - ;; C-x commands - (keymap-bind! *ctrl-x-map* "C-s" 'save-buffer) - (keymap-bind! *ctrl-x-map* "C-f" 'find-file) - (keymap-bind! *ctrl-x-map* "C-r" 'recentf-open) - (keymap-bind! *ctrl-x-map* "C-c" 'quit) - (keymap-bind! *ctrl-x-map* "b" 'switch-buffer) - (keymap-bind! *ctrl-x-map* "k" 'kill-buffer-cmd) - (keymap-bind! *ctrl-x-map* "2" 'split-window) - (keymap-bind! *ctrl-x-map* "o" 'other-window) - (keymap-bind! *ctrl-x-map* "0" 'delete-window) - (keymap-bind! *ctrl-x-map* "1" 'delete-other-windows) - (keymap-bind! *ctrl-x-map* "3" 'split-window-right) - - ;; REPL - (keymap-bind! *global-keymap* "M-:" 'eval-expression) - ;; C-c prefix - (keymap-bind! *global-keymap* "C-c" *ctrl-c-map*)