Add themeable TUI with 12 themes and a Ctrl-T theme picker
ober
8e6d39007d13919413fa93067cbd97c818c033d7
--- a/signal/store.ss +++ b/signal/store.ss @@ -12,7 +12,8 @@ (library (signal store) (export load-removed-ids save-removed-ids removed-store-path - messages-store-path ensure-store-dir!) + messages-store-path ensure-store-dir! + load-theme-name save-theme-name! themes-dir) (import (except (chezscheme) make-hash-table hash-table? @@ -34,6 +35,14 @@ (def (messages-store-path account) (string-append (store-dir) "/messages-" (sanitize account) ".db")) + ;; The chosen theme is global (not per-account): one line naming a registered + ;; theme. User-supplied opencode JSON themes live in themes/ beside it. + (def (theme-store-path) + (string-append (store-dir) "/theme.txt")) + + (def (themes-dir) + (string-append (store-dir) "/themes")) + ;; Keep the filename safe: phone numbers (+, digits), uuids (-) and ordinary ;; word characters pass through; anything else collapses to _. (def (sanitize s) @@ -77,6 +86,25 @@ (reverse acc) (loop (if (string=? line "") acc (cons line acc))))))) + ;; Remembered theme name, or #f when none has been saved yet. + (def (load-theme-name) + (let ([path (theme-store-path)]) + (if (file-exists? path) + (guard (e [#t #f]) + (let ([line (call-with-input-file path get-line)]) + (and (string? line) (not (string=? line "")) line))) + #f))) + + ;; Best-effort: a failed write must never break the UI. + (def (save-theme-name! name) + (guard (e [#t (void)]) + (ensure-store-dir!) + (let ([path (theme-store-path)]) + (when (file-exists? path) + (delete-file path)) + (call-with-output-file path + (lambda (port) (display name port) (newline port)))))) + ;; Best-effort: persistence must never break the UI, so failures are swallowed. (def (save-removed-ids account ids) (guard (e [#t (void)]) --- a/signal/tui/ffi.ss +++ b/signal/tui/ffi.ss @@ -21,13 +21,14 @@ 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_J TB_KEY_CTRL_K TB_KEY_CTRL_L - TB_KEY_CTRL_N TB_KEY_CTRL_Q TB_KEY_CTRL_R TB_KEY_CTRL_U TB_KEY_CTRL_Y + TB_KEY_CTRL_N TB_KEY_CTRL_Q TB_KEY_CTRL_R TB_KEY_CTRL_T TB_KEY_CTRL_U + TB_KEY_CTRL_Y TB_MOD_ALT TB_MOD_CTRL TB_MOD_SHIFT TB_INPUT_ESC TB_INPUT_MOUSE TB_OUTPUT_TRUECOLOR TB_DEFAULT TB_BLACK TB_RED TB_GREEN TB_YELLOW TB_BLUE TB_MAGENTA TB_CYAN TB_WHITE - TB_BOLD TB_REVERSE TB_DIM) + TB_BOLD TB_UNDERLINE TB_REVERSE TB_ITALIC TB_DIM) (import (except (chezscheme) make-hash-table hash-table? @@ -156,6 +157,7 @@ (def TB_KEY_CTRL_N #x0E) (def TB_KEY_CTRL_Q #x11) (def TB_KEY_CTRL_R #x12) + (def TB_KEY_CTRL_T #x14) (def TB_KEY_CTRL_U #x15) (def TB_KEY_CTRL_Y #x19) @@ -177,8 +179,11 @@ (def TB_CYAN #x0007) (def TB_WHITE #x0008) + ;; 32-bit attribute constants; the shim is built with -DTB_OPT_ATTR_W=32. (def TB_BOLD #x01000000) + (def TB_UNDERLINE #x02000000) (def TB_REVERSE #x04000000) + (def TB_ITALIC #x08000000) (def TB_DIM #x80000000) (def (tb-init!) --- a/signal/tui/main.ss +++ b/signal/tui/main.ss @@ -20,7 +20,8 @@ (signal logdb) (signal capture) (signal attach-save) - (signal tui ffi)) + (signal tui ffi) + (signal tui theme)) (defstruct chat-message (direction sender text timestamp kind status)) (defstruct conversation (id title kind target messages unread typing)) @@ -47,6 +48,13 @@ (with-tui (tb-set-input-mode! (bitwise-ior TB_INPUT_ESC TB_INPUT_MOUSE)) (tb-set-output-mode! TB_OUTPUT_TRUECOLOR) + ;; Load any user opencode JSON themes, then apply the saved theme + ;; (or the opencode-dark default), falling back if the saved name + ;; is no longer registered. + (load-themes-from-dir! (themes-dir)) + (let ([theme-name (or (load-theme-name) "opencode-dark")]) + (unless (set-theme-by-name! theme-name) + (set-theme-by-name! "opencode-dark"))) (let ([state (make-tui-state acct version receive-mode @@ -580,9 +588,9 @@ (def (chat-message-fg msg) (let ([dir (chat-message-direction msg)]) (cond - [(eq? dir 'out) (fg-accent)] - [(eq? dir 'system) (fg-dim)] - [else (fg)]))) + [(eq? dir 'out) (face-fg-attr 'msg-out)] + [(eq? dir 'system) (face-fg-attr 'msg-system)] + [else (face-fg-attr 'msg-in)]))) (def (handle-event! state actor ev) (cond @@ -601,6 +609,8 @@ (handle-attach-event! state actor ev)] [(eq? (tui-state-mode state) 'captcha) (handle-captcha-event! state actor ev)] + [(eq? (tui-state-mode state) 'theme) + (handle-theme-event! state ev)] [else (handle-chat-event! state actor ev)])] [else (void)])) @@ -627,6 +637,8 @@ (open-captcha! state)] [(= key TB_KEY_CTRL_D) (open-delete-confirm! state)] + [(= key TB_KEY_CTRL_T) + (open-theme-picker! state)] [(or (= key TB_KEY_BACKSPACE) (= key TB_KEY_BACKSPACE2)) (delete-input-char! state)] [(= key TB_KEY_CTRL_K) @@ -1344,6 +1356,66 @@ (save-removed-ids (tui-state-account state) (vector->list (hashtable-keys (tui-state-removed state))))) + ;; --- Theme picker (Ctrl-T) --- + ;; + ;; Lists every registered theme (the built-ins plus any opencode JSON themes + ;; loaded from the themes dir). Moving the selection applies that theme live + ;; so the picker previews it; Enter keeps and persists it, Esc restores the + ;; theme that was active when the picker opened. + + (def *theme-before-picker* (box #f)) + + (def (open-theme-picker! state) + (set-box! *theme-before-picker* (current-theme-name)) + (tui-state-mode-set! state 'theme) + (tui-state-picker-index-set! state (current-theme-list-index)) + (tui-state-status-set! + state "Theme: Up/Down preview, Enter keep, Esc cancel.")) + + (def (current-theme-list-index) + (let ([name (current-theme-name)]) + (let loop ([xs (get-registered-themes)] [i 0]) + (cond + [(null? xs) 0] + [(and name (string=? (car xs) name)) i] + [else (loop (cdr xs) (+ i 1))])))) + + (def (close-theme-picker! state) + (tui-state-mode-set! state 'chat) + (tui-state-picker-index-set! state 0)) + + ;; Move the selection and switch to that theme immediately for live preview. + (def (apply-theme-at-index! state index) + (let* ([themes (get-registered-themes)] + [count (length themes)]) + (when (> count 0) + (let* ([i (clamp-index index count)] + [name (list-ref themes i)]) + (tui-state-picker-index-set! state i) + (set-theme-by-name! name))))) + + (def (handle-theme-event! state ev) + (let ([key (tui-event-key ev)]) + (cond + [(= key TB_KEY_ESC) + (let ([prev (unbox *theme-before-picker*)]) + (when prev (set-theme-by-name! prev))) + (close-theme-picker! state) + (tui-state-status-set! state "Theme unchanged.")] + [(or (= key TB_KEY_CTRL_C) (= key TB_KEY_CTRL_Q)) + (tui-state-quit?-set! state #t)] + [(= key TB_KEY_ARROW_UP) + (apply-theme-at-index! state (- (tui-state-picker-index state) 1))] + [(= key TB_KEY_ARROW_DOWN) + (apply-theme-at-index! state (+ (tui-state-picker-index state) 1))] + [(= key TB_KEY_ENTER) + (let ([name (current-theme-name)]) + (when name (save-theme-name! name)) + (close-theme-picker! state) + (tui-state-status-set! + state (string-append "Theme set to " (or name "(custom)") ".")))] + [else (void)]))) + ;; --- Search across all conversations --- ;; ;; Scans the in-memory messages of every conversation: everything received @@ -1482,6 +1554,8 @@ (draw-attach-page! state 0 0 w status-y)] [(eq? (tui-state-mode state) 'captcha) (draw-captcha-page! state 0 0 w status-y)] + [(eq? (tui-state-mode state) 'theme) + (draw-theme-page! state 0 0 w status-y)] [else (draw-panel! 0 0 left-w body-h "Conversations") (draw-panel! thread-x 0 thread-w body-h "Messages") @@ -1620,6 +1694,40 @@ (draw-text! (+ x 2) (+ y 9) (- width 4) (fg-accent) (panel-bg) "Enter submit Esc cancel")) + (def (draw-theme-page! state x y width height) + (draw-panel! x y width height "Theme") + (draw-text! (+ x 2) (+ y 2) (- width 4) (fg-dim) (panel-bg) + "Up/Down preview a theme, Enter keeps it, Esc cancels.") + (let* ([themes (get-registered-themes)] + [count (length themes)] + [active (current-theme-name)] + [sel (clamp-index (tui-state-picker-index state) (max 1 count))] + [list-y (+ y 4)] + [rows (max 1 (- height 5))] + [start (theme-scroll-start sel rows count)]) + (let loop ([i start] [row list-y]) + (when (and (< i count) (< row (+ list-y rows))) + (let* ([name (list-ref themes i)] + [selected? (= i sel)] + [active? (and active (string=? name active))] + [marker (cond [selected? "> "] [active? "* "] [else " "])] + [fgc (if selected? (fg-accent) (fg))] + [bgc (if selected? (selected-bg) (panel-bg))]) + (fill-rect! (+ x 2) row (- width 4) 1 fgc bgc) + (draw-text! (+ x 2) row (- width 4) fgc bgc + (string-append marker name + (if active? " (active)" ""))) + (loop (+ i 1) (+ row 1))))))) + + ;; Keep the selected theme on screen when the list is taller than the panel. + (def (theme-scroll-start sel rows count) + (let ([half (quotient rows 2)]) + (cond + [(<= count rows) 0] + [(< sel half) 0] + [(>= sel (- count half)) (max 0 (- count rows))] + [else (- sel half)]))) + (def (draw-search-page! state x y width height) (draw-panel! x y width height "Search message history") (draw-text! (+ x 2) (+ y 2) 6 (fg-strong) (panel-bg) "Find:") @@ -1729,7 +1837,7 @@ (draw-text! (+ x 1) y (- width 2) (status-fg) (status-bg) (string-append "TUI | " (tui-state-status state) - " | Ctrl-N new Ctrl-F find Ctrl-U attach Ctrl-D del q quit"))) + " | Ctrl-N new Ctrl-F find Ctrl-U attach Ctrl-T theme Ctrl-D del q quit"))) (def (draw-cursor! state width composer-y) (cond @@ -1751,6 +1859,8 @@ (tb-set-cursor! cursor-x 2))] [(eq? (tui-state-mode state) 'confirm-delete) (tb-hide-cursor!)] + [(eq? (tui-state-mode state) 'theme) + (tb-hide-cursor!)] [else (let* ([input-len (string-length (tui-state-input state))] [cursor-x (min (- width 1) (+ 3 input-len))]) @@ -2042,21 +2152,20 @@ [else "[message]"])) ;; --- Colors --- - - (def (rgb r g b) - (bitwise-ior (bitwise-arithmetic-shift-left r 16) - (bitwise-arithmetic-shift-left g 8) - b)) - - (def (fg) (rgb #xee #xf2 #xf7)) - (def (fg-strong) (bitwise-ior (rgb #xff #xff #xff) TB_BOLD)) - (def (fg-dim) (rgb #xb8 #xc4 #xd4)) - (def (fg-accent) (bitwise-ior (rgb #x8b #xf2 #xbe) TB_BOLD)) - (def (bg) (rgb #x20 #x25 #x2d)) - (def (panel-bg) (rgb #x2b #x33 #x3d)) - (def (selected-bg) (rgb #x3c #x57 #x69)) - (def (input-bg) (rgb #x18 #x1d #x24)) - (def (status-fg) (rgb #xff #xff #xff)) - (def (status-bg) (rgb #x2d #x6f #x8f)) + ;; + ;; Every drawn color resolves through the active theme's named faces (see + ;; signal/tui/theme), so Ctrl-T restyles the whole UI at once. These keep the + ;; old call signatures so the drawing code is unchanged. + + (def (fg) (face-fg-attr 'default)) + (def (fg-strong) (face-fg-attr 'strong)) + (def (fg-dim) (face-fg-attr 'dim)) + (def (fg-accent) (face-fg-attr 'accent)) + (def (bg) (face-bg-attr 'default)) + (def (panel-bg) (face-bg-attr 'panel)) + (def (selected-bg) (face-bg-attr 'selected)) + (def (input-bg) (face-bg-attr 'input)) + (def (status-fg) (face-fg-attr 'status-bar)) + (def (status-bg) (face-bg-attr 'status-bar)) ) ;; end library new file mode 100644 --- /dev/null +++ b/signal/tui/theme.ss @@ -0,0 +1,456 @@ +#!chezscheme +;;; signal/tui/theme -- color themes and named faces for the TUI. +;;; +;;; Ported from jerboa-code's tui-theme: a theme is a table mapping face names +;;; (symbols) to face structs (fg, bg, bold/italic/underline), looked up at +;;; draw time, so switching themes restyles the whole UI at once. The built-in +;;; themes carry the same names and palettes as jerboa-code -- opencode-dark +;;; is the default there and here -- and extra themes load from JSON files in +;;; the same opencode format jerboa-code reads. + +(library (signal tui theme) + (export + make-face face? face-fg face-bg face-bold? face-italic? face-underline? + current-theme current-theme-name set-theme-by-name! + face-ref face-fg-attr face-bg-attr + register-theme! get-registered-themes cycle-theme-by-name! + load-theme-json! load-themes-from-dir! + rgb truecolor) + + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (except (jerboa prelude) meta atom?) + (std text json) + (std os path) + (signal tui ffi)) + + ;; ---- Face struct ---- + + (defstruct face (fg bg bold? italic? underline?)) + + ;; ---- Color helpers ---- + + (def (rgb r g b) + (bitwise-ior (bitwise-arithmetic-shift-left r 16) + (bitwise-arithmetic-shift-left g 8) + b)) + + (def (truecolor color . attrs) + (apply bitwise-ior color attrs)) + + ;; ---- Theme: table of face names -> face structs ---- + + (def *current-theme* (make-parameter #f)) + (def *current-theme-name* (make-parameter #f)) + (def (current-theme) (*current-theme*)) + (def (current-theme-name) (*current-theme-name*)) + + (def (set-theme-by-name! name) + (let ([theme (hashtable-ref *theme-registry* name #f)]) + (and theme + (begin + (*current-theme* theme) + (*current-theme-name* name) + #t)))) + + ;; Look up a face by symbol in the current theme; terminal-default if absent. + (def (face-ref name) + (let ([theme (current-theme)]) + (or (and theme (hashtable-ref theme name #f)) + (make-face TB_DEFAULT TB_DEFAULT #f #f #f)))) + + (def (face-fg-attr name) + (let* ([f (face-ref name)] + [c (face-fg f)] + [c (if (face-bold? f) (bitwise-ior c TB_BOLD) c)] + [c (if (face-italic? f) (bitwise-ior c TB_ITALIC) c)] + [c (if (face-underline? f) (bitwise-ior c TB_UNDERLINE) c)]) + c)) + + (def (face-bg-attr name) + (face-bg (face-ref name))) + + ;; ---- Theme registry ---- + + (def *theme-registry* (make-hashtable equal-hash equal?)) + + (def (register-theme! name theme-table) + (hashtable-set! *theme-registry* name theme-table)) + + (def (get-registered-themes) + (list-sort string<? (vector->list (hashtable-keys *theme-registry*)))) + + (def (cycle-theme-by-name!) + (let* ([names (get-registered-themes)] + [current (current-theme)] + [cur-name (or (current-theme-name) + (let loop ([ns names]) + (cond + [(null? ns) (car names)] + [(eq? (hashtable-ref *theme-registry* (car ns) #f) + current) + (car ns)] + [else (loop (cdr ns))])))] + [idx (let loop ([ns names] [i 0]) + (cond + [(null? ns) 0] + [(string=? (car ns) cur-name) i] + [else (loop (cdr ns) (+ i 1))]))] + [next (list-ref names (modulo (+ idx 1) (length names)))]) + (set-theme-by-name! next))) + + ;; ---- Palette -> faces ---- + ;; + ;; A palette is a small table of named colors (the opencode theme keys: + ;; background, text, primary, accent, ...). All faces the TUI draws with are + ;; derived from it, with a contrast check so a sloppy palette can't produce + ;; unreadable fg/bg pairs. + + (def *palette-keys* + '((primary . "primary") + (secondary . "secondary") + (accent . "accent") + (error . "error") + (warning . "warning") + (success . "success") + (info . "info") + (text . "text") + (textMuted . "textMuted") + (background . "background") + (backgroundPanel . "backgroundPanel") + (backgroundElement . "backgroundElement") + (border . "border") + (borderActive . "borderActive") + (borderSubtle . "borderSubtle") + ;; Extensions beyond the opencode set, for status bar / selection + ;; fidelity with jerboa-code's hand-built themes. + (statusBg . "statusBg") + (selectionBg . "selectionBg"))) + + (def (make-color-table pairs) + (let ([ht (make-hashtable equal-hash equal?)]) + (for-each (lambda (p) (hashtable-set! ht (car p) (cdr p))) pairs) + ht)) + + (def (make-theme-table pairs) + (let ([ht (make-hashtable equal-hash equal?)]) + (for-each (lambda (p) (hashtable-set! ht (car p) (cdr p))) pairs) + ht)) + + (def (color-ref colors key fallback) + (let ([v (hashtable-ref colors key #f)]) + (if (number? v) v fallback))) + + (def (color-channel c shift) + (bitwise-and (bitwise-arithmetic-shift-right c shift) #xff)) + + (def (color-brightness c) + (/ (+ (* 299 (color-channel c 16)) + (* 587 (color-channel c 8)) + (* 114 (color-channel c 0))) + 1000.0)) + + (def (readable-color? fg bg) + (or (not (number? fg)) + (not (number? bg)) + (>= (abs (- (color-brightness fg) (color-brightness bg))) 50.0))) + + (def (auto-contrast-color bg) + (if (and (number? bg) (> (color-brightness bg) 140.0)) + (rgb #x1a #x1a #x1a) + (rgb #xee #xee #xee))) + + (def (ensure-readable fg bg fallback-fg) + (cond + [(readable-color? fg bg) fg] + [(readable-color? fallback-fg bg) fallback-fg] + [else (auto-contrast-color bg)])) + + (def (color-or-default c) + (if (number? c) c TB_DEFAULT)) + + (def (theme-face colors fg bg bold? italic? underline?) + (let ([text (color-ref colors 'text (rgb #xd4 #xd4 #xd4))]) + (make-face (color-or-default (ensure-readable fg bg text)) + (color-or-default bg) + bold? italic? underline?))) + + (def (palette->theme colors) + (let* ([bg (color-ref colors 'background (rgb #x1e #x1e #x1e))] + [panel (color-ref colors 'backgroundPanel (rgb #x25 #x25 #x25))] + [element (color-ref colors 'backgroundElement (rgb #x2d #x2d #x2d))] + [text (color-ref colors 'text (rgb #xd4 #xd4 #xd4))] + [muted (color-ref colors 'textMuted (rgb #x80 #x80 #x80))] + [primary (color-ref colors 'primary (rgb #x56 #x9c #xd6))] + [secondary (color-ref colors 'secondary primary)] + [accent (color-ref colors 'accent (rgb #x4e #xc9 #xb0))] + [error-c (color-ref colors 'error (rgb #xf4 #x47 #x47))] + [warning (color-ref colors 'warning (rgb #xff #xcc #x00))] + [success (color-ref colors 'success accent)] + [status-bg (color-ref colors 'statusBg panel)] + [selection (color-ref colors 'selectionBg element)] + [f (lambda (fg bg bold? italic? underline?) + (theme-face colors fg bg bold? italic? underline?))]) + (make-theme-table + `((default . ,(f text bg #f #f #f)) + (strong . ,(f text bg #t #f #f)) + (dim . ,(f muted bg #f #f #f)) + (accent . ,(f accent bg #t #f #f)) + (error . ,(f error-c bg #t #f #f)) + (warning . ,(f warning bg #f #f #f)) + (success . ,(f success bg #f #f #f)) + (msg-out . ,(f primary bg #f #f #f)) + (msg-in . ,(f text bg #f #f #f)) + (msg-system . ,(f muted bg #f #t #f)) + (panel . ,(f muted panel #f #f #f)) + (panel-title . ,(f text panel #t #f #f)) + (selected . ,(f text selection #f #f #f)) + (input . ,(f text element #f #f #f)) + (input-prompt . ,(f primary element #t #f #f)) + (status-bar . ,(f text status-bg #f #f #f)) + (link . ,(f secondary bg #f #f #t)))))) + + (def (register-palette-theme! name pairs) + (register-theme! name (palette->theme (make-color-table pairs)))) + + ;; ---- Built-in themes ---- + ;; + ;; Same names and palettes as jerboa-code. dark/light/gruvbox carry the + ;; statusBg/selectionBg of their hand-built jerboa-code counterparts. + + (def (register-core-themes!) + (register-palette-theme! "dark" + `((background . ,(rgb #x1e #x1e #x1e)) (backgroundPanel . ,(rgb #x25 #x25 #x25)) + (backgroundElement . ,(rgb #x2d #x2d #x2d)) (text . ,(rgb #xd4 #xd4 #xd4)) + (textMuted . ,(rgb #x80 #x80 #x80)) (primary . ,(rgb #x56 #x9c #xd6)) + (secondary . ,(rgb #xc5 #x86 #xc0)) (accent . ,(rgb #x4e #xc9 #xb0)) + (error . ,(rgb #xf4 #x47 #x47)) (warning . ,(rgb #xff #xcc #x00)) + (success . ,(rgb #x4e #xc9 #xb0)) (info . ,(rgb #x56 #x9c #xd6)) + (border . ,(rgb #x3a #x3a #x3a)) (borderActive . ,(rgb #x56 #x9c #xd6)) + (borderSubtle . ,(rgb #x3a #x3a #x3a)) + (statusBg . ,(rgb #x00 #x7a #xcc)) (selectionBg . ,(rgb #x3a #x3a #x5a)))) + (register-palette-theme! "light" + `((background . ,(rgb #xff #xff #xff)) (backgroundPanel . ,(rgb #xf5 #xf5 #xf5)) + (backgroundElement . ,(rgb #xf0 #xf0 #xf0)) (text . ,(rgb #x1e #x1e #x1e)) + (textMuted . ,(rgb #x80 #x80 #x80)) (primary . ,(rgb #x00 #x51 #xa5)) + (secondary . ,(rgb #x6f #x42 #xc1)) (accent . ,(rgb #x09 #x7c #x5a)) + (error . ,(rgb #xc0 #x22 #x22)) (warning . ,(rgb #xc0 #x7b #x00)) + (success . ,(rgb #x09 #x7c #x5a)) (info . ,(rgb #x00 #x51 #xa5)) + (border . ,(rgb #xc0 #xc0 #xc0)) (borderActive . ,(rgb #x00 #x51 #xa5)) + (borderSubtle . ,(rgb #xc0 #xc0 #xc0)) + (statusBg . ,(rgb #x00 #x51 #xa5)) (selectionBg . ,(rgb #xe0 #xe0 #xf0)))) + (register-palette-theme! "gruvbox" + `((background . ,(rgb #x28 #x28 #x28)) (backgroundPanel . ,(rgb #x32 #x30 #x2f)) + (backgroundElement . ,(rgb #x3c #x38 #x36)) (text . ,(rgb #xeb #xdb #xb2)) + (textMuted . ,(rgb #xa8 #x99 #x84)) (primary . ,(rgb #x83 #xa5 #x98)) + (secondary . ,(rgb #xd3 #x86 #x9b)) (accent . ,(rgb #xb8 #xbb #x26)) + (error . ,(rgb #xfb #x49 #x34)) (warning . ,(rgb #xfa #xbd #x2f)) + (success . ,(rgb #xb8 #xbb #x26)) (info . ,(rgb #x83 #xa5 #x98)) + (border . ,(rgb #x50 #x49 #x45)) (borderActive . ,(rgb #x66 #x5c #x54)) + (borderSubtle . ,(rgb #x50 #x49 #x45)) + (statusBg . ,(rgb #x50 #x49 #x45)) (selectionBg . ,(rgb #x50 #x49 #x45)))) + (register-palette-theme! "opencode-dark" + `((background . ,(rgb #x0a #x0a #x0a)) (backgroundPanel . ,(rgb #x14 #x14 #x14)) + (backgroundElement . ,(rgb #x1e #x1e #x1e)) (text . ,(rgb #xee #xee #xee)) + (textMuted . ,(rgb #x80 #x80 #x80)) (primary . ,(rgb #xfa #xb2 #x83)) + (secondary . ,(rgb #x5c #x9c #xf5)) (accent . ,(rgb #x9d #x7c #xd8)) + (error . ,(rgb #xe0 #x6c #x75)) (warning . ,(rgb #xf5 #xa7 #x42)) + (success . ,(rgb #x7f #xd8 #x8f)) (info . ,(rgb #x56 #xb6 #xc2)) + (border . ,(rgb #x48 #x48 #x48)) (borderActive . ,(rgb #x60 #x60 #x60)) + (borderSubtle . ,(rgb #x3c #x3c #x3c)))) + (register-palette-theme! "opencode-light" + `((background . ,(rgb #xff #xff #xff)) (backgroundPanel . ,(rgb #xfa #xfa #xfa)) + (backgroundElement . ,(rgb #xf5 #xf5 #xf5)) (text . ,(rgb #x1a #x1a #x1a)) + (textMuted . ,(rgb #x8a #x8a #x8a)) (primary . ,(rgb #x3b #x7d #xd8)) + (secondary . ,(rgb #x7b #x5b #xb6)) (accent . ,(rgb #xd6 #x8c #x27)) + (error . ,(rgb #xd1 #x38 #x3d)) (warning . ,(rgb #xd6 #x8c #x27)) + (success . ,(rgb #x3d #x9a #x57)) (info . ,(rgb #x31 #x87 #x95)) + (border . ,(rgb #xb8 #xb8 #xb8)) (borderActive . ,(rgb #xa0 #xa0 #xa0)) + (borderSubtle . ,(rgb #xd4 #xd4 #xd4)))) + (register-palette-theme! "tokyonight-dark" + `((background . ,(rgb #x1a #x1b #x26)) (backgroundPanel . ,(rgb #x1e #x20 #x30)) + (backgroundElement . ,(rgb #x22 #x24 #x36)) (text . ,(rgb #xc8 #xd3 #xf5)) + (textMuted . ,(rgb #x82 #x8b #xb8)) (primary . ,(rgb #x82 #xaa #xff)) + (secondary . ,(rgb #xc0 #x99 #xff)) (accent . ,(rgb #xff #x96 #x6c)) + (error . ,(rgb #xff #x75 #x7f)) (warning . ,(rgb #xff #xc7 #x77)) + (success . ,(rgb #xc3 #xe8 #x8d)) (info . ,(rgb #x86 #xe1 #xfc)) + (border . ,(rgb #x73 #x7a #xa2)) (borderActive . ,(rgb #x90 #x99 #xb2)) + (borderSubtle . ,(rgb #x54 #x5c #x7e)))) + (register-palette-theme! "github-dark" + `((background . ,(rgb #x0d #x11 #x17)) (backgroundPanel . ,(rgb #x01 #x04 #x09)) + (backgroundElement . ,(rgb #x16 #x1b #x22)) (text . ,(rgb #xc9 #xd1 #xd9)) + (textMuted . ,(rgb #x8b #x94 #x9e)) (primary . ,(rgb #x58 #xa6 #xff)) + (secondary . ,(rgb #xbc #x8c #xff)) (accent . ,(rgb #x39 #xc5 #xcf)) + (error . ,(rgb #xf8 #x51 #x49)) (warning . ,(rgb #xe3 #xb3 #x41)) + (success . ,(rgb #x3f #xb9 #x50)) (info . ,(rgb #xd2 #x99 #x22)) + (border . ,(rgb #x30 #x36 #x3d)) (borderActive . ,(rgb #x58 #xa6 #xff)) + (borderSubtle . ,(rgb #x21 #x26 #x2d)))) + (register-palette-theme! "github-light" + `((background . ,(rgb #xff #xff #xff)) (backgroundPanel . ,(rgb #xf6 #xf8 #xfa)) + (backgroundElement . ,(rgb #xf0 #xf3 #xf6)) (text . ,(rgb #x24 #x29 #x2f)) + (textMuted . ,(rgb #x57 #x60 #x6a)) (primary . ,(rgb #x09 #x69 #xda)) + (secondary . ,(rgb #x82 #x50 #xdf)) (accent . ,(rgb #x1b #x7c #x83)) + (error . ,(rgb #xcf #x22 #x2e)) (warning . ,(rgb #x9a #x67 #x00)) + (success . ,(rgb #x1a #x7f #x37)) (info . ,(rgb #xbc #x4c #x00)) + (border . ,(rgb #xd0 #xd7 #xde)) (borderActive . ,(rgb #x09 #x69 #xda)) + (borderSubtle . ,(rgb #xd8 #xde #xe4)))) + (register-palette-theme! "nord-dark" + `((background . ,(rgb #x2e #x34 #x40)) (backgroundPanel . ,(rgb #x3b #x42 #x52)) + (backgroundElement . ,(rgb #x43 #x4c #x5e)) (text . ,(rgb #xec #xef #xf4)) + (textMuted . ,(rgb #x8b #x95 #xa7)) (primary . ,(rgb #x88 #xc0 #xd0)) + (secondary . ,(rgb #x81 #xa1 #xc1)) (accent . ,(rgb #x8f #xbc #xbb)) + (error . ,(rgb #xbf #x61 #x6a)) (warning . ,(rgb #xd0 #x87 #x70)) + (success . ,(rgb #xa3 #xbe #x8c)) (info . ,(rgb #x88 #xc0 #xd0)) + (border . ,(rgb #x43 #x4c #x5e)) (borderActive . ,(rgb #x4c #x56 #x6a)) + (borderSubtle . ,(rgb #x43 #x4c #x5e)))) + (register-palette-theme! "nord-light" + `((background . ,(rgb #xec #xef #xf4)) (backgroundPanel . ,(rgb #xe5 #xe9 #xf0)) + (backgroundElement . ,(rgb #xd8 #xde #xe9)) (text . ,(rgb #x2e #x34 #x40)) + (textMuted . ,(rgb #x3b #x42 #x52)) (primary . ,(rgb #x5e #x81 #xac)) + (secondary . ,(rgb #x81 #xa1 #xc1)) (accent . ,(rgb #x8f #xbc #xbb)) + (error . ,(rgb #xbf #x61 #x6a)) (warning . ,(rgb #xd0 #x87 #x70)) + (success . ,(rgb #xa3 #xbe #x8c)) (info . ,(rgb #x5e #x81 #xac)) + (border . ,(rgb #x4c #x56 #x6a)) (borderActive . ,(rgb #x43 #x4c #x5e)) + (borderSubtle . ,(rgb #x4c #x56 #x6a)))) + (register-palette-theme! "catppuccin-dark" + `((background . ,(rgb #x1e #x1e #x2e)) (backgroundPanel . ,(rgb #x18 #x18 #x25)) + (backgroundElement . ,(rgb #x11 #x11 #x1b)) (text . ,(rgb #xcd #xd6 #xf4)) + (textMuted . ,(rgb #x93 #x99 #xb2)) (primary . ,(rgb #x89 #xb4 #xfa)) + (secondary . ,(rgb #xcb #xa6 #xf7)) (accent . ,(rgb #xf5 #xc2 #xe7)) + (error . ,(rgb #xf3 #x8b #xa8)) (warning . ,(rgb #xf9 #xe2 #xaf)) + (success . ,(rgb #xa6 #xe3 #xa1)) (info . ,(rgb #x94 #xe2 #xd5)) + (border . ,(rgb #x31 #x32 #x44)) (borderActive . ,(rgb #x45 #x47 #x5a)) + (borderSubtle . ,(rgb #x58 #x5b #x70)))) + (register-palette-theme! "catppuccin-light" + `((background . ,(rgb #xef #xf1 #xf5)) (backgroundPanel . ,(rgb #xe6 #xe9 #xef)) + (backgroundElement . ,(rgb #xdc #xe0 #xe8)) (text . ,(rgb #x4c #x4f #x69)) + (textMuted . ,(rgb #x7c #x7f #x93)) (primary . ,(rgb #x1e #x66 #xf5)) + (secondary . ,(rgb #x88 #x39 #xef)) (accent . ,(rgb #xea #x76 #xcb)) + (error . ,(rgb #xd2 #x0f #x39)) (warning . ,(rgb #xdf #x8e #x1d)) + (success . ,(rgb #x40 #xa0 #x2b)) (info . ,(rgb #x17 #x92 #x99)) + (border . ,(rgb #xcc #xd0 #xda)) (borderActive . ,(rgb #xbc #xc0 #xcc)) + (borderSubtle . ,(rgb #xac #xb0 #xbe))))) + + ;; ---- opencode JSON theme loader ---- + ;; + ;; Reads the opencode theme format jerboa-code reads: a JSON object with + ;; optional "defs" (named colors), and color values that are "#rrggbb" / + ;; "#rgb" strings, ANSI palette numbers, def names, or {"dark":..,"light":..} + ;; variant objects. Each file registers "<name>-dark" and "<name>-light". + + (def (parse-hex-color/maybe s) + (cond + [(and (string? s) (>= (string-length s) 7) (char=? (string-ref s 0) #\#)) + (let ([r (string->number (substring s 1 3) 16)] + [g (string->number (substring s 3 5) 16)] + [b (string->number (substring s 5 7) 16)]) + (and r g b (rgb r g b)))] + [(and (string? s) (>= (string-length s) 4) (char=? (string-ref s 0) #\#)) + (let ([r (string->number (substring s 1 2) 16)] + [g (string->number (substring s 2 3) 16)] + [b (string->number (substring s 3 4) 16)]) + (and r g b (rgb (* r 17) (* g 17) (* b 17))))] + [else #f])) + + (def (ansi-color->tb n) + (case n + [(0) TB_BLACK] + [(1) TB_RED] + [(2) TB_GREEN] + [(3) TB_YELLOW] + [(4) TB_BLUE] + [(5) TB_MAGENTA] + [(6) TB_CYAN] + [(7) TB_WHITE] + [(8) (bitwise-ior TB_BLACK TB_BOLD)] + [(9) (bitwise-ior TB_RED TB_BOLD)] + [(10) (bitwise-ior TB_GREEN TB_BOLD)] + [(11) (bitwise-ior TB_YELLOW TB_BOLD)] + [(12) (bitwise-ior TB_BLUE TB_BOLD)] + [(13) (bitwise-ior TB_MAGENTA TB_BOLD)] + [(14) (bitwise-ior TB_CYAN TB_BOLD)] + [(15) (bitwise-ior TB_WHITE TB_BOLD)] + [else #f])) + + (def (resolve-defs defs val) + (cond + [(and (string? val) (hashtable? defs) (hashtable-contains? defs val)) + (hashtable-ref defs val #f)] + [(and (string? val) (string-prefix? "{" val)) + (let ([obj (guard (e [#t #f]) (string->json-object val))]) + (and (hashtable? obj) + (let ([ref (hashtable-ref obj "$ref" #f)]) + (and ref (hashtable-ref defs ref #f)))))] + [else val])) + + (def (json-color->color val defs variant) + (cond + [(hashtable? val) + (let ([c (or (hashtable-ref val variant #f) + (hashtable-ref val "dark" #f) + (hashtable-ref val "light" #f))]) + (and c (json-color->color c defs variant)))] + [(number? val) + (ansi-color->tb val)] + [(string? val) + (cond + [(string=? val "none") #f] + [else + (let ([hex (parse-hex-color/maybe val)]) + (if hex + hex + (let ([resolved (resolve-defs defs val)]) + (if (equal? resolved val) + #f + (json-color->color resolved defs variant)))))])] + [else #f])) + + (def (json-theme->colors theme-obj defs variant) + (let ([colors (make-hashtable equal-hash equal?)]) + (for-each + (lambda (entry) + (let* ([sym (car entry)] + [key (cdr entry)] + [val (hashtable-ref theme-obj key #f)]) + (when val + (let ([c (json-color->color val defs variant)]) + (when c (hashtable-set! colors sym c)))))) + *palette-keys*) + colors)) + + (def (load-theme-json! path) + (guard (e [#t #f]) + (let* ([obj (call-with-input-file path read-json)] + [defs (or (hashtable-ref obj "defs" #f) (make-hashtable equal-hash equal?))] + [theme-obj (or (hashtable-ref obj "theme" #f) obj)] + [name (or (hashtable-ref obj "name" #f) + (path-strip-extension (path-strip-directory path)))]) + (for-each + (lambda (variant) + (let ([colors (json-theme->colors theme-obj defs variant)]) + (register-theme! (string-append name "-" variant) + (palette->theme colors)))) + '("dark" "light")) + #t))) + + (def (load-themes-from-dir! dir) + (when (file-exists? dir) + (let ([files (guard (e [#t '()]) (directory-list dir))]) + (for-each + (lambda (f) + (when (string-suffix? ".json" f) + (load-theme-json! (path-join dir f)))) + files)))) + + ;; Register the built-ins once every helper above is defined: a Chez library + ;; body requires all definitions to precede any top-level expression. + (register-core-themes!) + + ) ;; end library