literate: create org/render.org, org/theme.org, org/package.org
Follows the literate programming workflow: Overview → Contract → Tests → Implement → Tangle → Test (GREEN) render.org covers render.lisp + render-tests.lisp (component protocol, render dispatch, dirty propagation) theme.org covers theme.lisp + theme-tests.lisp (theme class, presets, color resolution) package.org covers package.lisp (cl-tty.box defpackage)
This commit is contained in:
77
org/package.org
Normal file
77
org/package.org
Normal file
@@ -0,0 +1,77 @@
|
|||||||
|
#+TITLE: Base Component Package
|
||||||
|
#+STARTUP: content
|
||||||
|
#+FILETAGS: :cl-tty:components:
|
||||||
|
|
||||||
|
* Overview
|
||||||
|
|
||||||
|
The ~cl-tty.box~ package is the central namespace for the component
|
||||||
|
system. It aggregates all component-related symbols — box, text,
|
||||||
|
dirty tracking, render dispatch, theme engine — under one package.
|
||||||
|
|
||||||
|
Why ~box~ as the package name? Historically the package was created
|
||||||
|
for the ~box~ and ~text~ renderables, and the name stuck as the
|
||||||
|
package grew to encompass the entire component layer. The package
|
||||||
|
~:use~s ~cl-tty.backend~ (for drawing primitives) and ~cl-tty.layout~
|
||||||
|
(for layout nodes). All component code lives in this package.
|
||||||
|
|
||||||
|
This org file is documentation-only: it explains the package design
|
||||||
|
but the code itself is just a ~defpackage~ form.
|
||||||
|
|
||||||
|
* Contract
|
||||||
|
|
||||||
|
The ~cl-tty.box~ package exports these symbol groups:
|
||||||
|
|
||||||
|
- Box: ~box~, ~make-box~, ~render-box~, border style/title accessors
|
||||||
|
- Span: ~span~, span attribute readers
|
||||||
|
- Text: ~text~, ~make-text~, ~render-text~, text accessors
|
||||||
|
- Dirty: ~dirty-mixin~, ~dirty-p~, ~mark-clean~, ~mark-dirty~
|
||||||
|
- Render: ~render~, ~render-screen~, ~render-node~, tree navigation
|
||||||
|
- Theme: ~theme~, ~make-theme~, ~theme-color~, ~load-preset~,
|
||||||
|
~define-preset~
|
||||||
|
|
||||||
|
* Implementation
|
||||||
|
|
||||||
|
~cl-tty.box~ uses ~cl-tty.backend~ for ~draw-text~, ~draw-border~,
|
||||||
|
etc., and ~cl-tty.layout~ for ~layout-node~, ~compute-layout~, and the
|
||||||
|
~vbox~/~hbox~ macros.
|
||||||
|
|
||||||
|
The only direct dependencies are these two packages — no other
|
||||||
|
application code is needed to define components.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/package.lisp
|
||||||
|
(defpackage :cl-tty.box
|
||||||
|
(:use :cl :cl-tty.backend :cl-tty.layout)
|
||||||
|
(:export
|
||||||
|
;; Box
|
||||||
|
#:box #:make-box
|
||||||
|
#:box-layout-node
|
||||||
|
#:box-border-style #:box-title #:box-title-align
|
||||||
|
#:box-fg #:box-bg
|
||||||
|
#:render-box
|
||||||
|
;; Span
|
||||||
|
#:span
|
||||||
|
#:span-text #:span-bold #:span-italic #:span-underline
|
||||||
|
#:span-reverse #:span-dim #:span-fg #:span-bg
|
||||||
|
;; Text
|
||||||
|
#:text #:make-text
|
||||||
|
#:text-layout-node #:text-content #:text-spans
|
||||||
|
#:text-fg #:text-bg #:text-wrap-mode
|
||||||
|
#:render-text
|
||||||
|
;; Utilities (for tests)
|
||||||
|
#:word-wrap #:split-string
|
||||||
|
;; Dirty tracking
|
||||||
|
#:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty
|
||||||
|
;; Rendering pipeline
|
||||||
|
#:render #:render-screen #:render-node
|
||||||
|
#:component-layout-node #:component-children #:component-parent
|
||||||
|
#:available-width #:available-height
|
||||||
|
#:propagate-dirty
|
||||||
|
;; Theme engine
|
||||||
|
#:theme #:make-theme #:theme-mode
|
||||||
|
#:theme-color #:load-preset #:define-preset))
|
||||||
|
(in-package :cl-tty.box)
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
The ~#:word-wrap~ and ~#:split-string~ exports are for tests only —
|
||||||
|
they're utility functions used internally by ~text~ rendering but
|
||||||
|
exposed so the test suite can unit-test them directly.
|
||||||
272
org/render.org
Normal file
272
org/render.org
Normal file
@@ -0,0 +1,272 @@
|
|||||||
|
#+TITLE: Render Dispatch and Pipeline
|
||||||
|
#+STARTUP: content
|
||||||
|
#+FILETAGS: :cl-tty:components:
|
||||||
|
|
||||||
|
* Overview
|
||||||
|
|
||||||
|
The render module provides the generic function dispatch that connects
|
||||||
|
the component tree to the backend. Every component type defines its own
|
||||||
|
~render~ method; this module defines the common protocol and the
|
||||||
|
top-level orchestration functions.
|
||||||
|
|
||||||
|
Three responsibilities live here:
|
||||||
|
|
||||||
|
1. **Component protocol** — generic functions for navigating the
|
||||||
|
component tree (~component-children~, ~component-parent~,
|
||||||
|
~component-layout-node~)
|
||||||
|
|
||||||
|
2. **Render pipeline** — ~render-screen~ ties layout computation to
|
||||||
|
rendering, using the backend's actual terminal dimensions rather
|
||||||
|
than hardcoded values. ~render-node~ walks the tree.
|
||||||
|
|
||||||
|
3. **Dirty propagation** — ~propagate-dirty~ marks a component and all
|
||||||
|
its ancestors for re-render. This is what makes the incremental
|
||||||
|
pipeline efficient: only changed branches get re-processed.
|
||||||
|
|
||||||
|
* Contract
|
||||||
|
|
||||||
|
** ~component-layout-node component~ → layout-node or nil
|
||||||
|
|
||||||
|
Return the layout node associated with ~component~. Specialized per
|
||||||
|
component type (~box~, ~text~).
|
||||||
|
|
||||||
|
** ~component-children component~ → list or nil
|
||||||
|
|
||||||
|
Return child components. Default method returns ~nil~ (leaf components).
|
||||||
|
|
||||||
|
** ~component-parent component~ → component or nil
|
||||||
|
|
||||||
|
Return the parent component. Default method returns ~nil~.
|
||||||
|
|
||||||
|
** ~render component backend~
|
||||||
|
|
||||||
|
Render ~component~ at its computed position using ~backend~. Default
|
||||||
|
method is a no-op. Specialized per component type.
|
||||||
|
|
||||||
|
** ~render-screen root backend~
|
||||||
|
|
||||||
|
Full render pipeline: query backend size, compute layout, render tree,
|
||||||
|
wrapped in DECICM sync (~begin-sync~/~end-sync~).
|
||||||
|
|
||||||
|
** ~render-node node backend~
|
||||||
|
|
||||||
|
Render ~node~ and all descendants recursively. ~render-screen~ calls
|
||||||
|
this once layout is computed.
|
||||||
|
|
||||||
|
** ~available-width / available-height component~ → integer
|
||||||
|
|
||||||
|
Return the computed width/height from the component's layout node, or
|
||||||
|
80/24 as fallback.
|
||||||
|
|
||||||
|
** ~propagate-dirty component~
|
||||||
|
|
||||||
|
Mark ~component~ and every ancestor dirty. Walks up via
|
||||||
|
~component-parent~.
|
||||||
|
|
||||||
|
* Tests
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp
|
||||||
|
(in-package :cl-tty-box-test)
|
||||||
|
(in-suite box-suite)
|
||||||
|
|
||||||
|
(defun make-capturing-backend ()
|
||||||
|
(let* ((s (make-string-output-stream))
|
||||||
|
(b (make-modern-backend :output-stream s)))
|
||||||
|
(values b s)))
|
||||||
|
|
||||||
|
(test render-generic-dispatches-box
|
||||||
|
"render dispatches to render-box for box instances"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style :single :width 10 :height 5)))
|
||||||
|
(compute-layout (box-layout-node bx) 10 5)
|
||||||
|
(render bx b)
|
||||||
|
(is (search "┌" (get-output-stream-string s)) "box renders border"))))
|
||||||
|
|
||||||
|
(test render-generic-dispatches-text
|
||||||
|
"render dispatches to render-text for text instances"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((tx (make-text "Hello" :width 10 :height 1)))
|
||||||
|
(compute-layout (text-layout-node tx) 10 1)
|
||||||
|
(render tx b)
|
||||||
|
(is (search "Hello" (get-output-stream-string s)) "text renders content"))))
|
||||||
|
|
||||||
|
(test component-layout-node-works
|
||||||
|
"component-layout-node returns the right slot for each type"
|
||||||
|
(let ((bx (make-box)) (tx (make-text "")))
|
||||||
|
(is (typep (component-layout-node bx) 'layout-node))
|
||||||
|
(is (typep (component-layout-node tx) 'layout-node))))
|
||||||
|
|
||||||
|
(test component-children-returns-nil
|
||||||
|
"Leaf components have no children"
|
||||||
|
(let ((bx (make-box)) (tx (make-text "")))
|
||||||
|
(is (null (component-children bx)))
|
||||||
|
(is (null (component-children tx)))))
|
||||||
|
|
||||||
|
(test propagate-dirty-marks-component
|
||||||
|
"propagate-dirty marks the component dirty"
|
||||||
|
(let ((c (make-box)))
|
||||||
|
(mark-clean c)
|
||||||
|
(is-false (dirty-p c) "should be clean after mark-clean")
|
||||||
|
(propagate-dirty c)
|
||||||
|
(is-true (dirty-p c) "should be dirty after propagate-dirty")))
|
||||||
|
|
||||||
|
(test available-width-defaults
|
||||||
|
"available-width returns 0 for components without explicit width"
|
||||||
|
(let ((c (make-box)))
|
||||||
|
(is (= (available-width c) 0))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
* Implementation
|
||||||
|
|
||||||
|
** Component protocol
|
||||||
|
|
||||||
|
These three generic functions form the tree navigation API. They're
|
||||||
|
separated from ~render~ because layout and dirty propagation also
|
||||||
|
need to traverse the tree.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
|
||||||
|
(in-package :cl-tty.box)
|
||||||
|
|
||||||
|
;; ── Component Protocol ────────────────────────────────────────
|
||||||
|
|
||||||
|
(defgeneric component-layout-node (component)
|
||||||
|
(:documentation "Return the layout-node for COMPONENT.")
|
||||||
|
(:method ((bx box)) (box-layout-node bx))
|
||||||
|
(:method ((tx text)) (text-layout-node tx)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
Each component type defines its own ~component-layout-node~ method
|
||||||
|
that returns its internal layout node. The default method (on ~t~)
|
||||||
|
would return ~nil~, but since every component in cl-tty has a layout
|
||||||
|
node, we don't provide one — new component types must add their own
|
||||||
|
method.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
|
||||||
|
(defgeneric component-children (component)
|
||||||
|
(:documentation "Return the children of COMPONENT, or nil.")
|
||||||
|
(:method ((c t)) nil))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
Leaf components (~box~, ~text~) have no children. Container components
|
||||||
|
(~scrollbox~, ~tabbar~) override this to return their child list.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
|
||||||
|
(defgeneric component-parent (component)
|
||||||
|
(:documentation "Return the parent of COMPONENT, or nil.")
|
||||||
|
(:method ((c t)) nil))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
Parent links are set by the container when adding children. They're
|
||||||
|
used by ~propagate-dirty~ to walk up the tree.
|
||||||
|
|
||||||
|
** Render dispatch
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
|
||||||
|
;; ── Rendering Pipeline ────────────────────────────────────────
|
||||||
|
|
||||||
|
(defgeneric render (component backend)
|
||||||
|
(:documentation "Render COMPONENT at its computed position using BACKEND.")
|
||||||
|
(:method ((c t) backend)
|
||||||
|
(declare (ignore backend))
|
||||||
|
(values)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
The ~render~ generic is the central dispatch point. Every component
|
||||||
|
type that can be drawn defines a method on ~render~. The default
|
||||||
|
method is a no-op so that non-renderable objects (or components still
|
||||||
|
under development) don't cause errors.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
|
||||||
|
(defmethod render ((bx box) backend)
|
||||||
|
(render-box bx backend))
|
||||||
|
|
||||||
|
(defmethod render ((tx text) backend)
|
||||||
|
(render-text tx backend))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
Box and text are the two built-in renderable types. Their ~render~
|
||||||
|
methods delegate to the specific rendering functions defined in
|
||||||
|
~box.lisp~ and ~text.lisp~.
|
||||||
|
|
||||||
|
** Screen-level orchestration
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
|
||||||
|
(defun render-screen (root backend)
|
||||||
|
"Render the component tree ROOT using BACKEND.
|
||||||
|
Computes layout at the root level, then traverses children
|
||||||
|
rendering each at their pre-computed positions. Uses the actual
|
||||||
|
terminal dimensions from BACKEND rather than hardcoded defaults."
|
||||||
|
(multiple-value-bind (w h) (backend-size backend)
|
||||||
|
(begin-sync backend)
|
||||||
|
(compute-layout (component-layout-node root) w h)
|
||||||
|
(render-node root backend)
|
||||||
|
(end-sync backend)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
~render-screen~ is the entry point for rendering a full frame. It
|
||||||
|
queries the terminal size at render time (not at startup), so the
|
||||||
|
layout adapts to window resizes automatically.
|
||||||
|
|
||||||
|
The DECICM sync pair (~begin-sync~/~end-sync~) wraps the entire
|
||||||
|
frame in a synchronized update: the terminal buffers all escape
|
||||||
|
sequences and flushes them atomically. This prevents partial-frame
|
||||||
|
flicker.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
|
||||||
|
(defun render-node (node backend)
|
||||||
|
"Render a component NODE and its children.
|
||||||
|
Layout is computed once at the root by render-screen, so children
|
||||||
|
just render at their pre-computed positions."
|
||||||
|
(render node backend)
|
||||||
|
(dolist (child (component-children node))
|
||||||
|
(render-node child backend)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
Tree walk: render this node, then recurse into children. The layout
|
||||||
|
was already computed by ~render-screen~, so each node's position and
|
||||||
|
size are available from its ~layout-node~.
|
||||||
|
|
||||||
|
** Utility accessors
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
|
||||||
|
(defun available-width (component)
|
||||||
|
"Return the available width for COMPONENT (or 80 as default)."
|
||||||
|
(let ((ln (component-layout-node component)))
|
||||||
|
(if ln (layout-node-width ln) 80)))
|
||||||
|
|
||||||
|
(defun available-height (component)
|
||||||
|
"Return the available height for COMPONENT (or 24 as default)."
|
||||||
|
(let ((ln (component-layout-node component)))
|
||||||
|
(if ln (layout-node-height ln) 24)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
These accessors provide a clean API for components that need to know
|
||||||
|
their allocated space. They return the computed dimensions from the
|
||||||
|
layout node, which was set by ~compute-layout~ during ~render-screen~.
|
||||||
|
|
||||||
|
The fallback values (80x24) match the terminal default when no layout
|
||||||
|
node exists — typically during initialization or testing without a
|
||||||
|
backenπd.
|
||||||
|
|
||||||
|
** Dirty propagation
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
|
||||||
|
;; ── Dirty Propagation ─────────────────────────────────────────
|
||||||
|
|
||||||
|
(defun propagate-dirty (component)
|
||||||
|
"Mark COMPONENT and all ancestors dirty."
|
||||||
|
(mark-dirty component)
|
||||||
|
(let ((parent (component-parent component)))
|
||||||
|
(when parent
|
||||||
|
(propagate-dirty parent))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
Recursive walk up the parent chain. When a text input receives a
|
||||||
|
keystroke, it marks itself dirty, then its parent scrollbox, then the
|
||||||
|
containing box, then the root — triggering recomputation and
|
||||||
|
re-rendering of everything that might have changed.
|
||||||
|
|
||||||
|
This is the key to incremental rendering: only dirty branches are
|
||||||
|
re-processed. The ~render~ methods check ~dirty-p~ early and return
|
||||||
|
immediately for clean components (handled in each component's render,
|
||||||
|
not here).
|
||||||
267
org/theme.org
Normal file
267
org/theme.org
Normal file
@@ -0,0 +1,267 @@
|
|||||||
|
#+TITLE: Theme Engine
|
||||||
|
#+STARTUP: content
|
||||||
|
#+FILETAGS: :cl-tty:components:
|
||||||
|
|
||||||
|
* Overview
|
||||||
|
|
||||||
|
The theme engine provides semantic color tokens that decouple visual
|
||||||
|
design from implementation code. Instead of writing ~:bright-yellow~ or
|
||||||
|
~\"#FFD700\"~ everywhere, components use ~:accent~, ~:error~,
|
||||||
|
~:background~ — semantic roles that resolve to concrete hex values
|
||||||
|
through the current theme.
|
||||||
|
|
||||||
|
This means:
|
||||||
|
- Themes are swappable at runtime (default dark/light, nord, etc.)
|
||||||
|
- Components never reference hex values directly
|
||||||
|
- A single ~load-preset~ call changes the entire application's look
|
||||||
|
|
||||||
|
The engine is intentionally simple: a ~theme~ class holding a hash
|
||||||
|
table of role→hex mappings, a set of built-in presets defined via
|
||||||
|
~define-preset~, and ~load-preset~ which populates both the theme
|
||||||
|
and the backend's ~*theme-colors*~ for SGR resolution.
|
||||||
|
|
||||||
|
* Contract
|
||||||
|
|
||||||
|
** Theme class
|
||||||
|
|
||||||
|
- ~(make-theme &key mode)~ — create a theme in ~:dark~ or ~:light~ mode
|
||||||
|
- ~(theme-mode theme)~ — get current mode
|
||||||
|
- ~(theme-color theme role)~ → hex string or nil
|
||||||
|
- ~(setf (theme-color theme role) hex)~ — set a role
|
||||||
|
|
||||||
|
** Presets
|
||||||
|
|
||||||
|
- ~(define-preset name &key dark light)~ — register a preset with
|
||||||
|
dark and light plists of role→hex pairs
|
||||||
|
- ~(load-preset theme preset-name)~ — apply a preset to ~theme~.
|
||||||
|
Also populates ~cl-tty.backend:*theme-colors*~ so the backend can
|
||||||
|
resolve semantic colors to hex at render time.
|
||||||
|
- Unknown presets signal a ~warning~ (not an error).
|
||||||
|
|
||||||
|
** Built-in presets
|
||||||
|
|
||||||
|
- ~:default~ — gold/accent on dark blue-gray
|
||||||
|
- ~:nord~ — cool blue nord palette
|
||||||
|
|
||||||
|
* Tests
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
|
||||||
|
(in-package :cl-tty-box-test)
|
||||||
|
(in-suite box-suite)
|
||||||
|
|
||||||
|
(test theme-create-default
|
||||||
|
"A theme can be created with default mode"
|
||||||
|
(let ((th (make-theme)))
|
||||||
|
(is (typep th 'theme))
|
||||||
|
(is (eql (theme-mode th) :dark))))
|
||||||
|
|
||||||
|
(test theme-create-light
|
||||||
|
"A theme can be created in light mode"
|
||||||
|
(let ((th (make-theme :mode :light)))
|
||||||
|
(is (eql (theme-mode th) :light))))
|
||||||
|
|
||||||
|
(test theme-color-set-and-get
|
||||||
|
"theme-color setf/get works"
|
||||||
|
(let ((th (make-theme)))
|
||||||
|
(setf (theme-color th :primary) "#FFD700")
|
||||||
|
(is (string= (theme-color th :primary) "#FFD700"))))
|
||||||
|
|
||||||
|
(test theme-color-unknown-returns-nil
|
||||||
|
"Unknown roles return nil"
|
||||||
|
(let ((th (make-theme)))
|
||||||
|
(is (null (theme-color th :nonexistent)))))
|
||||||
|
|
||||||
|
(test load-default-dark-preset
|
||||||
|
"Loading the default dark preset populates roles"
|
||||||
|
(let ((th (make-theme :mode :dark)))
|
||||||
|
(load-preset th :default)
|
||||||
|
(is (string= (theme-color th :primary) "#FFD700"))
|
||||||
|
(is (string= (theme-color th :background) "#1A1A2E"))
|
||||||
|
(is (string= (theme-color th :error) "#FF4444"))))
|
||||||
|
|
||||||
|
(test load-default-light-preset
|
||||||
|
"Light variant has different colors"
|
||||||
|
(let ((th (make-theme :mode :light)))
|
||||||
|
(load-preset th :default)
|
||||||
|
(is (string= (theme-color th :primary) "#B8860B"))
|
||||||
|
(is (string= (theme-color th :background) "#F8F9FA"))))
|
||||||
|
|
||||||
|
(test load-nord-preset
|
||||||
|
"Nord preset has different colors than default"
|
||||||
|
(let ((th (make-theme :mode :dark)))
|
||||||
|
(load-preset th :nord)
|
||||||
|
(is (string= (theme-color th :primary) "#88C0D0"))
|
||||||
|
(is (string= (theme-color th :background) "#2E3440"))))
|
||||||
|
|
||||||
|
(test load-preset-unknown-warns
|
||||||
|
"Unknown preset warns but doesn't error"
|
||||||
|
(let ((th (make-theme)))
|
||||||
|
(signals warning (load-preset th :nonexistent))
|
||||||
|
(is (null (theme-color th :primary)))))
|
||||||
|
|
||||||
|
(test preset-switch-mode
|
||||||
|
"Switching mode and reloading changes colors"
|
||||||
|
(let ((th (make-theme :mode :dark)))
|
||||||
|
(load-preset th :default)
|
||||||
|
(is (string= (theme-color th :background) "#1A1A2E"))
|
||||||
|
(setf (theme-mode th) :light)
|
||||||
|
(load-preset th :default)
|
||||||
|
(is (string= (theme-color th :background) "#F8F9FA"))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
* Implementation
|
||||||
|
|
||||||
|
** Theme class
|
||||||
|
|
||||||
|
The ~theme~ class holds a mode flag (~:dark~/~:light~) and a hash
|
||||||
|
table of role→hex mappings. The hash table gives O(1) lookups for
|
||||||
|
~theme-color~ and clean iteration for ~load-preset~.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
|
||||||
|
(in-package :cl-tty.box)
|
||||||
|
|
||||||
|
;; ── Theme Engine ──────────────────────────────────────────────
|
||||||
|
|
||||||
|
(defclass theme ()
|
||||||
|
((mode :initform :dark :initarg :mode :accessor theme-mode)
|
||||||
|
(roles :initform (make-hash-table) :accessor theme-roles)))
|
||||||
|
|
||||||
|
(defun make-theme (&key (mode :dark))
|
||||||
|
(make-instance 'theme :mode mode))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
The mode defaults to ~:dark~. Applications can initialize with
|
||||||
|
~:light~ for terminals with light backgrounds. The mode controls
|
||||||
|
which variant ~load-preset~ selects.
|
||||||
|
|
||||||
|
** Color resolution
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
|
||||||
|
(defun theme-color (theme role)
|
||||||
|
"Resolve a semantic ROLE to a hex color string in THEME."
|
||||||
|
(gethash role (theme-roles theme)))
|
||||||
|
|
||||||
|
(defun (setf theme-color) (hex theme role)
|
||||||
|
"Set the hex color for a semantic ROLE in THEME."
|
||||||
|
(setf (gethash role (theme-roles theme)) hex))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
Uses ~gethash~ for both getter and setter. Unknown roles return ~nil~,
|
||||||
|
which the backend treats as "use default" — so missing roles degrade
|
||||||
|
gracefully rather than crashing.
|
||||||
|
|
||||||
|
** Preset system
|
||||||
|
|
||||||
|
Presets are stored in a global hash table keyed by keyword name. The
|
||||||
|
~define-preset~ macro registers a preset at macro-expansion time.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
|
||||||
|
(defparameter *presets* (make-hash-table :test #'eq))
|
||||||
|
|
||||||
|
(defmacro define-preset (name &key dark light)
|
||||||
|
"Define a theme preset with DARK and LIGHT variants.
|
||||||
|
NAME should be a keyword (e.g., :default, :nord)."
|
||||||
|
(check-type name keyword)
|
||||||
|
`(setf (gethash ,name *presets*) '(:dark ,dark :light ,light)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
Using ~#\'~ (quoted list) instead of an alist or hash table keeps the
|
||||||
|
preset data inline and easy to read. The ~eq~ hash table test matches
|
||||||
|
keyword identity.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
|
||||||
|
(defun load-preset (theme preset-name)
|
||||||
|
"Load PRESET-NAME colors into THEME.
|
||||||
|
Side-effect: populates cl-tty.backend:*theme-colors* so that semantic
|
||||||
|
color roles resolve to hex at SGR generation time."
|
||||||
|
(let ((preset (gethash preset-name *presets*)))
|
||||||
|
(if preset
|
||||||
|
(let* ((colors (if (eql (theme-mode theme) :dark)
|
||||||
|
(getf preset :dark)
|
||||||
|
(getf preset :light)))
|
||||||
|
;; Populate backend theme color map
|
||||||
|
(theme-map cl-tty.backend:*theme-colors*))
|
||||||
|
;; Set theme colors
|
||||||
|
(loop for (role hex) on colors by #'cddr
|
||||||
|
do (setf (theme-color theme role) hex)
|
||||||
|
(setf (gethash role theme-map) hex)))
|
||||||
|
(warn "Unknown preset: ~S" preset-name))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
~load-preset~ does double duty: it populates the theme's role map and
|
||||||
|
the backend's ~*theme-colors*~. This second step is what makes
|
||||||
|
semantic colors work at the SGR level — when the backend renders
|
||||||
|
~:accent~, it looks up ~*theme-colors*~ to get the hex, then
|
||||||
|
generates the escape sequence.
|
||||||
|
|
||||||
|
The ~loop for (role hex) on colors by #'cddr~ iterates the plist in
|
||||||
|
pairs, setting both the theme entry and the backend entry.
|
||||||
|
|
||||||
|
If the preset doesn't exist, ~warn~ is called instead of ~error~ — a
|
||||||
|
missing preset shouldn't crash the application.
|
||||||
|
|
||||||
|
** Built-in presets
|
||||||
|
|
||||||
|
Two presets are built in:
|
||||||
|
|
||||||
|
*** Default preset
|
||||||
|
|
||||||
|
Gold/accent palette on dark navy background. The light variant
|
||||||
|
inverts to warm tones on near-white.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
|
||||||
|
(define-preset :default
|
||||||
|
:dark (:primary "#FFD700" :secondary "#B8860B" :accent "#FFA500"
|
||||||
|
:error "#FF4444" :warning "#FF8800" :success "#44BB44" :info "#4488FF"
|
||||||
|
:text "#FFFFFF" :text-muted "#888888"
|
||||||
|
:background "#1A1A2E" :background-panel "#16213E" :background-element "#0F3460"
|
||||||
|
:border "#334155" :border-active "#FFD700"
|
||||||
|
:diff-added "#164B16" :diff-removed "#4B1616" :diff-context "#1A1A2E"
|
||||||
|
:markdown-heading "#FFD700" :markdown-code "#334155"
|
||||||
|
:markdown-link "#4488FF" :markdown-quote "#888888"
|
||||||
|
:syntax-keyword "#FF79C6" :syntax-function "#50FA7B"
|
||||||
|
:syntax-string "#F1FA8C" :syntax-number "#BD93F9"
|
||||||
|
:syntax-comment "#6272A4" :syntax-type "#8BE9FD")
|
||||||
|
:light (:primary "#B8860B" :secondary "#8B6914" :accent "#FF8C00"
|
||||||
|
:error "#CC0000" :warning "#CC6600" :success "#228B22" :info "#0055CC"
|
||||||
|
:text "#1A1A2E" :text-muted "#888888"
|
||||||
|
:background "#F8F9FA" :background-panel "#FFFFFF" :background-element "#E9ECEF"
|
||||||
|
:border "#DEE2E6" :border-active "#B8860B"
|
||||||
|
:diff-added "#DFD" :diff-removed "#FDD" :diff-context "#F8F9FA"
|
||||||
|
:markdown-heading "#B8860B" :markdown-code "#E9ECEF"
|
||||||
|
:markdown-link "#0055CC" :markdown-quote "#888888"
|
||||||
|
:syntax-keyword "#D63384" :syntax-function "#198754"
|
||||||
|
:syntax-string "#FFC107" :syntax-number "#6F42C1"
|
||||||
|
:syntax-comment "#6C757D" :syntax-type "#0DCAF0"))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
*** Nord preset
|
||||||
|
|
||||||
|
Cool blue palette inspired by Arctic Studio's Nord theme. Softer
|
||||||
|
contrast than default, designed for reduced eye strain.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
|
||||||
|
(define-preset :nord
|
||||||
|
:dark (:primary "#88C0D0" :secondary "#81A1C1" :accent "#5E81AC"
|
||||||
|
:error "#BF616A" :warning "#D08770" :success "#A3BE8C" :info "#B48EAD"
|
||||||
|
:text "#ECEFF4" :text-muted "#616E88"
|
||||||
|
:background "#2E3440" :background-panel "#3B4252" :background-element "#434C5E"
|
||||||
|
:border "#4C566A" :border-active "#88C0D0"
|
||||||
|
:diff-added "#164B16" :diff-removed "#4B1616" :diff-context "#2E3440"
|
||||||
|
:markdown-heading "#88C0D0" :markdown-code "#3B4252"
|
||||||
|
:markdown-link "#81A1C1" :markdown-quote "#616E88"
|
||||||
|
:syntax-keyword "#81A1C1" :syntax-function "#A3BE8C"
|
||||||
|
:syntax-string "#EBCB8B" :syntax-number "#B48EAD"
|
||||||
|
:syntax-comment "#616E88" :syntax-type "#88C0D0")
|
||||||
|
:light (:primary "#5E81AC" :secondary "#81A1C1" :accent "#88C0D0"
|
||||||
|
:error "#BF616A" :warning "#D08770" :success "#A3BE8C" :info "#B48EAD"
|
||||||
|
:text "#2E3440" :text-muted "#8F9BB3"
|
||||||
|
:background "#ECEFF4" :background-panel "#FFFFFF" :background-element "#E5E9F0"
|
||||||
|
:border "#D8DEE9" :border-active "#5E81AC"
|
||||||
|
:diff-added "#DFD" :diff-removed "#FDD" :diff-context "#ECEFF4"
|
||||||
|
:markdown-heading "#5E81AC" :markdown-code "#E5E9F0"
|
||||||
|
:markdown-link "#81A1C1" :markdown-quote "#8F9BB3"
|
||||||
|
:syntax-keyword "#81A1C1" :syntax-function "#A3BE8C"
|
||||||
|
:syntax-string "#D08770" :syntax-number "#B48EAD"
|
||||||
|
:syntax-comment "#8F9BB3" :syntax-type "#88C0D0"))
|
||||||
|
#+END_SRC
|
||||||
Reference in New Issue
Block a user