Add full TUI with termbox2: 12 modules, theme system, markdown rendering
ober
d67f4201000230aefe7b5ab294058dd8876051d2
--- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,6 @@ [submodule "vendor/chez-sqlite"] path = vendor/chez-sqlite url = https://github.com/ober/chez-sqlite.git +[submodule "vendor/termbox2"] + path = vendor/termbox2 + url = https://github.com/termbox/termbox2.git --- a/Makefile +++ b/Makefile @@ -6,10 +6,11 @@ JERBUILD = $(SCHEME) --libdirs $(JERBOA_HOME)/lib --script $(JERBOA_HOME)/jerb # Library paths for FFI shared objects (macOS: dylib, Linux: so) SQLITE_LIB_DIR := $(shell brew --prefix sqlite 2>/dev/null)/lib SHIM_DIR := $(CURDIR)/vendor/chez-sqlite +TUI_SHIM_DIR := $(CURDIR)/vendor/termbox2 NATIVE_LIB_DIR := $(JERBOA_HOME)/lib -LDPATH := $(SHIM_DIR):$(SQLITE_LIB_DIR):$(NATIVE_LIB_DIR) +LDPATH := $(SHIM_DIR):$(TUI_SHIM_DIR):$(SQLITE_LIB_DIR):$(NATIVE_LIB_DIR) -.PHONY: all build gen run test clean repl binary install +.PHONY: all build gen run test clean repl binary install tui-shim run-tui all: build @@ -24,6 +25,18 @@ run: DYLD_LIBRARY_PATH=$(LDPATH) LD_LIBRARY_PATH=$(LDPATH) \ $(SCHEME) $(LIBDIRS) --script main.ss +tui-shim: + @test -f $(TUI_SHIM_DIR)/jcode_tui_shim.dylib \ + -o -f $(TUI_SHIM_DIR)/jcode_tui_shim.so || \ + cc -shared -fPIC -DTB_OPT_ATTR_W=32 \ + -I$(TUI_SHIM_DIR) \ + -o $(TUI_SHIM_DIR)/jcode_tui_shim.dylib \ + src/jcode/ui/jcode_tui_shim.c + +run-tui: build tui-shim + DYLD_LIBRARY_PATH=$(LDPATH) LD_LIBRARY_PATH=$(LDPATH) \ + $(SCHEME) $(LIBDIRS) --script main.ss --tui + repl: $(SCHEME) $(LIBDIRS) --- a/lib/jcode/core/config.sls +++ b/lib/jcode/core/config.sls @@ -3,9 +3,9 @@ ;;; Source: src/jcode/core/config.ss (library (jcode core config) - (export load-config config-ref config-api-key config-model - config-provider config-get-provider-key config-default-model - *config*) + (export load-config jcode-home config-ref config-api-key + config-model config-provider config-get-provider-key + config-default-model *config*) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -13,15 +13,15 @@ (std text json) (std os path) (jerboa core) (jerboa runtime)) (define *config*--cell (vector (make-parameter #f))) + (def (jcode-home) + "Return ~/.jcode, creating it if needed." + (let ([dir (path-join (getenv "HOME") ".jcode")]) + (unless (file-exists? dir) (mkdir dir)) + dir)) (def (config-paths) (list (path-join (current-directory) "jcode.json") - (path-join - (or (getenv "XDG_CONFIG_HOME") - (path-join (getenv "HOME") ".config")) - "jcode" - "config.json") - (path-join (getenv "HOME") ".jcode.json"))) + (path-join (jcode-home) "config.json"))) (def (find-config-file) (let loop ([paths (config-paths)]) (cond @@ -56,11 +56,8 @@ (hash-put! config "providers" providers) config)) (def (merge-opencode-keys! providers) - (let ([auth-file (path-join - (or (getenv "XDG_DATA_HOME") - (path-join (getenv "HOME") ".local" "share")) - "opencode" - "auth.json")]) + (let ([auth-file (path-join (getenv "HOME") ".local" "share" + "opencode" "auth.json")]) (when (file-exists? auth-file) (try (let ([auth (call-with-input-file auth-file --- a/lib/jcode/core/plugin.sls +++ b/lib/jcode/core/plugin.sls @@ -14,11 +14,7 @@ (def *loaded-plugins* '()) (def (plugin-dirs) "Return list of directories to scan for plugins." - (let ([home-dir (path-join - (or (getenv "XDG_CONFIG_HOME") - (path-join (getenv "HOME") ".config")) - "jcode" - "plugins")] + (let ([home-dir (path-join (jcode-home) "plugins")] [local-dir (path-join (current-directory) ".jcode" --- a/lib/jcode/core/session.sls +++ b/lib/jcode/core/session.sls @@ -12,15 +12,10 @@ getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) (std db sqlite) (std misc uuid) (std os path) - (std text json) (jcode core message) (jerboa core) - (jerboa runtime)) + (std text json) (jcode core config) (jcode core message) + (jerboa core) (jerboa runtime)) (defstruct session (id title created messages)) - (def (db-path) - (let* ([data-dir (or (getenv "XDG_DATA_HOME") - (path-join (getenv "HOME") ".local" "share"))] - [dir (path-join data-dir "jcode")]) - (unless (file-exists? dir) (mkdir dir)) - (path-join dir "sessions.db"))) + (def (db-path) (path-join (jcode-home) "sessions.db")) (def (open-db) (sqlite-open (db-path))) (def (session-init-db) (let ([db (open-db)]) --- a/lib/jcode/ui/cli.sls +++ b/lib/jcode/ui/cli.sls @@ -5,15 +5,16 @@ (library (jcode ui cli) (export cli-main) (import - (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- - getenv path-extension path-absolute? thread? make-mutex - mutex? mutex-name) - (std misc string) (std text json) (jcode core config) - (jcode core log) (jcode core session) (jcode core message) - (jcode core agent) (jcode tool registry) (jcode tool file) - (jcode tool bash) (jcode tool web) (jcode tool batch) - (jcode tool git) (jcode mcp client) (jcode tool lsp) - (jcode core plugin) (jerboa core) (jerboa runtime)) + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (std misc string) (std text json) (jcode core config) + (jcode core log) (jcode core session) (jcode core message) + (jcode core agent) (jcode tool registry) (jcode tool file) + (jcode tool bash) (jcode tool web) (jcode tool batch) + (jcode tool git) (jcode mcp client) (jcode tool lsp) + (jcode core plugin) (jcode ui tui) (jerboa core) + (jerboa runtime)) (def logger (make-logger "cli")) (def *version* "0.1.0") (def (cli-main args) @@ -39,6 +40,7 @@ (let ([rest (let ([r (assoc '\x2D;- opts)]) (if r (cdr r) '()))]) (cond + [(assoc '\x2D;-tui opts) (tui-main args)] [(null? rest) (interactive-mode opts)] [(equal? (car rest) "session") (session-command (cdr rest))] [(equal? (car rest) "config") (config-command (cdr rest))] @@ -59,6 +61,10 @@ (loop (cdr args) (cons '(\x2D;-debug . #t) opts))] [(equal? (car args) "-d") (loop (cdr args) (cons '(\x2D;-debug . #t) opts))] + [(equal? (car args) "--tui") + (loop (cdr args) (cons '(\x2D;-tui . #t) opts))] + [(equal? (car args) "--no-tui") + (loop (cdr args) (cons '(\x2D;-no-tui . #t) opts))] [(and (equal? (car args) "--model") (pair? (cdr args))) (loop (cddr args) @@ -81,7 +87,7 @@ (init-mcp-tools) (init-lsp-tools) (init-plugins)) (def (display-help) (display - "jcode - Portable AI coding agent\n\nUSAGE:\n jcode [OPTIONS] [PROMPT]\n jcode [COMMAND]\n\nOPTIONS:\n -h, --help Show this help message\n -v, --version Show version\n -d, --debug Enable debug logging\n -m, --model Model to use (default: claude-sonnet-4-20250514)\n -p, --provider Provider to use (default: anthropic)\n\nCOMMANDS:\n session list List all sessions\n session resume Resume a previous session\n config Show or edit configuration\n\nEXAMPLES:\n jcode Start interactive session\n jcode \"Read main.ss\" One-shot query\n jcode session list List sessions\n")) + "jcode - Portable AI coding agent\n\nUSAGE:\n jcode [OPTIONS] [PROMPT]\n jcode [COMMAND]\n\nOPTIONS:\n -h, --help Show this help message\n -v, --version Show version\n -d, --debug Enable debug logging\n -m, --model Model to use (default: claude-sonnet-4-20250514)\n -p, --provider Provider to use (default: anthropic)\n --tui Launch terminal UI mode\n --no-tui Force line-mode REPL (default)\n\nCOMMANDS:\n session list List all sessions\n session resume Resume a previous session\n config Show or edit configuration\n\nEXAMPLES:\n jcode Start interactive session\n jcode \"Read main.ss\" One-shot query\n jcode session list List sessions\n")) (def (interactive-mode opts) (printf "jcode ~a~n" *version*) (printf new file mode 100644 --- /dev/null +++ b/lib/jcode/ui/tui-dialog.sls @@ -0,0 +1,158 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jcode/ui/tui-dialog.ss + +(library (jcode ui tui-dialog) + (export make-dialog dialog? dialog-title dialog-body dialog-actions + dialog-selected dialog-selected-set! dialog-result + show-dialog! render-dialog! make-permission-dialog + make-confirm-dialog) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (jcode ui tui-ffi) (jcode ui tui-theme) (jerboa core) + (jerboa runtime)) + (defstruct + dialog + (title body actions selected result) + transparent: + #t) + (def (make-permission-dialog tool-name tool-args) + (let ([body-lines (list + (string-append "Tool: " tool-name) + "" + (let ([summary (tool-args-summary tool-args)]) + (if summary + (string-append " " summary) + "")))]) + (make-dialog "Permission Required" body-lines + '(("Allow" . allow) ("Deny" . deny) ("Always" . always)) 0 + #f))) + (def (make-confirm-dialog title message) + (make-dialog title (string-split message #\newline) + '(("Yes" . yes) ("No" . no)) 0 #f)) + (def (tool-args-summary args) + (cond + [(hash-table? args) + (or (hash-get args "path") + (hash-get args "command") + (hash-get args "pattern") + #f)] + [#t #f])) + (def (show-dialog! dlg) + "Show dialog modally. Returns the selected action value." + (let loop () + (render-dialog! dlg (tb-width) (tb-height)) + (tb-present!) + (let ([ev (tb-poll-event)]) + (when ev + (when (tui-event-key? ev) + (let ([key (tui-event-key ev)] [ch (tui-event-ch ev)]) + (cond + [(or (= key TB_KEY_TAB) (= key TB_KEY_ARROW_RIGHT)) + (dialog-selected-set! + dlg + (modulo + (+ (dialog-selected dlg) 1) + (length (dialog-actions dlg))))] + [(= key TB_KEY_ARROW_LEFT) + (dialog-selected-set! + dlg + (modulo + (- (dialog-selected dlg) 1) + (length (dialog-actions dlg))))] + [(= key TB_KEY_ENTER) + (let ([action (list-ref + (dialog-actions dlg) + (dialog-selected dlg))]) + (dialog-result-set! dlg (cdr action)))] + [(= key TB_KEY_ESC) (dialog-result-set! dlg 'deny)] + [#t + (when (> ch 0) + (let ([c (char-downcase (integer->char ch))]) + (let find ([actions (dialog-actions dlg)] [idx 0]) + (when (pair? actions) + (let ([label (caar actions)]) + (when (and (> (string-length label) 0) + (char=? + (char-downcase + (string-ref label 0)) + c)) + (dialog-selected-set! dlg idx) + (dialog-result-set! dlg (cdar actions)))) + (find (cdr actions) (+ idx 1))))))])))) + (if (dialog-result dlg) (dialog-result dlg) (loop))))) + (def (render-dialog! dlg screen-w screen-h) + "Render dialog centered on screen." + (let* ([body (dialog-body dlg)] + [title (dialog-title dlg)] + [actions (dialog-actions dlg)] + [content-w (max (+ (string-length title) 4) + (apply + max + (map (lambda (l) (+ (string-length l) 4)) + body)) + (+ 4 + (apply + + + (map (lambda (a) + (+ (string-length (car a)) 4)) + actions))))] + [box-w (min (+ content-w 4) (- screen-w 4))] + [box-h (+ (length body) 5)] + [bx (max 0 (quotient (- screen-w box-w) 2))] + [by (max 0 (quotient (- screen-h box-h) 2))] + [bfg (face-fg-attr 'dialog-border)] + [bbg (face-bg-attr 'dialog-border)] + [tfg (face-fg-attr 'dialog-title)] + [dfg (face-fg-attr 'dialog-text)] + [dbg (face-bg-attr 'dialog-text)]) + (draw-hline! bx by box-w bfg bbg #\─) + (tb-print! (+ bx 2) by tfg bbg + (string-append "─ " title " ")) + (let loop ([lines body] [row (+ by 1)]) + (when (pair? lines) + (clear-dialog-row! bx row box-w dbg) + (tb-change-cell! bx row (char->integer #\│) bfg bbg) + (tb-change-cell! (+ bx box-w -1) row (char->integer #\│) bfg + bbg) + (tb-print! (+ bx 2) row dfg dbg (car lines)) + (loop (cdr lines) (+ row 1)))) + (let ([arow (+ by 1 (length body))]) + (clear-dialog-row! bx arow box-w dbg) + (tb-change-cell! bx arow (char->integer #\│) bfg bbg) + (tb-change-cell! (+ bx box-w -1) arow (char->integer #\│) + bfg bbg) + (let ([arow (+ arow 1)]) + (clear-dialog-row! bx arow box-w dbg) + (tb-change-cell! bx arow (char->integer #\│) bfg bbg) + (tb-change-cell! (+ bx box-w -1) arow (char->integer #\│) + bfg bbg) + (let act-loop ([acts actions] [idx 0] [col (+ bx 3)]) + (when (pair? acts) + (let* ([label (caar acts)] + [selected? (= idx (dialog-selected dlg))] + [afg (if selected? + (face-fg-attr 'dialog-action) + (face-fg-attr 'dialog-text))] + [abg (if selected? + (face-bg-attr 'completion-selected) + dbg)] + [display (string-append "[" label "]")]) + (tb-print! col arow afg abg display) + (act-loop + (cdr acts) + (+ idx 1) + (+ col (string-length display) 2))))) + (draw-hline! bx (+ arow 1) box-w bfg bbg #\─))))) + (def (draw-hline! x y width fg bg ch) + (let loop ([col x]) + (when (< col (+ x width)) + (tb-change-cell! col y (char->integer ch) fg bg) + (loop (+ col 1))))) + (def (clear-dialog-row! x y width bg) + (let loop ([col x]) + (when (< col (+ x width)) + (tb-change-cell! col y (char->integer #\space) bg bg) + (loop (+ col 1)))))) new file mode 100644 --- /dev/null +++ b/lib/jcode/ui/tui-diff.sls @@ -0,0 +1,48 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jcode/ui/tui-diff.ss + +(library (jcode ui tui-diff) + (export diff-render-segments diff-parse-lines) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (std misc string) (jcode ui tui-theme) (jerboa core) + (jerboa runtime)) + (defstruct diff-line (type text) transparent: #t) + (def (diff-parse-lines diff-text) + "Parse unified diff string into list of diff-line structs." + (let ([lines (string-split diff-text #\newline)]) + (map (lambda (line) + (cond + [(string-empty? line) (make-diff-line 'context "")] + [(string-prefix? "@@" line) (make-diff-line 'hunk line)] + [(string-prefix? "+++" line) + (make-diff-line 'header line)] + [(string-prefix? "---" line) + (make-diff-line 'header line)] + [(string-prefix? "+" line) (make-diff-line 'added line)] + [(string-prefix? "-" line) + (make-diff-line 'removed line)] + [#t (make-diff-line 'context line)])) + lines))) + (def (diff-render-segments diff-text file-path) + "Render a diff into a list of (list-of (text . face-name)) per line.\n Includes a file header line." + (let* ([parsed (diff-parse-lines diff-text)] + [header-line (list + (cons + (string-append "── " file-path " ") + 'diff-header) + (cons "──────────" 'diff-header))]) + (cons + header-line + (map (lambda (dl) + (let ([face (case (diff-line-type dl) + [(added) 'diff-added] + [(removed) 'diff-removed] + [(hunk) 'diff-hunk] + [(header) 'diff-header] + [else 'diff-context])]) + (list (cons (diff-line-text dl) face)))) + parsed))))) new file mode 100644 --- /dev/null +++ b/lib/jcode/ui/tui-ffi.sls @@ -0,0 +1,246 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jcode/ui/tui-ffi.ss + +(library (jcode ui tui-ffi) + (export tb-init! tb-shutdown! with-tui tb-width tb-height + tb-clear! tb-present! tb-set-cursor! tb-hide-cursor! + tb-change-cell! tb-set-clear-attrs! tb-print! tb-printf! + tb-set-input-mode! tb-set-output-mode! tb-poll-event + tb-peek-event make-tui-event tui-event? tui-event-type + tui-event-mod tui-event-key tui-event-ch tui-event-w + tui-event-h tui-event-x tui-event-y tui-event-key? + tui-event-resize? tui-event-mouse? TB_EVENT_KEY + TB_EVENT_RESIZE TB_EVENT_MOUSE TB_KEY_F1 TB_KEY_F2 TB_KEY_F3 + TB_KEY_F4 TB_KEY_F5 TB_KEY_F6 TB_KEY_F7 TB_KEY_F8 TB_KEY_F9 + TB_KEY_F10 TB_KEY_F11 TB_KEY_F12 TB_KEY_INSERT TB_KEY_DELETE + TB_KEY_HOME TB_KEY_END TB_KEY_PGUP TB_KEY_PGDN + TB_KEY_ARROW_UP TB_KEY_ARROW_DOWN TB_KEY_ARROW_LEFT + TB_KEY_ARROW_RIGHT TB_KEY_BACKSPACE TB_KEY_BACKSPACE2 + TB_KEY_TAB TB_KEY_ENTER TB_KEY_ESC TB_KEY_SPACE + TB_KEY_MOUSE_LEFT TB_KEY_MOUSE_RIGHT TB_KEY_MOUSE_MIDDLE + TB_KEY_MOUSE_RELEASE TB_KEY_MOUSE_WHEEL_UP + TB_KEY_MOUSE_WHEEL_DOWN TB_KEY_CTRL_A TB_KEY_CTRL_B + TB_KEY_CTRL_C TB_KEY_CTRL_D TB_KEY_CTRL_E TB_KEY_CTRL_F + TB_KEY_CTRL_G TB_KEY_CTRL_H TB_KEY_CTRL_I TB_KEY_CTRL_J + TB_KEY_CTRL_K TB_KEY_CTRL_L TB_KEY_CTRL_M TB_KEY_CTRL_N + TB_KEY_CTRL_O TB_KEY_CTRL_P TB_KEY_CTRL_Q TB_KEY_CTRL_R + TB_KEY_CTRL_S TB_KEY_CTRL_T TB_KEY_CTRL_U TB_KEY_CTRL_V + TB_KEY_CTRL_W TB_KEY_CTRL_X TB_KEY_CTRL_Y TB_KEY_CTRL_Z + TB_MOD_ALT TB_MOD_SHIFT TB_MOD_CTRL TB_MOD_MOTION + TB_INPUT_CURRENT TB_INPUT_ESC TB_INPUT_ALT TB_INPUT_MOUSE + TB_OUTPUT_CURRENT TB_OUTPUT_NORMAL TB_OUTPUT_256 + TB_OUTPUT_216 TB_OUTPUT_GRAYSCALE TB_OUTPUT_TRUECOLOR + TB_DEFAULT TB_BLACK TB_RED TB_GREEN TB_YELLOW TB_BLUE + TB_MAGENTA TB_CYAN TB_WHITE TB_BOLD TB_UNDERLINE TB_REVERSE + TB_ITALIC TB_BLINK TB_DIM TB_HIDE_CURSOR) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (std os path) + (jerboa core) + (jerboa runtime)) + (def _shim-loaded + (or (guard (e [list #t #f]) + (load-shared-object "jcode_tui_shim.dylib")) + (guard (e [list #t #f]) + (load-shared-object "jcode_tui_shim.so")) + (guard (e [list #t #f]) + (load-shared-object + (path-join + (path-directory (car (command-line))) + "jcode_tui_shim.dylib"))) + #f)) + (defrule + (define-tb name c-name arg-types ret-type) + (def name + (if (and _shim-loaded (foreign-entry? c-name)) + (foreign-procedure c-name arg-types ret-type) + (lambda args + (error 'tui-ffi "termbox shim not loaded" c-name))))) + (defstruct tui-event (type mod key ch w h x y)) + (def (read-event!) + (make-tui-event (c-tb-ev-type) (c-tb-ev-mod) (c-tb-ev-key) (c-tb-ev-ch) + (c-tb-ev-w) (c-tb-ev-h) (c-tb-ev-x) (c-tb-ev-y))) + (def TB_EVENT_KEY 1) + (def TB_EVENT_RESIZE 2) + (def TB_EVENT_MOUSE 3) + (def TB_KEY_F1 65535) + (def TB_KEY_F2 (- 65535 1)) + (def TB_KEY_F3 (- 65535 2)) + (def TB_KEY_F4 (- 65535 3)) + (def TB_KEY_F5 (- 65535 4)) + (def TB_KEY_F6 (- 65535 5)) + (def TB_KEY_F7 (- 65535 6)) + (def TB_KEY_F8 (- 65535 7)) + (def TB_KEY_F9 (- 65535 8)) + (def TB_KEY_F10 (- 65535 9)) + (def TB_KEY_F11 (- 65535 10)) + (def TB_KEY_F12 (- 65535 11)) + (def TB_KEY_INSERT (- 65535 12)) + (def TB_KEY_DELETE (- 65535 13)) + (def TB_KEY_HOME (- 65535 14)) + (def TB_KEY_END (- 65535 15)) + (def TB_KEY_PGUP (- 65535 16)) + (def TB_KEY_PGDN (- 65535 17)) + (def TB_KEY_ARROW_UP (- 65535 18)) + (def TB_KEY_ARROW_DOWN (- 65535 19)) + (def TB_KEY_ARROW_LEFT (- 65535 20)) + (def TB_KEY_ARROW_RIGHT (- 65535 21)) + (def TB_KEY_BACKSPACE 8) + (def TB_KEY_BACKSPACE2 127) + (def TB_KEY_TAB 9) + (def TB_KEY_ENTER 13) + (def TB_KEY_ESC 27) + (def TB_KEY_SPACE 32) + (def TB_KEY_MOUSE_LEFT (- 65535 22)) + (def TB_KEY_MOUSE_RIGHT (- 65535 23)) + (def TB_KEY_MOUSE_MIDDLE (- 65535 24)) + (def TB_KEY_MOUSE_RELEASE (- 65535 25)) + (def TB_KEY_MOUSE_WHEEL_UP (- 65535 26)) + (def TB_KEY_MOUSE_WHEEL_DOWN (- 65535 27)) + (def TB_KEY_CTRL_A 1) + (def TB_KEY_CTRL_B 2) + (def TB_KEY_CTRL_C 3) + (def TB_KEY_CTRL_D 4) + (def TB_KEY_CTRL_E 5) + (def TB_KEY_CTRL_F 6) + (def TB_KEY_CTRL_G 7) + (def TB_KEY_CTRL_H 8) + (def TB_KEY_CTRL_I 9) + (def TB_KEY_CTRL_J 10) + (def TB_KEY_CTRL_K 11) + (def TB_KEY_CTRL_L 12) + (def TB_KEY_CTRL_M 13) + (def TB_KEY_CTRL_N 14) + (def TB_KEY_CTRL_O 15) + (def TB_KEY_CTRL_P 16) + (def TB_KEY_CTRL_Q 17) + (def TB_KEY_CTRL_R 18) + (def TB_KEY_CTRL_S 19) + (def TB_KEY_CTRL_T 20) + (def TB_KEY_CTRL_U 21) + (def TB_KEY_CTRL_V 22) + (def TB_KEY_CTRL_W 23) + (def TB_KEY_CTRL_X 24) + (def TB_KEY_CTRL_Y 25) + (def TB_KEY_CTRL_Z 26) + (def TB_MOD_ALT 1) + (def TB_MOD_SHIFT 4) + (def TB_MOD_CTRL 2) + (def TB_MOD_MOTION 8) + (def TB_INPUT_CURRENT 0) + (def TB_INPUT_ESC 1) + (def TB_INPUT_ALT 2) + (def TB_INPUT_MOUSE 4) + (def TB_OUTPUT_CURRENT 0) + (def TB_OUTPUT_NORMAL 1) + (def TB_OUTPUT_256 2) + (def TB_OUTPUT_216 3) + (def TB_OUTPUT_GRAYSCALE 4) + (def TB_OUTPUT_TRUECOLOR 5) + (def TB_DEFAULT 0) + (def TB_BLACK 1) + (def TB_RED 2) + (def TB_GREEN 3) + (def TB_YELLOW 4) + (def TB_BLUE 5) + (def TB_MAGENTA 6) + (def TB_CYAN 7) + (def TB_WHITE 8) + (def TB_BOLD 16777216) + (def TB_UNDERLINE 33554432) + (def TB_REVERSE 67108864) + (def TB_ITALIC 134217728) + (def TB_BLINK 268435456) + (def TB_DIM 536870912) + (def TB_HIDE_CURSOR -1) + (def (tb-init!) + (let ([rc (c-tb-init)]) + (when (< rc 0) (error 'tb-init! "termbox init failed" rc)) + rc)) + (def (tb-shutdown!) (c-tb-shutdown)) + (defrule + (with-tui body ...) + (dynamic-wind + (lambda () (tb-init!)) + (lambda () body ...) + (lambda () (tb-shutdown!)))) + (def (tb-width) (c-tb-width)) + (def (tb-height) (c-tb-height)) + (def (tb-clear!) (c-tb-clear)) + (def (tb-present!) (c-tb-present)) + (def (tb-set-cursor! x y) (c-tb-set-cursor x y)) + (def (tb-hide-cursor!) (c-tb-hide-cursor)) + (def (tb-change-cell! x y ch fg bg) + (c-tb-change-cell x y ch fg bg)) + (def (tb-set-clear-attrs! fg bg) (c-tb-set-clear fg bg)) + (def (tb-print! x y fg bg str) (c-tb-print x y fg bg str)) + (def (tb-printf! x y fg bg fmt arg) + (c-tb-printf x y fg bg fmt arg)) + (def (tb-set-input-mode! mode) (c-tb-set-input mode)) + (def (tb-set-output-mode! mode) (c-tb-set-output mode)) + (def (tb-poll-event) + (let ([rc (c-tb-poll)]) (if (> rc 0) (read-event!) #f))) + (def (tb-peek-event timeout-ms) + (let ([rc (c-tb-peek timeout-ms)]) + (if (> rc 0) (read-event!) #f))) + (def (tui-event-key? ev) + (= (tui-event-type ev) TB_EVENT_KEY)) + (def (tui-event-resize? ev) + (= (tui-event-type ev) TB_EVENT_RESIZE)) + (def (tui-event-mouse? ev) + (= (tui-event-type ev) TB_EVENT_MOUSE)) + (define-tb c-tb-init "jcode_tb_init" () int) + (define-tb c-tb-shutdown "jcode_tb_shutdown" () void) + (define-tb c-tb-width "jcode_tb_width" () int) + (define-tb c-tb-height "jcode_tb_height" () int) + (define-tb c-tb-clear "jcode_tb_clear" () void) + (define-tb c-tb-present "jcode_tb_present" () void) + (define-tb + c-tb-set-cursor + "jcode_tb_set_cursor" + (int int) + void) + (define-tb c-tb-hide-cursor "jcode_tb_hide_cursor" () void) + (define-tb + c-tb-change-cell + "jcode_tb_change_cell" + (int int unsigned-32 unsigned-32 unsigned-32) + void) + (define-tb + c-tb-set-clear + "jcode_tb_set_clear_attrs" + (unsigned-32 unsigned-32) + void) + (define-tb + c-tb-print + "jcode_tb_print" + (int int unsigned-32 unsigned-32 string) + int) + (define-tb + c-tb-printf + "jcode_tb_printf" + (int int unsigned-32 unsigned-32 string string) + int) + (define-tb + c-tb-set-input + "jcode_tb_set_input_mode" + (int) + int) + (define-tb + c-tb-set-output + "jcode_tb_set_output_mode" + (int) + int) + (define-tb c-tb-poll "jcode_tb_poll_event" () int) + (define-tb c-tb-peek "jcode_tb_peek_event" (int) int) + (define-tb c-tb-ev-type "jcode_tb_event_type" () int) + (define-tb c-tb-ev-mod "jcode_tb_event_mod" () int) + (define-tb c-tb-ev-key "jcode_tb_event_key" () int) + (define-tb c-tb-ev-ch "jcode_tb_event_ch" () unsigned-32) + (define-tb c-tb-ev-w "jcode_tb_event_w" () int) + (define-tb c-tb-ev-h "jcode_tb_event_h" () int) + (define-tb c-tb-ev-x "jcode_tb_event_x" () int) + (define-tb c-tb-ev-y "jcode_tb_event_y" () int)) new file mode 100644 --- /dev/null +++ b/lib/jcode/ui/tui-input.sls @@ -0,0 +1,295 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jcode/ui/tui-input.ss + +(library (jcode ui tui-input) + (export make-input-state make-fresh-input input-state? + input-state-text input-state-cursor-pos + input-state-text-set! input-state-cursor-pos-set! + input-state-history input-state-history-idx + input-state-completion input-state-comp-selected + input-state-history-set! input-state-history-idx-set! + input-state-completion-set! input-state-comp-selected-set! + input-state-stash-set! input-handle-key! input-submit! + input-clear! input-lines input-cursor-row input-cursor-col + render-input! render-completion! *slash-commands*) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (std misc string) (jcode ui tui-ffi) (jcode ui tui-theme) + (jerboa core) (jerboa runtime)) + (defstruct + input-state + (text cursor-pos history history-idx completion + comp-selected stash) + transparent: + #t) + (def (make-fresh-input) + (make-input-state "" 0 '() 0 #f 0 "")) + (define *slash-commands*--cell + (vector + '(("/help" . "Show help") ("/model" . "Show or set model") + ("/provider" . "Show or set provider") + ("/tools" . "List available tools") + ("/clear" . "Start new session") + ("/sessions" . "List saved sessions") + ("/compact" . "Compact conversation") + ("/quit" . "Exit jcode") ("/theme" . "Switch color theme") + ("/sidebar" . "Toggle sidebar")))) + (def (input-handle-key! inp ev) + "Handle a key event for the input prompt. Returns action symbol." + (let ([key (tui-event-key ev)] + [ch (tui-event-ch ev)] + [mod (tui-event-mod ev)]) + (cond + [(or (and (= key TB_KEY_ENTER) + (not (zero? (bitwise-and mod TB_MOD_ALT)))) + (= key TB_KEY_CTRL_J)) + 'submit] + [(= key TB_KEY_ENTER) + (if (input-state-completion inp) + (begin (accept-completion! inp) 'continue) + (if (string-contains (input-state-text inp) "\n") + (begin (insert-char! inp #\newline) 'continue) + 'submit))] + [(= key TB_KEY_CTRL_C) 'cancel] + [(= key TB_KEY_CTRL_D) + (if (string-empty? (input-state-text inp)) 'quit 'continue)] + [(= key TB_KEY_CTRL_K) (input-clear! inp) 'continue] + [(= key TB_KEY_TAB) + (if (input-state-completion inp) + (begin + (input-state-comp-selected-set! + inp + (modulo + (+ (input-state-comp-selected inp) 1) + (length (input-state-completion inp)))) + 'continue) + (begin (try-start-completion! inp) 'continue))] + [(= key TB_KEY_ESC) + (input-state-completion-set! inp #f) + 'continue] + [(or (= key TB_KEY_BACKSPACE) (= key TB_KEY_BACKSPACE2)) + (delete-backward! inp) + (maybe-update-completion! inp) + 'continue] + [(= key TB_KEY_ARROW_LEFT) (move-cursor! inp -1) 'continue] + [(= key TB_KEY_ARROW_RIGHT) (move-cursor! inp 1) 'continue] + [(= key TB_KEY_ARROW_UP) + (if (input-state-completion inp) + (begin + (input-state-comp-selected-set! + inp + (max 0 (- (input-state-comp-selected inp) 1))) + 'continue) + (begin (history-prev! inp) 'continue))] + [(= key TB_KEY_ARROW_DOWN) + (if (input-state-completion inp) + (begin + (input-state-comp-selected-set! + inp + (min (- (length (input-state-completion inp)) 1) + (+ (input-state-comp-selected inp) 1))) + 'continue) + (begin (history-next! inp) 'continue))] + [(= key TB_KEY_CTRL_A) + (input-state-cursor-pos-set! inp 0) + 'continue] + [(= key TB_KEY_CTRL_E) + (input-state-cursor-pos-set! + inp + (string-length (input-state-text inp))) + 'continue] + [(> ch 0) + (insert-char! inp (integer->char ch)) + (maybe-update-completion! inp) + 'continue] + [#t 'continue]))) + (def (insert-char! inp ch) + (let* ([text (input-state-text inp)] + [pos (input-state-cursor-pos inp)] + [new-text (string-append + (substring text 0 pos) + (string ch) + (substring text pos (string-length text)))]) + (input-state-text-set! inp new-text) + (input-state-cursor-pos-set! inp (+ pos 1)))) + (def (delete-backward! inp) + (let ([pos (input-state-cursor-pos inp)]) + (when (> pos 0) + (let* ([text (input-state-text inp)] + [new-text (string-append + (substring text 0 (- pos 1)) + (substring text pos (string-length text)))]) + (input-state-text-set! inp new-text) + (input-state-cursor-pos-set! inp (- pos 1)))))) + (def (move-cursor! inp delta) + (let* ([pos (input-state-cursor-pos inp)] + [len (string-length (input-state-text inp))] + [new-pos (max 0 (min len (+ pos delta)))]) + (input-state-cursor-pos-set! inp new-pos))) + (def (input-submit! inp) + "Add current text to history and return it." + (let ([text (input-state-text inp)]) + (unless (string-empty? text) + (input-state-history-set! + inp + (cons text (input-state-history inp)))) + (input-clear! inp) + text)) + (def (input-clear! inp) (input-state-text-set! inp "") + (input-state-cursor-pos-set! inp 0) + (input-state-history-idx-set! inp 0) + (input-state-completion-set! inp #f) + (input-state-stash-set! inp "")) + (def (history-prev! inp) + (let ([hist (input-state-history inp)] + [idx (input-state-history-idx inp)]) + (when (< idx (length hist)) + (when (= idx 0) + (input-state-stash-set! inp (input-state-text inp))) + (let ([new-idx (+ idx 1)]) + (input-state-history-idx-set! inp new-idx) + (input-state-text-set! inp (list-ref hist (- new-idx 1))) + (input-state-cursor-pos-set! + inp + (string-length (input-state-text inp))))))) + (def (history-next! inp) + (let ([idx (input-state-history-idx inp)]) + (when (> idx 0) + (let ([new-idx (- idx 1)]) + (input-state-history-idx-set! inp new-idx) + (if (= new-idx 0) + (begin + (input-state-text-set! inp (input-state-stash inp)) + (input-state-cursor-pos-set! + inp + (string-length (input-state-text inp)))) + (begin + (input-state-text-set! + inp + (list-ref (input-state-history inp) (- new-idx 1))) + (input-state-cursor-pos-set! + inp + (string-length (input-state-text inp))))))))) + (def (try-start-completion! inp) + (let ([text (input-state-text inp)]) + (when (and (> (string-length text) 0) + (char=? (string-ref text 0) #\/)) + (let ([matches (filter + (lambda (cmd) (string-prefix? text (car cmd))) + *slash-commands*)]) + (unless (null? matches) + (input-state-completion-set! inp matches) + (input-state-comp-selected-set! inp 0)))))) + (def (maybe-update-completion! inp) + (let ([text (input-state-text inp)]) + (if (and (> (string-length text) 0) + (char=? (string-ref text 0) #\/)) + (let ([matches (filter + (lambda (cmd) + (string-prefix? text (car cmd))) + *slash-commands*)]) + (if (null? matches) + (input-state-completion-set! inp #f) + (begin + (input-state-completion-set! inp matches) + (input-state-comp-selected-set! + inp + (min (input-state-comp-selected inp) + (- (length matches) 1)))))) + (input-state-completion-set! inp #f)))) + (def (accept-completion! inp) + (let ([comp (input-state-completion inp)]) + (when comp + (let ([selected (list-ref + comp + (input-state-comp-selected inp))]) + (input-state-text-set! + inp + (string-append (car selected) " ")) + (input-state-cursor-pos-set! + inp + (string-length (input-state-text inp))) + (input-state-completion-set! inp #f))))) + (def (input-lines inp) + "Split input text into lines." + (string-split (input-state-text inp) #\newline)) + (def (input-cursor-row inp) + "Which line the cursor is on (0-based)." + (let ([text (input-state-text inp)] + [pos (input-state-cursor-pos inp)]) + (let loop ([i 0] [row 0]) + (cond + [(>= i pos) row] + [(char=? (string-ref text i) #\newline) + (loop (+ i 1) (+ row 1))] + [#t (loop (+ i 1) row)])))) + (def (input-cursor-col inp) + "Column within current line (0-based)." + (let ([text (input-state-text inp)] + [pos (input-state-cursor-pos inp)]) + (let loop ([i (- pos 1)] [col 0]) + (cond + [(< i 0) col] + [(char=? (string-ref text i) #\newline) col] + [#t (loop (- i 1) (+ col 1))])))) + (def (render-input! inp x y width prompt-text) + "Render the input prompt at (x, y). Returns number of rows used." + (let* ([lines (input-lines inp)] + [nlines (length lines)] + [pfg (face-fg-attr 'input-prompt)] + [pbg (face-bg-attr 'input-prompt)] + [tfg (face-fg-attr 'input-text)] + [tbg (face-bg-attr 'input-text)] + [prompt-len (string-length prompt-text)]) + (clear-row! x y width tbg) + (tb-print! x y pfg pbg prompt-text) + (when (pair? lines) + (tb-print! (+ x prompt-len) y tfg tbg (car lines))) + (let loop ([rest (if (pair? lines) (cdr lines) '())] + [row (+ y 1)]) + (when (pair? rest) + (clear-row! x row width tbg) + (tb-print! (+ x 2) row tfg tbg (car rest)) + (loop (cdr rest) (+ row 1)))) + (let ([crow (input-cursor-row inp)] + [ccol (input-cursor-col inp)]) + (tb-set-cursor! + (+ x (if (= crow 0) (+ prompt-len ccol) (+ 2 ccol))) + (+ y crow))) + (max 1 nlines))) + (def (render-completion! inp x y width) + "Render completion overlay above the input area." + (let ([comp (input-state-completion inp)]) + (when comp + (let ([sel (input-state-comp-selected inp)]) + (let loop ([items comp] [idx 0] [row y]) + (when (pair? items) + (let* ([item (car items)] + [selected? (= idx sel)] + [face (if selected? + 'completion-selected + 'completion-item)] + [fg (face-fg-attr face)] + [bg (face-bg-attr face)] + [text (string-append (car item) " " (cdr item))]) + (clear-row! x row width bg) + (tb-print! (+ x 1) row fg bg + (if (> (string-length text) (- width 2)) + (substring text 0 (- width 2)) + text)) + (loop (cdr items) (+ idx 1) (+ row 1))))))))) + (def (clear-row! x y width bg) + (let loop ([col x]) + (when (< col (+ x width)) + (tb-change-cell! col y (char->integer #\space) bg bg) + (loop (+ col 1))))) + (define-syntax *slash-commands* + (identifier-syntax + [id (vector-ref *slash-commands*--cell 0)] + [(set! id val) (vector-set! + *slash-commands*--cell + 0 + val)]))) new file mode 100644 --- /dev/null +++ b/lib/jcode/ui/tui-keys.sls @@ -0,0 +1,85 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jcode/ui/tui-keys.ss + +(library (jcode ui tui-keys) + (export + keymap-bind! + keymap-dispatch + event->key-name + make-keymap) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (jcode ui tui-ffi) + (jerboa core) + (jerboa runtime)) + (def (make-keymap) (make-hash-table)) + (def (keymap-bind! km key handler) + "Bind a key name (string) to a handler (lambda (state) ...)." + (hash-put! km key handler)) + (def (keymap-dispatch km ev) + "Look up handler for event. Returns handler or #f." + (let ([name (event->key-name ev)]) + (and name (hash-get km name)))) + (def (event->key-name ev) + "Convert a tui-event to a canonical key name string." + (let ([typ (tui-event-type ev)] + [key (tui-event-key ev)] + [ch (tui-event-ch ev)] + [mod (tui-event-mod ev)]) + (cond + [(not (= typ TB_EVENT_KEY)) #f] + [(and (> key 0) (<= key 26) (= ch 0)) + (let ([base (integer->char (+ key 96))]) + (string-append "ctrl-" (string base)))] + [(and (not (zero? (bitwise-and mod TB_MOD_ALT))) (> ch 0)) + (string-append "alt-" (string (integer->char ch)))] + [(> key 65280) + (let ([base (special-key-name key)]) + (cond + [(not (zero? (bitwise-and mod TB_MOD_SHIFT))) + (string-append "shift-" base)] + [(not (zero? (bitwise-and mod TB_MOD_ALT))) + (string-append "alt-" base)] + [#t base]))] + [(= key TB_KEY_ENTER) + (if (not (zero? (bitwise-and mod TB_MOD_ALT))) + "alt-enter" + "enter")] + [(= key TB_KEY_TAB) "tab"] + [(= key TB_KEY_ESC) "escape"] + [(= key TB_KEY_SPACE) + (if (not (zero? (bitwise-and mod TB_MOD_CTRL))) + "ctrl-space" + "space")] + [(= key TB_KEY_BACKSPACE2) "backspace"] + [(= key TB_KEY_BACKSPACE) "backspace"] + [(> ch 0) (string (integer->char ch))] + [#t #f]))) + (def (special-key-name key)