From af572d5a8c5e1592c0f87a62e6f726f1d3861fd2 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Mon, 18 May 2026 13:04:10 -0400 Subject: [PATCH] v0.8.0: tangle to XDG (~/.local/share/cl-tty/), remove stale memex .lisp files --- org/backend-protocol.org | 108 ++--- org/box-renderable.org | 58 +-- org/container-package.org | 2 +- org/detection.org | 12 +- org/dialog.org | 46 +- org/dirty.org | 12 +- org/framebuffer.org | 78 +-- org/integration-tests.org | 30 +- org/layout-engine.org | 72 +-- org/markdown-renderer.org | 98 ++-- org/modern-backend.org | 112 ++--- org/mouse.org | 50 +- org/package.org | 14 +- org/render.org | 40 +- org/scrollbox.org | 52 +- org/select.org | 50 +- org/slot.org | 32 +- org/tabbar.org | 20 +- org/text-input.org | 112 ++--- org/theme.org | 38 +- src/backend/classes.lisp | 109 ----- src/backend/detection.lisp | 66 --- src/backend/modern-tests.lisp | 116 ----- src/backend/modern.lisp | 333 ------------- src/backend/package.lisp | 35 -- src/backend/simple.lisp | 176 ------- src/backend/tests.lisp | 139 ------ src/components/box-tests.lisp | 162 ------- src/components/box.lisp | 54 --- src/components/container-package.lisp | 16 - src/components/dialog-package.lisp | 25 - src/components/dialog.lisp | 116 ----- src/components/dirty-tests.lisp | 26 - src/components/dirty.lisp | 14 - src/components/input-package.lisp | 38 -- src/components/input.lisp | 284 ----------- src/components/keybindings.lisp | 63 --- src/components/markdown-package.lisp | 9 - src/components/markdown.lisp | 672 -------------------------- src/components/mouse-package.lisp | 12 - src/components/mouse.lisp | 108 ----- src/components/package.lisp | 37 -- src/components/render-tests.lisp | 48 -- src/components/render.lisp | 72 --- src/components/scrollbox.lisp | 133 ----- src/components/select-package.lisp | 13 - src/components/select.lisp | 142 ------ src/components/slot-package.lisp | 9 - src/components/slot.lisp | 59 --- src/components/tabbar.lisp | 82 ---- src/components/text-input.lisp | 110 ----- src/components/text.lisp | 105 ---- src/components/textarea.lisp | 234 --------- src/components/theme-tests.lisp | 61 --- src/components/theme.lisp | 89 ---- src/layout/layout.lisp | 181 ------- src/layout/tests.lisp | 167 ------- src/rendering/framebuffer.lisp | 223 --------- tests/dialog-tests.lisp | 43 -- tests/framebuffer-tests.lisp | 110 ----- tests/input-tests.lisp | 409 ---------------- tests/integration-tests.lisp | 243 ---------- tests/markdown-tests.lisp | 294 ----------- tests/mouse-tests.lisp | 47 -- tests/scrollbox-tabbar-tests.lisp | 124 ----- tests/select-tests.lisp | 120 ----- tests/slot-tests.lisp | 55 --- 67 files changed, 518 insertions(+), 6301 deletions(-) delete mode 100644 src/backend/classes.lisp delete mode 100644 src/backend/detection.lisp delete mode 100644 src/backend/modern-tests.lisp delete mode 100644 src/backend/modern.lisp delete mode 100644 src/backend/package.lisp delete mode 100644 src/backend/simple.lisp delete mode 100644 src/backend/tests.lisp delete mode 100644 src/components/box-tests.lisp delete mode 100644 src/components/box.lisp delete mode 100644 src/components/container-package.lisp delete mode 100644 src/components/dialog-package.lisp delete mode 100644 src/components/dialog.lisp delete mode 100644 src/components/dirty-tests.lisp delete mode 100644 src/components/dirty.lisp delete mode 100644 src/components/input-package.lisp delete mode 100644 src/components/input.lisp delete mode 100644 src/components/keybindings.lisp delete mode 100644 src/components/markdown-package.lisp delete mode 100644 src/components/markdown.lisp delete mode 100644 src/components/mouse-package.lisp delete mode 100644 src/components/mouse.lisp delete mode 100644 src/components/package.lisp delete mode 100644 src/components/render-tests.lisp delete mode 100644 src/components/render.lisp delete mode 100644 src/components/scrollbox.lisp delete mode 100644 src/components/select-package.lisp delete mode 100644 src/components/select.lisp delete mode 100644 src/components/slot-package.lisp delete mode 100644 src/components/slot.lisp delete mode 100644 src/components/tabbar.lisp delete mode 100644 src/components/text-input.lisp delete mode 100644 src/components/text.lisp delete mode 100644 src/components/textarea.lisp delete mode 100644 src/components/theme-tests.lisp delete mode 100644 src/components/theme.lisp delete mode 100644 src/layout/layout.lisp delete mode 100644 src/layout/tests.lisp delete mode 100644 src/rendering/framebuffer.lisp delete mode 100644 tests/dialog-tests.lisp delete mode 100644 tests/framebuffer-tests.lisp delete mode 100644 tests/input-tests.lisp delete mode 100644 tests/integration-tests.lisp delete mode 100644 tests/markdown-tests.lisp delete mode 100644 tests/mouse-tests.lisp delete mode 100644 tests/scrollbox-tabbar-tests.lisp delete mode 100644 tests/select-tests.lisp delete mode 100644 tests/slot-tests.lisp diff --git a/org/backend-protocol.org b/org/backend-protocol.org index c9f4eb4..4d1a948 100644 --- a/org/backend-protocol.org +++ b/org/backend-protocol.org @@ -107,7 +107,7 @@ FiveAM requires a test package with :use of :fiveam and the system under test. The suite name ~backend-suite~ is referenced by the multi-suite runner in ~run-all-tests.lisp~. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (defpackage :cl-tty-backend-test (:use :cl :fiveam :cl-tty.backend) (:export #:run-tests)) @@ -124,7 +124,7 @@ creates a simple-backend pointed at a string output stream and returns both the backend and the stream. The test can then call ~get-output-stream-string~ after the operation. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (defun make-capturing-backend () "Create a simple-backend that writes to a string stream." (let* ((s (make-string-output-stream)) @@ -138,7 +138,7 @@ The ~run-tests~ function is an alternative entry point for interactive use or for downstream scripts that want to run only the backend suite. It prints results with FiveAM's explainer. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (defun run-tests () "Run all backend tests." (let ((result (run 'backend-suite))) @@ -153,7 +153,7 @@ shut down without errors. Also confirms that the capability query returns nil for truecolor — the defining characteristic of the simple backend. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test simple-backend-lifecycle "simple-backend can be created and shut down" (let ((b (make-simple-backend))) @@ -172,7 +172,7 @@ and position. It merely appends the text string to the output stream. This test confirms that passing style keywords does not change the output — the captured stream should contain exactly the string "hello". -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test simple-backend-draw-text "simple-backend renders text at position, ignoring style" (multiple-value-bind (b s) (make-capturing-backend) @@ -190,7 +190,7 @@ Border rendering on the simple backend uses ASCII characters: This test checks that the top edge contains "+---+" and a middle row shows "| |" with pipe-separated empty space. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test simple-backend-draw-border "simple-backend draws ASCII border with +-| characters" (multiple-value-bind (b s) (make-capturing-backend) @@ -209,7 +209,7 @@ falls back to the same ASCII characters. This test verifies that requesting ~:rounded~ produces the same output as ~:single~, confirming the graceful fallback. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test simple-backend-draw-rounded "simple-backend falls back to straight edges for rounded style" (multiple-value-bind (b s) (make-capturing-backend) @@ -227,7 +227,7 @@ Hyperlinks are meaningless on a simple terminal output. The simple backend's ~draw-link~ should output only the visible text and completely ignore the URL parameter. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test simple-backend-draw-link "simple-backend renders link as plain text" (multiple-value-bind (b s) (make-capturing-backend) @@ -244,7 +244,7 @@ Truncation markers are rendered as three literal dots on the simple backend. This test checks that ~draw-ellipsis~ outputs exactly "..." at the specified position. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test simple-backend-draw-ellipsis "simple-backend renders ... for ellipsis" (multiple-value-bind (b s) (make-capturing-backend) @@ -262,7 +262,7 @@ backend. This comprehensive check iterates every feature keyword to ensure the simple backend makes no false claims about its capabilities. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test capable-p-known-features "capable-p returns nil for all features on simple-backend" (let ((b (make-simple-backend))) @@ -281,7 +281,7 @@ representing columns and lines. This test verifies the return types and a minimum size threshold (10 columns, 3 lines) for any terminal-like environment. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test backend-size-returns-integers "backend-size returns two integer values" (let ((b (make-simple-backend))) @@ -302,7 +302,7 @@ test calls ~cursor-hide~, ~cursor-show~, ~cursor-style~, ~begin-sync~, and ~end-sync~ and confirms none of them produce multiple return values. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test default-methods-are-no-ops "Default backend methods don't error" (let ((b (make-simple-backend))) @@ -322,7 +322,7 @@ output. This test verifies that wrapping a draw-text call between ~begin-sync~ and ~end-sync~ produces exactly the same output as draw-text alone — no extra escape sequences are emitted. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test sync-is-noop-on-simple "begin-sync and end-sync produce no output on simple-backend" (multiple-value-bind (b s) (make-capturing-backend) @@ -342,7 +342,7 @@ colors. Since the simple backend emits no escape sequences, ~draw-rect~ should produce zero output regardless of the fill color requested. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test draw-rect-fills-area-correctly "draw-rect with background writes nothing to output (simple-backend no-op)" (multiple-value-bind (b s) (make-capturing-backend) @@ -359,7 +359,7 @@ The ~detect-backend~ function must return a backend instance suitable for the current environment. This test verifies that the returned value is of type ~backend~ (satisfying the protocol). -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test detection-returns-backend-instance "detect-backend returns a valid backend instance" (let ((be (cl-tty.backend:detect-backend))) @@ -373,7 +373,7 @@ subsequent calls are cheap. This test clears the cache, calls detect-backend, and verifies that the special variable is no longer nil. -#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp (test detection-caches-result "detect-backend caches the result in *detected-backend*" (let ((*detected-backend* nil)) @@ -395,7 +395,7 @@ The package also exports internal symbols (~sgr-fg~, ~hex-to-24bit~, etc.) for testing. These let the test suite verify escape sequence construction without actually rendering to a terminal. -#+BEGIN_SRC lisp :tangle ../src/backend/package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/package.lisp (defpackage :cl-tty.backend (:use :cl) (:export @@ -445,7 +445,7 @@ actually support. An empty base class. There are no slots because backends manage their own state (e.g., output streams) directly. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (in-package :cl-tty.backend) (defclass backend () ()) @@ -457,7 +457,7 @@ Sets up terminal raw mode and enables features. The default method returns the backend instance unchanged — subclasses that need setup override this. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric initialize-backend (backend) (:method ((b backend)) b)) #+END_SRC @@ -468,7 +468,7 @@ Restores terminal to cooked mode, resets colors, shows cursor. Must be called on exit. The default method is a no-op returning multiple values; subclasses with terminal state override this. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric shutdown-backend (backend) (:method ((b backend)) (values))) #+END_SRC @@ -478,7 +478,7 @@ multiple values; subclasses with terminal state override this. Returns terminal dimensions as two values: columns and lines. The default of 80x24 is a safe fallback that works everywhere. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric backend-size (backend) (:method ((b backend)) (values 80 24))) @@ -490,7 +490,7 @@ Writes a raw string to the terminal output. Has no default method because every backend must provide its own output mechanism — there is no reasonable universal behavior. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric backend-write (backend string)) #+END_SRC @@ -500,7 +500,7 @@ Clears the entire screen and resets the cursor to (0,0). The default method sends the ANSI escape sequence ~ESC[2J~ (clear entire screen) followed by ~ESC[H~ (cursor home). -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric backend-clear (backend) (:method ((b backend)) (backend-write b (format nil "~C[2J~C[H" #\Esc #\Esc)))) @@ -514,7 +514,7 @@ it lets individual backend methods accept keyword arguments they don't use without signaling an error. The simple backend ignores styles; the modern backend processes them. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric draw-text (backend x y string fg bg &key bold italic underline reverse dim blink &allow-other-keys)) @@ -526,7 +526,7 @@ Draws a border rectangle with optional title. Style is one of ~:single~, ~:double~, or ~:rounded~. The default method has no implementation — each backend provides its own border rendering. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric draw-border (backend x y width height &key style fg bg title title-align)) #+END_SRC @@ -537,7 +537,7 @@ Fills a rectangular area with a background color. On the simple backend this is a no-op; on the modern backend it writes space characters with the appropriate SGR background color. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric draw-rect (backend x y width height &key bg)) #+END_SRC @@ -547,7 +547,7 @@ Renders a clickable hyperlink using OSC 8 escape sequences. The default is a protocol declaration only — modern-backend implements the actual escape sequences, simple-backend falls back to plain text. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric draw-link (backend x y string url &key fg bg)) #+END_SRC @@ -557,7 +557,7 @@ Renders a "..." truncation marker at position (x, y). This is used when text exceeds the available width. Each backend positions the marker according to its own coordinate system. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric draw-ellipsis (backend x y width &key fg bg)) #+END_SRC @@ -566,7 +566,7 @@ marker according to its own coordinate system. Moves the cursor to absolute position (x, y). The default method is a no-op — backends that support cursor positioning override this. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric cursor-move (backend x y) (:method ((b backend) x y) (declare (ignore x y)) (values))) #+END_SRC @@ -576,7 +576,7 @@ is a no-op — backends that support cursor positioning override this. Hides the terminal cursor. The default method is a no-op so that backends that lack cursor control still work safely. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric cursor-hide (backend) (:method ((b backend)) (values))) #+END_SRC @@ -586,7 +586,7 @@ backends that lack cursor control still work safely. Shows the terminal cursor after a hide. Always paired with ~cursor-hide~. Default is a no-op. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric cursor-show (backend) (:method ((b backend)) (values))) #+END_SRC @@ -597,7 +597,7 @@ Sets the cursor shape and blink behavior. Shape is ~:block~, ~:bar~, or ~:underline~. Default is a no-op for backends that don't support cursor styling. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric cursor-style (backend shape &key blink) (:method ((b backend) shape &key blink) (values))) #+END_SRC @@ -607,7 +607,7 @@ don't support cursor styling. Starts a synchronized update (DECICM). All subsequent output is buffered by the terminal until ~end-sync~. Default is a no-op. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric begin-sync (backend) (:method ((b backend)) (values))) #+END_SRC @@ -617,7 +617,7 @@ buffered by the terminal until ~end-sync~. Default is a no-op. Flushes the synchronized update buffer so the entire frame appears at once. Always paired with ~begin-sync~. Default is a no-op. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric end-sync (backend) (:method ((b backend)) (values))) #+END_SRC @@ -628,7 +628,7 @@ Reads the next input event from the terminal. Blocks until an event arrives or the timeout expires. Returns (values keyword event-data). The default method returns ~(values nil nil)~ — no events available. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric read-event (backend &key timeout) (:method ((b backend) &key timeout) (values nil nil))) #+END_SRC @@ -639,7 +639,7 @@ Enables SGR mouse tracking so mouse click and motion events are reported as input. Default is a no-op on backends that don't support mouse input. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric enable-mouse (backend) (:method ((b backend)) (values))) #+END_SRC @@ -649,7 +649,7 @@ support mouse input. Enables bracketed paste mode so the application can distinguish pasted text from typed input. Default is a no-op. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric enable-bracketed-paste (backend) (:method ((b backend)) (values))) #+END_SRC @@ -661,7 +661,7 @@ keywords include ~:truecolor~, ~:osc8~, ~:sync~, ~:mouse~, ~:bracketed-paste~, ~:kitty-keyboard~, ~:sixel~, and ~:cursor-style~. The default method returns ~nil~ for all features. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (defgeneric capable-p (backend feature) (:method ((b backend) feature) (declare (ignore feature)) @@ -675,7 +675,7 @@ application receives SIGTSTP (suspend) or SIGCONT (resume) signals. The default methods are no-ops; backends with terminal state override these to restore cooked mode on suspend and raw mode on resume. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (in-package :cl-tty.backend) (defgeneric suspend-backend (backend) @@ -705,7 +705,7 @@ Arguments: lines captured after initialization. - ~&body body~ — executed with the above bindings. -#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp (in-package :cl-tty.backend) (defmacro with-terminal ((backend-var &optional cols-var rows-var) @@ -754,7 +754,7 @@ the ~:output-stream~ initarg — the key extensibility point. Tests use ~make-string-output-stream~ to capture output, while production uses ~*standard-output*~. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (in-package :cl-tty.backend) (defclass simple-backend (backend) @@ -770,7 +770,7 @@ Constructor function that creates a ~simple-backend~ instance. Uses ~*standard-output*~. This function is exported rather than exposing ~make-instance~ directly to provide a stable API surface. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defun make-simple-backend (&key output-stream) (make-instance 'simple-backend :output-stream (or output-stream *standard-output*))) @@ -782,7 +782,7 @@ Simple backend initialization is a no-op — there is no terminal state to configure. Returns the backend instance to satisfy the protocol contract. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod initialize-backend ((b simple-backend)) b) #+END_SRC @@ -792,7 +792,7 @@ protocol contract. Simple backend shutdown is a no-op — there is no terminal state to restore. Returns multiple values to satisfy the protocol contract. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod shutdown-backend ((b simple-backend)) (values)) #+END_SRC @@ -801,7 +801,7 @@ restore. Returns multiple values to satisfy the protocol contract. No-op — simple backend has no terminal state to save. -#+begin_src lisp :tangle ../src/backend/simple.lisp +#+begin_src lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod suspend-backend ((b simple-backend)) (values)) #+end_src @@ -810,7 +810,7 @@ No-op — simple backend has no terminal state to save. No-op — simple backend has no terminal state to restore. -#+begin_src lisp :tangle ../src/backend/simple.lisp +#+begin_src lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod resume-backend ((b simple-backend)) (values)) #+end_src @@ -825,7 +825,7 @@ a hard-coded 80x24 at the end: 3. **ioctl on ~/dev/tty~** — fallback when stdin/stdout are pipes. 4. **~(values 80 24)~** — last resort. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod backend-size ((b simple-backend)) ;; Try ioctl on fd 0 (stdin), then stdout, then /dev/tty, then 80x24. ;; Use multiple-value-bind/values to preserve both cols and rows @@ -883,7 +883,7 @@ Writes a string to the backend's output stream and returns its length. Does NOT flush — explicit sync points (~initialize-backend~, ~end-sync~, etc.) call ~finish-output~ as needed. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod backend-write ((b simple-backend) string) (let ((stream (backend-output-stream b))) (write-string string stream) @@ -897,7 +897,7 @@ completely. It appends only the string content to the output stream. This means simple backends are always a "scroll and dump" mode — no cursor positioning, no escape sequences. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod draw-text ((b simple-backend) x y string fg bg &key bold italic underline reverse dim blink &allow-other-keys) @@ -912,7 +912,7 @@ corners use ~#\+~, horizontal edges use ~#\-~, and vertical edges use ~#\|~. No style distinction — single, double, and rounded are identical in ASCII output. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defun %simple-border-char (pos) "Return ASCII border character at POS. POS is :top-left, :top-right, :bottom-left, :bottom-right, @@ -931,7 +931,7 @@ The title rendering supports ~:left~ and ~:center~ alignment, placing the title inside the top border line with horizontal dashes filling the remaining space. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod draw-border ((b simple-backend) x y width height &key style fg bg title title-align) (declare (ignore style fg bg)) @@ -987,7 +987,7 @@ dashes filling the remaining space. Background fill is impossible without escape sequences. This method is a no-op — it discards all arguments and returns ~(values)~. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod draw-rect ((b simple-backend) x y width height &key bg) (declare (ignore x y width height bg)) @@ -1001,7 +1001,7 @@ Hyperlinks fall back to plain text on the simple backend. The URL parameter is discarded entirely; the visible text is rendered via ~draw-text~ with no styling. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod draw-link ((b simple-backend) x y string url &key fg bg) (declare (ignore url fg bg)) @@ -1014,7 +1014,7 @@ Renders "..." using the simple backend's positioning pattern: newlines to reach the target row, spaces to reach the target column, then the literal three dots. No escape sequences are used. -#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp (defmethod draw-ellipsis ((b simple-backend) x y width &key fg bg) (declare (ignore width fg bg)) diff --git a/org/box-renderable.org b/org/box-renderable.org index 0a7cffc..049915a 100644 --- a/org/box-renderable.org +++ b/org/box-renderable.org @@ -43,7 +43,7 @@ The test package exports ~run-tests~ so it can be invoked from the top-level test runner. ~fiveam~ imports directly for declarative ~test~ and ~is~ forms. The ~box-suite~ collects all box/text tests. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (defpackage :cl-tty-box-test (:use :cl :fiveam :cl-tty.backend :cl-tty.layout :cl-tty.box) (:export #:run-tests)) @@ -59,7 +59,7 @@ top-level test runner. ~fiveam~ imports directly for declarative ~run-all-tests.lisp~. It runs the ~box-suite~, explains results to stdout, and exits cleanly with ~uiop:quit~. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (defun run-tests () (let ((result (run 'box-suite))) (fiveam:explain! result) @@ -73,7 +73,7 @@ stdout, and exits cleanly with ~uiop:quit~. actual terminal I/O. Returns the backend and stream as multiple values. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (defun make-capturing-backend () (let* ((s (make-string-output-stream)) (b (make-modern-backend :output-stream s))) @@ -85,7 +85,7 @@ values. Verify that a bare ~make-box~ returns a ~box~ instance and automatically creates a ~layout-node~ through inheritance. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test box-creates-with-defaults "A box created with no arguments has reasonable defaults" (let ((b (make-box))) @@ -98,7 +98,7 @@ automatically creates a ~layout-node~ through inheritance. Verify that a box with ~:border-style :single~ draws the four corner characters (┌ ┐ └ ┘) in the output stream. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test box-renders-border "A box with border draws border characters" (multiple-value-bind (b s) (make-capturing-backend) @@ -117,7 +117,7 @@ characters (┌ ┐ └ ┘) in the output stream. Verify that a box with ~:bg :red~ emits SGR background color codes (41m) in the output stream. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test box-renders-background "A box with background color fills interior" (multiple-value-bind (b s) (make-capturing-backend) @@ -134,7 +134,7 @@ Verify that a box with ~:bg :red~ emits SGR background color codes Verify that a title string appears in the rendered output stream when ~:title~ is provided. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test box-renders-title "A box with title renders the title text" (multiple-value-bind (b s) (make-capturing-backend) @@ -150,7 +150,7 @@ when ~:title~ is provided. Verify that ~:border-style nil~ suppresses corner characters but background fill rendering continues to work. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test box-without-border "A box with border-style nil draws no border" (multiple-value-bind (b s) (make-capturing-backend) @@ -167,7 +167,7 @@ background fill rendering continues to work. Verify that a box with zero width and height produces no output (triggers the early-return guard in ~render-box~). -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test box-zero-size "A box with any zero dimension renders nothing" (multiple-value-bind (b s) (make-capturing-backend) @@ -183,7 +183,7 @@ Verify that a box with zero width and height produces no output Verify that a box with width 1 produces no output — ~draw-border~ requires at least 2 columns to draw corner and edge characters. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test box-single-column "A box with width 1 renders nothing (needs min 2 for border)" (multiple-value-bind (b s) (make-capturing-backend) @@ -199,7 +199,7 @@ requires at least 2 columns to draw corner and edge characters. Verify that a 2x2 box (the minimum viable size for border rendering) still produces corner characters in the output. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test box-minimum-size "A box with minimum non-zero size still renders" (multiple-value-bind (b s) (make-capturing-backend) @@ -215,7 +215,7 @@ still produces corner characters in the output. Verify that ~make-text~ with an empty string returns a ~text~ instance and creates a ~layout-node~. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test text-creates-with-defaults "A text created with no arguments has reasonable defaults" (let ((txt (make-text ""))) @@ -228,7 +228,7 @@ instance and creates a ~layout-node~. Verify that text content appears in the captured output stream after rendering. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test text-renders-content "A text renders its content at position" (multiple-value-bind (b s) (make-capturing-backend) @@ -244,7 +244,7 @@ rendering. Verify that an empty string produces no output (triggers the early-return guard in ~render-text~). -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test text-empty-string "Empty text produces no output" (multiple-value-bind (b s) (make-capturing-backend) @@ -260,7 +260,7 @@ early-return guard in ~render-text~). Verify that ~:wrap-mode :none~ truncates the content string to fit within the available width, producing only the first N characters. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test text-truncates-when-no-wrap "Text with wrap-mode :none truncates at width" (multiple-value-bind (b s) (make-capturing-backend) @@ -277,7 +277,7 @@ within the available width, producing only the first N characters. Verify that ~:wrap-mode :word~ breaks lines at word boundaries, distributing words across successive rows. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test text-word-wraps "Text with wrap-mode :word wraps at word boundaries" (multiple-value-bind (b s) (make-capturing-backend) @@ -295,7 +295,7 @@ distributing words across successive rows. Verify that a single word longer than the available width is hard-broken at character boundaries into ~max-width~-sized chunks. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test text-word-wrap-single-word "A word longer than width is hard-broken at max-width" (multiple-value-bind (b s) (make-capturing-backend) @@ -312,7 +312,7 @@ hard-broken at character boundaries into ~max-width~-sized chunks. Verify that ~span~ stores its text content and style attributes correctly, with unset attributes defaulting to ~nil~. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test span-creates-with-attributes "A span has text and optional style attributes" (let ((s (span "bold text" :bold t))) @@ -326,7 +326,7 @@ correctly, with unset attributes defaulting to ~nil~. Verify that ~make-text~ with ~:spans~ stores the provided span objects and they are accessible via ~text-spans~. -#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp (test make-text-with-spans "Text with spans stores span objects" (let* ((sp (list (span "Hello" :bold t) @@ -346,7 +346,7 @@ color change) trigger incremental re-render. The ~layout-node~ slot holds the computed position and size from the layout engine. Border style, title, alignment, and colors are all configurable slots. -#+BEGIN_SRC lisp :tangle ../src/components/box.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box.lisp (in-package :cl-tty.box) (defclass box (dirty-mixin) @@ -367,7 +367,7 @@ The constructor wraps ~make-instance~ and passes layout parameters through to the layout node. Width and height are optional; when omitted the layout engine will compute them from parent constraints. -#+BEGIN_SRC lisp :tangle ../src/components/box.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box.lisp (defun make-box (&key (border-style :single) title (title-align :left) fg bg width height) @@ -393,7 +393,7 @@ Title rendering supports ~:left~, ~:center~, and ~:right~ alignment with automatic truncation when the title is wider than available content area (width-4 when border is present). -#+BEGIN_SRC lisp :tangle ../src/components/box.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box.lisp (defun render-box (box backend) "Render BOX at its computed layout position using BACKEND." (let ((ln (box-layout-node box)) @@ -430,7 +430,7 @@ Multiple spans let a single Text contain bold, colored, or italicized runs. Each style attribute is a separate slot so consumers can inspect and apply them individually. -#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp (in-package :cl-tty.box) (defclass span () @@ -450,7 +450,7 @@ inspect and apply them individually. keyword arguments for all style attributes. A ~nil~ default means "inherit/no-change" when merged with parent styling context. -#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp (defun span (text &key bold italic underline reverse dim fg bg) (make-instance 'span :text text :bold bold :italic italic @@ -465,7 +465,7 @@ Spans are stored for future per-run styling but the current implementation renders all content as plain text. It inherits from ~dirty-mixin~ so content, color, or size changes trigger re-render. -#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp (defclass text (dirty-mixin) ((layout-node :initform (make-layout-node) :accessor text-layout-node :initarg :layout-node) @@ -483,7 +483,7 @@ dimensions and content parameters. It defaults ~wrap-mode~ to ~:word~ so text wraps by default, and creates a ~:column~-oriented layout node. -#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp (defun make-text (content &key fg bg wrap-mode width height spans) (make-instance 'text :content content @@ -502,7 +502,7 @@ at successive row positions. For ~:none~, it truncates the content to fit the width in a single line. Empty content or zero dimensions triggers an early return. -#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp (defun render-text (text-object backend) "Render TEXT-OBJECT at its computed layout position using BACKEND." (let ((ln (text-layout-node text-object)) @@ -535,7 +535,7 @@ input into words, then packs them into lines respecting ~max-width~. Words that exceed ~max-width~ are hard-broken at character boundaries in chunks of ~max-width~ to ensure no line exceeds the limit. -#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp (defun word-wrap (text max-width) "Split TEXT into lines, each <= MAX-WIDTH chars." (if (or (zerop max-width) (zerop (length text))) @@ -572,7 +572,7 @@ newline). It uses ~position-if~ to find delimiters and builds the word list iteratively. Consecutive delimiters are collapsed (only one advance per delimiter character). -#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp (defun split-string (string) "Split STRING into words separated by whitespace." (loop with words = nil diff --git a/org/container-package.org b/org/container-package.org index 80ced07..e2f32e3 100644 --- a/org/container-package.org +++ b/org/container-package.org @@ -107,7 +107,7 @@ that point. The current scope favors simplicity and co-location. * Package Definition -#+BEGIN_SRC lisp :tangle ../src/components/container-package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/container-package.lisp (defpackage :cl-tty.container (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export diff --git a/org/detection.org b/org/detection.org index 0199356..c2ed4a2 100644 --- a/org/detection.org +++ b/org/detection.org @@ -80,7 +80,7 @@ Using a global variable rather than a closure or class slot keeps the detection path stateless and trivially resettable for testing: binding ~*detected-backend*~ to ~nil~ forces a fresh detection run. -#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/detection.lisp (in-package :cl-tty.backend) (defvar *detected-backend* nil @@ -98,7 +98,7 @@ sequence queries. Case-insensitive matching via ~char-equal~ handles variances across platforms (GNOME Terminal uses ~truecolor~, some Windows builds use ~24bit~). -#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/detection.lisp (defun detect-backend-by-env () "Check COLORTERM environment variable for modern terminal support. Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise." @@ -119,7 +119,7 @@ further (I/O-dependent) probes. Must happen before ~detect-backend-by-da1~. Testing this predicate first also avoids wasting time on DA1 queries when the output is consumed by a test runner, CI pipeline, or pipe. -#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/detection.lisp (defun detect-backend-by-tty () "Check if stdout is a real terminal (not a pipe/redirect). Returns T if stdout is interactive, nil otherwise." @@ -140,7 +140,7 @@ bytes arrive within the timeout without blocking. The ~0.1~ second default strikes a balance between responsiveness and reliability: fast enough to avoid noticeable delay in interactive use, long enough for most terminals to reply. -#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/detection.lisp (defun query-terminal (query &optional (timeout 0.1)) "Send QUERY string to terminal and return any response received within TIMEOUT seconds. Returns the response string, or nil if no response." @@ -168,7 +168,7 @@ This probe is best-effort: many terminals do not respond within the timeout, and some return different codes for the same capabilities. A ~nil~ result from this function should never prevent fallback detection via environment variables. -#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/detection.lisp (defun detect-backend-by-da1 () "Send DA1 (ESC[c) query and check for kitty terminal response code. Returns T if terminal reports kitty compatibility codes." @@ -193,7 +193,7 @@ returns nil, the expensive DA1 query never runs. If ~detect-backend-by-env~ returns ~:modern~, the DA1 query is skipped. The result is cached in ~*detected-backend*~ so subsequent calls are effectively free. -#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/detection.lisp (defun detect-backend () "Auto-detect the appropriate backend for the current terminal. Returns a backend instance (modern-backend or simple-backend). diff --git a/org/dialog.org b/org/dialog.org index 07b9c14..32d6b4d 100644 --- a/org/dialog.org +++ b/org/dialog.org @@ -50,7 +50,7 @@ duration. They stack in the top-right corner. The ~cl-tty.dialog~ package uses the backend, input, and select subsystems. All public symbols are exported for user convenience. -#+BEGIN_SRC lisp :tangle ../src/components/dialog-package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog-package.lisp ;;; dialog-package.lisp — Package definition for cl-tty.dialog (defpackage :cl-tty.dialog @@ -87,7 +87,7 @@ The active dialog stack. ~push-dialog~ conses onto this list; should bind its own instance so multiple screens can have independent dialog states. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (in-package :cl-tty.dialog) (defvar *dialog-stack* nil @@ -100,7 +100,7 @@ List of active toast notifications. ~toast~ pushes, ~dismiss-toast~ removes by identity. The render loop walks this list to draw toasts in the top-right corner. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defvar *toasts* nil "List of active toast notifications.") #+END_SRC @@ -111,7 +111,7 @@ The core dialog class stores a title, a size preset, the content component to render inside the panel, and an optional ~:on-dismiss~ callback invoked when the dialog is popped. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defclass dialog () ((title :initarg :title :accessor dialog-title) (size :initarg :size :initform :medium :accessor dialog-size) @@ -125,7 +125,7 @@ Converts a size keyword (~:small~, ~:medium~, ~:large~) to pixel dimensions. Accepts optional ~max-w~ / ~max-h~ to clamp the result to terminal bounds, preventing off-screen overflow (fixed in v1.0.0). -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun dialog-size-pixels (size &optional (max-w 80) (max-h 24)) (multiple-value-bind (dw dh) (case size @@ -142,7 +142,7 @@ Renders a dialog: draws a dimmed full-screen backdrop using ~draw-rect~, then draws the bordered dialog panel centered on screen. Content is rendered via ~draw-text~ inside the panel area. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun render-dialog (dialog screen w h) (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h) (let ((x (floor (- w dw) 2)) @@ -163,7 +163,7 @@ Content is rendered via ~draw-text~ inside the panel area. Pushes a dialog onto =*dialog-stack*=. Returns the dialog for chaining. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun push-dialog (dialog) (push dialog *dialog-stack*) dialog) @@ -174,7 +174,7 @@ Pushes a dialog onto =*dialog-stack*=. Returns the dialog for chaining. Pops the top dialog from the stack. If an ~:on-dismiss~ callback is set on the dialog, it is called before returning. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun pop-dialog () (when *dialog-stack* (let ((dialog (pop *dialog-stack*))) @@ -194,7 +194,7 @@ Simple alert with title, message, and an OK button. The button is a ~select~ with a single "OK" option. Dismissing fires ~pop-dialog~ on both selection and backdrop dismiss. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun alert-dialog (title message) (make-instance 'dialog :title title @@ -210,7 +210,7 @@ both selection and backdrop dismiss. Confirm dialog with Yes/No buttons. Returns ~:yes~ or ~:no~ via the ~on-yes~/~on-no~ callbacks. The dialog auto-dismisses on selection. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun confirm-dialog (title message &key on-yes on-no) (make-instance 'dialog :title title @@ -230,7 +230,7 @@ Confirm dialog with Yes/No buttons. Returns ~:yes~ or ~:no~ via the Modal wrapper around the ~select~ component. Presents a list of options and calls ~on-select~ with the chosen value after dismissing. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun select-dialog (title options &key on-select) (make-instance 'dialog :title title @@ -247,7 +247,7 @@ and calls ~on-select~ with the chosen value after dismissing. Modal wrapper around ~text-input~. Shows a text input field inside the dialog and calls ~on-submit~ with the entered value after dismissing. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun prompt-dialog (title &key on-submit) (make-instance 'dialog :title title @@ -268,7 +268,7 @@ has a message and a variant that determines its color (~:info~, Lightweight class storing the message text and variant keyword. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defclass toast () ((message :initarg :message :accessor toast-message) (variant :initarg :variant :initform :info :accessor toast-variant))) @@ -280,7 +280,7 @@ Draws a toast in the top-right corner of the screen. The message is truncated to 60 columns with an ellipsis if necessary. The background color reflects the variant. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun render-toast (toast screen w) (let* ((msg (toast-message toast)) (variant (toast-variant toast)) @@ -302,7 +302,7 @@ Fire-and-forget toast notification. Creates a ~toast~ instance, pushes it onto =*toasts*~, and optionally schedules auto-dismissal via ~dismiss-toast~ when ~duration~ is positive. -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun toast (message &key (variant :info) (duration 0)) (let ((toast (make-instance 'toast :message message :variant variant))) (push toast *toasts*) @@ -315,7 +315,7 @@ it onto =*toasts*~, and optionally schedules auto-dismissal via Removes a toast from =*toasts*~ by identity (~remove~ with default ~:test #'eql~ compares by pointer for CLOS objects). -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp (defun dismiss-toast (toast) (setf *toasts* (remove toast *toasts*))) #+END_SRC @@ -327,7 +327,7 @@ interaction. ** Test package and suite -#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp ;;; dialog-tests.lisp — Tests for cl-tty.dialog (defpackage :cl-tty-dialog-test @@ -343,7 +343,7 @@ interaction. Basic dialog instantiation — verifies ~make-instance~ and accessors. -#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp (def-test dialog-create () (let ((d (make-instance 'dialog :title "Test"))) (is-true (typep d 'dialog)) @@ -354,7 +354,7 @@ Basic dialog instantiation — verifies ~make-instance~ and accessors. ~dialog-size-pixels~ returns the correct dimensions for ~:small~. -#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp (def-test dialog-size-small () (multiple-value-bind (w h) (dialog-size-pixels :small) (is (= 40 w)) @@ -365,7 +365,7 @@ Basic dialog instantiation — verifies ~make-instance~ and accessors. ~dialog-size-pixels~ returns the correct dimensions for ~:medium~. -#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp (def-test dialog-size-medium () (multiple-value-bind (w h) (dialog-size-pixels :medium) (is (= 60 w)) @@ -377,7 +377,7 @@ Basic dialog instantiation — verifies ~make-instance~ and accessors. Verifies stack operations: push adds to =*dialog-stack*~, pop removes the top element. -#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp (def-test dialog-push-pop () (let ((*dialog-stack* nil)) (push-dialog (make-instance 'dialog :title "D1")) @@ -392,7 +392,7 @@ the top element. Verifies that ~toast~ pushes onto =*toasts*~. -#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp (def-test toast-create () (let ((*toasts* nil)) (toast "Hello" :variant :info :duration 0) @@ -403,7 +403,7 @@ Verifies that ~toast~ pushes onto =*toasts*~. Verifies that ~dismiss-toast~ removes the toast from =*toasts*~. -#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp (def-test toast-dismiss () (let ((*toasts* (list (make-instance 'toast :message "T" :variant :info)))) (dismiss-toast (first *toasts*)) diff --git a/org/dirty.org b/org/dirty.org index 60dec8d..00829b6 100644 --- a/org/dirty.org +++ b/org/dirty.org @@ -47,7 +47,7 @@ with ~dirty~ set to ~t~. This is the core invariant of the dirty tracking system — without this, the first render pass would skip new components, making them invisible until something explicitly marked them dirty. -#+BEGIN_SRC lisp :tangle ../src/components/dirty-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty-tests.lisp (in-package :cl-tty-box-test) (in-suite box-suite) @@ -65,7 +65,7 @@ signaling that it is up-to-date and does not need re-render until the next change. Without this, every component would be re-rendered every frame. -#+BEGIN_SRC lisp :tangle ../src/components/dirty-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty-tests.lisp (in-package :cl-tty-box-test) (in-suite box-suite) @@ -83,7 +83,7 @@ re-marked as dirty via ~mark-dirty~. This exercises the full lifecycle: new (dirty) → render (mark-clean) → state change (mark-dirty) → render again. It ensures the dirty flag is not a one-shot toggle. -#+BEGIN_SRC lisp :tangle ../src/components/dirty-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty-tests.lisp (in-package :cl-tty-box-test) (in-suite box-suite) @@ -102,7 +102,7 @@ choice: make this a separate mixin rather than part of the base ~component~ class. This lets non-UI objects (layout nodes, render commands) opt into dirty tracking without inheriting from component. -#+BEGIN_SRC lisp :tangle ../src/components/dirty.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty.lisp (in-package :cl-tty.box) ;; ── Dirty Tracking ───────────────────────────────────────────── @@ -116,7 +116,7 @@ the first render pass doesn't skip them. If this default were ~nil~, new components would be invisible until something explicitly marked them dirty. -#+BEGIN_SRC lisp :tangle ../src/components/dirty.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty.lisp (defgeneric mark-clean (component) (:method ((c dirty-mixin)) (setf (dirty-p c) nil))) @@ -126,7 +126,7 @@ them dirty. method (for non-dirty-mixin components) is a no-op — they have no dirty state to clear. -#+BEGIN_SRC lisp :tangle ../src/components/dirty.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty.lisp (defgeneric mark-dirty (component) (:method ((c dirty-mixin)) (setf (dirty-p c) t))) diff --git a/org/framebuffer.org b/org/framebuffer.org index 2055157..80e9b8b 100644 --- a/org/framebuffer.org +++ b/org/framebuffer.org @@ -188,7 +188,7 @@ framebuffer backend class, constructor, diff/flush utilities, scissor macro, and frame-inspection functions. It depends on ~:cl-tty.backend~ for the ~backend~ base class and protocol methods. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defpackage :cl-tty.rendering (:use :cl :cl-tty.backend) (:export @@ -206,7 +206,7 @@ and frame-inspection functions. It depends on ~:cl-tty.backend~ for the Switch to the ~cl-tty.rendering~ package for all subsequent definitions. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (in-package :cl-tty.rendering) #+END_SRC @@ -218,7 +218,7 @@ compared by value during diffing. All fields have sensible defaults so that ~make-cell~ with no arguments produces a blank space cell. The ~link-url~ slot enables OSC-8 hyperlink support for clickable text. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defstruct cell "A single terminal cell — character, colors, and attributes." (char #\space :type character) @@ -239,7 +239,7 @@ columns. Using ~:initial-element (make-cell)~ ensures every cell is a fresh struct instance (not shared). The ~:element-type~ declaration is a hint for potential optimizations. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun make-framebuffer (width height) "Create a 2D array of CELL with dimensions HEIGHT x WIDTH." (make-array (list height width) @@ -253,13 +253,13 @@ Accessors that return the dimensions of a framebuffer array. These guard against non-array values (returning 0) so that callers don't crash on nil or uninitialized framebuffer slots. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun framebuffer-width (fb) "Return the width (columns) of framebuffer FB." (if (arrayp fb) (array-dimension fb 1) 0)) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun framebuffer-height (fb) "Return the height (rows) of framebuffer FB." (if (arrayp fb) (array-dimension fb 0) 0)) @@ -274,7 +274,7 @@ plus scissor-clipping state. All drawing methods on this backend write to the cell array instead of emitting escape sequences. The scissor coordinates are used by ~%in-scissor-p~ to clip drawing during component rendering. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defclass framebuffer-backend (backend) ((framebuffer :initform nil :accessor fb-framebuffer) (scissor-x :initform 0 :accessor fb-scissor-x) @@ -289,7 +289,7 @@ Constructor that creates a ~framebuffer-backend~ instance and initializes its framebuffer array to the given dimensions (defaulting to 80x24, a common terminal size). -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun make-framebuffer-backend (&key (width 80) (height 24)) "Create a framebuffer-backend with a fresh framebuffer." (let ((fb (make-instance 'framebuffer-backend))) @@ -306,7 +306,7 @@ scissor rectangle. If either scissor dimension is nil (meaning no scissor is set), the corresponding axis check is skipped, effectively treating the entire framebuffer as the drawable area. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun %in-scissor-p (fb cx cy) "Check if (CX, CY) falls within the current scissor rectangle." (let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) @@ -323,7 +323,7 @@ ultimately lands, ensuring consistent clipping behavior across all drawing operations. Only cells within both the framebuffer dimensions and the active scissor rectangle are written. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun %set-cell (fb x y char &key fg bg bold italic underline link-url) "Set cell (X, Y) if within bounds and scissor." (let ((cells (fb-framebuffer fb))) @@ -346,7 +346,7 @@ clipping apply automatically. The ~&allow-other-keys~ permits passing style-related keyword arguments that other backends may use but the framebuffer does not need (e.g., reverse, dim, blink). -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defmethod draw-text ((fb framebuffer-backend) x y string fg bg &key bold italic underline reverse dim blink (link-url nil link-url-p) @@ -365,7 +365,7 @@ Direct rendering onto a raw 2D framebuffer array (the type returned by ~make-framebuffer~). This lets application code call ~draw-text~ directly on a framebuffer without wrapping it in a ~framebuffer-backend~. -#+begin_src lisp :tangle ../src/rendering/framebuffer.lisp +#+begin_src lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defmethod draw-text ((fb array) x y string fg bg &key bold italic underline reverse dim blink &allow-other-keys) @@ -387,7 +387,7 @@ framebuffer without wrapping it in a ~framebuffer-backend~. Allow clearing a raw 2D framebuffer array directly (same type as returned by ~make-framebuffer~). Resets all cells to blank defaults. -#+begin_src lisp :tangle ../src/rendering/framebuffer.lisp +#+begin_src lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defmethod backend-clear ((fb array)) (dotimes (y (array-dimension fb 0)) (dotimes (x (array-dimension fb 1)) @@ -401,7 +401,7 @@ color. This is used for clearing areas and rendering background fills for panels and widgets. Iterates row by row, column by column, using ~%set-cell~ so scissor clipping is respected. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg) (dotimes (row h) (dotimes (col w) @@ -415,7 +415,7 @@ string at the top edge. Supports three border styles: :single, :double, and :rounded, each using different corner and line characters. The title is drawn starting two cells from the left edge, overwriting top-edge characters. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg) (let* ((chars (case style (:single '(#\+ #\- #\|)) @@ -447,7 +447,7 @@ Clears every cell in the framebuffer to a fresh default cell (space, no style). This is the ~backend-clear~ protocol method specialized on ~framebuffer-backend~, providing a full-frame reset used between render passes. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defmethod backend-clear ((fb framebuffer-backend)) (let ((cells (fb-framebuffer fb))) (dotimes (y (framebuffer-height cells)) @@ -464,7 +464,7 @@ stores the URL in the cell's ~link-url~ slot for later retrieval (e.g., on mouse click). The actual OSC-8 escape sequence rendering is deferred to the real backend during flush. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defmethod draw-link ((fb framebuffer-backend) x y string url &key fg bg) ;; OSC 8 links are not rendered in framebuffer — store as text (draw-text fb x y string fg bg :link-url url)) @@ -475,7 +475,7 @@ real backend during flush. Renders a horizontal ellipsis (up to 3 periods) starting at position (X, Y). Width is capped at 3 characters to prevent overflow into adjacent cells. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defmethod draw-ellipsis ((fb framebuffer-backend) x y width &key fg bg) (dotimes (i (min 3 width)) (%set-cell fb (+ x i) y #\. :fg fg :bg bg))) @@ -490,7 +490,7 @@ same visual output. Uses ~eql~ for characters, symbols, and booleans, and ~equal~ for string comparison of ~link-url~. This predicate drives the diff algorithm — only cells that differ are flushed. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun cells-equal-p (a b) "Return T if two cells have identical content and style." (and (eql (cell-char a) (cell-char b)) @@ -509,7 +509,7 @@ framebuffers and collect a list of (X Y CELL) triples for every cell that changed. Using ~nreverse~ at the end ensures stable ordering (top-to-bottom, left-to-right) without consing during accumulation. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun diff-framebuffers (prev curr) "Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes." (let ((changes nil) @@ -533,7 +533,7 @@ minimal cursor movement (tracking the current row to avoid redundant cursor positioning). Returns the count of changed cells so callers can monitor rendering overhead. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun flush-framebuffer (prev-fb curr-fb backend) "Diff PREV-FB and CURR-FB and flush changes to BACKEND. Returns the number of changed cells." @@ -564,7 +564,7 @@ Retrieves the hyperlink URL stored at cell position (X, Y) in a framebuffer array. Returns nil if the cell is out of bounds or has no link. This enables click-to-open-link functionality in the TUI. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun fb-cell-link-url (fb x y) "Return the link URL at (X Y) in framebuffer FB, or nil." (when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0)) @@ -580,7 +580,7 @@ mouse selection and clipboard operations. Normalizes coordinate order (so the user can drag in any direction) and appends newlines between rows for natural multi-line text. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defun extract-text (fb x1 y1 x2 y2) "Extract visible text from the rectangle between (X1,Y1) and (X2,Y2)." (let ((x-min (max 0 (min x1 x2))) (x-max (max 0 (max x1 x2))) @@ -604,7 +604,7 @@ for the duration of BODY. Saves and restores previous scissor state via ~unwind-protect~ for proper cleanup even on non-local exits. Using gensyms for the state variables ensures no variable capture issues. -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp (defmacro with-scissor ((fb x y w h) &body body) "Clip all drawing on FB to rectangle (X Y W H)." (let ((old-x (gensym)) (old-y (gensym)) @@ -632,7 +632,7 @@ Setting up the test package with FiveAM, importing the rendering and backend packages for use in all subsequent tests. This block tangles to the test file that is loaded by the test runner. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (defpackage :cl-tty-framebuffer-test (:use :cl :fiveam :cl-tty.rendering :cl-tty.backend)) (in-package :cl-tty-framebuffer-test) @@ -647,7 +647,7 @@ Verify that the framebuffer constructor produces an array with the expected dimensions. Height should match the first dimension (rows), width the second dimension (columns). -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test make-framebuffer-creates-correct-size (let ((fb (make-framebuffer 80 24))) (is (= 24 (framebuffer-height fb))) @@ -659,7 +659,7 @@ dimension (columns). Cells created via MAKE-CELL with no arguments should default to a space character with nil foreground and background — a blank, unstyled cell. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test cell-defaults-are-space (let ((cell (aref (make-framebuffer 10 10) 0 0))) (is (eql #\space (cell-char cell))) @@ -673,7 +673,7 @@ Drawing a string into the framebuffer backend should set the character and foreground color at each cell position. Characters should appear at the expected (x, y) offsets. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test draw-text-on-fb-sets-cells (let ((fb (make-framebuffer-backend))) (draw-text fb 2 3 "abc" :red nil) @@ -690,7 +690,7 @@ When drawing text that extends past the right edge of the framebuffer, cells beyond the width should remain unchanged (space characters). This prevents buffer overflow and undefined memory access. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test draw-text-clips-at-bounds (let ((fb (make-framebuffer-backend :width 10 :height 5))) (draw-text fb 8 2 "hello" nil nil) @@ -705,7 +705,7 @@ buffer overflow and undefined memory access. Two framebuffers with identical cells should produce no changes. The diff engine must short-circuit when no cells differ. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test diff-identical-fbs-returns-empty (let ((fb1 (make-framebuffer 80 24)) (fb2 (make-framebuffer 80 24))) @@ -717,7 +717,7 @@ engine must short-circuit when no cells differ. After modifying a single cell in one framebuffer, the diff engine should return exactly one change with the correct coordinates and cell data. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test diff-changed-fb-returns-changes (let* ((fb1 (make-framebuffer 10 10)) (fb2 (make-framebuffer 10 10))) @@ -735,7 +735,7 @@ exactly one change with the correct coordinates and cell data. When a scissor rectangle is active, drawing operations outside the rectangle should be clipped away. Operations inside the rectangle should proceed normally. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test with-scissor-clips-drawing (let ((fb (make-framebuffer-backend :width 20 :height 10))) (with-scissor (fb 5 5 3 3) @@ -753,7 +753,7 @@ should be diffed. This test verifies correct behavior at both the smaller and larger end of the size mismatch — ensuring edge cells in the non-overlapping region are ignored. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test flush-different-sized-fbs-handles-edge-cells (let* ((small-fb (make-framebuffer 5 5)) (large-fb (make-framebuffer 10 10)) @@ -775,7 +775,7 @@ region are ignored. After drawing on a framebuffer backend and flushing to a real backend, at least one cell change should be detected and forwarded to the output backend. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test flush-fb-copies-to-backend (let* ((real-be (make-simple-backend :output-stream (make-string-output-stream))) (fb (make-framebuffer-backend))) @@ -789,7 +789,7 @@ one cell change should be detected and forwarded to the output backend. A cell without a hyperlink should return nil from ~fb-cell-link-url~, ensuring the default state is correct and no spurious URL is reported. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test fb-cell-link-url-returns-nil-for-blank-cell (let ((fb (make-framebuffer 10 10))) (is (null (fb-cell-link-url fb 5 5))))) @@ -801,7 +801,7 @@ After drawing text with a link-url, the corresponding cell should return that URL. Cells at other positions should still return nil. This validates that link metadata is stored per-cell and correctly retrievable. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test fb-cell-link-url-finds-link-url (let ((fb (make-framebuffer-backend))) (draw-text fb 0 0 "click" nil nil :link-url "https://example.com") @@ -815,7 +815,7 @@ Querying a cell position outside the framebuffer dimensions should gracefully return nil rather than erroring, which prevents crashes during mouse event processing at the edges of the terminal. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test fb-cell-link-url-out-of-bounds-returns-nil (let ((fb (make-framebuffer 5 5))) (is (null (fb-cell-link-url fb 10 10))))) @@ -827,7 +827,7 @@ Extracting text from a single row of the framebuffer should return the characters in that row as a contiguous string, preserving order and including only visible characters. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test extract-text-single-row (let ((fb (make-framebuffer-backend))) (draw-text fb 0 0 "hello" nil nil) @@ -841,7 +841,7 @@ Extracting text from a rectangle spanning multiple rows should concatenate rows with newline separators. This matches the expected behavior for clipboard copy of rectangular selections in the TUI. -#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp (test extract-text-multi-row (let ((fb (make-framebuffer-backend))) (draw-text fb 0 0 "abc" nil nil) diff --git a/org/integration-tests.org b/org/integration-tests.org index 84be638..5b727c2 100644 --- a/org/integration-tests.org +++ b/org/integration-tests.org @@ -39,7 +39,7 @@ The run-all-tests.lisp loader references this suite by name (~\"INTEGRATION-SUITE\"~) and looks it up via ~find-symbol~ in the package, so the symbol must be interned and accessible. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp ;;; integration-tests.lisp — Full pipeline integration tests for cl-tty ;;; ;;; Composes all major components through the rendering pipeline onto a @@ -75,7 +75,7 @@ The framebuffer stores cells in a 2D array indexed as ~(aref cells y x)~. Cells are structs with a ~cell-char~ slot holding the character. We iterate horizontally and collect each ~cell-char~ into a string. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (defun fb-string (fb x y &optional (len 1)) "Read a string of LEN characters from framebuffer FB starting at (X,Y)." (let* ((cells (fb-framebuffer fb)) @@ -95,7 +95,7 @@ Extracts all rows from the framebuffer as a list of strings. Each row is the full width of the framebuffer converted via ~fb-string~. Optional ~start-row~ and ~end-row~ keywords let callers inspect a sub-region. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (defun fb-lines (fb &key (start-row 0) (end-row nil)) "Extract all lines from framebuffer FB as a list of strings." (let* ((cells (fb-framebuffer fb)) @@ -116,7 +116,7 @@ newlines and runs ~search~. This is the most commonly used assertion helper — it lets tests check for the presence of rendered text without specifying exact coordinates. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (defun fb-contains (fb text) "Return T if framebuffer FB contains TEXT anywhere." (let ((all-text (format nil "~{~a~^~%~}" (fb-lines fb)))) @@ -135,7 +135,7 @@ The title is rendered starting at column 2 of row 1 (just inside the top border). We check ~fb-string~ at those exact coordinates for the title text, and ~fb-contains~ for the border characters. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test box-title-renders-on-fb "A Box with a title draws border and title text on framebuffer." (let* ((fb (make-framebuffer-backend :width 40 :height 10)) @@ -160,7 +160,7 @@ Word-wrap mode ~:word~ preserves word boundaries — it only wraps between words, never in the middle of one. The framebuffer is 20 columns wide, so each row holds roughly 2-3 words. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test text-component-on-fb "Text component renders word-wrapped content on framebuffer." (let* ((fb (make-framebuffer-backend :width 20 :height 6)) @@ -186,7 +186,7 @@ Direct cell access (~aref~ on the framebuffer array) is necessary because the cursor block is a single character that ~fb-contains~ could match ambiguously. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test textinput-value-on-fb "TextInput renders its value and cursor on framebuffer." (let* ((fb (make-framebuffer-backend :width 40 :height 3)) @@ -213,7 +213,7 @@ The placeholder must disappear once a value is set — that behavior is tested indirectly here by verifying the placeholder text appears on an empty input. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test textinput-placeholder-on-fb "TextInput with empty value shows placeholder text." (let* ((fb (make-framebuffer-backend :width 40 :height 3)) @@ -236,7 +236,7 @@ with ~scroll-y=2~ and a viewport height of 8. Lines 1-2 should be scrolled out, while Lines 3-8 should be visible. We check both presence (visible lines) and absence (scrolled-out lines). -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test scrollbox-children-on-fb "ScrollBox renders visible children offset by scroll position." (let* ((fb (make-framebuffer-backend :width 40 :height 10)) @@ -276,7 +276,7 @@ The ~make-select~ function takes a list of plists with ~:title~ and ~:value~ keys. The render method iterates over options and draws each title. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test select-options-on-fb "Select renders option titles on framebuffer." (let* ((fb (make-framebuffer-backend :width 40 :height 10)) @@ -304,7 +304,7 @@ global stack, renders it, and checks for the title and ASCII border characters. The backdrop is a dimming overlay applied across the full framebuffer area. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test dialog-appears-on-fb "Dialog renders a dimmed backdrop and dialog panel with title." (let* ((fb (make-framebuffer-backend :width 80 :height 24)) @@ -331,7 +331,7 @@ verifies that only the top dialog (\"Dialog Two\") renders, then pops it and verifies that \"Dialog One\" appears after clearing and re-rendering. This exercises the full push-pop-render cycle. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test dialog-push-pop-render "Dialog push/pop cycle works with rendering." (let* ((fb (make-framebuffer-backend :width 80 :height 24)) @@ -359,7 +359,7 @@ in the list, verifies the message text appears, and then dismisses it to clean up. The ~duration~ is set to 0 so the toast does not auto-dismiss during the test. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test toast-appears-on-fb "Toast notification renders with colored background." (let* ((fb (make-framebuffer-backend :width 80 :height 24))) @@ -380,7 +380,7 @@ This test creates a simple tree with a single Box, calls appear. This validates that the pipeline dispatches correctly from root through the component hierarchy. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test render-screen-pipeline "render-screen processes a component tree through the full pipeline." (let* ((fb (make-framebuffer-backend :width 40 :height 12)) @@ -410,7 +410,7 @@ Each component is positioned manually via ~layout-node-x~ and ~layout-node-y~ to simulate a composed screen. All components must coexist without overwriting each other's output. -#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp (test full-composition-via-fb "All components compose correctly on a single framebuffer." (let* ((fb (make-framebuffer-backend :width 60 :height 24))) diff --git a/org/layout-engine.org b/org/layout-engine.org index 63ab432..9ea118b 100644 --- a/org/layout-engine.org +++ b/org/layout-engine.org @@ -47,7 +47,7 @@ unnecessary — ~200 lines of CL math suffices. The test package uses ~:fiveam~ for the test framework and imports all exported symbols from ~cl-tty.layout~. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (defpackage :cl-tty-layout-test (:use :cl :fiveam :cl-tty.layout) (:export #:run-tests)) @@ -59,7 +59,7 @@ all exported symbols from ~cl-tty.layout~. ~fiveam~ suites collect related tests under a descriptive name for batch execution. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (def-suite layout-suite :description "Layout engine tests") (in-suite layout-suite) #+END_SRC @@ -69,7 +69,7 @@ batch execution. ~run-tests~ provides a convenient entry point that prints results and exits cleanly for CI or batch runs. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (defun run-tests () (let ((result (run 'layout-suite))) (fiveam:explain! result) @@ -81,7 +81,7 @@ exits cleanly for CI or batch runs. Verify that a node created with no arguments has the correct default direction ~:column~ and is of type ~layout-node~. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test make-layout-node-defaults (let ((n (make-layout-node))) (is (typep n 'layout-node)) @@ -93,7 +93,7 @@ direction ~:column~ and is of type ~layout-node~. Verify that passing ~:direction :row~ produces a node whose direction slot reflects that choice. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test make-layout-node-row (let ((n (make-layout-node :direction :row))) (is (eql (layout-node-direction n) :row)))) @@ -104,7 +104,7 @@ slot reflects that choice. Children must have their ~parent~ back-pointer set when added, and the parent's ~children~ list must contain the child. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test add-child-sets-parent (let ((parent (make-layout-node)) (child (make-layout-node))) (layout-node-add-child parent child) @@ -117,7 +117,7 @@ the parent's ~children~ list must contain the child. Removing a child should clear its parent reference and remove it from the parent's ~children~ list. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test remove-child-clears-parent (let ((parent (make-layout-node)) (child (make-layout-node))) (layout-node-add-child parent child) @@ -131,7 +131,7 @@ from the parent's ~children~ list. In a column layout, children stack top-to-bottom. The first child starts at y=0; the second starts below the first. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test column-two-children-vertical (let* ((root (make-layout-node :direction :column)) (c1 (make-layout-node :height 3)) @@ -147,7 +147,7 @@ starts at y=0; the second starts below the first. In a row layout, children stack left-to-right. The first child starts at x=0; the second starts to the right of the first. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test row-two-children-horizontal (let* ((root (make-layout-node :direction :row)) (c1 (make-layout-node :width 10)) @@ -164,7 +164,7 @@ When children have different ~grow~ values, remaining space is divided in proportion to those values. A child with grow=2 gets twice as much extra space as a child with grow=1. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test flex-grow-distributes-space (let* ((root (make-layout-node :direction :row :width 20)) (c1 (make-layout-node :width 4 :grow 1)) @@ -179,7 +179,7 @@ twice as much extra space as a child with grow=1. A single flexible child with ~grow~ set should expand to fill all available space in the container. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test flex-grow-single-child (let* ((root (make-layout-node :direction :row :width 20)) (c (make-layout-node :width 5 :grow 1))) @@ -193,7 +193,7 @@ available space in the container. When children exceed the container size, each child shrinks in proportion to its ~shrink~ value. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test flex-shrink-reduces-overflow (let* ((root (make-layout-node :direction :row :width 10)) (c1 (make-layout-node :width 8 :shrink 1)) @@ -208,7 +208,7 @@ proportion to its ~shrink~ value. Padding insets the child rendering area. Children are offset by the padding values and sized to the remaining space. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test padding-reduces-content-area (let* ((root (make-layout-node :direction :column :padding '(:top 1 :left 1 :bottom 1 :right 1))) (c (make-layout-node :height 3))) @@ -223,7 +223,7 @@ padding values and sized to the remaining space. The ~gap~ property inserts spacing between consecutive children without adding space before the first or after the last. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test gap-between-children (let* ((root (make-layout-node :direction :column :gap 2)) (c1 (make-layout-node :height 3)) @@ -239,7 +239,7 @@ The ~vbox~ macro creates a column-direction container and adds children in one expression. The second child's y-offset should be the sum of the first child's height plus gap. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test vbox-macro (let ((r (vbox () (make-layout-node :height 3) (make-layout-node :height 5)))) (compute-layout r 20 20) @@ -252,7 +252,7 @@ the sum of the first child's height plus gap. The ~hbox~ macro creates a row-direction container. The second child's x-offset should equal the first child's width. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test hbox-macro (let ((r (hbox () (make-layout-node :width 5) (make-layout-node :width 3)))) (compute-layout r 20 10) @@ -266,7 +266,7 @@ The ~spacer~ macro creates a flexible node that pushes siblings apart. With two fixed-width children and a spacer between them, the spacer absorbs all remaining width. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test spacer-takes-grow (let ((r (hbox (:width 20) (make-layout-node :width 5) (spacer :grow 1) (make-layout-node :width 5)))) (compute-layout r 20 10) @@ -279,7 +279,7 @@ spacer absorbs all remaining width. Nesting a column layout inside a row layout exercises the recursive solver. Sidebar gets fixed width; main content stretches. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test nested-vbox-in-hbox (let* ((sidebar (vbox (:width 5 :height 10) (make-layout-node :height 3) (make-layout-node :height 7))) (main (vbox (:grow 1 :height 10) (make-layout-node :height 2) (make-layout-node :grow 1))) @@ -297,7 +297,7 @@ solver. Sidebar gets fixed width; main content stretches. Layout must gracefully handle containers with no children, returning valid integer dimensions. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test empty-container-does-not-crash (let ((r (make-layout-node))) (compute-layout r 20 20) @@ -310,7 +310,7 @@ valid integer dimensions. A column with one child positions it at the origin and sizes it to its requested height. Width is inherited from the container. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test single-child-in-column (let* ((r (make-layout-node :direction :column :width 10 :height 20)) (c (make-layout-node :height 5))) @@ -325,7 +325,7 @@ its requested height. Width is inherited from the container. When available space is zero, the solver must still produce valid integer coordinates without crashing or producing NaN/infinite values. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test zero-size-container (let* ((r (make-layout-node :direction :column)) (c (make-layout-node :height 5))) @@ -340,7 +340,7 @@ integer coordinates without crashing or producing NaN/infinite values. Three levels of nested vboxes ensure that layout is computed correctly for deeply nested subtrees. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test deep-nesting-three-levels (let* ((out (vbox () (vbox (:grow 1) @@ -356,7 +356,7 @@ correctly for deeply nested subtrees. Substantial padding on all sides should offset children inward by the full padding amount. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test large-padding-leaves-room (let* ((r (make-layout-node :direction :column :padding '(:top 5 :left 5 :bottom 5 :right 5))) @@ -372,7 +372,7 @@ full padding amount. A negative ~grow~ value should not cause layout errors. The solver treats it as zero for distribution purposes and produces valid output. -#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp (test negative-grow-is-clamped (let* ((r (make-layout-node :direction :row :width 10)) (c (make-layout-node :width 5 :grow -1))) @@ -390,7 +390,7 @@ and manipulating layout trees. Internal accessors like ~layout-node-parent~ and helpers like ~normalize-box~ are also exported for testing. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defpackage :cl-tty.layout (:use :cl) (:export @@ -417,7 +417,7 @@ exported for testing. plist. This normalisation layer means users can pass ~:padding 2~ or ~:padding '(:top 1 :left 2)~ interchangeably throughout the API. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defun normalize-box (spec) (cond ((null spec) (list :top 0 :right 0 :bottom 0 :left 0)) ((numberp spec) (list :top spec :right spec :bottom spec :left spec)) @@ -432,7 +432,7 @@ plist. This normalisation layer means users can pass ~:padding 2~ or ~box-edge~ extracts the value for a specific edge keyword from a canonical box plist, defaulting to zero if the key is not present. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defun box-edge (box edge) (or (getf box edge) 0)) #+END_SRC @@ -446,7 +446,7 @@ and input constraints (~direction~, ~grow~, ~shrink~, ~padding~, ~margin~, ~gap~, ~position-type~, ~position-offset~, ~fixed-width~, ~fixed-height~). -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defclass layout-node () ((parent :initform nil :accessor layout-node-parent) (children :initform nil :accessor layout-node-children) @@ -472,7 +472,7 @@ and input constraints (~direction~, ~grow~, ~shrink~, ~padding~, keyword arguments through ~normalize-box~ for padding/margin, fills defaults for missing values, and delegates to ~make-instance~. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defun make-layout-node (&key direction grow shrink padding margin gap position-type position-offset width height) (make-instance 'layout-node @@ -493,7 +493,7 @@ defaults for missing values, and delegates to ~make-instance~. child's parent back-pointer and appending to the parent's children list. Returns the child for convenience in chaining or ~let~ forms. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defun layout-node-add-child (parent child) (setf (layout-node-parent child) parent) (setf (layout-node-children parent) @@ -507,7 +507,7 @@ list. Returns the child for convenience in chaining or ~let~ forms. back-pointer and removing it from the parent's children list. Returns the child. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defun layout-node-remove-child (parent child) (setf (layout-node-parent child) nil) (setf (layout-node-children parent) @@ -524,7 +524,7 @@ gap. Each child starts from its fixed size. Remaining space is distributed by grow ratio; overflow is reduced by shrink ratio. Rounding errors are amortized across the first N children. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defun distribute-sizes (children avail gap horizontal) (let* ((n (length children)) (gap-total (* gap (max 0 (1- n)))) @@ -563,7 +563,7 @@ within given dimensions. It positions each child at the correct inner ~labels~ form ~place-children~ handles the recursive descent, adjusting for padding and direction at each level. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defun compute-layout (root available-width available-height) (labels ((place-children (node x y max-w max-h) (let* ((children (layout-node-children node)) @@ -628,7 +628,7 @@ adjusting for padding and direction at each level. properties and adds all children via ~layout-node-add-child~. The ~gensym~ ensures no variable capture in the expansion. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defmacro vbox ((&key grow shrink padding margin gap width height) &body children) (let ((n (gensym))) `(let ((,n (make-layout-node :direction :column @@ -648,7 +648,7 @@ properties and adds all children via ~layout-node-add-child~. The ~hbox~ creates a row-direction container, structurally identical to ~vbox~ except the ~:direction~ is ~:row~. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defmacro hbox ((&key grow shrink padding margin gap width height) &body children) (let ((n (gensym))) `(let ((,n (make-layout-node :direction :row @@ -668,7 +668,7 @@ properties and adds all children via ~layout-node-add-child~. The ~spacer~ creates a minimal flex-grow node that fills remaining space, defaulting to ~grow 1~ when no keyword is given. -#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp (defmacro spacer (&key grow) `(make-layout-node :grow ,(or grow 1))) #+END_SRC diff --git a/org/markdown-renderer.org b/org/markdown-renderer.org index bfbdc75..b144bd7 100644 --- a/org/markdown-renderer.org +++ b/org/markdown-renderer.org @@ -11,7 +11,7 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package. ** Package -#+BEGIN_SRC lisp :tangle ../src/components/markdown-package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown-package.lisp (defpackage :cl-tty.markdown (:use :cl) (:export @@ -30,7 +30,7 @@ comment indicating the file's purpose. This block is the first to target ~markdown.lisp~ and thus overwrites any previous content; all subsequent blocks append. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp ;;; markdown.lisp — Markdown + Code + Diff rendering for cl-tty (in-package :cl-tty.markdown) @@ -51,7 +51,7 @@ symbol and optional keyword arguments for ~children~, ~properties~, ~content~, and ~url~. Only non-nil slots are stored, keeping the plist compact. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun make-md-node (type &key children properties content url) (let ((node (list :type type))) (when children (setf (getf node :children) children)) @@ -67,7 +67,7 @@ Predicate that checks whether a value is an AST node by verifying it is a list and has a ~:type~ property. This uses plist access which bypasses the need for ~typep~ or class-based dispatch. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun md-node-p (thing) (and (listp thing) (getf thing :type))) #+END_SRC @@ -80,7 +80,7 @@ node tree. The ~:link~ type formats as ~text (url)~; ~:text~ and concatenate their children's text. This is useful for summarisation and testing. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun md-node-text (node) (let ((type (getf node :type))) (cond ((eql type :text) (or (getf node :content) "")) @@ -107,7 +107,7 @@ Handles ~CRLF~, ~LF~, and missing trailing newline uniformly. Returns a ~vector~ for fast indexed access by line number during parsing. Returns an empty vector for ~nil~ input. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun split-string-into-lines (string) (unless string (return-from split-string-into-lines (coerce nil 'vector))) (let ((result nil) (start 0)) @@ -130,7 +130,7 @@ markers, unordered/ordered list items, diff headers, diff lines, and fenced code-block starts — and returns a ~(cons type data)~ pair. Everything else is treated as a paragraph continuation line. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun classify-line (line) (cond ((string= line "") (cons :blank nil)) @@ -188,7 +188,7 @@ Scans for a literal marker string starting from position ~start~, escaping backslash-escaped markers. This is shared by inline emphasis, code span, and link parsing. Returns the position or ~nil~. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun find-closing-marker (text start marker) (let ((marker-len (length marker)) (len (length text))) (loop for j from start to (- len marker-len) @@ -206,7 +206,7 @@ into a single ~:paragraph~ node. Stops at a blank line or any non-paragraph classification. Lines are joined with spaces before inline parsing. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-paragraph (lines start) (let ((text-parts nil) (i start)) (loop while (< i (length lines)) @@ -233,7 +233,7 @@ Like ~parse-paragraph~ but collects ~:blockquote~ lines and strips the leading ~>~ marker. The collected text is then inline-parsed to support bold, italic, code, and links inside quotes. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-blockquote (lines start) (let ((text-parts nil) (i start)) (loop while (< i (length lines)) @@ -262,7 +262,7 @@ loose lists), but a blank line followed by a non-list line terminates the list. Returns multiple nodes because each top-level list item becomes its own ~:list-item~ or ~:ordered-item~ node. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-list (lines start) (let ((items nil) (i start)) (loop while (< i (length lines)) @@ -297,7 +297,7 @@ match in character and be at least as long. The language (if any) is taken from the info string on the opening fence. Produces a single ~:code-block~ node. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-code-block (lines start lang) (let ((code-lines nil) (i (1+ start)) @@ -333,7 +333,7 @@ single ~:diff-block~ node. The raw lines are preserved in a ~:lines~ property for coloured rendering later. Diff blocks are delimited by blank lines. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-diff-block (lines start) (let ((diff-lines nil) (i start)) (loop while (< i (length lines)) @@ -363,7 +363,7 @@ Handles blank lines, thematic breaks, headings, paragraphs, blockquotes, lists, code blocks, and diff blocks. Returns ~nil~ for ~nil~ input. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-blocks (text) (unless text (return-from parse-blocks nil)) (let ((lines (split-string-into-lines text)) (nodes nil) (i 0)) @@ -416,7 +416,7 @@ triggers inline code; ~[~ triggers links; everything else is accumulated as plain ~:text~ nodes. Consecutive plain text is merged into single nodes for efficiency. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-inline (text) (unless (and text (> (length text) 0)) (return-from parse-inline nil)) (let ((nodes nil) (i 0) (len (length text))) @@ -462,7 +462,7 @@ node, otherwise it falls back to single-star ~:italic~. If neither closes, returns ~nil~ to let the caller treat the character as literal text. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-star-emphasis (text i len) (when (>= i len) (return-from parse-star-emphasis (values nil i))) (if (and (< (1+ i) len) (char= (char text (1+ i)) #\*)) @@ -486,7 +486,7 @@ opens after whitespace or at the start of text, and single-underscore italic only closes before whitespace or punctuation. This avoids false positives in identifiers like ~foo_bar~. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-underscore-emphasis (text i len) (when (>= i len) (return-from parse-underscore-emphasis (values nil i))) (when (and (> i 0) (not (find (char text (1- i)) " \t\n\r"))) @@ -512,7 +512,7 @@ Parses backtick-delimited inline code spans. Supports up to three backticks as delimiters (so single backticks inside double-backtick spans work). The matched pair's backtick count must be equal. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-inline-code (text i len) (when (or (>= i len) (not (char= (char text i) #\`))) (return-from parse-inline-code (values nil i))) @@ -534,7 +534,7 @@ matching via ~find-closing-marker~. The text portion is inline-parsed to support formatting inside link text. Returns ~nil~ if the syntax is incomplete, letting the caller render the ~[~ as literal text. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun parse-link (text i len) (when (or (>= i len) (not (char= (char text i) #\[))) (return-from parse-link (values nil i))) @@ -568,7 +568,7 @@ the caller to fall back to plain rendering. The assoc list uses ~string=~ for matching on the language tag, and each entry uses a dotted-pair format ~(\"language\" . plist)~. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun get-highlighter (lang) (cdr (assoc lang '(("lisp" . (:comment (";" "#|" ";;") :string ("\"") @@ -665,7 +665,7 @@ provides the patterns for comment delimiters, string delimiters, keywords, and builtins. Words immediately followed by ~(~ are classified as ~:function~ calls. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun tokenize-line (line highlighter) (let ((tokens nil) (i 0) (len (length line)) (comment-chars (getf highlighter :comment)) @@ -742,7 +742,7 @@ returns a flat list of ~(token . category)~ pairs with newline separators between lines. Returns ~nil~ for empty input or a single ~:plain~ pair if no highlighter is found for the language. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun highlight-code (code language) (unless code (return-from highlight-code nil)) (let ((highlighter (get-highlighter (and language (string-downcase language))))) @@ -763,7 +763,7 @@ category. Keywords get colour 33 (yellow), builtins 36 (cyan), functions 34 (blue), comments 2 (dim), strings 32 (green), numbers 35 (magenta). Unrecognised categories render as plain text. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun apply-highlight-token (token category) (let ((code (case category (:keyword "33") (:builtin "36") @@ -778,7 +778,7 @@ Coerces an adjustable character vector (accumulated during line rendering) back into a string. This is a thin wrapper that exists for potential future customisation of style application. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun apply-highlight-style (char-vector) (coerce char-vector 'string)) #+END_SRC @@ -793,7 +793,7 @@ colourised output. Utility predicate that checks whether ~string~ starts with ~prefix~. Avoids reimplementing this inline in multiple diff classifiers. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun string-prefix-p (prefix string) (and (>= (length string) (length prefix)) (string= prefix (subseq string 0 (length prefix))))) @@ -806,7 +806,7 @@ Classifies a single diff line into a semantic category: ~:file-header~ (for ~+~ lines), ~:removed~ (for ~-~ lines), or ~:context~ (for everything else). This powers colourised diff rendering. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun classify-diff-line (line) (cond ((string-prefix-p "+++ " line) :file-header) ((string-prefix-p "--- " line) :file-header) @@ -830,7 +830,7 @@ string. Supports both keyword (e.g. ~:bold~) and string (e.g. bold, italic, dim, code, link, underline, and the full set of 16 terminal colours. Unrecognised styles return the text unchanged. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun apply-style (style text) (let ((code (cond ((eql style :bold) "1") ((eql style :italic) "3") @@ -870,7 +870,7 @@ Renders a list of inline child nodes into a single string. Handles types. Links render the text styled as link followed by the URL in parentheses styled as url. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-inline (children) (if (null children) "" (with-output-to-string (s) @@ -897,7 +897,7 @@ level determines the number of ~#~ characters (capped at 6) and the colour: level 1 uses bright-cyan, level 2 uses bright-yellow, and deeper levels use bright-white. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-heading (node) (let* ((level (or (getf (getf node :properties) :level) 1)) (prefix (make-string (min level 6) :initial-element #\#)) @@ -912,7 +912,7 @@ deeper levels use bright-white. Renders a paragraph node by inline-rendering its children. The result is a single-element list containing the rendered text. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-paragraph (node) (list (render-inline (getf node :children)))) #+END_SRC @@ -922,7 +922,7 @@ result is a single-element list containing the rendered text. Renders a blockquote node with a dimmed ~> ~ prefix before the inline-rendered content. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-blockquote (node) (list (apply-style :dim (concatenate 'string "> " (render-inline (getf node :children)))))) #+END_SRC @@ -934,7 +934,7 @@ highlighter supports it, the code is syntax-highlighted with ANSI colours. Otherwise it is rendered in plain ~:code~ style. A dimmed language header line is shown when a language is present. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-code-block (node) (let* ((language (or (getf (getf node :properties) :language) "")) (content (or (getf node :content) "")) @@ -971,7 +971,7 @@ colour: added lines in green (32), removed in red (31), hunk headers in cyan (36), file headers in bold-cyan (1;36), and context lines unstyled. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-diff-block (node) (let* ((lines (getf (getf node :properties) :lines)) (result nil)) (dolist (line (or lines @@ -993,7 +993,7 @@ unstyled. Renders a thematic break as a dimmed horizontal rule using Unicode box-drawing characters. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-thematic-break (node) (declare (ignore node)) (list (apply-style :dim "──────────────────────────────────────────────"))) @@ -1004,7 +1004,7 @@ Unicode box-drawing characters. Renders a list item node. Ordered items get ~ 1.~ prefix, unordered items get ~ * ~ prefix. The content is inline-rendered. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-list-item (node) (list (concatenate 'string (if (eql (getf node :type) :ordered-item) " 1." " * ") @@ -1017,7 +1017,7 @@ Dispatcher function that routes a single AST node to the correct renderer based on its ~:type~. Each type-specific renderer returns a list of strings (multiple lines), which ~render-md~ concatenates. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-md-node (node) (let ((type (getf node :type))) (case type @@ -1038,7 +1038,7 @@ Renders a list of AST nodes (the output of ~parse-blocks~) into a flat list of output lines by calling ~render-md-node~ on each node and concatenating the results. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-md (nodes) (let ((lines nil)) (dolist (node nodes) (setf lines (nconc lines (render-md-node node)))) @@ -1051,7 +1051,7 @@ Top-level convenience function that parses a Markdown string and renders it to a single output string with newline-separated lines. Returns an empty string for ~nil~ input. -#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp (defun render-markdown (text) (unless text (return-from render-markdown "")) (let ((nodes (parse-blocks text)) (parts nil)) @@ -1077,7 +1077,7 @@ This block must be first because ~tests/markdown-tests.lisp~ does not exist yet — the tangle script creates it by writing this block's content. All later blocks append. -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp ;;; markdown-tests.lisp — Tests for cl-tty.markdown (defpackage :cl-tty-markdown-test @@ -1098,7 +1098,7 @@ Edge cases guard against crashes on ~nil~ input, very long lines, blank-only input, and unclosed fenced blocks. These come first because they exercise the defensive gate checks at the top of each parsing function. -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp ;; ─── Parser edge cases ───────────────────────────────────────── @@ -1183,7 +1183,7 @@ defensive gate checks at the top of each parsing function. ATX headings from level 1 through 6, including headings with inline formatting inside the heading text. -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp ;; ─── Parser tests ───────────────────────────────────────────────────────────── @@ -1215,7 +1215,7 @@ formatting inside the heading text. Single-line and multi-line paragraphs. Multi-line paragraphs are joined with spaces before inline parsing. -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp (def-test paragraph-parsing ( ) (let* ((result (parse-blocks "This is a paragraph.")) (node (first result))) @@ -1231,7 +1231,7 @@ with spaces before inline parsing. Bold, italic, combined bold+italic, inline code, and link parsing. Each test verifies both structure (node types) and content (text/url values). -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp (def-test bold-parsing ( ) (let* ((children (parse-inline "hello **world** here")) @@ -1275,7 +1275,7 @@ test verifies both structure (node types) and content (text/url values). Fenced code blocks with and without a language annotation. Verifies the presence/absence of the ~:language~ property on the resulting node. -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp (def-test code-block-parsing ( ) (let* ((lines '("```lisp" "(defun hello ())" " (print \"hi\")" "```")) @@ -1299,7 +1299,7 @@ Verifies that blockquote markers, unordered list items, ordered list items, and thematic breaks (---) are correctly classified and produce the expected node types. -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp (def-test blockquote-parsing ( ) (let* ((result (parse-blocks "> This is a quote")) (node (first result))) @@ -1323,7 +1323,7 @@ the expected node types. Tests ~classify-diff-line~ with each diff line variant: added (+), removed (-), hunk header (@@), and context (neither). -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp ;; ─── Diff tests ─────────────────────────────────────────────────────────────── @@ -1346,7 +1346,7 @@ Verifies that ~highlight-code~ returns categorised tokens for Lisp keywords, builtins, comments, and falls back to plain tokens for unknown languages. -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp ;; ─── Syntax highlighting tests ──────────────────────────────────────────────── (def-test highlight-lisp-keyword ( ) @@ -1377,7 +1377,7 @@ Verifies that each node type produces output via ~render-md-node~. Heading, paragraph, thematic-break, code-block, and diff-block are all exercised to ensure the render dispatcher routes correctly. -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp ;; ─── Render tests ───────────────────────────────────────────────────────────── @@ -1422,7 +1422,7 @@ A full parse-and-render integration test exercises the pipeline end-to-end. The ~md-node-text~ utility tests verify both simple and nested node traversal. -#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp ;; ─── Integration tests ──────────────────────────────────────────────────────── diff --git a/org/modern-backend.org b/org/modern-backend.org index 01c54bc..d1c8889 100644 --- a/org/modern-backend.org +++ b/org/modern-backend.org @@ -53,7 +53,7 @@ covers one logical behavior. The test package uses =cl-tty.backend= to access internal symbols for white-box testing of escape generation. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (defpackage :cl-tty-modern-backend-test (:use :cl :fiveam :cl-tty.backend) (:export #:run-tests)) @@ -64,7 +64,7 @@ white-box testing of escape generation. A single suite groups all modern backend tests. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (def-suite modern-backend-suite :description "Modern backend tests") (in-suite modern-backend-suite) #+END_SRC @@ -73,7 +73,7 @@ A single suite groups all modern backend tests. The =run-tests= entry point is called by the CI test harness. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (defun run-tests () (let ((result (run 'modern-backend-suite))) (fiveam:explain! result) @@ -85,7 +85,7 @@ The =run-tests= entry point is called by the CI test harness. Verifies that =make-modern-backend= returns an instance of the correct class. This is the most basic smoke test for the backend factory. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test make-modern-backend-creates "make-modern-backend returns a modern-backend instance" (let ((b (make-modern-backend))) @@ -97,7 +97,7 @@ class. This is the most basic smoke test for the backend factory. Ensures a 6-digit hex string produces the correct 24-bit foreground escape sequence with red, green, and blue components in the right order. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test sgr-truecolor-foreground "SGR truecolor foreground escape is correct" (is (equal (cl-tty.backend::sgr-fg "#FFD700") @@ -108,7 +108,7 @@ escape sequence with red, green, and blue components in the right order. Same as foreground but uses the =48= background prefix instead of =38=. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test sgr-truecolor-background "SGR truecolor background escape is correct" (is (equal (cl-tty.backend::sgr-bg "#1a1b26") @@ -120,7 +120,7 @@ Same as foreground but uses the =48= background prefix instead of =38=. Verifies that keyword symbols like =:red= and =:blue= resolve to the standard 8-color SGR codes (=31= foreground, =44= background). -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test sgr-named-colors "SGR named colors resolve to 8-color codes" (is (equal (cl-tty.backend::sgr-fg :red) @@ -134,7 +134,7 @@ standard 8-color SGR codes (=31= foreground, =44= background). Each attribute keyword (=:bold=, =:italic=, =:underline=, =:reset=) should map to the correct SGR number. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test sgr-bold-italic "SGR attribute escapes are correct" (is (equal (cl-tty.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc))) @@ -148,7 +148,7 @@ should map to the correct SGR number. Verifies that =cursor-move-escape= produces a CSI =H= sequence with 1-indexed row and column. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test cursor-move-escape "cursor-move generates correct CSI escape" (let ((b (make-modern-backend))) @@ -160,7 +160,7 @@ Verifies that =cursor-move-escape= produces a CSI =H= sequence with Verifies the DECSTR escape for a block cursor without blinking (code 2). -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test cursor-style-block "cursor-style :block generate correct escape" (let ((b (make-modern-backend))) @@ -172,7 +172,7 @@ Verifies the DECSTR escape for a block cursor without blinking (code 2). Verifies the DECSTR escape for a bar cursor without blinking (code 6). -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test cursor-style-bar "cursor-style :bar generate correct escape" (let ((b (make-modern-backend))) @@ -185,7 +185,7 @@ Verifies the DECSTR escape for a bar cursor without blinking (code 6). Verifies that =:underline= with =blink=t= produces code 5 (underline blinking), which is base 4 + blink offset 1. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test cursor-style-underline-blink "cursor-style :underline with blink" (let ((b (make-modern-backend))) @@ -198,7 +198,7 @@ blinking), which is base 4 + blink offset 1. Confirms that =decicm-begin= and =decicm-end= produce =?2026h= and =?2026l= respectively. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test decicm-escapes "DECICM synchronized update escapes" (is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc))) @@ -211,7 +211,7 @@ Verifies the full OSC 8 wrapping: opening sequence with URL, the text, and the closing sequence. The FORMAT string uses ~~ for literal tilde and ~\\ for literal backslash. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test osc8-escape "OSC 8 hyperlink escape wraps text" (is (equal (cl-tty.backend::osc8-link "http://example.com" "click here") @@ -223,7 +223,7 @@ and ~\\ for literal backslash. Verifies that ="#FFD700"= parses to (255, 215, 0). -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test hex-color-parsing "hex-to-rgb parses valid hex colors" (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#FFD700") @@ -236,7 +236,7 @@ Verifies that ="#FFD700"= parses to (255, 215, 0). Verifies all-zero parsing. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test hex-color-black "hex-to-rgb parses black" (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#000000") @@ -249,7 +249,7 @@ Verifies all-zero parsing. Verifies that ="#F00"= expands to ="#FF0000"= = (255, 0, 0). -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test hex-color-short-form "hex-to-rgb parses 3-digit hex" (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#F00") @@ -263,7 +263,7 @@ Verifies that ="#F00"= expands to ="#FF0000"= = (255, 0, 0). Confirms that =:rounded= style maps to the Unicode box-drawing characters for the four corners and edges. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test border-char-rounded "modern-border-char returns Unicode box-drawing for rounded style" (is (equal (cl-tty.backend::border-char :rounded :top-left) "╭")) @@ -276,7 +276,7 @@ characters for the four corners and edges. Confirms that =:double= style maps to double-line box-drawing characters. -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test border-char-double "modern-border-char returns double-line chars" (is (equal (cl-tty.backend::border-char :double :top-left) "╔")) @@ -289,7 +289,7 @@ Confirms that =:double= style maps to double-line box-drawing characters. Verifies that suspend-backend and resume-backend are no-ops when called on a backend not attached to a real terminal (no errors, return nil). -#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp (test suspend-resume-noop "suspend-backend and resume-backend are no-ops in test context" (let ((b (make-modern-backend))) @@ -307,7 +307,7 @@ on a backend not attached to a real terminal (no errors, return nil). both 6-digit (fully specified) and 3-digit (shorthand) formats. The 3-digit form expands each hexit by duplicating it (=#F00= => =#FF0000=). -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (in-package :cl-tty.backend) (defun hex-to-rgb (hex) @@ -331,7 +331,7 @@ Maps keyword color names to 8-color SGR index values. Used as the primary lookup in =sgr-fg= and =sgr-bg= before falling back to the theme colors hash table. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defparameter *named-colors* '((:black . 0) (:red . 1) (:green . 2) (:yellow . 3) (:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7))) @@ -344,7 +344,7 @@ Populated by the theme system's =load-preset=. When a keyword is not in =*named-colors*=, =sgr-fg= and =sgr-bg= consult this table as a fallback, enabling user themes to define custom color roles. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defvar *theme-colors* (make-hash-table :test 'eq) "Hash table mapping theme keywords to hex color strings. Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg @@ -357,7 +357,7 @@ as a fallback when a keyword is not in *named-colors*.") hex string => named color => semantic theme role => empty string if unresolved. Truecolor uses =38;2;R;G;B=, named colors use =3n=. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun sgr-fg (color) "Return SGR foreground escape for COLOR." (if (null color) "" @@ -381,7 +381,7 @@ unresolved. Truecolor uses =38;2;R;G;B=, named colors use =3n=. ~sgr-bg~ produces the SGR background escape. Same resolution chain as =sgr-fg= but uses =48;2;R;G;B= for truecolor and =4n= for named colors. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun sgr-bg (color) "Return SGR background escape for COLOR." (if (null color) "" @@ -405,7 +405,7 @@ unresolved. Truecolor uses =38;2;R;G;B=, named colors use =3n=. Maps attribute keywords to SGR parameter numbers. Covers bold, dim, italic, underline, blink, reverse video, and reset. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defparameter *sgr-attr-codes* '((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4) (:blink . 5) (:reverse . 7) (:reset . 0))) @@ -416,7 +416,7 @@ italic, underline, blink, reverse video, and reset. ~sgr-attr~ looks up the keyword in =*sgr-attr-codes*= and produces the matching SGR escape. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun sgr-attr (attr) "Return SGR attribute escape for ATTR keyword." (let ((code (cdr (assoc attr *sgr-attr-codes*)))) @@ -432,7 +432,7 @@ matching SGR escape. Produces a CSI =H= (CUP) sequence to position the cursor. Coordinates are 1-indexed: =cursor-move-escape 0 0= moves to row 1, column 1. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun cursor-move-escape (x y) "Return CSI escape to move cursor to (x, y), 1-indexed." (format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x))) @@ -444,7 +444,7 @@ Produces a DECSTR sequence (=CSI Ps q=) to set the cursor shape. Base codes: block=2, underline=4, bar=6. When =blink= is true the code is incremented by 1 (e.g. blinking block = code 3). -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun cursor-style-escape (shape blink) "Return DECSTR escape for cursor shape." (let* ((base (case shape @@ -462,7 +462,7 @@ Enables DEC private mode 2026 (synchronized updates). All output between =begin= and =end= is buffered by the terminal and rendered atomically. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun decicm-begin () "Return escape to enable synchronized updates." (format nil "~C[?2026h" #\Esc)) @@ -473,7 +473,7 @@ atomically. Disables DEC private mode 2026, flushing the buffered frame to the display. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun decicm-end () "Return escape to disable synchronized updates." (format nil "~C[?2026l" #\Esc)) @@ -485,7 +485,7 @@ Wraps text in an OSC 8 hyperlink. The opening sequence carries the URL, the closing sequence (=ESC]8;;ESC\)=) terminates the link. This allows clickable text in terminals that support the protocol. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun osc8-link (url text) "Wrap TEXT in an OSC 8 hyperlink to URL." (format nil "~C]8;;~A~C\\~A~C]8;;~C\\" @@ -500,7 +500,7 @@ Lookup alist mapping =(style position)= pairs to Unicode box-drawing characters. Covers single, double, and rounded styles with all four corners plus horizontal and vertical connectors. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defparameter *border-chars* '(((:single :top-left) . "┌") ((:single :top-right) . "┐") ((:single :bottom-left) . "└") ((:single :bottom-right) . "┘") @@ -520,7 +520,7 @@ horizontal/vertical lines (=U+2500=, =U+2502=) if the style is unknown for edge positions, or =+= for corners --- ensuring the UI never shows a blank gap. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun border-char (style pos) "Return the Unicode box-drawing character for STYLE at POS." (let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal)))) @@ -537,7 +537,7 @@ Subclasses the abstract =backend= class. =output-stream= is where escape sequences are written; =in-sync-p= tracks whether we are inside a DECICM synchronized update block. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defclass modern-backend (backend) ((output-stream :initform *standard-output* :initarg :output-stream @@ -552,7 +552,7 @@ optional =output-stream=; defaults to =*standard-output*=. The =color-palette= argument is ignored in favor of the dynamic =*theme-colors*= hash table. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defun make-modern-backend (&key color-palette output-stream) (declare (ignore color-palette)) (make-instance 'modern-backend :output-stream (or output-stream *standard-output*))) @@ -567,7 +567,7 @@ drag + SGR), bracketed paste mode, and the Kitty keyboard protocol. Hides the cursor and flushes the stream. Returns the backend instance for chaining. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod initialize-backend ((b modern-backend)) (backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen (backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic @@ -586,7 +586,7 @@ Restores the terminal: shows the cursor, disables the Kitty keyboard protocol, bracketed paste, SGR mouse, drag, basic mouse, and finally leaves the alternate screen. Returns =nil= (via =(values)=). -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod shutdown-backend ((b modern-backend)) (cursor-show b) (backend-write b (format nil "~C[?u" #\Esc)) @@ -611,7 +611,7 @@ kitty keyboard — those would add ~100ms of overhead on every suspend/resume cycle and are harmless while suspended (the terminal just ignores the escape sequences). -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod suspend-backend ((b modern-backend)) (cursor-show b) (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen @@ -629,7 +629,7 @@ Re-enters the alternate screen buffer and re-enables all input features (mouse, bracketed paste, kitty keyboard). The application is responsible for redrawing the full screen after resume. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod resume-backend ((b modern-backend)) (backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen (backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic @@ -649,7 +649,7 @@ is responsible for redrawing the full screen after resume. Uses ioctl (TIOCGWINSZ = 21523) to query actual terminal dimensions from the kernel, with a ~/dev/tty~ fallback and 80x24 last resort. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod backend-size ((b modern-backend)) ;; Try ioctl on stdout, fall back to /dev/tty, then 80x24. ;; Each arm uses multiple-value-bind/values to preserve both cols and rows @@ -695,7 +695,7 @@ caller is responsible for calling ~finish-output~ at appropriate sync points (frame boundaries via ~end-sync~, initialization, shutdown). Returns the string length for protocol compatibility. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod backend-write ((b modern-backend) string) (let ((stream (backend-output-stream b))) (write-string string stream) @@ -708,7 +708,7 @@ Advertises which features this backend supports. =modern-backend= supports truecolor, OSC 8 hyperlinks, DECICM sync, SGR mouse, bracketed paste, cursor style control, and the Kitty keyboard protocol. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod capable-p ((b modern-backend) feature) (member feature '(:truecolor :osc8 :sync :mouse :bracketed-paste :cursor-style @@ -724,7 +724,7 @@ itself, and a reset into a single concatenated string. Minimizes output calls --- one =backend-write= per draw operation --- by packing everything into one buffer. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod draw-text ((b modern-backend) x y string fg bg &key bold italic underline reverse dim blink &allow-other-keys) @@ -748,7 +748,7 @@ title, repeated mid sections, bottom) and writes them with minimal output calls. The title can be left-aligned or centered within the top border line. Uses the border character lookup for the chosen style. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod draw-border ((b modern-backend) x y width height &key style fg bg title title-align) (let* ((s (or style :single)) @@ -810,7 +810,7 @@ the cursor and writes a filled line. This is simpler than =draw-border= because it has no border characters --- just spaces with a background color. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod draw-rect ((b modern-backend) x y width height &key bg) (let* ((bg-esc (sgr-bg bg)) (reset (sgr-attr :reset)) @@ -830,7 +830,7 @@ positioning, optional fg/bg colors, the OSC 8 link wrapper around the text, and a reset. This lets the user click the text to open the URL in terminals that support OSC 8. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod draw-link ((b modern-backend) x y string url &key fg bg) (let ((parts (list (cursor-move-escape x y) @@ -846,7 +846,7 @@ Draws a three-dot ellipsis at the given position. The =width= parameter is ignored since dots have a fixed visual length; delegates to =draw-text= for uniform rendering. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod draw-ellipsis ((b modern-backend) x y width &key fg bg) (declare (ignore width)) @@ -861,7 +861,7 @@ is ignored since dots have a fixed visual length; delegates to Delegates to =cursor-move-escape= and writes the resulting CSI sequence to the output stream. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod cursor-move ((b modern-backend) x y) (backend-write b (cursor-move-escape x y))) #+END_SRC @@ -870,7 +870,7 @@ to the output stream. Sends the DECTCEM private mode =?25l= to hide the cursor. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod cursor-hide ((b modern-backend)) (backend-write b (format nil "~C[?25l" #\Esc))) #+END_SRC @@ -879,7 +879,7 @@ Sends the DECTCEM private mode =?25l= to hide the cursor. Sends =?25h= to restore the cursor visibility. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod cursor-show ((b modern-backend)) (backend-write b (format nil "~C[?25h" #\Esc))) #+END_SRC @@ -889,7 +889,7 @@ Sends =?25h= to restore the cursor visibility. Sets the cursor shape (block/underline/bar, optionally blinking) by delegating to =cursor-style-escape=. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod cursor-style ((b modern-backend) shape &key blink) (backend-write b (cursor-style-escape shape blink))) #+END_SRC @@ -900,7 +900,7 @@ Enables basic mouse tracking, button-event tracking (drag), and SGR extended mouse mode. These three modes together give full mouse support while staying compatible with modern terminal emulators. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod enable-mouse ((b modern-backend)) (backend-write b (format nil "~C[?1000h" #\Esc)) (backend-write b (format nil "~C[?1002h" #\Esc)) @@ -914,7 +914,7 @@ Enables bracketed paste mode, where the terminal wraps pasted text in =ESC[200~= and =ESC[201~= delimiters. This allows the application to distinguish user input from pasted content. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod enable-bracketed-paste ((b modern-backend)) (backend-write b (format nil "~C[?2004h" #\Esc)) (finish-output (backend-output-stream b))) @@ -925,7 +925,7 @@ distinguish user input from pasted content. Begins a synchronized update frame using DECICM. Sets the =in-sync-p= slot so other methods can check whether we are inside a sync block. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod begin-sync ((b modern-backend)) (setf (in-sync-p b) t) (backend-write b (decicm-begin))) @@ -936,7 +936,7 @@ slot so other methods can check whether we are inside a sync block. Ends the synchronized update frame and flushes the output, causing the terminal to render the buffered changes atomically. -#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp (defmethod end-sync ((b modern-backend)) (setf (in-sync-p b) nil) (backend-write b (decicm-end)) diff --git a/org/mouse.org b/org/mouse.org index 741ccaf..923a321 100644 --- a/org/mouse.org +++ b/org/mouse.org @@ -32,7 +32,7 @@ implementation. It re-exports the public API symbols that consumers (~cl-tty.core~, user applications) rely on without pulling in implementation details. -#+BEGIN_SRC lisp :tangle ../src/components/mouse-package.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse-package.lisp :noweb no (defpackage :cl-tty.mouse (:use :cl :cl-tty.layout :cl-tty.input :cl-tty.box :cl-tty.rendering) (:export @@ -51,7 +51,7 @@ implementation details. Standard boilerplate to enter the package defined above. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (in-package :cl-tty.mouse) #+END_SRC @@ -63,7 +63,7 @@ that want mouse support simply inherit from ~mouse-mixin~ alongside their primary superclass. Each slot stores a closure invoked when the corresponding event fires; ~nil~ means "no handler." -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defclass mouse-mixin () ((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down) (on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up) @@ -79,7 +79,7 @@ function dispatch because the mapping is one-to-one and never needs CLOS multiple-dispatch. Returns ~nil~ when no handler is bound (the caller can decide whether to bubble the event up). -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun handle-mouse-event (component event) (let* ((type (mouse-event-type event)) (handler (case type @@ -98,7 +98,7 @@ innermost matching component wins (front-most in rendering order). yet (no ~layout-node~ bound). This makes hit-testing safe to call mid-render when the tree is partially constructed. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun hit-test (root x y) "Find the deepest component at (X, Y) by testing layout-node bounds. Recurses into component-children to find the innermost match. @@ -131,7 +131,7 @@ process without threading it through the entire component tree. This keeps the API simple for now; a future refactor could store the selection on a per-frame or per-window basis if needed. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defvar *selection* nil) #+END_SRC @@ -143,7 +143,7 @@ avoiding name collisions. Using a struct (vs. a class) gives inline accessors and no CLOS overhead, which matters when the selection is read on every render frame. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defstruct (selection (:conc-name sel-)) (start-x 0) (start-y 0) (end-x 0) (end-y 0) (text "")) #+END_SRC @@ -153,7 +153,7 @@ read on every render frame. Simple accessor that returns nil when nothing is selected (rather than an empty string), making it easy for callers to test with ~when~. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun get-selection () (when *selection* (sel-text *selection*))) #+END_SRC @@ -168,7 +168,7 @@ Darwin uses ~pbcopy~. The approach avoids build-time feature detection the common case of a single SBCL binary used across X11 and Wayland sessions. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun copy-to-clipboard (text) #+linux (cond @@ -187,7 +187,7 @@ should draw a highlight overlay. A global flag (rather than threading the drag state through event handlers) mirrors the simplicity of ~*selection*~ and makes it trivial to check in rendering code. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defvar *selection-active* nil "T when a drag selection is in progress.") #+END_SRC @@ -198,7 +198,7 @@ Stored as a cons cell ~(X . Y)~ of the mouse-down position. Using a cons (vs. a struct) keeps the imperative mutation simple — ~setf~ with ~cons~ is a single expression. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defvar *selection-start* nil "Cons (X . Y) of mouse-down position during drag.") #+END_SRC @@ -209,7 +209,7 @@ Updated on every mouse-move during a drag so the rendering loop can draw the live highlight rectangle between ~*selection-start*~ and ~*selection-end*~. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defvar *selection-end* nil "Cons (X . Y) of current mouse position during drag.") #+END_SRC @@ -220,7 +220,7 @@ Initializes all three drag state variables in one call. Both start and end are set to the same position so that before the first mouse-move the "selection" is a zero-width region (which renders as nothing). -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun start-selection (x y) "Begin a drag selection at (X Y)." (setf *selection-start* (cons x y) @@ -234,7 +234,7 @@ Called on every mouse-move event while dragging. Only updates the end position; the start remains fixed from the original mouse-down. The rendering loop reads both globals to draw the highlight rectangle. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun update-selection (x y) "Update the drag selection end position to (X Y)." (setf *selection-end* (cons x y))) @@ -246,7 +246,7 @@ Encapsulates the global flag behind a function so that callers don't need to know the variable name. Returning ~*selection-active*~ directly works because it is always ~nil~ or ~T~. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun selection-active-p () "Return T if a drag selection is in progress." *selection-active*) @@ -260,7 +260,7 @@ framebuffer via ~cl-tty.rendering:extract-text~, stores the result in ~*selection*~, and returns the extracted string. The ~fb~ parameter must be the current framebuffer at the time of release. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun finalize-selection (fb) "End the drag selection and extract text from the framebuffer." (setf *selection-active* nil) @@ -283,7 +283,7 @@ Delegates to the rendering layer's ~fb-cell-link-url~ to look up the cell metadata. This indirection keeps mouse code independent of the framebuffer's internal storage format. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun cell-link-at (fb x y) "Return the link URL at (X Y) in framebuffer FB, or nil." (cl-tty.rendering:fb-cell-link-url fb x y)) @@ -296,7 +296,7 @@ If ~cell-link-at~ finds a URL, open it with the OS default handler the caller can log or react to the result. The ~:wait nil~ avoids blocking the TTY UI while the browser launches. -#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/mouse.lisp :noweb no (defun open-link-at (fb x y) "If there is a link URL at (X Y) in FB, open it via xdg-open." (let ((url (cell-link-at fb x y))) @@ -314,7 +314,7 @@ Isolates test symbols in their own package to avoid polluting the production namespace. FiveAM's ~def-suite~ groups all mouse tests under a single name for convenient batch execution. -#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/mouse-tests.lisp :noweb no (defpackage :cl-tty-mouse-test (:use :cl :cl-tty.mouse :fiveam)) (in-package :cl-tty-mouse-test) @@ -328,7 +328,7 @@ Verifies that the mixin class can be instantiated and passes a basic typep check. This guards against missing ~:initform~ values or superclass chain issues. -#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/mouse-tests.lisp :noweb no (def-test mouse-mixin-create () (let ((m (make-instance 'mouse-mixin))) (is-true (typep m 'mouse-mixin)))) @@ -340,7 +340,7 @@ superclass chain issues. for any coordinates. This tests the ~ignore-errors~ guard path in the hit-testing logic. -#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/mouse-tests.lisp :noweb no (def-test mouse-hit-test-point () "hit-test returns nil when no component has position slots bound" (let ((obj (make-instance 'mouse-mixin))) @@ -354,7 +354,7 @@ Sets ~*selection*~ directly (simulating a completed drag) and checks that ~get-selection~ returns the expected text. This validates the ~selection~ struct accessor chain end-to-end. -#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/mouse-tests.lisp :noweb no (def-test selection-set-and-get () (setf cl-tty.mouse::*selection* (make-selection :text "hello")) (is (equal "hello" (get-selection)))) @@ -367,7 +367,7 @@ that ~get-selection~ returns the expected text. This validates the resets globals to avoid cross-test contamination (FiveAM does not automatically reset special variables between tests). -#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/mouse-tests.lisp :noweb no (def-test start-selection-initializes-state () (start-selection 5 10) (is-true (selection-active-p)) @@ -384,7 +384,7 @@ After ~start-selection~, calling ~update-selection~ must update ~*selection-end*~ while leaving ~*selection-start*~ unchanged. This validates the drag-tracking update path. -#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/mouse-tests.lisp :noweb no (def-test update-selection-moves-end () (start-selection 0 0) (update-selection 3 7) @@ -401,7 +401,7 @@ simulates a drag selection, and verifies that ~finalize-selection~ extracts the correct multi-line string. This exercises the full chain from framebuffer cell storage through coordinate normalization. -#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/mouse-tests.lisp :noweb no (def-test finalize-selection-extracts-text () (let* ((fb-be (cl-tty.rendering:make-framebuffer-backend)) (fb (cl-tty.rendering:fb-framebuffer fb-be))) diff --git a/org/package.org b/org/package.org index 051d88a..3a51093 100644 --- a/org/package.org +++ b/org/package.org @@ -53,7 +53,7 @@ computation. We export it separately from the rendering symbols because it is also needed by code that walks the component tree without triggering a full render. -#+BEGIN_SRC lisp :tangle ../src/components/package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp (defpackage :cl-tty.box (:use :cl :cl-tty.backend :cl-tty.layout) (:export @@ -75,7 +75,7 @@ properties without pulling in the internal representation. We keep the accessor list flat (no grouping macro) to make the package surface easy to grep and to keep the API browser-friendly. -#+BEGIN_SRC lisp :tangle ../src/components/package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp ;; Span #:span #:span-text #:span-bold #:span-italic #:span-underline @@ -97,7 +97,7 @@ separate ~cl-tty.text~ package to keep inter-component references trivial — boxes can hold text children, and text can be nested inside other components, all without cross-package imports. -#+BEGIN_SRC lisp :tangle ../src/components/package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp ;; Text #:text #:make-text #:text-layout-node #:text-content #:text-spans @@ -113,7 +113,7 @@ exported specifically so the test suite can unit-test them in isolation. They are not part of the public component API and should not be relied upon by application code outside of tests. -#+BEGIN_SRC lisp :tangle ../src/components/package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp ;; Utilities (for tests) #:word-wrap #:split-string #+END_SRC @@ -131,7 +131,7 @@ dirty-p)~) makes it easy for subclasses to add side effects on dirty transitions — for example, invalidating a cached bitmap or recomputing string metrics. -#+BEGIN_SRC lisp :tangle ../src/components/package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp ;; Dirty tracking #:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty #+END_SRC @@ -151,7 +151,7 @@ Collecting these under a single "Rendering pipeline" group signals to readers that they form a coherent subsystem — if you override one, you likely need to understand all of them. -#+BEGIN_SRC lisp :tangle ../src/components/package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp ;; Rendering pipeline #:render #:render-screen #:render-node #:component-layout-node #:component-children #:component-parent @@ -172,7 +172,7 @@ boxes and text reference theme colors by name at render time, and the theme object is passed in from the application level. This separation means themes can be swapped without touching component instances. -#+BEGIN_SRC lisp :tangle ../src/components/package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp ;; Theme engine #:theme #:make-theme #:theme-mode #:theme-color #:load-preset #:define-preset)) diff --git a/org/render.org b/org/render.org index f91bb5f..85613b7 100644 --- a/org/render.org +++ b/org/render.org @@ -72,7 +72,7 @@ to a string stream instead of writing to the real terminal. This helper creates a ~modern-backend~ with a ~string-output-stream~ and returns both, so tests can inspect what was rendered. -#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp (in-package :cl-tty-box-test) (in-suite box-suite) @@ -90,7 +90,7 @@ generic dispatch works for the box type and that the border rendering pipeline is intact. A regression here would mean ~render-box~ is not being called or produces no output. -#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp (test render-generic-dispatches-box "render dispatches to render-box for box instances" (multiple-value-bind (b s) (make-capturing-backend) @@ -108,7 +108,7 @@ dispatch works for the text type and that text content is correctly emitted to the backend. A regression would mean ~render-text~ is not being called. -#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp (test render-generic-dispatches-text "render dispatches to render-text for text instances" (multiple-value-bind (b s) (make-capturing-backend) @@ -127,7 +127,7 @@ return a ~layout-node~ instance from their ~component-layout-node~ method. A failure here means a component type is missing its method or the slot accessor is wrong. -#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp (test component-layout-node-works "component-layout-node returns the right slot for each type" (let ((bx (make-box)) (tx (make-text ""))) @@ -143,7 +143,7 @@ nor text accidentally inherits or defines a method that returns non-nil, which would break the tree-walk in ~render-node~ by causing infinite recursion or rendering phantom children. -#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp (test component-children-returns-nil "Leaf components have no children" (let ((bx (make-box)) (tx (make-text ""))) @@ -160,7 +160,7 @@ test verifies that calling ~propagate-dirty~ on a clean component sets it dirty. Without this, components that mutate would never trigger a re-render and the display would become stale. -#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp (test propagate-dirty-marks-component "propagate-dirty marks the component dirty" (let ((c (make-box))) @@ -180,7 +180,7 @@ computation. This matters because container components use ~available-width~ to position children — getting a sensible default prevents division-by-zero or garbled layouts during initialization. -#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp (test available-width-defaults "available-width returns 0 for components without explicit width" (let ((c (make-box))) @@ -203,7 +203,7 @@ rendering must have a layout node — it stores the computed position and size after layout passes. The generic is defined with two specific methods for the built-in component types. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp (in-package :cl-tty.box) ;; ── Component Protocol ──────────────────────────────────────── @@ -215,7 +215,7 @@ methods for the built-in component types. Each component type returns its internal layout node slot. This method specializes on ~box~ and returns the ~box-layout-node~ slot value. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp (defmethod component-layout-node ((bx box)) (box-layout-node bx)) #+END_SRC @@ -224,7 +224,7 @@ The ~text~ component stores its layout node in the ~text-layout-node~ slot. Both methods return the same type (~layout-node~), so the layout engine can operate uniformly regardless of component type. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp (defmethod component-layout-node ((tx text)) (text-layout-node tx)) #+END_SRC @@ -236,7 +236,7 @@ Leaf components (~box~, ~text~) have no children. Container components default method on ~t~ returns ~nil~, so new component types are automatically treated as leaves unless they explicitly override. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp (defgeneric component-children (component) (:documentation "Return the children of COMPONENT, or nil.") (:method ((c t)) nil)) @@ -250,7 +250,7 @@ used by ~propagate-dirty~ to walk up the tree. The default method on recursive dirty walk — when ~component-parent~ returns ~nil~, we've reached the root. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp (defgeneric component-parent (component) (:documentation "Return the parent of COMPONENT, or nil.") (:method ((c t)) nil)) @@ -266,7 +266,7 @@ pipeline. Every component type that can be drawn defines a method on objects (or components still under development) don't cause errors when the tree walk reaches them. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp ;; ── Rendering Pipeline ──────────────────────────────────────── (defgeneric render (component backend) @@ -282,7 +282,7 @@ Boxes are rendered with border characters. The ~render~ method delegates to the ~render-box~ function defined in ~box.lisp~, which handles the actual drawing of border lines and corners. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp (defmethod render ((bx box) backend) (render-box bx backend)) #+END_SRC @@ -293,7 +293,7 @@ Text components render their content string at the computed position. The ~render~ method delegates to ~render-text~ from ~text.lisp~, which writes the string with appropriate escape sequences for positioning. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp (defmethod render ((tx text) backend) (render-text tx backend)) #+END_SRC @@ -313,7 +313,7 @@ The pipeline is: (1) query backend pixel/dimension size, (2) begin sync, (3) compute layout at the root, (4) walk the tree rendering each node, (5) end sync. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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 @@ -334,7 +334,7 @@ are available from its ~layout-node~. The recursion is depth-first: parents are drawn before children, which matters for z-ordering (the parent's background is drawn first, children overlay on top). -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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 @@ -354,7 +354,7 @@ reflects the actual allocated space — not the requested width. The fallback of 80 matches the default terminal width when no layout node exists (during initialization or testing without a backend). -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp (defun available-width (component) "Return the available width for COMPONENT (or 80 as default)." (let ((ln (component-layout-node component))) @@ -369,7 +369,7 @@ fallback of 24 matches the default terminal height. These accessors provide a clean API for components that need to know their allocated space during rendering, avoiding direct access to layout nodes. -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp (defun available-height (component) "Return the available height for COMPONENT (or 24 as default)." (let ((ln (component-layout-node component))) @@ -391,7 +391,7 @@ immediately for clean components (handled in each component's render, not here). The recursion terminates when ~component-parent~ returns ~nil~ (the root component has no parent). -#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp ;; ── Dirty Propagation ───────────────────────────────────────── (defun propagate-dirty (component) diff --git a/org/scrollbox.org b/org/scrollbox.org index 22be5f5..96b7225 100644 --- a/org/scrollbox.org +++ b/org/scrollbox.org @@ -45,7 +45,7 @@ Defining this as a class (rather than a struct) lets us integrate with the CLOS-based component protocol — ~render~ dispatches on the class, and dirty-mixin provides the marking machinery used by the refresh loop. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (in-package #:cl-tty.container) (defclass scroll-box (dirty-mixin) @@ -69,7 +69,7 @@ value explicitly passed as ~:sticky-scroll-p nil~ needs to be preserved). Using a function instead of making the user call ~make-instance~ directly keeps the API ergonomic and hides CLOS plumbing. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) sticky-scroll-p) (make-instance 'scroll-box @@ -87,7 +87,7 @@ delegating to the ~scroll-box-children~ accessor, we keep the protocol implementation thin — just an indirection that makes ~scroll-box~ participate polymorphically alongside other container types. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defmethod component-children ((sb scroll-box)) (scroll-box-children sb)) #+END_SRC @@ -99,7 +99,7 @@ uses to position the ScrollBox itself within its parent. Each ScrollBox creates its own layout node at construction time via ~make-layout-node~, so this method simply returns that stored node. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defmethod component-layout-node ((sb scroll-box)) (scroll-box-layout-node sb)) #+END_SRC @@ -113,7 +113,7 @@ content dimensions from the content-size helpers, then clamps both scroll offsets with ~max~/~min~ to ensure they never go below 0 or beyond the scrollable range. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defun clamp-scroll (sb) "Clamp scroll offsets to valid range." (let* ((ln (scroll-box-layout-node sb)) @@ -137,7 +137,7 @@ the component dirty so the render loop picks up the change. This is the primary API entry point for programmatic scrolling (from keyboard input or mouse wheel events). -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defun scroll-by (sb dy dx) "Scroll by DY rows and DX columns. Clamps to valid range." (incf (scroll-box-scroll-y sb) dy) @@ -154,7 +154,7 @@ layout node, with a minimum of 1 row (even zero-height children get a floor so they don't collapse the layout). This is used by ~clamp-scroll~, scrollbar rendering, and sticky-scroll logic. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defun scroll-box-content-height (sb) "Total height of all children." (reduce #'+ (scroll-box-children sb) @@ -171,7 +171,7 @@ since horizontal scrolling follows the widest child rather than summing widths. Like the height counterpart, it floors child widths at 1 so empty children don't zero out the measurement. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defun scroll-box-content-width (sb) "Maximum width among children." (reduce #'max (scroll-box-children sb) @@ -198,7 +198,7 @@ position. After child rendering, it delegates to ~draw-scrollbars~ for the scrollbar overlay. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defmethod render ((sb scroll-box) backend) "Render visible children with scroll offset applied. Delegates to each child's `render` method, temporarily offsetting @@ -241,7 +241,7 @@ viewport-h 1)~) so minor content changes don't cause jitter. The sticky flag is reset to nil when the user manually scrolls up (handled by callers of ~scroll-by~). -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defun update-sticky-scroll (sb) "If sticky-scroll-p is active and at bottom, keep at bottom." (when (sticky-scroll-p sb) @@ -262,7 +262,7 @@ it returns 0.0 (no scrolling possible). This normalized value is used by ~draw-scrollbars~ to compute the pixel/character position of the thumb. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defun scrollbar-thumb (scroll-pos viewport-size content-size) "Return the thumb position for a scrollbar (0.0 to 1.0)." (if (> content-size viewport-size) @@ -283,7 +283,7 @@ the bottom edge. Both account for the scrollbox's own position within the layout tree (~ox~, ~oy~) so nested scrollboxes render scrollbars at the correct screen coordinates. -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp (defun draw-scrollbars (sb backend viewport-w viewport-h) "Draw scrollbars if content exceeds viewport." (let* ((content-h (scroll-box-content-height sb)) @@ -342,7 +342,7 @@ along with the base ~:cl~ language and ~:fiveam~ itself. unconditionally; it runs the ~scrollbox-suite~ and prints results via ~fiveam:explain!~ before exiting. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (defpackage :cl-tty-scrollbox-test (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container) (:export #:run-tests)) @@ -363,7 +363,7 @@ Confirms a bare ~make-scroll-box~ returns a ~scroll-box~ instance with default scroll offsets of 0 and no children. This establishes that the class definition and constructor are wired up correctly. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test scrollbox-creates "A ScrollBox can be created with defaults." (let ((sb (make-scroll-box))) @@ -379,7 +379,7 @@ Verifies that the ~:children~ initarg is accepted and that ~scroll-box-children~ returns the list. A ScrollBox with one child should report length 1. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test scrollbox-with-children "A ScrollBox can have children." (let ((sb (make-scroll-box :children (list (make-text "hello"))))) @@ -393,7 +393,7 @@ scroll-y is non-negative after the operation. Combined with ~scrollbox-scroll-clamp~ below, this covers both the normal and boundary behavior of the scroll mechanic. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test scrollbox-scroll-by "ScrollBy adjusts offset clamped to valid range." (let ((sb (make-scroll-box :scroll-y 0))) @@ -408,7 +408,7 @@ same child list that ~scroll-box-children~ does. This ensures the protocol indirection works and that the rendering pipeline will see the correct children. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test scrollbox-component-children "Component protocol: children are accessible." (let* ((child (make-text "hello")) @@ -423,7 +423,7 @@ The test passes if no errors are signaled — this guards against nil layout nodes or unbound slots causing problems during the render pipeline's initial traversal. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test scrollbox-render-noop "Rendering a ScrollBox with no children does not error." (let* ((stream (make-string-output-stream)) @@ -439,7 +439,7 @@ Confirms a bare ~make-tab-bar~ returns a ~tab-bar~ instance with no active tab and no tabs. This validates the TabBar class definition and constructor. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test tabbar-creates "A TabBar can be created with defaults." (let ((tb (make-tab-bar))) @@ -454,7 +454,7 @@ Tests that ~tab-bar-add~ returns the supplied ID, adds a tab to the internal list, and stores the title correctly. Each tab is stored as a plist, so the test checks both list length and the ~:title~ property. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test tabbar-add-tab "Adding a tab returns the id and updates tabs." (let ((tb (make-tab-bar))) @@ -469,7 +469,7 @@ plist, so the test checks both list length and the ~:title~ property. Verifies that ~(setf tab-bar-active)~ correctly selects a tab by ID and that ~tab-bar-active~ returns that ID afterward. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test tabbar-active-tab "Setting active tab works." (let ((tb (make-tab-bar))) @@ -486,7 +486,7 @@ a string-output-stream backend to confirm the render method doesn't error. A TabBar must draw its tab strip without crashing even when disconnected from a real terminal. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test tabbar-render-noop "Rendering a TabBar does not error." (let* ((stream (make-string-output-stream)) @@ -507,7 +507,7 @@ wrapping around past the first. This is the core keyboard interaction for tabbed UIs and must handle edge cases (empty bar, single tab, etc.) gracefully. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test tabbar-next-prev "TabBar next/prev wraps around through tabs." (let ((tb (make-tab-bar))) @@ -531,7 +531,7 @@ gracefully. next/prev navigation). This test verifies that selecting ~:tab2~ from a three-tab bar correctly sets the active tab. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test tabbar-select "TabBar select activates the specified tab." (let ((tb (make-tab-bar))) @@ -548,7 +548,7 @@ three-tab bar correctly sets the active tab. This tests the bridge between the input event system and the TabBar navigation API. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test tabbar-handle-key "TabBar handle-key dispatches left/right." (let ((tb (make-tab-bar))) @@ -568,7 +568,7 @@ values (negative and extremely large) and confirming they get clamped back to 0. With no children, content size is 0 so the max scroll is also 0 — this exercises the degenerate case. -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp (test scrollbox-scroll-clamp "ScrollBox clamp prevents scrolling past bounds." (let ((sb (make-scroll-box :scroll-y 5 :scroll-x 3))) diff --git a/org/select.org b/org/select.org index d5b93ac..907c159 100644 --- a/org/select.org +++ b/org/select.org @@ -47,19 +47,19 @@ by the select widget tests — FiveAM itself, the backend/box/layout/input infra and the ~cl-tty.select~ package under test. ~run-tests~ is the entry point for CI and interactive use. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (defpackage :cl-tty-select-test (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.select) (:export #:run-tests)) (in-package #:cl-tty-select-test) #+END_SRC -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (def-suite select-suite :description "Select widget tests") (in-suite select-suite) #+END_SRC -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (defun run-tests () (let ((result (run 'select-suite))) (fiveam:explain! result) @@ -72,7 +72,7 @@ Verifies that a select widget can be constructed with default values. The ~selected-index~ should start at 0, and both ~options~ and ~filter~ should be nil. This establishes the baseline contract for the default constructor. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-creates "A Select can be created with defaults." (let ((sel (make-select))) @@ -87,7 +87,7 @@ be nil. This establishes the baseline contract for the default constructor. Ensures that passing ~:options~ to ~make-select~ stores them correctly. The length check is the simplest invariant — two options in, two options out. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-with-options "A Select stores options." (let ((sel (make-select :options '((:title "Red" :value :red) @@ -102,7 +102,7 @@ match \"Blue\" but not \"Red\" or \"Green\". The return value is an alist of ~(display-index original-index option)~, so we dig into the third element to check the ~:value~. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-filtered-exact "Filter returns case-insensitive substring matches." (let ((sel (make-select @@ -121,7 +121,7 @@ When the filter is nil ~select-filtered-options~ must return every option unchanged. This is the unfiltered/identity case and the most common state when the user hasn't typed anything. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-filtered-all "Nil filter returns all options." (let ((sel (make-select @@ -137,7 +137,7 @@ Exercises ~select-next~ and ~select-prev~ through a three-item list, confirming that forward and backward movement works and that both directions wrap around at list boundaries. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-navigation "Select-next and select-prev navigate through options." (let ((sel (make-select @@ -162,7 +162,7 @@ navigation — ~select-next~ and ~select-prev~ skip over them. This test sets up a list with two category headers interleaved and verifies they are transparent to movement. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-navigation-skips-categories "Navigation skips category header options." (let ((sel (make-select @@ -186,7 +186,7 @@ Validates that ~select-handle-key~ dispatches correctly: Down moves forward, Up moves backward, and Enter invokes the ~on-select~ callback with the currently highlighted option's plist. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-handle-key "Select handle-key dispatches navigation and selection." (let* ((result (list nil)) @@ -207,7 +207,7 @@ Ctrl+N and Ctrl+P are Emacs-compatible alternatives to Down/Up. They must produce identical navigation behavior. This test confirms the control-key dispatch paths. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-handle-key-ctrl "Ctrl+N and Ctrl+P navigate like down/up." (let ((sel (make-select @@ -224,7 +224,7 @@ dispatch paths. height. This test creates 20 options, sets the layout height to 5, and asserts the visible subset fits within that constraint. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-visible-count "Visible options respects viewport height." (let* ((ln (make-layout-node)) @@ -242,7 +242,7 @@ When exact substring matching fails, the filter falls back to character-set Jaccard similarity. ~\"nrd\"~ should match ~\"Nord\"~ because the character overlap (n, o, r, d → 3 of 4) exceeds the 0.3 threshold. -#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp (test select-fuzzy-fallback "Fuzzy filter catches near-misses." (let ((sel (make-select @@ -265,7 +265,7 @@ and input subsystems. The exported symbols cover the public API: the handling, rendering, and the fuzzy matching predicate (exposed for testing and extensibility). -#+BEGIN_SRC lisp :tangle ../src/components/select-package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select-package.lisp (defpackage :cl-tty.select (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export @@ -292,7 +292,7 @@ currently highlighted option. ~filter~ is a string (or nil for unfiltered). ~on-select~ is a callback receiving the selected option plist. ~layout-node~ positions the widget in the window. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (in-package #:cl-tty.select) (defclass select (dirty-mixin) @@ -314,7 +314,7 @@ A convenience constructor that wraps ~make-instance~ with keyword arguments. Defaults to nil for all optional parameters, matching the ~defclass~ initforms. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defun make-select (&key options filter on-select) (make-instance 'select :options (or options nil) @@ -330,7 +330,7 @@ The layout engine needs a uniform way to access a component's position. ~component-layout-node~ is part of the component protocol; this method for ~select~ simply delegates to the ~select-layout-node~ accessor. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defmethod component-layout-node ((sel select)) (select-layout-node sel)) #+END_SRC @@ -352,7 +352,7 @@ Internally, the filter first checks for exact substring containment via character-set ~fuzzy-match-p~ predicate. Category headers short-circuit so they always pass through the filter. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defun select-filtered-options (sel) "Return list of options matching the current filter, in display order. Each item: (display-index original-index option-plist)." @@ -424,7 +424,7 @@ query and target exceeds 0.3. The character-set approach is simpler and cheaper than trigrams while still catching common typos and near-misses like ~\"nrd\"~ for ~\"Nord\"~. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defun fuzzy-match-p (query target) "T if character-set Jaccard similarity exceeds threshold (0.3)." (let* ((q-chars (remove-duplicates (coerce (string-downcase query) 'list))) @@ -443,7 +443,7 @@ index may point beyond the filtered list. ~select-clamp-index~ ensures the index stays within valid bounds. If the list is empty the index resets to 0. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defun select-clamp-index (sel) "Ensure selected-index is valid. Wraps if empty." (let* ((filtered (select-filtered-options sel)) @@ -461,7 +461,7 @@ through the filtered list starting from the current index, wrapping around at the end. Each candidate is checked for ~:category t~ and skipped. Marks the widget dirty so the render pass picks up the change. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defun select-next (sel) "Move selection to next non-category option. Wraps at end." (let* ((filtered (select-filtered-options sel)) @@ -483,7 +483,7 @@ Moves the selection backward to the previous non-category option. Mirrors ~select-next~ but decrements the index (with modular arithmetic for wrap-around). Category headers are skipped identically. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defun select-prev (sel) "Move selection to previous non-category option. Wraps at start." (let* ((filtered (select-filtered-options sel)) @@ -512,7 +512,7 @@ Dispatches keyboard events: Returns T if the key was handled (consumed), NIL otherwise so the caller knows not to propagate the event further. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defun select-handle-key (sel event) "Handle a key-event. Returns T if handled." (let ((key (key-event-key event)) @@ -545,7 +545,7 @@ hundreds of items when the viewport shows only 10. The window is centered around the currently selected index so the user always sees context around their cursor. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defun select-visible-options (sel) "Return filtered options that fit within the viewport." (let* ((ln (select-layout-node sel)) @@ -569,7 +569,7 @@ background. Category headers are rendered dimmed (~:text-muted~) and visually distinct from selectable items. Long titles are truncated with an ellipsis character to fit the viewport width. -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp (defmethod render ((sel select) backend) (let* ((ln (select-layout-node sel)) (x (if ln (layout-node-x ln) 0)) diff --git a/org/slot.org b/org/slot.org index 5f5e0e0..1de893f 100644 --- a/org/slot.org +++ b/org/slot.org @@ -50,7 +50,7 @@ same slot with conflicting mode specifications. The package provides the public API and exports all slot system symbols. Clients :use this package or refer to symbols qualified. -#+BEGIN_SRC lisp :tangle ../src/components/slot-package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot-package.lisp (defpackage :cl-tty.slot (:use :cl) (:export @@ -73,7 +73,7 @@ case-insensitive lookup via ~equal~). Each value is a plist: The ~:test #'equal~ ensures that ~:sidebar~ and ~"sidebar"~ map to the same key. -#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp (in-package :cl-tty.slot) (defvar *slots* (make-hash-table :test 'equal) @@ -97,7 +97,7 @@ The mode parameter is validated on first call via ~assert~ and then frozen for subsequent calls. This prevents a later registration from changing the slot's semantics out from under earlier registrations. -#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp (defun defslot (name &key (order 0) render-fn (mode :stack)) (let* ((key (string name)) (slot (gethash key *slots*))) @@ -143,7 +143,7 @@ changing the slot's semantics out from under earlier registrations. Returns ~nil~ if the slot has no registrations or if the handler is nil. -#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp (defun slot-render (slot-name &rest args) (let ((slot (gethash (string slot-name) *slots*))) (when slot @@ -169,7 +169,7 @@ Uses ~nth-value 1~ of ~gethash~ which returns ~t~ if the key is present (even if the value is ~nil~) or ~nil~ if absent. This is the canonical Common Lisp idiom for testing hash-table membership. -#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp (defun slot-p (slot-name) (nth-value 1 (gethash (string slot-name) *slots*))) #+END_SRC @@ -180,7 +180,7 @@ Calls ~remhash~ to delete the slot's entry from the hash table entirely. After this call ~slot-p~ returns false and ~slot-render~ returns nil for the given slot name. -#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp (defun clear-slot (slot-name) (remhash (string slot-name) *slots*)) #+END_SRC @@ -191,7 +191,7 @@ Iterates over all hash keys in ~*slots*~ and returns them as a list. Only slots that have been registered (i.e. have at least one entry) appear in the result. -#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp (defun list-slots () (loop for key being the hash-keys of *slots* collect key)) #+END_SRC @@ -203,7 +203,7 @@ including mode-specific behavior. *** Test Package and Suite -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp (defpackage :cl-tty-slot-test (:use :cl :cl-tty.slot :fiveam)) (in-package :cl-tty-slot-test) @@ -213,7 +213,7 @@ including mode-specific behavior. *** defslot-register: Registering a slot makes it visible -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp (def-test defslot-register () (clear-slot :test-slot) (defslot :test-slot :order 1 :render-fn (lambda () "hello")) @@ -225,7 +225,7 @@ including mode-specific behavior. Verifies that ~:stack~ mode preserves multiple registrations and calls them in ascending order sequence. -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp (def-test slot-render-calls () (clear-slot :test-slot) (defslot :test-slot :order 1 :render-fn (lambda () "a")) @@ -235,7 +235,7 @@ them in ascending order sequence. *** slot-render-empty: Unregistered slot returns nil -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp (def-test slot-render-empty () (clear-slot :ghost) (is-false (slot-render :ghost))) @@ -243,7 +243,7 @@ them in ascending order sequence. *** clear-slot-removes: Clearing a slot makes it absent -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp (def-test clear-slot-removes () (clear-slot :test-slot) (defslot :test-slot :order 1 :render-fn (lambda () "x")) @@ -256,7 +256,7 @@ them in ascending order sequence. Verifies that ~:stack~ mode (default) accumulates entries across multiple ~defslot~ calls. -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp (def-test stack-mode-multiple-entries () (clear-slot :stack-test) (defslot :stack-test :order 1 :render-fn (lambda () "first")) @@ -270,7 +270,7 @@ multiple ~defslot~ calls. Verifies that ~:replace~ mode discards previous entries on each new ~defslot~ call. -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp (def-test replace-mode-last-wins () (clear-slot :replace-test) (defslot :replace-test :mode :replace :order 1 :render-fn (lambda () "old")) @@ -282,7 +282,7 @@ Verifies that ~:replace~ mode discards previous entries on each new Verifies that ~:single-winner~ mode ignores subsequent registrations. -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp (def-test single-winner-mode-first-wins () (clear-slot :winner-test) (defslot :winner-test :mode :single-winner :order 1 @@ -297,7 +297,7 @@ Verifies that ~:single-winner~ mode ignores subsequent registrations. Verifies that clearing a slot removes the mode lock, so a subsequent ~defslot~ can set a new mode. -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp (def-test clear-slot-removes-mode () (clear-slot :mode-test) (defslot :mode-test :mode :replace :render-fn (lambda () "only")) diff --git a/org/tabbar.org b/org/tabbar.org index b23e377..a8b4946 100644 --- a/org/tabbar.org +++ b/org/tabbar.org @@ -32,7 +32,7 @@ other container components (scrollbox, box, slot, etc.). This keeps the symbol namespace clean and avoids accidental collisions with user-level code. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (in-package #:cl-tty.container) #+END_SRC @@ -48,7 +48,7 @@ The ~tabs~ slot is a simple plist list rather than a hash table or alist because the total number of tabs in a UI is typically small (< 20) and we need ordered iteration for rendering. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (defclass tab-bar (dirty-mixin) ((tabs :initform nil :initarg :tabs :accessor tab-bar-tabs :type list) @@ -65,7 +65,7 @@ Convenience constructor that forwards keyword arguments to ~make-instance~ everywhere gives us a single place to add defaulting, validation, or initialization hooks in the future. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (defun make-tab-bar (&key tabs active) (make-instance 'tab-bar :tabs (or tabs nil) :active active)) #+END_SRC @@ -79,7 +79,7 @@ tab becomes active automatically — this ensures there is always a sensible default when the first tab is created. Returns the ~id~ so callers can chain or store it. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (defun tab-bar-add (tb id title) "Add a tab with ID and TITLE. Sets as active if first tab." (setf (tab-bar-tabs tb) @@ -95,7 +95,7 @@ Returns the layout node so the layout engine can position and size the tab bar within its parent. Every component that participates in automatic layout must implement this method. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (defmethod component-layout-node ((tb tab-bar)) (tab-bar-layout-node tb)) #+END_SRC @@ -110,7 +110,7 @@ The lookup strategy — mapcar ids, position, mod — is O(n) but acceptable since tab lists are small. A hash-based index would be premature optimization at this scale. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (defun tab-bar-next (tb) "Move to next tab." (let* ((tabs (tab-bar-tabs tb)) @@ -130,7 +130,7 @@ incrementing it. ~mod~ handles negative wrap-around correctly in Common Lisp (returns a non-negative remainder), so ~(mod (1- 0) 3)~ produces 2 rather than −1. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (defun tab-bar-prev (tb) "Move to previous tab." (let* ((tabs (tab-bar-tabs tb)) @@ -150,7 +150,7 @@ cyclic navigation. This is used when a user clicks a tab (via mouse binding), when a programmatic action needs to switch views, or when activating a tab from outside the keyboard flow. Always marks dirty. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (defun tab-bar-select (tb id) "Select a tab by ID." (setf (tab-bar-active tb) id) @@ -165,7 +165,7 @@ consumed and ~nil~ otherwise, which lets the keybinding system fall through to other handlers — important for composable UIs where a tab bar lives alongside other focusable elements. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (defun tab-bar-handle-key (tb event) "Handle a key-event on a TabBar. Returns T if handled." (case (key-event-key event) @@ -186,7 +186,7 @@ exceeds the available space, tabs are truncated and an ellipsis ~...~ is drawn at the overflow point. This prevents the tab bar from breaking the layout on narrow terminals. -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp (defmethod render ((tb tab-bar) backend) (let* ((ln (tab-bar-layout-node tb)) (x (if ln (layout-node-x ln) 0)) diff --git a/org/text-input.org b/org/text-input.org index ea43c82..98d7433 100644 --- a/org/text-input.org +++ b/org/text-input.org @@ -178,7 +178,7 @@ start avoids package redefinition churn. The current system does not yet call raw mode from within the input module; consumers manage raw mode themselves via ~sb-posix~ directly. -#+BEGIN_SRC lisp :tangle ../src/components/input-package.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input-package.lisp (defpackage :cl-tty.input (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout) (:export @@ -243,7 +243,7 @@ textarea line splitting — a blank document has one empty line. This is the first block tangling to input.lisp, so it includes the ~in-package~ form that all subsequent blocks share. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (in-package #:cl-tty.input) (defun %split-string (string separator) @@ -262,12 +262,12 @@ application's main loop. Widget ~render~ methods use them to draw themselves. Defining them here rather than in the rendering module keeps the dependency clean — input widgets depend on rendering, not the other way around. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defvar *current-backend* nil "The active backend used for rendering.") #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defvar *current-theme* nil "The active theme used for semantic color resolution.") #+END_SRC @@ -299,7 +299,7 @@ or lowercase, but ~code~ preserves the actual code point. The ~handle-text-input~ function uses ~code-char~ on the code slot to get the true character for insertion. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defstruct key-event (key nil :type (or keyword null)) (ctrl nil :type boolean) @@ -323,7 +323,7 @@ field is :press, :release, or :drag, determined by whether the button code includes the motion bit (bit 5). Coordinates are 1-indexed from the terminal; no adjustment is performed here. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defstruct mouse-event (type nil :type (or keyword null)) (button nil :type (or keyword null)) @@ -342,7 +342,7 @@ the modern xterm format, as opposed to the single-letter terminators used by VT100-style sequences (~ESC[H~ = Home, ~ESC[F~ = End). Modern terminal emulators emit the tilde form for most keys; we handle both. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defparameter *csi-tilde-table* '((1 . :home) (2 . :insert) (3 . :delete) (4 . :end) (5 . :page-up) (6 . :page-down) @@ -363,7 +363,7 @@ emitted by most terminal emulators in "normal" (non-application) cursor key mode. The ~:back-tab~ mapping for Z handles Shift+Tab, which some emulators report as ~ESC[Z~. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defparameter *csi-key-table* '((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left) (#\F . :end) (#\H . :home) @@ -391,7 +391,7 @@ Modifier encoding follows the xterm convention: Shift=1, Alt=2, Ctrl=4. The extended parameter vector carries the raw parameter bytes for sequences where modifiers appear in a non-standard position. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defun parse-csi-params (params terminator extended) (let* ((key (if (find terminator '(#\~ #\u)) (cdr (assoc (first params) *csi-tilde-table*)) @@ -440,7 +440,7 @@ and read directly into the backing storage. This avoids alien allocation and manual ~free-alien~ while keeping the GC from moving the buffer during the ~unix-read~ syscall. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defun read-raw-byte (&key timeout) (let* ((buf (make-array 1 :element-type '(unsigned-byte 8))) (fd 0) @@ -481,7 +481,7 @@ The SS3 path handles shifted cursor keys that some emulators report as ~ESC O A~ through ~ESC O D~ (shifted up/down/right/left). These use a different byte prefix from the CSI form ~ESC [ A~ through ~ESC [ D~. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defun %read-escape-sequence () (flet ((read-next (&optional (timeout nil)) (let ((b (read-raw-byte :timeout timeout))) @@ -536,7 +536,7 @@ non-digit byte, handling an optional list of initial bytes that were already consumed by the caller. Returns the parsed integer and the terminator byte. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defun %read-digits (&optional (initial-bytes nil)) "Read bytes until a non-digit is encountered. Returns (values number terminator-byte)." @@ -564,7 +564,7 @@ a ~mouse-event~ struct with proper button and type classification. Coordinates are converted from 1-based (terminal protocol) to 0-based (framebuffer convention) by subtracting 1 from both x and y. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defun %parse-sgr-mouse () "Parse SGR mouse escape sequence: ESC [ < Cb ; Cx ; Cy M/m Returns a mouse-event struct." @@ -609,7 +609,7 @@ the modifier appears after the primary parameter in an extended format (e.g., ~ESC [ 1 ; 5 A~ where 5 encodes Ctrl+Shift). This array is passed to ~parse-csi-params~ for modifier extraction. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defun parse-csi-sequence () (flet ((read-param (next-fn) (let ((acc nil)) (loop for b = (funcall next-fn) @@ -655,7 +655,7 @@ Overlong sequences (e.g., encoding ASCII in 2+ bytes) are rejected because the range checks on the leading byte exclude them: a 2-byte sequence with b0=0xC0 would have ~(= #xc2 b0 #xdf)~ fail since 0xC0 < 0xC2. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defun utf8-decode (bytes) (case (length bytes) (2 (let ((b0 (first bytes)) (b1 (second bytes))) @@ -703,7 +703,7 @@ streamed in real time from the terminal; if we're too aggressive, we might cut off a multi-byte character during a slow paste or network connection. The 500ms gives the terminal ample time to deliver all bytes. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defun %read-event (&key timeout) (multiple-value-bind (b reason) (read-raw-byte :timeout timeout) (unless b (return-from %read-event (if (eq reason :eof) :eof nil))) @@ -754,11 +754,11 @@ call and, if set, query the new terminal dimensions and redraw. The flag is not automatically cleared — the consumer must set it to ~nil~ after handling the resize. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defvar *terminal-resized-p* nil) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp #+sbcl (eval-when (:load-toplevel :execute) (require :sb-posix) @@ -775,7 +775,7 @@ input). SBCL's ~SB-POSIX:WITH-RAW-TERMINAL~ is not available in all builds (e.g. Debian-packaged SBCL 2.5.x). This implementation uses ~stty~ for portability. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defun %raw-mode-on () (uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr") :output nil :error-output nil :ignore-error-status t)) @@ -806,7 +806,7 @@ This method is deliberately simple: it's a thin wrapper that adapts the ~%read-event~ API to the backend protocol's ~read-event~ generic function. All the complexity lives in ~%read-event~ and its callees. -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp (defmethod read-event ((b cl-tty.backend:backend) &key timeout) ;; Check for pending terminal resize before reading input. ;; The SIGWINCH handler sets *terminal-resized-p* asynchronously. @@ -851,7 +851,7 @@ shift out when full) keeps memory bounded. This is the first block tangling to textarea.lisp, so it includes the ~in-package~ form. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (in-package #:cl-tty.input) (defclass textarea (dirty-mixin) @@ -878,7 +878,7 @@ The constructor is a separate function rather than a ~:constructor~ option on ~defclass~ because it needs to normalize the value argument ~(or value "")~ — a pattern that would clutter the class definition. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun make-textarea (&key value on-submit) (make-instance 'textarea :value (or value "") @@ -895,13 +895,13 @@ line, which is the correct representation of a blank document. ~textarea-line-count~ is a simple wrapper for the number of lines. It's used by cursor movement functions to clamp the cursor row. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-lines (ta) "Split value into lines." (%split-string (textarea-value ta) #\Newline)) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-line-count (ta) "Number of lines in value." (length (textarea-lines ta))) @@ -919,7 +919,7 @@ that change line structure (newline, backspace joining lines). It also marks the widget dirty, ensuring the renderer picks up the cursor position change. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-ensure-cursor (ta) "Clamp cursor to valid range." (let ((lines (textarea-lines ta))) @@ -942,7 +942,7 @@ the textarea code work with different representations — ~textarea-lines~ returns a list, but the insertion/backspace code operates on vectors for efficient element replacement. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun %join-lines (lines) "Join a sequence of strings with newlines." (with-output-to-string (s) @@ -969,7 +969,7 @@ within the current line. The algorithm: The function updates ~cursor-col~ by 1 after insertion and marks the widget dirty. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-insert-char (ta char) "Insert CHAR at the cursor position." (textarea-push-undo ta) @@ -1010,7 +1010,7 @@ Algorithm: 6. If the cursor row is beyond the last line, simply append a newline. 7. Mark dirty. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-newline (ta) "Insert a newline at the cursor." (textarea-push-undo ta) @@ -1056,7 +1056,7 @@ line, removing the newline character between them. All paths push undo state before modifying the value. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-backspace (ta) "Delete character before cursor." (textarea-push-undo ta) @@ -1106,13 +1106,13 @@ on a long line and moves up to a shorter 5-character line, the column clamps to 5. This matches how most editors handle column preservation — the column "remembers" its position but is constrained by line length. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-move-up (ta) (decf (textarea-cursor-row ta)) (textarea-ensure-cursor ta)) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-move-down (ta) (incf (textarea-cursor-row ta)) (textarea-ensure-cursor ta)) @@ -1143,7 +1143,7 @@ discarded because the edit graph has branched. Implementing a full tree undo would be significantly more complex and is unnecessary for a TUI textarea. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-push-undo (ta) "Save current value on undo stack." (let ((stack (textarea-undo-stack ta))) @@ -1155,7 +1155,7 @@ textarea. (setf (fill-pointer (textarea-redo-stack ta)) 0))) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-undo (ta) (let ((stack (textarea-undo-stack ta))) (when (plusp (length stack)) @@ -1166,7 +1166,7 @@ textarea. (mark-dirty ta))))) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun textarea-redo (ta) (let ((stack (textarea-redo-stack ta))) (when (plusp (length stack)) @@ -1203,7 +1203,7 @@ rather than looking at ~key-event-key~. This is because ~key-event-key~ is always an uppercase keyword (~:a~ for both 'a' and 'A'), but the code preserves the actual character. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defun handle-textarea-input (ta event) "Process a key-event on a textarea widget." (cond @@ -1277,7 +1277,7 @@ Cursor rendering is handled by the focus/selection rendering layer, not by this method. This keeps the render method simple — it just paints text. -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp (defmethod render ((ta textarea) (backend t)) "Render textarea lines at layout position." (let* ((ln (textarea-layout-node ta)) @@ -1321,7 +1321,7 @@ tracking. Slots: This is the first block tangling to text-input.lisp, so it includes the ~in-package~ form. -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (in-package #:cl-tty.input) (defclass text-input (dirty-mixin) @@ -1350,7 +1350,7 @@ The ~(or value "")~ pattern ensures the value is always a string, even if the caller passes nil. This eliminates a class of nil-pointer errors in string operations downstream. -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun make-text-input (&key value cursor placeholder max-length on-submit) (make-instance 'text-input :value (or value "") @@ -1376,7 +1376,7 @@ This is a pure insert — it does not replace the character at the cursor; it shifts subsequent characters right. For overwrite behavior, the caller would need a different function. -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun text-input-insert (input char) (let* ((val (text-input-value input)) (pos (text-input-cursor input)) @@ -1396,7 +1396,7 @@ The algorithm concatenates the prefix (up to one before cursor) with the suffix (from cursor onward), effectively removing the character at cursor-1. The cursor is decremented by 1. -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun text-input-backspace (input) (let* ((val (text-input-value input)) (pos (text-input-cursor input))) (when (zerop pos) (return-from text-input-backspace)) @@ -1417,7 +1417,7 @@ moving the cursor position. This contrasts with backspace, which removes the character before cursor and decrements the cursor. -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun text-input-delete (input) (let* ((val (text-input-value input)) (pos (text-input-cursor input))) (when (>= pos (length val)) (return-from text-input-delete)) @@ -1434,13 +1434,13 @@ one character position, clamped to [0, length]. Left movement stops at Each movement function marks the widget dirty so the renderer redraws the cursor position. -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun text-input-move-left (input) (when (plusp (text-input-cursor input)) (decf (text-input-cursor input))) (mark-dirty input)) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun text-input-move-right (input) (when (< (text-input-cursor input) (length (text-input-value input))) (incf (text-input-cursor input))) (mark-dirty input)) @@ -1454,13 +1454,13 @@ the cursor position. These are the programmatic equivalents of the Home and End keys and are also used by the Ctrl+A and Ctrl+E keybindings. -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun text-input-move-home (input) (setf (text-input-cursor input) 0) (mark-dirty input)) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun text-input-move-end (input) (setf (text-input-cursor input) (length (text-input-value input))) (mark-dirty input)) @@ -1485,7 +1485,7 @@ A "word" here is defined as a run of non-space characters. This matches the shell/Emacs convention for Ctrl+W rather than an English word boundary (which would involve punctuation handling). -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun text-input-delete-word-before (input) (let* ((val (text-input-value input)) (pos (text-input-cursor input))) (when (zerop pos) (return-from text-input-delete-word-before)) @@ -1523,7 +1523,7 @@ visible characters (letters, digits, punctuation, symbols) are inserted. Control characters and spaces are handled by their specific key bindings. -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defun handle-text-input (input event) (cond ((key-event-ctrl event) @@ -1569,7 +1569,7 @@ The cursor is a solid block ("█") drawn at the cursor column offset from the text start. If the cursor is beyond the truncated display width, it's clamped to the last visible position. -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp (defmethod render ((in text-input) (backend t)) (let* ((ln (text-input-layout-node in)) (x (if ln (layout-node-x ln) 0)) (y (if ln (layout-node-y ln) 0)) @@ -1608,7 +1608,7 @@ polymorphism is handled by the dispatch function. This is the first block tangling to keybindings.lisp, so it includes the ~in-package~ form. -#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp (in-package #:cl-tty.input) (defstruct keymap @@ -1628,11 +1628,11 @@ chord support (e.g., ~(:ctrl+x :ctrl+s)~). Currently only single-key specs work; the timeout and list-of-lists spec syntax are placeholders for the eventual chord implementation. -#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp (defparameter *keymaps* (make-hash-table :test #'equal)) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp (defparameter *chord-timeout* 0.5) #+END_SRC @@ -1657,7 +1657,7 @@ The modifier matching uses ~string=?~ on the modifier part because on the keyword would make them different specifiers, which is unexpected for users writing ~:ctrl+p~ in their keymaps. -#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp (defun key-match-p (spec event) "T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword) or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords." @@ -1716,7 +1716,7 @@ Chords ~((:ctrl+x :ctrl+s))~ are not yet supported; only single key specs work. The ~*chord-timeout*~ variable and list-of-lists syntax are reserved for future implementation. -#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp (defun dispatch-key-event (event &key component) (labels ((try-keymap (km) (when km @@ -1738,7 +1738,7 @@ are reserved for future implementation. ~defkeymap~ is a convenience macro that registers a keymap in the global ~*keymaps*~ hash table. Syntax: -#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp (defmacro defkeymap (name &body bindings) `(setf (gethash ',name *keymaps*) (make-keymap :name ',name @@ -1759,7 +1759,7 @@ This generic function allows the dispatch system to query any object for its keymap, enabling per-component keybinding customization without requiring components to inherit from a specific base class. -#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp ;;; --- Component protocol integration --- (defgeneric component-keymap (component) (:method ((c t)) nil)) @@ -1780,7 +1780,7 @@ The test suite is tangled to ~../tests/input-tests.lisp~ and covers: key-spec matching with all modifiers, list-form specs, return values, empty keymap, local-over-global, multiple bindings, defkeymap macro) -#+BEGIN_SRC lisp :tangle ../tests/input-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/input-tests.lisp (defpackage :cl-tty-input-test (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export #:run-tests)) diff --git a/org/theme.org b/org/theme.org index 20a3b03..bd2bf5a 100644 --- a/org/theme.org +++ b/org/theme.org @@ -49,7 +49,7 @@ and the backend's ~*theme-colors*~ for SGR resolution. Package declaration and test suite registration. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (in-package :cl-tty-box-test) (in-suite box-suite) #+END_SRC @@ -60,7 +60,7 @@ Verifies basic construction of a theme with default ~:dark~ mode. The ~make-theme~ constructor should return an instance of the ~theme~ class with ~:dark~ as the initial mode. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (test theme-create-default "A theme can be created with default mode" (let ((th (make-theme))) @@ -73,7 +73,7 @@ class with ~:dark~ as the initial mode. Verifies explicit ~:light~ mode works. Both modes must produce themes ready to accept color role assignments. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (test theme-create-light "A theme can be created in light mode" (let ((th (make-theme :mode :light))) @@ -86,7 +86,7 @@ Confirms ~setf~ on ~theme-color~ stores a value and that reading it back returns the same string. This is the core read/write contract for the theme's role map. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (test theme-color-set-and-get "theme-color setf/get works" (let ((th (make-theme))) @@ -100,7 +100,7 @@ Unassigned roles must return ~nil~ rather than signaling an error. This allows components to degrade gracefully when a theme doesn't define every possible role. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (test theme-color-unknown-returns-nil "Unknown roles return nil" (let ((th (make-theme))) @@ -113,7 +113,7 @@ Loading the ~:default~ preset in ~:dark~ mode must populate a set of expected roles with their documented hex values. We spot-check ~:primary~, ~:background~, and ~:error~. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (test load-default-dark-preset "Loading the default dark preset populates roles" (let ((th (make-theme :mode :dark))) @@ -129,7 +129,7 @@ The light variant of ~:default~ must produce different values (warm tones on near-white). This validates the mode dispatch inside ~load-preset~. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (test load-default-light-preset "Light variant has different colors" (let ((th (make-theme :mode :light))) @@ -144,7 +144,7 @@ The ~:nord~ preset must produce a distinct cool-blue palette, different from the ~:default~ gold scheme. This validates independent preset data. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (test load-nord-preset "Nord preset has different colors than default" (let ((th (make-theme :mode :dark))) @@ -159,7 +159,7 @@ An unknown preset name must signal a ~warning~ (not an ~error~) and leave the theme's roles unpopulated. This ensures graceful degradation when a preset is missing. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (test load-preset-unknown-warns "Unknown preset warns but doesn't error" (let ((th (make-theme))) @@ -173,7 +173,7 @@ Switching the mode at runtime and re-loading the same preset must produce the other variant's colors. This validates that ~load-preset~ reads the current ~theme-mode~ each time, not a cached value. -#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp (test preset-switch-mode "Switching mode and reloading changes colors" (let ((th (make-theme :mode :dark))) @@ -200,7 +200,7 @@ table storing role→hex mappings, lazily initialized to an empty hash table). Using ~make-hash-table~ as the ~:initform~ ensures each instance gets its own table instead of sharing one. -#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp (in-package :cl-tty.box) (defclass theme () @@ -215,7 +215,7 @@ this in a function lets us change the constructor signature without breaking callers. Mode defaults to ~:dark~, suitable for dark-background terminals; callers pass ~:mode :light~ for light backgrounds. -#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp (defun make-theme (&key (mode :dark)) (make-instance 'theme :mode mode)) #+END_SRC @@ -229,7 +229,7 @@ Reads a semantic role from the theme's roles hash table. Uses degrade gracefully rather than crashing. The backend treats ~nil~ as "use default." -#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))) @@ -241,7 +241,7 @@ The setter companion to ~theme-color~. Storing via ~setf~ writes directly into the roles hash table. Uses ~setf~ on ~gethash~ which creates the entry if it doesn't exist. -#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp (defun (setf theme-color) (hex theme role) "Set the hex color for a semantic ROLE in THEME." (setf (gethash role (theme-roles theme)) hex)) @@ -258,7 +258,7 @@ table keeps preset data inline and readable. Global storage for preset definitions. The ~eq~ test matches keyword identity, which is the fastest hash test for keywords. -#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp (defparameter *presets* (make-hash-table :test #'eq)) #+END_SRC @@ -269,7 +269,7 @@ Registers a preset by name (~keyword~) at macro-expansion time. The ~setf~ of ~gethash~, storing a plist of ~:dark~ and ~:light~ variants. Using a quoted list (not an alist or hash) keeps the data compact. -#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp (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)." @@ -292,7 +292,7 @@ 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. -#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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 @@ -320,7 +320,7 @@ Two presets are built in: 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 +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp (define-preset :default :dark (:primary "#FFD700" :secondary "#B8860B" :accent "#FFA500" :error "#FF4444" :warning "#FF8800" :success "#44BB44" :info "#4488FF" @@ -351,7 +351,7 @@ inverts to warm tones on near-white. 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 +#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp (define-preset :nord :dark (:primary "#88C0D0" :secondary "#81A1C1" :accent "#5E81AC" :error "#BF616A" :warning "#D08770" :success "#A3BE8C" :info "#B48EAD" diff --git a/src/backend/classes.lisp b/src/backend/classes.lisp deleted file mode 100644 index 677a565..0000000 --- a/src/backend/classes.lisp +++ /dev/null @@ -1,109 +0,0 @@ -(in-package :cl-tty.backend) - -(defclass backend () ()) - -(defgeneric initialize-backend (backend) - (:method ((b backend)) b)) - -(defgeneric shutdown-backend (backend) - (:method ((b backend)) (values))) - -(defgeneric backend-size (backend) - (:method ((b backend)) - (values 80 24))) - -(defgeneric backend-write (backend string)) - -(defgeneric backend-clear (backend) - (:method ((b backend)) - (backend-write b (format nil "~C[2J~C[H" #\Esc #\Esc)))) - -(defgeneric draw-text (backend x y string fg bg &key - bold italic underline reverse dim blink - &allow-other-keys)) - -(defgeneric draw-border (backend x y width height - &key style fg bg title title-align)) - -(defgeneric draw-rect (backend x y width height &key bg)) - -(defgeneric draw-link (backend x y string url &key fg bg)) - -(defgeneric draw-ellipsis (backend x y width &key fg bg)) - -(defgeneric cursor-move (backend x y) - (:method ((b backend) x y) (declare (ignore x y)) (values))) - -(defgeneric cursor-hide (backend) - (:method ((b backend)) (values))) - -(defgeneric cursor-show (backend) - (:method ((b backend)) (values))) - -(defgeneric cursor-style (backend shape &key blink) - (:method ((b backend) shape &key blink) (values))) - -(defgeneric begin-sync (backend) - (:method ((b backend)) (values))) - -(defgeneric end-sync (backend) - (:method ((b backend)) (values))) - -(defgeneric read-event (backend &key timeout) - (:method ((b backend) &key timeout) (values nil nil))) - -(defgeneric enable-mouse (backend) - (:method ((b backend)) (values))) - -(defgeneric enable-bracketed-paste (backend) - (:method ((b backend)) (values))) - -(defgeneric capable-p (backend feature) - (:method ((b backend) feature) - (declare (ignore feature)) - nil)) - -(in-package :cl-tty.backend) - -(defgeneric suspend-backend (backend) - (:documentation "Temporarily suspend the backend, restoring terminal to normal state. -Called before SIGTSTP or similar suspension. Application should redraw after resume.") - (:method ((b backend)) (values))) - -(defgeneric resume-backend (backend) - (:documentation "Re-initialize the backend after suspension. -Called after SIGCONT or similar resume. Re-enables raw mode and backend features.") - (:method ((b backend)) (values))) - -(in-package :cl-tty.backend) - -(defmacro with-terminal ((backend-var &optional cols-var rows-var) - &body body) - "Execute BODY with a fully initialized terminal backend. - -DETECT-BACKEND, INITIALIZE-BACKEND, and SHUTDOWN-BACKEND are called -automatically. The backend instance is bound to BACKEND-VAR. If -COLS-VAR and ROWS-VAR are provided, they are bound to the terminal -dimensions at startup. - -The caller should wrap this in SB-POSIX:WITH-RAW-TERMINAL (or -equivalent) if raw-mode input handling is needed. - -Example: - (with-terminal (be cols rows) - (loop for ev = (read-event be :timeout 0.1) - while ev - do (format t \"~A~%\" ev))))" - (let ((be-sym (gensym "BE")) - (c-sym (gensym "COLS")) - (r-sym (gensym "ROWS"))) - `(let* ((,be-sym (detect-backend)) - ,@(when cols-var `((,c-sym (nth-value 0 (backend-size ,be-sym))))) - ,@(when rows-var `((,r-sym (nth-value 1 (backend-size ,be-sym)))))) - (initialize-backend ,be-sym) - (unwind-protect - (let ((,backend-var ,be-sym) - ,@(when cols-var `((,cols-var ,c-sym))) - ,@(when rows-var `((,rows-var ,r-sym)))) - ,@body) - (shutdown-backend ,be-sym))))) diff --git a/src/backend/detection.lisp b/src/backend/detection.lisp deleted file mode 100644 index ca4b932..0000000 --- a/src/backend/detection.lisp +++ /dev/null @@ -1,66 +0,0 @@ -(in-package :cl-tty.backend) - -(defvar *detected-backend* nil - "Cached backend instance from detect-backend. Nil = not yet detected.") - -(defun detect-backend-by-env () - "Check COLORTERM environment variable for modern terminal support. -Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise." - (let ((colorterm (sb-ext:posix-getenv "COLORTERM"))) - (when (and colorterm - (or (search "truecolor" colorterm :test #'char-equal) - (search "24bit" colorterm :test #'char-equal))) - :modern))) - -(defun detect-backend-by-tty () - "Check if stdout is a real terminal (not a pipe/redirect). -Returns T if stdout is interactive, nil otherwise." - (interactive-stream-p *standard-output*)) - -(defun query-terminal (query &optional (timeout 0.1)) - "Send QUERY string to terminal and return any response received within -TIMEOUT seconds. Returns the response string, or nil if no response." - (write-string query *standard-output*) - (force-output *standard-output*) - (sleep timeout) - (let ((response (make-array 0 :element-type 'character - :fill-pointer 0 :adjustable t))) - (loop while (listen *standard-input*) - do (vector-push-extend (read-char-no-hang *standard-input*) response)) - (when (plusp (length response)) - response))) - -(defun detect-backend-by-da1 () - "Send DA1 (ESC[c) query and check for any terminal response. -Returns T if the terminal responds to DA1 (indicating an ANSI-compatible terminal)." - (let ((response (query-terminal (format nil "~C[c" (code-char 27))))) - (when response - ;; Any DA1 response (ESC [ ? digits ... c) means the terminal - ;; understands ANSI escape sequences — good enough for modern-backend - (> (length response) 0)))) - -(defun detect-backend-by-term () - "Check TERM environment variable for modern terminal types. -Returns :modern if TERM contains xterm, tmux, screen, kitty, -alacritty, foot, wezterm, or ghostty." - (let ((term (sb-ext:posix-getenv "TERM"))) - (when term - ;; Known non-modern terms - (unless (or (string-equal term "dumb") - (string-equal term "dump") - (string-equal term "emacs") - (search "52" term)) ; VT52 — no ANSI - :modern)))) - -(defun detect-backend () - "Auto-detect the appropriate backend for the current terminal. -Returns a backend instance (modern-backend or simple-backend). -Result is cached in *detected-backend* for subsequent calls." - (or *detected-backend* - (setf *detected-backend* - (if (and (detect-backend-by-tty) - (or (eql (detect-backend-by-env) :modern) - (detect-backend-by-da1) - (eql (detect-backend-by-term) :modern))) - (make-modern-backend) - (make-simple-backend))))) diff --git a/src/backend/modern-tests.lisp b/src/backend/modern-tests.lisp deleted file mode 100644 index 20b2d2c..0000000 --- a/src/backend/modern-tests.lisp +++ /dev/null @@ -1,116 +0,0 @@ -(defpackage :cl-tty-modern-backend-test - (:use :cl :fiveam :cl-tty.backend) - (:export #:run-tests)) -(in-package :cl-tty-modern-backend-test) - -(def-suite modern-backend-suite :description "Modern backend tests") -(in-suite modern-backend-suite) - -(defun run-tests () - (let ((result (run 'modern-backend-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -(test make-modern-backend-creates - "make-modern-backend returns a modern-backend instance" - (let ((b (make-modern-backend))) - (is (typep b 'cl-tty.backend::modern-backend)))) - -(test sgr-truecolor-foreground - "SGR truecolor foreground escape is correct" - (is (equal (cl-tty.backend::sgr-fg "#FFD700") - (format nil "~C[38;2;255;215;0m" #\Esc)))) - -(test sgr-truecolor-background - "SGR truecolor background escape is correct" - (is (equal (cl-tty.backend::sgr-bg "#1a1b26") - (format nil "~C[48;2;26;27;38m" #\Esc)))) - -(test sgr-named-colors - "SGR named colors resolve to 8-color codes" - (is (equal (cl-tty.backend::sgr-fg :red) - (format nil "~C[31m" #\Esc))) - (is (equal (cl-tty.backend::sgr-bg :blue) - (format nil "~C[44m" #\Esc)))) - -(test sgr-bold-italic - "SGR attribute escapes are correct" - (is (equal (cl-tty.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc))) - (is (equal (cl-tty.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc))) - (is (equal (cl-tty.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc))) - (is (equal (cl-tty.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc)))) - -(test cursor-move-escape - "cursor-move generates correct CSI escape" - (let ((b (make-modern-backend))) - (is (equal (cl-tty.backend::cursor-move-escape 5 10) - (format nil "~C[11;6H" #\Esc))))) - -(test cursor-style-block - "cursor-style :block generate correct escape" - (let ((b (make-modern-backend))) - (is (equal (cl-tty.backend::cursor-style-escape :block nil) - (format nil "~C[2 q" #\Esc))))) - -(test cursor-style-bar - "cursor-style :bar generate correct escape" - (let ((b (make-modern-backend))) - (is (equal (cl-tty.backend::cursor-style-escape :bar nil) - (format nil "~C[6 q" #\Esc))))) - -(test cursor-style-underline-blink - "cursor-style :underline with blink" - (let ((b (make-modern-backend))) - (is (equal (cl-tty.backend::cursor-style-escape :underline t) - (format nil "~C[5 q" #\Esc))))) - -(test decicm-escapes - "DECICM synchronized update escapes" - (is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc))) - (is (equal (cl-tty.backend::decicm-end) (format nil "~C[?2026l" #\Esc)))) - -(test osc8-escape - "OSC 8 hyperlink escape wraps text" - (is (equal (cl-tty.backend::osc8-link "http://example.com" "click here") - (format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\\" - #\Esc #\Esc #\Esc #\Esc)))) - -(test hex-color-parsing - "hex-to-rgb parses valid hex colors" - (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#FFD700") - (is (= r 255)) - (is (= g 215)) - (is (= b 0)))) - -(test hex-color-black - "hex-to-rgb parses black" - (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#000000") - (is (= r 0)) - (is (= g 0)) - (is (= b 0)))) - -(test hex-color-short-form - "hex-to-rgb parses 3-digit hex" - (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#F00") - (is (= r 255)) - (is (= g 0)) - (is (= b 0)))) - -(test border-char-rounded - "modern-border-char returns Unicode box-drawing for rounded style" - (is (equal (cl-tty.backend::border-char :rounded :top-left) "╭")) - (is (equal (cl-tty.backend::border-char :rounded :horizontal) "─")) - (is (equal (cl-tty.backend::border-char :rounded :vertical) "│")) - (is (equal (cl-tty.backend::border-char :rounded :bottom-right) "╯"))) - -(test border-char-double - "modern-border-char returns double-line chars" - (is (equal (cl-tty.backend::border-char :double :top-left) "╔")) - (is (equal (cl-tty.backend::border-char :double :horizontal) "═")) - (is (equal (cl-tty.backend::border-char :double :vertical) "║"))) - -(test suspend-resume-noop - "suspend-backend and resume-backend are no-ops in test context" - (let ((b (make-modern-backend))) - (is (null (multiple-value-list (suspend-backend b)))) - (is (null (multiple-value-list (resume-backend b)))))) diff --git a/src/backend/modern.lisp b/src/backend/modern.lisp deleted file mode 100644 index 5e1be3b..0000000 --- a/src/backend/modern.lisp +++ /dev/null @@ -1,333 +0,0 @@ -(in-package :cl-tty.backend) - -(defun hex-to-rgb (hex) - "Parse a hex color string like \"#FFD700\" into (values r g b). - Also handles 3-digit hex like \"#F00\" (expands to \"#FF0000\")." - (let ((clean (string-trim '(#\# #\Space) hex))) - (if (= (length clean) 3) - ;; Expand 3-digit: #F00 -> #FF0000 - (let* ((r (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t)) - (g (parse-integer (subseq clean 1 2) :radix 16 :junk-allowed t)) - (b (parse-integer (subseq clean 2 3) :radix 16 :junk-allowed t))) - (values (+ r (* r 16)) (+ g (* g 16)) (+ b (* b 16)))) - (values (parse-integer (subseq clean 0 2) :radix 16 :junk-allowed t) - (parse-integer (subseq clean 2 4) :radix 16 :junk-allowed t) - (parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t))))) - -(defparameter *named-colors* - '((:black . 0) (:red . 1) (:green . 2) (:yellow . 3) - (:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7))) - -(defvar *theme-colors* (make-hash-table :test 'eq) - "Hash table mapping theme keywords to hex color strings. -Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg -as a fallback when a keyword is not in *named-colors*.") - -(defun sgr-fg (color) - "Return SGR foreground escape for COLOR." - (if (null color) "" - (cond ((and (stringp color) (char= (char color 0) #\#)) - (multiple-value-bind (r g b) (hex-to-rgb color) - (format nil "~C[38;2;~d;~d;~dm" #\Esc r g b))) - ((keywordp color) - (let ((index (cdr (assoc color *named-colors*)))) - (if index - (format nil "~C[~dm" #\Esc (+ 30 index)) - (let ((hex (gethash color *theme-colors*))) - (if hex - (multiple-value-bind (r g b) (hex-to-rgb hex) - (format nil "~C[38;2;~d;~d;~dm" #\Esc r g b)) - ""))))) - (t "")))) - -(defun sgr-bg (color) - "Return SGR background escape for COLOR." - (if (null color) "" - (cond ((and (stringp color) (char= (char color 0) #\#)) - (multiple-value-bind (r g b) (hex-to-rgb color) - (format nil "~C[48;2;~d;~d;~dm" #\Esc r g b))) - ((keywordp color) - (let ((index (cdr (assoc color *named-colors*)))) - (if index - (format nil "~C[~dm" #\Esc (+ 40 index)) - (let ((hex (gethash color *theme-colors*))) - (if hex - (multiple-value-bind (r g b) (hex-to-rgb hex) - (format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)) - ""))))) - (t "")))) - -(defparameter *sgr-attr-codes* - '((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4) - (:blink . 5) (:reverse . 7) (:reset . 0))) - -(defun sgr-attr (attr) - "Return SGR attribute escape for ATTR keyword." - (let ((code (cdr (assoc attr *sgr-attr-codes*)))) - (if code - (format nil "~C[~dm" #\Esc code) - ""))) - -(defun cursor-move-escape (x y) - "Return CSI escape to move cursor to (x, y), 1-indexed." - (format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x))) - -(defun cursor-style-escape (shape blink) - "Return DECSTR escape for cursor shape." - (let* ((base (case shape - (:block 2) (:underline 4) (:bar 6) - (t 2))) - (code (if blink (1+ base) base))) - (format nil "~C[~d q" #\Esc code))) - -(defun decicm-begin () - "Return escape to enable synchronized updates." - (format nil "~C[?2026h" #\Esc)) - -(defun decicm-end () - "Return escape to disable synchronized updates." - (format nil "~C[?2026l" #\Esc)) - -(defun osc8-link (url text) - "Wrap TEXT in an OSC 8 hyperlink to URL." - (format nil "~C]8;;~A~C\\~A~C]8;;~C\\" - #\Esc url #\Esc text #\Esc #\Esc)) - -(defparameter *border-chars* - '(((:single :top-left) . "┌") ((:single :top-right) . "┐") - ((:single :bottom-left) . "└") ((:single :bottom-right) . "┘") - ((:single :horizontal) . "─") ((:single :vertical) . "│") - ((:double :top-left) . "╔") ((:double :top-right) . "╗") - ((:double :bottom-left) . "╚") ((:double :bottom-right) . "╝") - ((:double :horizontal) . "═") ((:double :vertical) . "║") - ((:rounded :top-left) . "╭") ((:rounded :top-right) . "╮") - ((:rounded :bottom-left) . "╰") ((:rounded :bottom-right) . "╯") - ((:rounded :horizontal) . "─") ((:rounded :vertical) . "│"))) - -(defun border-char (style pos) - "Return the Unicode box-drawing character for STYLE at POS." - (let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal)))) - (or char (if (member pos '(:horizontal :vertical)) - (case pos (:horizontal "─") (:vertical "│")) - "+")))) - -(defclass modern-backend (backend) - ((output-stream :initform *standard-output* - :initarg :output-stream - :accessor backend-output-stream) - (in-sync-p :initform nil :accessor in-sync-p))) - -(defun make-modern-backend (&key color-palette output-stream) - (declare (ignore color-palette)) - (make-instance 'modern-backend :output-stream (or output-stream *standard-output*))) - -(defmethod initialize-backend ((b modern-backend)) - (backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen - (backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic - (backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag - (backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse - (backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste - (backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard - (cursor-hide b) - (finish-output (backend-output-stream b)) - b) - -(defmethod shutdown-backend ((b modern-backend)) - (cursor-show b) - (backend-write b (format nil "~C[?u" #\Esc)) - (backend-write b (format nil "~C[?2004l" #\Esc)) - (backend-write b (format nil "~C[?1006l" #\Esc)) - (backend-write b (format nil "~C[?1002l" #\Esc)) - (backend-write b (format nil "~C[?1000l" #\Esc)) - (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen - (finish-output (backend-output-stream b)) - (values)) - -(defmethod suspend-backend ((b modern-backend)) - (cursor-show b) - (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen - (cursor-move b 0 0) - (finish-output (backend-output-stream b)) - (values)) - -(defmethod resume-backend ((b modern-backend)) - (backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen - (backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic - (backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag - (backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse - (backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste - (backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard - (cursor-hide b) - (finish-output (backend-output-stream b)) - (values)) - -(defmethod backend-size ((b modern-backend)) - ;; Try ioctl on stdout, fall back to /dev/tty, then 80x24. - ;; Each arm uses multiple-value-bind/values to preserve both cols and rows - ;; (or discards secondary values, so we avoid it for multi-value returns). - (multiple-value-bind (cols rows) - (ignore-errors - (let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) - (unwind-protect - (let ((ok (sb-unix:unix-ioctl - (sb-sys:fd-stream-fd (backend-output-stream b)) - 21523 (sb-alien:alien-sap winsize)))) - (when ok - (values (sb-alien:deref winsize 1) ;; cols - (sb-alien:deref winsize 0)))) ;; rows - (sb-alien:free-alien winsize)))) - (if (and cols rows (> cols 0) (> rows 0)) - (values cols rows) - ;; Direct ioctl on /dev/tty. - (multiple-value-bind (cols rows) - (ignore-errors - (let ((tty-fd (sb-unix:unix-open "/dev/tty" 0 0))) - (when (and tty-fd (numberp tty-fd) (> tty-fd 0)) - (unwind-protect - (let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) - (let ((ok (sb-unix:unix-ioctl tty-fd 21523 - (sb-alien:alien-sap winsize)))) - (when ok - (let ((cols (sb-alien:deref winsize 1)) - (rows (sb-alien:deref winsize 0))) - (values cols rows))))) - (sb-unix:unix-close tty-fd))))) - (if (and cols rows (> cols 0) (> rows 0)) - (values cols rows) - (values 80 24)))))) - -(defmethod backend-write ((b modern-backend) string) - (let ((stream (backend-output-stream b))) - (write-string string stream) - (length string))) - -(defmethod capable-p ((b modern-backend) feature) - (member feature '(:truecolor :osc8 :sync :mouse - :bracketed-paste :cursor-style - :kitty-keyboard))) - -(defmethod draw-text ((b modern-backend) x y string fg bg - &key bold italic underline reverse dim blink - &allow-other-keys) - (let* ((style-reset (format nil "~C[22;23;24;25;27m" #\Esc)) - (parts (list (cursor-move-escape x y) - (sgr-fg fg) (sgr-bg bg) - (when bold (sgr-attr :bold)) - (when italic (sgr-attr :italic)) - (when underline (sgr-attr :underline)) - (when reverse (sgr-attr :reverse)) - (when dim (sgr-attr :dim)) - (when blink (sgr-attr :blink)) - string - style-reset))) - (backend-write b (apply #'concatenate 'string parts)))) - -(defmethod draw-border ((b modern-backend) x y width height - &key style fg bg title title-align) - (let* ((s (or style :single)) - (tl (border-char s :top-left)) - (tr (border-char s :top-right)) - (bl (border-char s :bottom-left)) - (br (border-char s :bottom-right)) - (h (border-char s :horizontal)) - (v (border-char s :vertical)) - (fg-esc (sgr-fg fg)) - (bg-esc (sgr-bg bg)) - (reset (format nil "~C[22;23;24;25;27m" #\Esc)) - (inner-width (- width 2)) - (hc (char h 0)) - (top (if (and title (plusp (length title))) - (let* ((align (or title-align :left)) - (max-tlen (- inner-width 2)) - (tlen (min (length title) max-tlen)) - (trunc-title (subseq title 0 tlen))) - (ecase align - (:left - (let ((right-hyphens (- inner-width tlen 2))) - (concatenate 'string - fg-esc bg-esc tl (string #\Space) - trunc-title (string #\Space) - (make-string (max 0 right-hyphens) :initial-element hc) - tr reset (string #\Newline)))) - (:center - (let* ((total-pad (- inner-width tlen)) - (left-pad (floor total-pad 2)) - (right-pad (- total-pad left-pad))) - (concatenate 'string - fg-esc bg-esc tl - (make-string left-pad :initial-element hc) - trunc-title - (make-string right-pad :initial-element hc) - tr reset (string #\Newline)))))) - (concatenate 'string - fg-esc bg-esc tl - (make-string inner-width :initial-element hc) - tr reset (string #\Newline)))) - (mid (concatenate 'string - fg-esc bg-esc v - (make-string inner-width :initial-element #\Space) - v reset (string #\Newline))) - (bot (concatenate 'string - fg-esc bg-esc bl - (make-string inner-width :initial-element hc) - br reset))) - (backend-write b top) - (loop repeat (- height 2) do (backend-write b mid)) - (backend-write b bot))) - -(defmethod draw-rect ((b modern-backend) x y width height &key bg) - (let* ((bg-esc (sgr-bg bg)) - (style-reset (format nil "~C[22;23;24;25;27m" #\Esc)) - (line (concatenate 'string - bg-esc - (make-string width :initial-element #\Space) - style-reset (string #\Newline)))) - (loop :for row :from 0 :below height :do - (backend-write b (cursor-move-escape x (+ y row))) - (backend-write b line)))) - -(defmethod draw-link ((b modern-backend) x y string url - &key fg bg) - (let* ((style-reset (format nil "~C[22;23;24;25;27m" #\Esc)) - (parts (list (cursor-move-escape x y) - (sgr-fg fg) (sgr-bg bg) - (osc8-link url string) - style-reset))) - (backend-write b (apply #'concatenate 'string parts)))) - -(defmethod draw-ellipsis ((b modern-backend) x y width - &key fg bg) - (declare (ignore width)) - (let ((dots "...")) - (draw-text b x y dots fg bg))) - -(defmethod cursor-move ((b modern-backend) x y) - (backend-write b (cursor-move-escape x y))) - -(defmethod cursor-hide ((b modern-backend)) - (backend-write b (format nil "~C[?25l" #\Esc))) - -(defmethod cursor-show ((b modern-backend)) - (backend-write b (format nil "~C[?25h" #\Esc))) - -(defmethod cursor-style ((b modern-backend) shape &key blink) - (backend-write b (cursor-style-escape shape blink))) - -(defmethod enable-mouse ((b modern-backend)) - (backend-write b (format nil "~C[?1000h" #\Esc)) - (backend-write b (format nil "~C[?1002h" #\Esc)) - (backend-write b (format nil "~C[?1006h" #\Esc)) - (finish-output (backend-output-stream b))) - -(defmethod enable-bracketed-paste ((b modern-backend)) - (backend-write b (format nil "~C[?2004h" #\Esc)) - (finish-output (backend-output-stream b))) - -(defmethod begin-sync ((b modern-backend)) - (setf (in-sync-p b) t) - (backend-write b (decicm-begin))) - -(defmethod end-sync ((b modern-backend)) - (setf (in-sync-p b) nil) - (backend-write b (decicm-end)) - (finish-output (backend-output-stream b))) diff --git a/src/backend/package.lisp b/src/backend/package.lisp deleted file mode 100644 index 7657d95..0000000 --- a/src/backend/package.lisp +++ /dev/null @@ -1,35 +0,0 @@ -(defpackage :cl-tty.backend - (:use :cl) - (:export - ;; Backend classes - #:backend #:simple-backend - ;; Lifecycle - #:initialize-backend #:shutdown-backend - #:suspend-backend #:resume-backend - #:backend-size #:backend-write #:backend-clear - ;; Drawing - #:draw-text #:draw-border #:draw-rect - #:draw-link #:draw-ellipsis - ;; Cursor - #:cursor-move #:cursor-hide #:cursor-show #:cursor-style - ;; Sync - #:begin-sync #:end-sync - ;; Input - #:read-event #:enable-mouse #:enable-bracketed-paste - ;; Queries - #:capable-p - ;; Constructors - #:make-simple-backend - #:with-terminal - ;; Modern backend - #:modern-backend #:make-modern-backend - ;; Detection - #:detect-backend #:*detected-backend* - ;; Theme color resolution (populated by theme system) - #:*theme-colors* - ;; Internal (for testing) - #:sgr-fg #:sgr-bg #:sgr-attr - #:cursor-move-escape #:cursor-style-escape - #:decicm-begin #:decicm-end #:osc8-link - #:hex-to-rgb #:border-char)) -(in-package :cl-tty.backend) diff --git a/src/backend/simple.lisp b/src/backend/simple.lisp deleted file mode 100644 index 6b7e939..0000000 --- a/src/backend/simple.lisp +++ /dev/null @@ -1,176 +0,0 @@ -(in-package :cl-tty.backend) - -(defclass simple-backend (backend) - ((output-stream :initform *standard-output* - :initarg :output-stream - :accessor backend-output-stream))) - -(defun make-simple-backend (&key output-stream) - (make-instance 'simple-backend - :output-stream (or output-stream *standard-output*))) - -(defmethod initialize-backend ((b simple-backend)) - b) - -(defmethod shutdown-backend ((b simple-backend)) - (values)) - -(defmethod suspend-backend ((b simple-backend)) - (values)) - -(defmethod resume-backend ((b simple-backend)) - (values)) - -(defmethod end-sync ((b simple-backend)) - (finish-output (backend-output-stream b))) - -(defmethod backend-size ((b simple-backend)) - ;; Try ioctl on fd 0 (stdin), then stdout, then /dev/tty, then 80x24. - ;; Use multiple-value-bind/values to preserve both cols and rows - ;; (or discards secondary values). - (multiple-value-bind (cols rows) - (ignore-errors - (let ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) - (unwind-protect - (let ((ok (sb-unix:unix-ioctl 0 21523 - (sb-alien:alien-sap winsize)))) - (when ok - (let ((c (sb-alien:deref winsize 1)) - (r (sb-alien:deref winsize 0))) - (when (and c r (> c 0) (> r 0)) - (values c r))))) - (sb-alien:free-alien winsize)))) - (if (and cols rows (> cols 0) (> rows 0)) - (values cols rows) - ;; ioctl on stdout fd - (multiple-value-bind (cols rows) - (ignore-errors - (let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) - (unwind-protect - (let ((ok (sb-unix:unix-ioctl - (sb-sys:fd-stream-fd (backend-output-stream b)) - 21523 (sb-alien:alien-sap winsize)))) - (when ok - (values (sb-alien:deref winsize 1) - (sb-alien:deref winsize 0)))) - (sb-alien:free-alien winsize)))) - (if (and cols rows (> cols 0) (> rows 0)) - (values cols rows) - ;; Direct ioctl on /dev/tty - (multiple-value-bind (cols rows) - (ignore-errors - (let ((tty-fd (sb-unix:unix-open "/dev/tty" 0 0))) - (when (and tty-fd (numberp tty-fd) (> tty-fd 0)) - (unwind-protect - (let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) - (let ((ok (sb-unix:unix-ioctl tty-fd 21523 - (sb-alien:alien-sap winsize)))) - (when ok - (values (sb-alien:deref winsize 1) - (sb-alien:deref winsize 0)))) - (sb-alien:free-alien winsize)) - (sb-unix:unix-close tty-fd))))) - (if (and cols rows (> cols 0) (> rows 0)) - (values cols rows) - (values 80 24)))))))) - -(defmethod backend-write ((b simple-backend) string) - (let ((stream (backend-output-stream b))) - (write-string string stream) - (length string))) - -(defmethod draw-text ((b simple-backend) x y string fg bg - &key bold italic underline reverse dim blink - &allow-other-keys) - (let* ((style-reset (format nil "~C[22;23;24;25;27m" #\Esc)) - (parts (list (cursor-move-escape x y) - (sgr-fg fg) (sgr-bg bg) - (when bold (sgr-attr :bold)) - (when italic (sgr-attr :italic)) - (when underline (sgr-attr :underline)) - (when reverse (sgr-attr :reverse)) - (when dim (sgr-attr :dim)) - (when blink (sgr-attr :blink)) - string - style-reset))) - (backend-write b (apply #'concatenate 'string parts)))) - -(defun %simple-border-char (pos) - "Return ASCII border character at POS. -POS is :top-left, :top-right, :bottom-left, :bottom-right, -:horizontal, or :vertical." - (case pos - ((:top-left :top-right :bottom-left :bottom-right) #\+) - (:horizontal #\-) - (:vertical #\|))) - -(defmethod draw-border ((b simple-backend) x y width height - &key style fg bg title title-align) - (declare (ignore style fg bg)) - (let ((h (%simple-border-char :horizontal)) - (v (%simple-border-char :vertical)) - (tl (%simple-border-char :top-left)) - (tr (%simple-border-char :top-right)) - (bl (%simple-border-char :bottom-left)) - (br (%simple-border-char :bottom-right))) - ;; Position cursor with newlines and spaces (no escape sequences) - (dotimes (row y) (backend-write b (string #\Newline))) - ;; Top edge with optional title - (backend-write b (make-string x :initial-element #\space)) - (backend-write b (string tl)) - (if (and title (plusp (length title))) - (let* ((align (or title-align :left)) - (inner-width (- width 2)) - (max-tlen (- inner-width 2)) - (tlen (min (length title) max-tlen)) - (trunc-title (subseq title 0 tlen))) - (ecase align - (:left - (backend-write b (string #\Space)) - (backend-write b trunc-title) - (backend-write b (string #\Space)) - (backend-write b (make-string (- inner-width tlen 2) :initial-element h))) - (:center - (let* ((total-pad (- inner-width tlen)) - (left-pad (floor total-pad 2)) - (right-pad (- total-pad left-pad))) - (backend-write b (make-string left-pad :initial-element h)) - (backend-write b trunc-title) - (backend-write b (make-string right-pad :initial-element h)))))) - (backend-write b (make-string (- width 2) :initial-element h))) - (backend-write b (string tr)) - ;; Sides - (loop for i from 1 below (1- height) - do (backend-write b (string #\Newline)) - (backend-write b (make-string x :initial-element #\space)) - (backend-write b (string v)) - (backend-write b (make-string (- width 2) :initial-element #\space)) - (backend-write b (string v))) - ;; Bottom edge - (backend-write b (string #\Newline)) - (backend-write b (make-string x :initial-element #\space)) - (backend-write b (string bl)) - (backend-write b (make-string (- width 2) :initial-element h)) - (backend-write b (string br)))) - -(defmethod draw-rect ((b simple-backend) x y width height - &key bg) - (let* ((bg-esc (sgr-bg bg)) - (style-reset (format nil "~C[22;23;24;25;27m" #\Esc)) - (line (concatenate 'string - bg-esc - (make-string width :initial-element #\Space) - style-reset (string #\Newline)))) - (loop :for row :from 0 :below height :do - (backend-write b (cursor-move-escape x (+ y row))) - (backend-write b line)))) - -(defmethod draw-link ((b simple-backend) x y string url - &key fg bg) - (declare (ignore url)) - (draw-text b x y string fg bg)) - -(defmethod draw-ellipsis ((b simple-backend) x y width - &key fg bg) - (declare (ignore width)) - (draw-text b x y "..." fg bg)) diff --git a/src/backend/tests.lisp b/src/backend/tests.lisp deleted file mode 100644 index 8e25684..0000000 --- a/src/backend/tests.lisp +++ /dev/null @@ -1,139 +0,0 @@ -(defpackage :cl-tty-backend-test - (:use :cl :fiveam :cl-tty.backend) - (:export #:run-tests)) -(in-package :cl-tty-backend-test) - -(def-suite backend-suite :description "Backend protocol tests") -(in-suite backend-suite) - -(defun make-capturing-backend () - "Create a simple-backend that writes to a string stream." - (let* ((s (make-string-output-stream)) - (b (make-simple-backend :output-stream s))) - (values b s))) - -(defun run-tests () - "Run all backend tests." - (let ((result (run 'backend-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -(test simple-backend-lifecycle - "simple-backend can be created and shut down" - (let ((b (make-simple-backend))) - (is (typep b 'simple-backend)) - (initialize-backend b) - (is-false (capable-p b :truecolor) "simple backend has no truecolor") - (is (null (multiple-value-list (suspend-backend b)))) - (is (null (multiple-value-list (resume-backend b)))) - (shutdown-backend b))) - -(test simple-backend-draw-text - "simple-backend renders text at position, ignoring style" - (multiple-value-bind (b s) (make-capturing-backend) - (initialize-backend b) - (draw-text b 0 0 "hello" :red nil :bold t :italic t) - (shutdown-backend b) - (is (string= (get-output-stream-string s) "hello") - "draw-text should output the string ignoring style"))) - -(test simple-backend-draw-border - "simple-backend draws ASCII border with +-| characters" - (multiple-value-bind (b s) (make-capturing-backend) - (initialize-backend b) - (draw-border b 0 0 5 3 :style :single) - (shutdown-backend b) - (let ((out (get-output-stream-string s))) - (is (search "+---+" out) "top edge should have +---+\"") - (is (search "| |" out) "middle row should have pipe sides")))) - -(test simple-backend-draw-rounded - "simple-backend falls back to straight edges for rounded style" - (multiple-value-bind (b s) (make-capturing-backend) - (initialize-backend b) - (draw-border b 0 0 5 3 :style :rounded) - (shutdown-backend b) - (let ((out (get-output-stream-string s))) - ;; Rounded falls back to ASCII -- identical output to single - (is (search "+---+" out) "rounded style produces same dashes as single")))) - -(test simple-backend-draw-link - "simple-backend renders link as plain text" - (multiple-value-bind (b s) (make-capturing-backend) - (initialize-backend b) - (draw-link b 0 0 "click me" "http://example.com") - (shutdown-backend b) - (is (string= (get-output-stream-string s) "click me") - "simple-backend ignores URL, outputs text only"))) - -(test simple-backend-draw-ellipsis - "simple-backend renders ... for ellipsis" - (multiple-value-bind (b s) (make-capturing-backend) - (initialize-backend b) - (draw-ellipsis b 0 0 5) - (shutdown-backend b) - (is (string= (get-output-stream-string s) "...") - "ellipsis should output 3 dots"))) - -(test capable-p-known-features - "capable-p returns nil for all features on simple-backend" - (let ((b (make-simple-backend))) - (initialize-backend b) - (dolist (f '(:truecolor :osc8 :sync :mouse :bracketed-paste - :kitty-keyboard :sixel :cursor-style)) - (is-false (capable-p b f) - (format nil "~s should not be supported on simple-backend" f))) - (shutdown-backend b))) - -(test backend-size-returns-integers - "backend-size returns two integer values" - (let ((b (make-simple-backend))) - (initialize-backend b) - (multiple-value-bind (cols lines) (backend-size b) - (is (integerp cols)) - (is (integerp lines)) - (is (>= cols 10)) - (is (>= lines 3))) - (shutdown-backend b))) - -(test default-methods-are-no-ops - "Default backend methods don't error" - (let ((b (make-simple-backend))) - (initialize-backend b) - (is (null (multiple-value-list (cursor-hide b)))) - (is (null (multiple-value-list (cursor-show b)))) - (is (null (multiple-value-list (cursor-style b :block)))) - (is (null (multiple-value-list (begin-sync b)))) - (is (null (multiple-value-list (end-sync b)))) - (shutdown-backend b))) - -(test sync-is-noop-on-simple - "begin-sync and end-sync produce no output on simple-backend" - (multiple-value-bind (b s) (make-capturing-backend) - (initialize-backend b) - (begin-sync b) - (draw-text b 0 0 "in sync" nil nil) - (end-sync b) - (shutdown-backend b) - (is (string= (get-output-stream-string s) "in sync") - "no sync escape sequences should appear"))) - -(test draw-rect-fills-area-correctly - "draw-rect with background writes nothing to output (simple-backend no-op)" - (multiple-value-bind (b s) (make-capturing-backend) - (initialize-backend b) - (draw-rect b 0 0 5 3 :bg :red) - (shutdown-backend b) - (is (string= (get-output-stream-string s) "") - "draw-rect is a no-op on simple-backend"))) - -(test detection-returns-backend-instance - "detect-backend returns a valid backend instance" - (let ((be (cl-tty.backend:detect-backend))) - (is (typep be 'cl-tty.backend:backend)))) - -(test detection-caches-result - "detect-backend caches the result in *detected-backend*" - (let ((*detected-backend* nil)) - (cl-tty.backend:detect-backend) - (is-true (not (null cl-tty.backend::*detected-backend*))))) diff --git a/src/components/box-tests.lisp b/src/components/box-tests.lisp deleted file mode 100644 index ab13acf..0000000 --- a/src/components/box-tests.lisp +++ /dev/null @@ -1,162 +0,0 @@ -(defpackage :cl-tty-box-test - (:use :cl :fiveam :cl-tty.backend :cl-tty.layout :cl-tty.box) - (:export #:run-tests)) -(in-package :cl-tty-box-test) - -(def-suite box-suite :description "Box renderable tests") -(in-suite box-suite) - -(defun run-tests () - (let ((result (run 'box-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -(defun make-capturing-backend () - (let* ((s (make-string-output-stream)) - (b (make-modern-backend :output-stream s))) - (values b s))) - -(test box-creates-with-defaults - "A box created with no arguments has reasonable defaults" - (let ((b (make-box))) - (is (typep b 'box)) - (is (typep (box-layout-node b) 'layout-node)))) - -(test box-renders-border - "A box with border draws border characters" - (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-box bx b) - (let ((out (get-output-stream-string s))) - (is (search "┌" out) "top-left corner") - (is (search "┐" out) "top-right corner") - (is (search "└" out) "bottom-left corner") - (is (search "┘" out) "bottom-right corner"))))) - -(test box-renders-background - "A box with background color fills interior" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((bx (make-box :bg :red :width 5 :height 3))) - (compute-layout (box-layout-node bx) 5 3) - (render-box bx b) - (let ((out (get-output-stream-string s))) - (is (search "┌" out) "border with background") - (is (search "41m" out) "SGR background for red"))))) - -(test box-renders-title - "A box with title renders the title text" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((bx (make-box :title "Hello" :width 12 :height 3))) - (compute-layout (box-layout-node bx) 12 3) - (render-box bx b) - (let ((out (get-output-stream-string s))) - (is (search "Hello" out) "title text should appear"))))) - -(test box-without-border - "A box with border-style nil draws no border" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((bx (make-box :border-style nil :bg :red :width 5 :height 3))) - (compute-layout (box-layout-node bx) 5 3) - (render-box bx b) - (let ((out (get-output-stream-string s))) - (is (search "41m" out) "background still renders") - (is-false (search "┌" out) "no top-left corner"))))) - -(test box-zero-size - "A box with any zero dimension renders nothing" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((bx (make-box :border-style :single :width 0 :height 0))) - (compute-layout (box-layout-node bx) 0 0) - (render-box bx b) - (is (string= (get-output-stream-string s) "") - "zero-size box produces no output")))) - -(test box-single-column - "A box with width 1 renders nothing (needs min 2 for border)" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((bx (make-box :border-style :single :width 1 :height 5))) - (compute-layout (box-layout-node bx) 1 5) - (render-box bx b) - (is (string= (get-output-stream-string s) "") - "width=1 box renders nothing")))) - -(test box-minimum-size - "A box with minimum non-zero size still renders" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((bx (make-box :border-style :single :width 2 :height 2))) - (compute-layout (box-layout-node bx) 2 2) - (render-box bx b) - (let ((out (get-output-stream-string s))) - (is (search "┌" out) "2x2 box still has borders"))))) - -(test text-creates-with-defaults - "A text created with no arguments has reasonable defaults" - (let ((txt (make-text ""))) - (is (typep txt 'text)) - (is (typep (text-layout-node txt) 'layout-node)))) - -(test text-renders-content - "A text renders its content at position" - (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-text tx b) - (let ((out (get-output-stream-string s))) - (is (search "Hello" out) "content should appear"))))) - -(test text-empty-string - "Empty text produces no output" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((tx (make-text "" :width 10 :height 1))) - (compute-layout (text-layout-node tx) 10 1) - (render-text tx b) - (is (string= (get-output-stream-string s) "") - "empty string produces no output")))) - -(test text-truncates-when-no-wrap - "Text with wrap-mode :none truncates at width" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((tx (make-text "Hello World" :width 5 :height 1 - :wrap-mode :none))) - (compute-layout (text-layout-node tx) 5 1) - (render-text tx b) - (let ((out (get-output-stream-string s))) - (is (search "Hello" out) "truncated to first 5 chars"))))) - -(test text-word-wraps - "Text with wrap-mode :word wraps at word boundaries" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((tx (make-text "Hello brave new world" :width 6 :height 3))) - (compute-layout (text-layout-node tx) 6 3) - (render-text tx b) - (let ((out (get-output-stream-string s))) - (is (search "Hello" out) "first line") - (is (search "brave" out) "second line") - (is (search "new" out) "third line"))))) - -(test text-word-wrap-single-word - "A word longer than width is hard-broken at max-width" - (multiple-value-bind (b s) (make-capturing-backend) - (let ((tx (make-text "Hello" :width 3 :height 3))) - (compute-layout (text-layout-node tx) 3 3) - (render-text tx b) - (let ((out (get-output-stream-string s))) - (is (search "Hel" out) "first chunk is Hel") - (is (search "lo" out) "second chunk is lo"))))) - -(test span-creates-with-attributes - "A span has text and optional style attributes" - (let ((s (span "bold text" :bold t))) - (is (string= (span-text s) "bold text")) - (is-true (span-bold s)) - (is-false (span-italic s)))) - -(test make-text-with-spans - "Text with spans stores span objects" - (let* ((sp (list (span "Hello" :bold t) - (span "World" :italic t))) - (tx (make-text "" :spans sp))) - (is (= (length (text-spans tx)) 2)) - (is (string= (span-text (elt (text-spans tx) 0)) "Hello")) - (is-true (span-bold (elt (text-spans tx) 0))))) diff --git a/src/components/box.lisp b/src/components/box.lisp deleted file mode 100644 index 9aa08d1..0000000 --- a/src/components/box.lisp +++ /dev/null @@ -1,54 +0,0 @@ -(in-package :cl-tty.box) - -(defclass box (dirty-mixin) - ((layout-node :initform (make-layout-node) :accessor box-layout-node - :initarg :layout-node) - (border-style :initform :single :initarg :border-style - :accessor box-border-style) - (title :initform nil :initarg :title :accessor box-title) - (title-align :initform :left :initarg :title-align - :accessor box-title-align) - (fg :initform nil :initarg :fg :accessor box-fg) - (bg :initform nil :initarg :bg :accessor box-bg))) - -(defun make-box (&key (border-style :single) title - (title-align :left) fg bg - width height) - (make-instance 'box - :border-style border-style - :title title - :title-align title-align - :fg fg - :bg bg - :layout-node (make-layout-node - :width width - :height height - :direction :column))) - -(defun render-box (box backend) - "Render BOX at its computed layout position using BACKEND." - (let ((ln (box-layout-node box)) - (bs (box-border-style box)) - (title (box-title box)) - (fg (box-fg box)) - (bg (box-bg box))) - (let ((x (layout-node-x ln)) - (y (layout-node-y ln)) - (w (layout-node-width ln)) - (h (layout-node-height ln))) - (when (or (zerop w) (zerop h) (< w 2) (< h 2)) - (return-from render-box (values))) - (when bg - (draw-rect backend x y w h :bg bg)) - (when bs - (draw-border backend x y w h :style bs :fg fg :bg bg)) - (when title - (let* ((content-w (- w 4)) - (tx (+ x 2)) - (ty (+ y (if bs 1 0))) - (ta (box-title-align box)) - (display (subseq title 0 (min (length title) content-w)))) - (case ta - (:center (draw-text backend (+ x (ceiling (- w (length display)) 2)) ty display fg bg)) - (:right (draw-text backend (+ x (- w (length display) 2)) ty display fg bg)) - (t (draw-text backend tx ty display fg bg)))))))) diff --git a/src/components/container-package.lisp b/src/components/container-package.lisp deleted file mode 100644 index 0427e23..0000000 --- a/src/components/container-package.lisp +++ /dev/null @@ -1,16 +0,0 @@ -(defpackage :cl-tty.container - (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) - (:export - ;; ScrollBox - #:scroll-box #:make-scroll-box - #:scroll-box-scroll-y #:scroll-box-scroll-x - #:scroll-box-children - #:scroll-by #:sticky-scroll-p - #:clamp-scroll - ;; TabBar - #:tab-bar #:make-tab-bar - #:tab-bar-active #:tab-bar-tabs - #:tab-bar-add #:tab-bar-next #:tab-bar-prev - #:tab-bar-select #:tab-bar-handle-key - ;; Rendering - #:render)) diff --git a/src/components/dialog-package.lisp b/src/components/dialog-package.lisp deleted file mode 100644 index d3e5712..0000000 --- a/src/components/dialog-package.lisp +++ /dev/null @@ -1,25 +0,0 @@ -;;; dialog-package.lisp — Package definition for cl-tty.dialog - -(defpackage :cl-tty.dialog - (:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select) - (:export - #:dialog - #:dialog-title - #:dialog-content - #:dialog-on-dismiss - #:dialog-size - #:dialog-size-pixels - #:render-dialog - #:push-dialog - #:pop-dialog - #:*dialog-stack* - #:alert-dialog - #:confirm-dialog - #:select-dialog - #:prompt-dialog - #:toast - #:toast-message - #:toast-variant - #:render-toast - #:dismiss-toast - #:*toasts*)) diff --git a/src/components/dialog.lisp b/src/components/dialog.lisp deleted file mode 100644 index 5e0aaea..0000000 --- a/src/components/dialog.lisp +++ /dev/null @@ -1,116 +0,0 @@ -(in-package :cl-tty.dialog) - -(defvar *dialog-stack* nil - "Stack of active dialogs. (list) of dialog instances.") - -(defvar *toasts* nil - "List of active toast notifications.") - -(defclass dialog () - ((title :initarg :title :accessor dialog-title) - (size :initarg :size :initform :medium :accessor dialog-size) - (content :initarg :content :initform nil :accessor dialog-content) - (on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss))) - -(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24)) - (multiple-value-bind (dw dh) - (case size - (:small (values 40 8)) - (:medium (values 60 16)) - (:large (values 88 24)) - (t (values 60 16))) - (values (min dw max-w) (min dh max-h)))) - -(defun render-dialog (dialog screen w h) - (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h) - (let ((x (floor (- w dw) 2)) - (y (floor (- h dh) 2))) - ;; Backdrop — dim the full screen - (dotimes (row h) - (draw-rect screen 0 row w 1 :bg :bright-black)) - ;; Dialog panel - (draw-border screen x y dw dh :style :single :title (dialog-title dialog)) - (when (dialog-content dialog) - ;; Content rendering delegated to component system - (draw-text screen (1+ x) (1+ y) - (format nil "~a" (dialog-content dialog)) - :white :default))))) - -(defun push-dialog (dialog) - (push dialog *dialog-stack*) - dialog) - -(defun pop-dialog () - (when *dialog-stack* - (let ((dialog (pop *dialog-stack*))) - (when (dialog-on-dismiss dialog) - (funcall (dialog-on-dismiss dialog))) - dialog))) - -(defun alert-dialog (title message) - (make-instance 'dialog - :title title - :size :small - :content (make-instance 'select - :options (list (list :title "OK" :value :ok)) - :on-select (lambda (opt) (declare (ignore opt)) (pop-dialog))) - :on-dismiss (lambda () (pop-dialog)))) - -(defun confirm-dialog (title message &key on-yes on-no) - (make-instance 'dialog - :title title - :size :small - :content (make-instance 'select - :options (list (list :title "Yes" :value :yes) - (list :title "No" :value :no)) - :on-select (lambda (opt) - (pop-dialog) - (if (eql opt :yes) - (when on-yes (funcall on-yes)) - (when on-no (funcall on-no))))))) - -(defun select-dialog (title options &key on-select) - (make-instance 'dialog - :title title - :size :medium - :content (make-instance 'select - :options options - :on-select (lambda (opt) - (pop-dialog) - (when on-select (funcall on-select opt)))))) - -(defun prompt-dialog (title &key on-submit) - (make-instance 'dialog - :title title - :size :small - :content (make-instance 'text-input - :on-submit (lambda (value) - (pop-dialog) - (when on-submit (funcall on-submit value)))))) - -(defclass toast () - ((message :initarg :message :accessor toast-message) - (variant :initarg :variant :initform :info :accessor toast-variant))) - -(defun render-toast (toast screen w) - (let* ((msg (toast-message toast)) - (variant (toast-variant toast)) - (color (case variant - (:info :blue) (:success :green) - (:warning :yellow) (:error :red))) - (max-w (min 60 (1- w))) - (x (- w max-w 1)) - (text (if (> (length msg) (- max-w 2)) - (concatenate 'string (subseq msg 0 (- max-w 5)) "...") - msg))) - (draw-rect screen x 0 max-w 1 :bg color) - (draw-text screen (1+ x) 0 text :white color :bold t))) - -(defun toast (message &key (variant :info) (duration 0)) - (let ((toast (make-instance 'toast :message message :variant variant))) - (push toast *toasts*) - (when (plusp duration) (dismiss-toast toast)) - toast)) - -(defun dismiss-toast (toast) - (setf *toasts* (remove toast *toasts*))) diff --git a/src/components/dirty-tests.lisp b/src/components/dirty-tests.lisp deleted file mode 100644 index 52488e9..0000000 --- a/src/components/dirty-tests.lisp +++ /dev/null @@ -1,26 +0,0 @@ -(in-package :cl-tty-box-test) -(in-suite box-suite) - -(test dirty-mixin-default-is-dirty - "A dirty-mixin starts as dirty" - (let ((c (make-instance 'dirty-mixin))) - (is-true (dirty-p c) "new component should be dirty"))) - -(in-package :cl-tty-box-test) -(in-suite box-suite) - -(test mark-clean-clears-dirty - "mark-clean sets dirty to nil" - (let ((c (make-instance 'dirty-mixin))) - (mark-clean c) - (is-false (dirty-p c) "after mark-clean, should not be dirty"))) - -(in-package :cl-tty-box-test) -(in-suite box-suite) - -(test mark-dirty-sets-dirty - "mark-dirty sets dirty to t" - (let ((c (make-instance 'dirty-mixin))) - (mark-clean c) - (mark-dirty c) - (is-true (dirty-p c) "after mark-dirty, should be dirty again"))) diff --git a/src/components/dirty.lisp b/src/components/dirty.lisp deleted file mode 100644 index 92edaaa..0000000 --- a/src/components/dirty.lisp +++ /dev/null @@ -1,14 +0,0 @@ -(in-package :cl-tty.box) - -;; ── Dirty Tracking ───────────────────────────────────────────── - -(defclass dirty-mixin () - ((dirty :initform t :accessor dirty-p))) - -(defgeneric mark-clean (component) - (:method ((c dirty-mixin)) - (setf (dirty-p c) nil))) - -(defgeneric mark-dirty (component) - (:method ((c dirty-mixin)) - (setf (dirty-p c) t))) diff --git a/src/components/input-package.lisp b/src/components/input-package.lisp deleted file mode 100644 index 2eff30e..0000000 --- a/src/components/input-package.lisp +++ /dev/null @@ -1,38 +0,0 @@ -(defpackage :cl-tty.input - (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout) - (:export - ;; Key events - #:key-event #:make-key-event - #:key-event-p #:key-event-key #:key-event-ctrl - #:key-event-alt #:key-event-shift #:key-event-code - #:key-event-raw #:key-event-text - ;; Mouse events - #:mouse-event #:make-mouse-event - #:mouse-event-p #:mouse-event-type #:mouse-event-button - #:mouse-event-x #:mouse-event-y - ;; Terminal raw mode - #:save-terminal-state #:set-raw-mode #:restore-terminal-state - #:with-raw-terminal - ;; Event reading - #:read-event - #:*terminal-resized-p* - ;; UTF-8 input support - #:utf8-decode - ;; TextInput - #:text-input #:make-text-input - #:text-input-value #:text-input-cursor - #:text-input-placeholder #:text-input-max-length - #:text-input-on-submit #:text-input-layout-node - #:handle-text-input #:render-text-input - ;; Textarea - #:textarea #:make-textarea - #:textarea-value #:textarea-cursor-row #:textarea-cursor-col - #:textarea-lines - #:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack - #:textarea-layout-node - #:handle-textarea-input #:render-textarea - ;; Keybindings - #:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent - #:*keymaps* #:*chord-timeout* - #:defkeymap #:dispatch-key-event #:key-match-p - #:component-keymap)) diff --git a/src/components/input.lisp b/src/components/input.lisp deleted file mode 100644 index e0c59fe..0000000 --- a/src/components/input.lisp +++ /dev/null @@ -1,284 +0,0 @@ -(in-package #:cl-tty.input) - -(defun %split-string (string separator) - "Split STRING at each occurrence of SEPARATOR. Returns list of strings." - (loop with start = 0 - for pos = (position separator string :start start) - collect (subseq string start pos) - while pos - do (setf start (1+ pos)))) - -(defvar *current-backend* nil - "The active backend used for rendering.") - -(defvar *current-theme* nil - "The active theme used for semantic color resolution.") - -(defstruct key-event - (key nil :type (or keyword null)) - (ctrl nil :type boolean) - (alt nil :type boolean) - (shift nil :type boolean) - (code nil :type (or fixnum null)) - (raw nil :type (or string null)) - (text nil :type (or string null))) - -(defstruct mouse-event - (type nil :type (or keyword null)) - (button nil :type (or keyword null)) - (x 0 :type fixnum) - (y 0 :type fixnum)) - -(defparameter *csi-tilde-table* - '((1 . :home) (2 . :insert) (3 . :delete) (4 . :end) - (5 . :page-up) (6 . :page-down) - (11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4) - (15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8) - (20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12))) - -(defparameter *csi-key-table* - '((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left) - (#\F . :end) (#\H . :home) - (#\P . :f1) (#\Q . :f2) (#\R . :f3) (#\S . :f4) - (#\Z . :back-tab))) - -(defun parse-csi-params (params terminator extended) - (let* ((term-char (code-char terminator)) - (tilde-key (when (find term-char '(#\~ #\u)) - (cdr (assoc (first params) *csi-tilde-table*)))) - ;; If tilde/u lookup fails, try direct csi-key-table match (ESC[A etc.) - ;; For u-terminator with cursor codes (1=up,2=down,3=right,4=left) that - ;; aren't in *csi-tilde-table* (which maps 1→:home,2→:insert,3→:delete...), - ;; handle them explicitly before falling through to :codepoint. - (key (or tilde-key - (and (eql term-char #\u) - (case (first params) - (1 :up) (2 :down) (3 :right) (4 :left) - (5 :page-up) (6 :page-down) - (otherwise (cdr (assoc (first params) *csi-tilde-table*))))) - (cdr (assoc term-char *csi-key-table*)))) - (modifier (when (and (> (length params) 1) (not (find term-char '(#\~ #\u)))) - (second params))) - (actual-modifier (when (> (length extended) 1) (second extended))) - (ctrl nil) (alt nil) (shift nil)) - (when modifier - (setf shift (logtest modifier 1) - alt (logtest modifier 2) - ctrl (logtest modifier 4))) - (when actual-modifier - (setf shift (or shift (logtest actual-modifier 1)) - alt (or alt (logtest actual-modifier 2)) - ctrl (or ctrl (logtest actual-modifier 4)))) - (if (and (eql term-char #\u) (not key)) - ;; Kitty protocol with unknown codepoint — send as :codepoint - (let ((code (first params))) - (make-key-event :key :codepoint :code code - :ctrl ctrl :alt alt :shift shift - :raw (string (code-char code)))) - (make-key-event :key (or key :unknown) - :ctrl ctrl :alt alt :shift shift - :raw (if (consp params) - (format nil "~C[~{~d~};~d" #\Esc params terminator) - ""))))) - - -(defun read-raw-byte (&key timeout) - (let* ((buf (make-array 1 :element-type '(unsigned-byte 8))) - (fd 0) - (timeout-ms (when timeout (max 1 (round (* timeout 1000)))))) - (sb-sys:with-pinned-objects (buf) - (let ((sap (sb-sys:vector-sap buf))) - (if timeout-ms - (let ((poll-result (sb-unix:unix-simple-poll fd :input timeout-ms))) - (if poll-result - (let ((n (sb-unix:unix-read fd sap 1))) - (if (= n 1) (aref buf 0) (values nil :eof))) - (values nil nil))) - (let ((n (sb-unix:unix-read fd sap 1))) - (if (= n 1) (aref buf 0) (values nil :eof)))))))) - -(defun %read-escape-sequence (&optional (timeout 0.1)) - (flet ((read-next (&optional (to timeout)) - (let ((b (read-raw-byte :timeout to))) - (unless b (return-from %read-escape-sequence - (make-key-event :key :escape :code 27))) - b))) - (let ((b1 (read-next timeout))) - (cond - ((null b1) (make-key-event :key :escape :code 27)) - ((= b1 79) (let ((b2 (read-next timeout))) - (case b2 - (80 (make-key-event :key :f1)) - (81 (make-key-event :key :f2)) - (82 (make-key-event :key :f3)) - (83 (make-key-event :key :f4)) - (72 (make-key-event :key :home)) - (70 (make-key-event :key :end)) - (65 (make-key-event :key :up :shift t)) - (66 (make-key-event :key :down :shift t)) - (67 (make-key-event :key :right :shift t)) - (68 (make-key-event :key :left :shift t)) - (otherwise (make-key-event :key :unknown :raw (string (code-char b2))))))) - ((= b1 91) (parse-csi-sequence :timeout timeout)) - ((= b1 127) (make-key-event :key :alt-backspace)) - ((< b1 32) - (let ((c (code-char (+ b1 96)))) - (make-key-event :key (intern (string-upcase (string c)) :keyword) - :alt t :code b1))) - (t (make-key-event :key (intern (string-upcase (string (code-char b1))) :keyword) - :alt t :code b1)))))) - -(defun %read-digits (&optional (initial-bytes nil) (timeout 0.5)) - "Read bytes until a non-digit is encountered. -Returns (values number terminator-byte)." - (let ((acc nil)) - (dolist (b initial-bytes) - (when (and (>= b 48) (<= b 57)) - (push (- b 48) acc))) - (loop for b = (read-raw-byte :timeout timeout) - while (and b (>= b 48) (<= b 57)) - do (push (- b 48) acc) - finally (return (values (if acc - (reduce (lambda (n d) (+ (* n 10) d)) - (reverse acc)) - 0) - b))))) - -(defun %parse-sgr-mouse (&optional (timeout 0.5)) - "Parse SGR mouse escape sequence: ESC [ < Cb ; Cx ; Cy M/m -Returns a mouse-event struct." - (let ((b (read-raw-byte :timeout timeout))) - (unless b (return-from %parse-sgr-mouse nil)) - (multiple-value-bind (cb sep1) (%read-digits (list b) timeout) - (declare (ignore sep1)) - (multiple-value-bind (cx sep2) (%read-digits nil timeout) - (declare (ignore sep2)) - (multiple-value-bind (cy term) (%read-digits nil timeout) - (let ((button (cond - ((= cb 0) :left) - ((= cb 1) :middle) - ((= cb 2) :right) - ((= cb 64) :scroll-up) - ((= cb 65) :scroll-down) - ((>= cb 32) :drag) - (t :left))) - (type (cond - ((= term 77) :press) - ((= term 109) :release) - (t :press)))) - (make-mouse-event :type type :button button - :x (- cx 1) :y (- cy 1)))))))) - -(defun parse-csi-sequence (&key (timeout 0.1)) - (flet ((read-param (next-fn) (let ((acc nil)) - (loop for b = (funcall next-fn) - do (if (and b (>= b 48) (<= b 57)) - (push (- b 48) acc) - (return (values (reverse acc) b))))))) - (let* ((b2 (read-raw-byte :timeout timeout))) - (unless b2 (return-from parse-csi-sequence - (make-key-event :key :escape :code 27))) - (if (= b2 60) ;; < — SGR mouse marker - (or (%parse-sgr-mouse timeout) - (make-key-event :key :escape :code 27)) - (let ((extended (make-array 8 :element-type 'fixnum :fill-pointer 0))) - (multiple-value-bind (params terminator) - (if (and (>= b2 48) (<= b2 57)) - (multiple-value-bind (p term) (read-param (lambda () - (read-raw-byte :timeout timeout))) - (unless term (return-from parse-csi-sequence - (make-key-event :key :escape :code 27))) - (setf (fill-pointer extended) (length p)) - (replace extended p) - (values p term)) - (progn (vector-push-extend b2 extended) - (multiple-value-bind (p term) - (read-param (lambda () - (read-raw-byte :timeout timeout))) - (unless term (return-from parse-csi-sequence - (make-key-event :key :escape :code 27))) - (values p term)))) - (parse-csi-params params terminator extended))))))) - -(defun utf8-decode (bytes) - (case (length bytes) - (2 (let ((b0 (first bytes)) (b1 (second bytes))) - (when (and (<= #xc2 b0 #xdf) (<= #x80 b1 #xbf)) - (+ (ash (logand b0 #x1f) 6) (logand b1 #x3f))))) - (3 (let ((b0 (first bytes)) (b1 (second bytes)) (b2 (third bytes))) - (when (and (<= #xe0 b0 #xef) (<= #x80 b1 #xbf) (<= #x80 b2 #xbf)) - (+ (ash (logand b0 #x0f) 12) (ash (logand b1 #x3f) 6) (logand b2 #x3f))))) - (4 (let ((b0 (first bytes)) (b1 (second bytes)) (b2 (third bytes)) (b3 (fourth bytes))) - (when (and (<= #xf0 b0 #xf4) (<= #x80 b1 #xbf) (<= #x80 b2 #xbf) (<= #x80 b3 #xbf)) - (+ (ash (logand b0 #x07) 18) (ash (logand b1 #x3f) 12) - (ash (logand b2 #x3f) 6) (logand b3 #x3f))))) - (t nil))) - -(defun %read-event (&key timeout) - (multiple-value-bind (b reason) (read-raw-byte :timeout timeout) - (unless b (return-from %read-event (if (eq reason :eof) :eof nil))) - (cond - ((= b #x1b) (%read-escape-sequence timeout)) - ((= b #x09) (make-key-event :key :tab :code #x09)) - ((= b #x0a) (make-key-event :key :enter :code #x0a)) - ((= b #x0d) (make-key-event :key :enter :code #x0d)) - ((or (= b #x7f) (= b #x08)) (make-key-event :key :backspace :code b)) - ((and (>= b #x01) (<= b #x1a)) - (let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword))) - (make-key-event :key key :ctrl t :code b))) - ((= b #x1c) (make-key-event :key :backslash :ctrl t :code b)) - ((= b #x1d) (make-key-event :key :rbracket :ctrl t :code b)) - ((= b #x1e) (make-key-event :key :caret :ctrl t :code b)) - ((= b #x1f) (make-key-event :key :underscore :ctrl t :code b)) - ((and (>= b #x20) (<= b #x7e)) - (let ((ch (code-char b))) - (make-key-event :key (intern (string (string-upcase ch)) :keyword) :code b))) - ((>= b #xc2) - (let* ((n (cond ((<= b #xdf) 2) ((<= b #xef) 3) (t 4))) - (bytes (list b))) - (loop for i from 1 below n - for b2 = (multiple-value-bind (byte reason) (read-raw-byte :timeout 0.5) - (declare (ignore reason)) byte) - while (and b2 (<= #x80 b2 #xbf)) - do (push b2 bytes)) - (setf bytes (nreverse bytes)) - (if (= (length bytes) n) - (let ((cp (utf8-decode bytes))) - (if cp (make-key-event :key :codepoint :code cp :raw (map 'string #'code-char bytes)) - (make-key-event :key :unknown :raw (map 'string #'code-char bytes)))) - (make-key-event :key :unknown :raw (map 'string #'code-char bytes))))) - (t (make-key-event :key :unknown :code b :raw (string (code-char b))))))) - -(defvar *terminal-resized-p* nil) - -#+sbcl -(eval-when (:load-toplevel :execute) - (require :sb-posix) - (sb-sys:enable-interrupt sb-posix:sigwinch - (lambda (signal info context) - (declare (ignore signal info context)) - (setf *terminal-resized-p* t)))) - -(defun %raw-mode-on () - (uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr") - :output nil :error-output nil :ignore-error-status t)) - -(defun %raw-mode-off () - (uiop:run-program '("stty" "sane") - :output nil :error-output nil :ignore-error-status t)) - -(defmacro with-raw-terminal (&body body) - "Execute BODY with the terminal in raw mode." - `(unwind-protect - (progn (%raw-mode-on) ,@body) - (%raw-mode-off))) - -(defmethod read-event ((b cl-tty.backend:backend) &key timeout) - ;; Check for pending terminal resize before reading input. - ;; The SIGWINCH handler sets *terminal-resized-p* asynchronously. - (when *terminal-resized-p* - (setf *terminal-resized-p* nil) - (multiple-value-bind (w h) (backend-size b) - (return-from read-event (values :resize (cons w h))))) - (when (probe-file "/dev/stdin") - (%read-event :timeout timeout))) diff --git a/src/components/keybindings.lisp b/src/components/keybindings.lisp deleted file mode 100644 index 28997f2..0000000 --- a/src/components/keybindings.lisp +++ /dev/null @@ -1,63 +0,0 @@ -(in-package #:cl-tty.input) - -(defstruct keymap - (name nil :type (or keyword null)) - (bindings nil :type list) - (parent nil :type (or keymap null))) - -(defparameter *keymaps* (make-hash-table :test #'equal)) - -(defparameter *chord-timeout* 0.5) - -(defun key-match-p (spec event) - "T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword) - or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords." - (etypecase spec - ;; Keyword like :ctrl+p, :alt+f, :enter, :space, :f1 - (keyword - (let* ((name (string spec)) - (plus (position #\+ name))) - (if plus - ;; Modified key: :ctrl+p -> mod-str="CTRL", key-str="P" - (let ((mod-str (subseq name 0 plus)) - (key-str (subseq name (1+ plus)))) - (and (eql (intern key-str :keyword) - (key-event-key event)) - (cond - ((string= mod-str "CTRL") (key-event-ctrl event)) - ((string= mod-str "ALT") (key-event-alt event)) - ((string= mod-str "SHIFT") (key-event-shift event)) - (t t)))) - ;; Plain keyword: :enter, :escape, :f1, etc. - (eql spec (key-event-key event))))) - ;; List: (:ctrl+p) or (:ctrl+x :ctrl+s) - (list - (when spec - (key-match-p (first spec) event))))) - -(defun dispatch-key-event (event &key component) - (labels ((try-keymap (km) - (when km - (loop for (spec . handler) in (keymap-bindings km) - thereis (when (key-match-p spec event) - (funcall handler event) - t)))) - (find-keymap (name) - (gethash name *keymaps*))) - (or (and component - (let ((km (component-keymap component))) - (when km (try-keymap km)))) - (try-keymap (find-keymap :local)) - (try-keymap (find-keymap :global))))) - -(defmacro defkeymap (name &body bindings) - `(setf (gethash ',name *keymaps*) - (make-keymap :name ',name - :bindings (list ,@(loop for b in bindings - collect (if (consp (cdr b)) - `(cons ',(car b) ,(cadr b)) - `(cons ',(car b) ,(cdr b)))))))) - -;;; --- Component protocol integration --- -(defgeneric component-keymap (component) - (:method ((c t)) nil)) diff --git a/src/components/markdown-package.lisp b/src/components/markdown-package.lisp deleted file mode 100644 index 77a2c3c..0000000 --- a/src/components/markdown-package.lisp +++ /dev/null @@ -1,9 +0,0 @@ -(defpackage :cl-tty.markdown - (:use :cl) - (:export - #:make-md-node #:md-node-p #:md-node-text - #:parse-blocks #:parse-inline - #:highlight-code - #:classify-diff-line #:render-md #:render-md-node - #:render-markdown #:render-inline - #:apply-style #:apply-styles)) diff --git a/src/components/markdown.lisp b/src/components/markdown.lisp deleted file mode 100644 index f3f5ce7..0000000 --- a/src/components/markdown.lisp +++ /dev/null @@ -1,672 +0,0 @@ -;;; markdown.lisp — Markdown + Code + Diff rendering for cl-tty - -(in-package :cl-tty.markdown) - -(defun make-md-node (type &key children properties content url) - (let ((node (list :type type))) - (when children (setf (getf node :children) children)) - (when properties (setf (getf node :properties) properties)) - (when content (setf (getf node :content) content)) - (when url (setf (getf node :url) url)) - node)) - -(defun md-node-p (thing) - (and (listp thing) (getf thing :type))) - -(defun md-node-text (node) - (let ((type (getf node :type))) - (cond ((eql type :text) (or (getf node :content) "")) - ((eql type :link) - (concatenate 'string - (md-node-text (first (getf node :children))) - (format nil " (~a)" (or (getf node :url) "")))) - ((eql type :inline-code) (or (getf node :content) "")) - ((getf node :children) - (apply #'concatenate 'string - (mapcar #'md-node-text (getf node :children)))) - (t "")))) - -(defun split-string-into-lines (string) - (unless string (return-from split-string-into-lines (coerce nil 'vector))) - (let ((result nil) (start 0)) - (flet ((add-line (end) (push (subseq string start end) result))) - (loop for i from 0 below (length string) - do (let ((c (char string i))) - (cond ((char= c #\Newline) (add-line i) (setf start (1+ i))) - ((and (char= c #\Return) (< (1+ i) (length string)) - (char= (char string (1+ i)) #\Newline)) - (add-line i) (setf start (+ i 2)) (incf i))))) - (when (< start (length string)) (add-line (length string))) - (coerce (nreverse result) 'vector)))) - -(defun classify-line (line) - (cond - ((string= line "") (cons :blank nil)) - ((and (>= (length line) 3) - (let ((c0 (char line 0))) - (and (find c0 "-*") - (every (lambda (c) (or (char= c c0) (char= c #\Space) (char= c #\Tab))) - line)))) - (cons :thematic-break nil)) - ((and (char= (char line 0) #\#) - (let ((count 0)) - (loop for c across line while (char= c #\#) do (incf count)) - (and (<= 1 count 6) - (or (>= (length line) (1+ count)) - (member (char line count) '(#\Space #\Tab)))))) - (let* ((hash-count (loop for c across line while (char= c #\#) count c)) - (content (string-trim (list #\Space #\Tab) (subseq line hash-count)))) - (cons :heading (cons hash-count content)))) - ((char= (char line 0) #\>) - (cons :blockquote (string-trim (list #\Space #\Tab) (subseq line 1)))) - ((and (>= (length line) 2) (find (char line 0) "-*+") - (char= (char line 1) #\Space)) - (cons :list-item (string-trim (list #\Space #\Tab) (subseq line 2)))) - ((and (>= (length line) 3) (digit-char-p (char line 0)) - (loop for c across line while (digit-char-p c) - finally (return (find c ". )")))) - (let ((dot-pos (position-if (lambda (c) (find c ". )")) line))) - (if (and dot-pos (find (char line dot-pos) ". )")) - (cons :ordered-item (string-trim (list #\Space #\Tab) - (subseq line (1+ dot-pos)))) - (cons :paragraph line)))) - ((and (>= (length line) 4) (find (char line 0) "-+") - (char= (char line 1) (char line 0)) - (char= (char line 2) (char line 0)) - (char= (char line 3) #\Space)) - (cons :diff-header line)) - ((and (>= (length line) 1) (find (char line 0) "-+") - (not (and (>= (length line) 3) - (char= (char line 1) (char line 0)) - (char= (char line 2) (char line 0))))) - (cons :diff-line (cons (char line 0) (subseq line 1)))) - ((and (>= (length line) 3) (find (char line 0) "`~") - (let ((fence-len (loop for c across line - while (char= c (char line 0)) count c))) - (and (>= fence-len 3) - (let ((rest (string-trim (list #\Space #\Tab) - (subseq line fence-len)))) - (cons :code-start rest)))))) - (t (cons :paragraph line)))) - -(defun find-closing-marker (text start marker) - (let ((marker-len (length marker)) (len (length text))) - (loop for j from start to (- len marker-len) - do (when (and (char= (char text j) (char marker 0)) - (string= marker (subseq text j (+ j marker-len))) - (or (= j 0) (not (char= (char text (1- j)) #\\)))) - (return j)) - finally (return nil)))) - -(defun parse-paragraph (lines start) - (let ((text-parts nil) (i start)) - (loop while (< i (length lines)) - do (let* ((raw-line (aref lines i)) - (line (string-trim (list #\return) raw-line)) - (class (classify-line line))) - (case (car class) - ((:paragraph) (push (cdr class) text-parts) (incf i)) - (:blank (incf i) (loop-finish)) - (t (loop-finish))))) - (values (make-md-node :paragraph :children - (parse-inline - (with-output-to-string (s) - (loop for part in (nreverse text-parts) - for first = t then nil - do (unless first (write-char #\Space s)) - (princ part s))))) - i))) - -(defun parse-blockquote (lines start) - (let ((text-parts nil) (i start)) - (loop while (< i (length lines)) - do (let* ((raw-line (aref lines i)) - (line (string-trim (list #\return) raw-line)) - (class (classify-line line))) - (case (car class) - (:blockquote (push (cdr class) text-parts) (incf i)) - (:blank (incf i) (loop-finish)) - (t (loop-finish))))) - (values (make-md-node :blockquote :children - (parse-inline - (with-output-to-string (s) - (loop for part in (nreverse text-parts) - for first = t then nil - do (unless first (write-char #\Space s)) - (princ part s))))) - i))) - -(defun parse-list (lines start) - (let ((items nil) (i start)) - (loop while (< i (length lines)) - do (let* ((raw-line (aref lines i)) - (line (string-trim (list #\return) raw-line)) - (class (classify-line line))) - (case (car class) - ((:list-item :ordered-item) - (push (cons (car class) (cdr class)) items) (incf i)) - (:blank - (if (and (< (1+ i) (length lines)) - (let ((nc (classify-line - (string-trim (list #\return) - (aref lines (1+ i)))))) - (member (car nc) '(:list-item :ordered-item)))) - (progn (push (cons :blank-sep nil) items) (incf i)) - (progn (incf i) (loop-finish)))) - (t (loop-finish))))) - (let ((nodes nil)) - (dolist (item (nreverse items)) - (let ((type (car item)) (content (cdr item))) - (when (and content (not (string= content ""))) - (push (make-md-node type :children (parse-inline content)) nodes)))) - (values (nreverse nodes) i)))) - -(defun parse-code-block (lines start lang) - (let ((code-lines nil) - (i (1+ start)) - (fence-char (char (aref lines start) 0)) - (fence-len (loop for c across (aref lines start) - while (char= c (char (aref lines start) 0)) count c))) - (loop while (< i (length lines)) - do (let* ((raw-line (aref lines i)) - (line (string-trim (list #\return) raw-line))) - (when (and (>= (length line) fence-len) - (every (lambda (c) (char= c fence-char)) - (subseq line 0 fence-len)) - (or (= (length line) fence-len) - (every (lambda (c) (find c " \t")) - (subseq line fence-len)))) - (incf i) (loop-finish)) - (push line code-lines) - (incf i))) - (values (make-md-node :code-block - :properties (list :language (and lang (not (string= lang "")) lang)) - :content - (with-output-to-string (s) - (loop for cl in (nreverse code-lines) - for first = t then nil - do (unless first (terpri s)) (princ cl s)))) - i))) - -(defun parse-diff-block (lines start) - (let ((diff-lines nil) (i start)) - (loop while (< i (length lines)) - do (let* ((raw-line (aref lines i)) - (line (string-trim (list #\return) raw-line)) - (class (classify-line line))) - (case (car class) - ((:diff-header :diff-line) (push line diff-lines) (incf i)) - (:blank (incf i) (loop-finish)) - (t (loop-finish))))) - (let ((lines-list (nreverse diff-lines))) - (values (make-md-node :diff-block - :content - (with-output-to-string (s) - (loop for dl in lines-list - for first = t then nil - do (unless first (terpri s)) (princ dl s))) - :properties (list :lines lines-list)) - i)))) - -(defun parse-blocks (text) - (unless text (return-from parse-blocks nil)) - (let ((lines (split-string-into-lines text)) (nodes nil) (i 0)) - (loop while (< i (length lines)) - do (let* ((line (string-trim (list #\return) (aref lines i))) - (classification (classify-line line))) - (case (car classification) - (:blank (incf i)) - (:thematic-break (push (make-md-node :thematic-break) nodes) (incf i)) - (:paragraph - (multiple-value-bind (node consumed) (parse-paragraph lines i) - (push node nodes) (setf i consumed))) - (:heading - (let* ((level+content (cdr classification)) - (level (car level+content)) - (content (cdr level+content))) - (push (make-md-node :heading :properties (list :level level) - :children (parse-inline content)) nodes) - (incf i))) - (:blockquote - (multiple-value-bind (node consumed) (parse-blockquote lines i) - (push node nodes) (setf i consumed))) - (:list-item - (multiple-value-bind (node consumed) (parse-list lines i) - (dolist (n node) (push n nodes)) (setf i consumed))) - (:ordered-item - (multiple-value-bind (node consumed) (parse-list lines i) - (dolist (n node) (push n nodes)) (setf i consumed))) - (:code-start - (multiple-value-bind (node consumed) - (parse-code-block lines i (cdr classification)) - (push node nodes) (setf i consumed))) - (:diff-header - (multiple-value-bind (node consumed) (parse-diff-block lines i) - (push node nodes) (setf i consumed))) - (t (incf i))))) - (nreverse nodes))) - -(defun parse-inline (text) - (unless (and text (> (length text) 0)) (return-from parse-inline nil)) - (let ((nodes nil) (i 0) (len (length text))) - (loop while (< i len) - do (let ((c (char text i))) - (case c - (#\* - (multiple-value-bind (node consumed) (parse-star-emphasis text i len) - (if node (progn (push node nodes) (setf i consumed)) - (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) - (#\_ - (multiple-value-bind (node consumed) (parse-underscore-emphasis text i len) - (if node (progn (push node nodes) (setf i consumed)) - (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) - (#\` - (multiple-value-bind (node consumed) (parse-inline-code text i len) - (if node (progn (push node nodes) (setf i consumed)) - (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) - (#\[ - (multiple-value-bind (node consumed) (parse-link text i len) - (if node (progn (push node nodes) (setf i consumed)) - (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) - (t (let ((start i)) - (incf i) - (loop while (< i len) - do (let ((nc (char text i))) - (if (find nc "*_`[") (loop-finish) - (progn - (when (and (< (1+ i) len) - (find nc "*_") - (char= nc (char text (1+ i)))) - (loop-finish)) - (incf i))))) - (push (make-md-node :text :content (subseq text start i)) nodes)))))) - (nreverse nodes))) - -(defun parse-star-emphasis (text i len) - (when (>= i len) (return-from parse-star-emphasis (values nil i))) - (if (and (< (1+ i) len) (char= (char text (1+ i)) #\*)) - (let ((close (find-closing-marker text (+ i 2) "**"))) - (if close - (values (make-md-node :bold :children (parse-inline (subseq text (+ i 2) close))) - (+ close 2)) - (values nil i))) - (let ((close (find-closing-marker text (1+ i) "*"))) - (if close - (values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close))) - (1+ close)) - (values nil i))))) - -(defun parse-underscore-emphasis (text i len) - (when (>= i len) (return-from parse-underscore-emphasis (values nil i))) - (when (and (> i 0) (not (find (char text (1- i)) " \t\n\r"))) - (return-from parse-underscore-emphasis (values nil i))) - (if (and (< (1+ i) len) (char= (char text (1+ i)) #\_)) - (let ((close (find-closing-marker text (+ i 2) "__"))) - (if close - (values (make-md-node :bold :children (parse-inline (subseq text (+ i 2) close))) - (+ close 2)) - (values nil i))) - (let ((close (find-closing-marker text (1+ i) "_"))) - (if (and close - (or (>= (1+ close) len) - (find (char text (1+ close)) " \t\n\r.,;:!?"))) - (values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close))) - (1+ close)) - (values nil i))))) - -(defun parse-inline-code (text i len) - (when (or (>= i len) (not (char= (char text i) #\`))) - (return-from parse-inline-code (values nil i))) - (let ((bt-count (loop for j from i below (min len (+ i 3)) - while (char= (char text j) #\`) count j))) - (let ((close (find-closing-marker text (+ i bt-count) - (make-string bt-count :initial-element #\`)))) - (if close - (values (make-md-node :inline-code - :content (subseq text (+ i bt-count) close)) - (+ close bt-count)) - (values nil i))))) - -(defun parse-link (text i len) - (when (or (>= i len) (not (char= (char text i) #\[))) - (return-from parse-link (values nil i))) - (let ((close-bracket (find-closing-marker text (1+ i) "]"))) - (unless close-bracket (return-from parse-link (values nil i))) - (when (or (>= (1+ close-bracket) len) - (not (char= (char text (1+ close-bracket)) #\())) - (return-from parse-link (values nil i))) - (let ((close-paren (find-closing-marker text (+ close-bracket 2) ")"))) - (unless close-paren (return-from parse-link (values nil i))) - (values (make-md-node :link - :children (parse-inline (subseq text (1+ i) close-bracket)) - :url (subseq text (+ close-bracket 2) close-paren)) - (1+ close-paren))))) - -(defun get-highlighter (lang) - (cdr (assoc lang - '(("lisp" . (:comment (";" "#|" ";;") :string ("\"") - :keyword ("defun" "defmacro" "defmethod" "defgeneric" - "defvar" "defparameter" "defconstant" "defstruct" - "defclass" "deftype" "define-condition" - "let" "let*" "flet" "labels" "macrolet" - "if" "when" "unless" "cond" "case" "ecase" "typecase" - "loop" "do" "dolist" "dotimes" "tagbody" "go" - "block" "return" "return-from" - "progn" "prog1" "prog2" - "lambda" "function" "quote" - "setf" "setq" "push" "pop" "incf" "decf" - "in-package" "defpackage" "export" "import" - "handler-case" "handler-bind" "ignore-errors" - "multiple-value-bind" "multiple-value-call" - "destructuring-bind" - "declare" "the" "values" - "and" "or" "not" "null" - "car" "cdr" "first" "rest" "second" - "cons" "list" "append" "nconc" - "mapcar" "mapc" "reduce" - "find" "position" "count" "subseq" - "format" "princ" "print" "write" "read" - "load" "compile" "eval" - "make-instance" "slot-value" - "type-of" "class-of") - :builtin ("t" "nil" - "*standard-output*" "*standard-input*" - "*error-output*" "*debug-io*" - "*package*" "*print-circle*"))) - - ("common-lisp" . (:comment (";" "#|" ";;") :string ("\"") - :keyword ("defun" "defmacro" "defmethod" "defgeneric" - "let" "if" "when" "unless" "cond" "case" - "loop" "do" "dolist" "dotimes" - "return" "return-from" "block" - "lambda" "function" "quote" - "setf" "setq" "push" "pop" "incf" "decf" - "handler-case" "handler-bind" - "declare" "the" "values" - "defpackage" "in-package" "export" "import" - "error" "warn" "assert" - "car" "cdr" "first" "rest" - "cons" "list" "append" "mapcar" "reduce" - "format" "princ" "print" "read" "load" - "make-instance") - :builtin ("t" "nil"))) - - ("python" . (:comment ("#") :string ("\"" "'" "\"\"\"" "'''") - :keyword ("def" "class" "return" "yield" "import" "from" - "if" "elif" "else" "for" "while" "in" "not" - "try" "except" "finally" "raise" "with" "pass" - "break" "continue" "lambda" "global" - "assert" "del" "is" - "self" "cls" "async" "await") - :builtin ("None" "True" "False"))) - - ("javascript" . (:comment ("//" "/*") :string ("\"" "'" "`") - :keyword ("function" "class" "const" "let" "var" - "if" "else" "for" "while" "do" "switch" - "return" "break" "continue" - "try" "catch" "finally" "throw" - "new" "this" "super" "delete" "typeof" - "import" "export" "from" "default" - "async" "await" "yield" "of") - :builtin ("true" "false" "null" "undefined" "NaN"))) - - ("bash" . (:comment ("#") :string ("\"" "'") - :keyword ("if" "then" "else" "elif" "fi" "for" "while" - "done" "case" "esac" "in" "function" "return" - "export" "local" "unset" "source" - "echo" "printf" "read" "test" "let" "declare") - :builtin ("true" "false" "cd" "ls" "cat" "grep" "sed" - "mv" "cp" "rm" "mkdir" "touch" "find" "wc" - "head" "tail" "date" "sleep" "kill"))) - - ("shell" . (:comment ("#") :string ("\"" "'") - :keyword ("if" "then" "else" "elif" "fi" "for" "while" - "done" "case" "esac" "in" "function" "return" - "export" "local" "unset" "source" - "echo" "printf" "read" "test") - :builtin ("true" "false" "cd" "ls" "grep" "sed" - "mv" "cp" "rm" "mkdir" "touch" "find")))) - :test #'string=))) - -(defun tokenize-line (line highlighter) - (let ((tokens nil) (i 0) (len (length line)) - (comment-chars (getf highlighter :comment)) - (string-chars (getf highlighter :string)) - (keywords (getf highlighter :keyword)) - (builtins (getf highlighter :builtin))) - (loop while (< i len) - do (let ((c (char line i))) - (cond - ((find c " \t") - (let ((start i)) - (loop while (and (< i len) (find (char line i) " \t")) do (incf i)) - (push (cons (subseq line start i) :plain) tokens))) - ((and comment-chars - (some (lambda (cc) - (and (<= (+ i (length cc)) len) - (string= cc (subseq line i (+ i (length cc)))))) - comment-chars)) - (push (cons (subseq line i) :comment) tokens) (setf i len)) - ((and string-chars (some (lambda (s) (find c s)) string-chars)) - (let ((start i)) - (incf i) - (let ((triple (and (< i (1- len)) (char= (char line i) c) - (char= (char line (1+ i)) c)))) - (if triple - (progn (incf i 2) - (loop while (and (< i len) - (not (and (char= (char line i) c) - (< (1+ i) len) - (char= (char line (1+ i)) c) - (< (+ i 2) len) - (char= (char line (+ i 2)) c)))) - do (incf i)) - (incf i 3)) - (progn (loop while (and (< i len) (char/= (char line i) c)) - do (incf i)) - (when (< i len) (incf i))))) - (push (cons (subseq line start i) :string) tokens))) - ((or (digit-char-p c) - (and (find c "+-") (< (1+ i) len) (digit-char-p (char line (1+ i))))) - (let ((start i)) - (loop while (and (< i len) (not (find (char line i) " \t()[]{}'\";:#"))) - do (incf i)) - (let ((token (subseq line start i))) - (if (digit-char-p (char token 0)) - (push (cons token :number) tokens) - (push (cons token :plain) tokens))))) - ((or (alpha-char-p c) - (and (find c "-_?!*<>=") (> len 1))) - (let ((start i)) - (loop while (and (< i len) - (or (alphanumericp (char line i)) - (find (char line i) "-_?!*<>="))) - do (incf i)) - (let* ((token (subseq line start i)) - (down (string-downcase token))) - (cond - ((find down keywords :test #'string=) - (push (cons token :keyword) tokens)) - ((find down builtins :test #'string=) - (push (cons token :builtin) tokens)) - (t (if (and (< i len) (char= (char line i) #\()) - (push (cons token :function) tokens) - (push (cons token :plain) tokens))))))) - (t (push (cons (string c) :plain) tokens) (incf i))))) - (nreverse tokens))) - -(defun highlight-code (code language) - (unless code (return-from highlight-code nil)) - (let ((highlighter (get-highlighter (and language (string-downcase language))))) - (unless highlighter (return-from highlight-code (list (cons code :plain)))) - (let ((tokens nil)) - (with-input-from-string (stream code) - (loop for line = (read-line stream nil nil) while line - do (let ((line-tokens (tokenize-line line highlighter))) - (when tokens (push (cons (string #\Newline) :plain) tokens)) - (setf tokens (nconc (nreverse line-tokens) tokens))))) - (nreverse tokens)))) - -(defun apply-highlight-token (token category) - (let ((code (case category - (:keyword "33") (:builtin "36") - (:function "34") (:comment "2") (:string "32") (:number "35") - (t nil)))) - (if code (format nil "~c[~am~a~c[0m" #\Esc code token #\Esc) token))) - -(defun apply-highlight-style (char-vector) - (coerce char-vector 'string)) - -(defun string-prefix-p (prefix string) - (and (>= (length string) (length prefix)) - (string= prefix (subseq string 0 (length prefix))))) - -(defun classify-diff-line (line) - (cond ((string-prefix-p "+++ " line) :file-header) - ((string-prefix-p "--- " line) :file-header) - ((string-prefix-p "@@" line) :hunk-header) - ((string-prefix-p "+" line) :added) - ((string-prefix-p "-" line) :removed) - (t :context))) - -(defun apply-style (style text) - (let ((code (cond - ((eql style :bold) "1") ((eql style :italic) "3") - ((eql style :dim) "2") ((eql style :code) "0") - ((eql style :link) "4;36") ((eql style :url) "4;2") - ((eql style :underline) "4") ((eql style :strike) "9") - ((eql style :black) "30") ((eql style :red) "31") - ((eql style :green) "32") ((eql style :yellow) "33") - ((eql style :blue) "34") ((eql style :magenta) "35") - ((eql style :cyan) "36") ((eql style :white) "37") - ((eql style :bright-black) "90") ((eql style :bright-red) "91") - ((eql style :bright-green) "92") ((eql style :bright-yellow) "93") - ((eql style :bright-blue) "94") ((eql style :bright-magenta) "95") - ((eql style :bright-cyan) "96") ((eql style :bright-white) "97") - ((string= style "bold") "1") ((string= style "italic") "3") - ((string= style "dim") "2") ((string= style "code") "0") - ((string= style "link") "4;36") ((string= style "url") "4;2") - ((string= style "bright-cyan") "96") - ((string= style "bright-yellow") "93") - ((string= style "bright-white") "97") - ((string= style "bright-red") "91") - ((string= style "bright-green") "92") - ((string= style "bright-blue") "94") - ((string= style "bright-magenta") "95") - ((string= style "cyan") "36") ((string= style "yellow") "33") - ((string= style "red") "31") ((string= style "green") "32") - ((string= style "blue") "34") ((string= style "magenta") "35") - ((string= style "white") "37") ((string= style "black") "30") - (t nil)))) - (if code (format nil "~c[~am~a~c[0m" #\Esc code text #\Esc) text))) - -(defun render-inline (children) - (if (null children) "" - (with-output-to-string (s) - (dolist (child children) - (let ((type (getf child :type))) - (case type - (:text (princ (or (getf child :content) "") s)) - (:bold (princ (apply-style :bold (render-inline (getf child :children))) s)) - (:italic (princ (apply-style :italic (render-inline (getf child :children))) s)) - (:inline-code (princ (apply-style :code (or (getf child :content) "")) s)) - (:link (let ((text (render-inline (getf child :children))) - (url (or (getf child :url) ""))) - (princ (apply-style :link text) s) - (when (and url (not (string= url ""))) - (princ " " s) - (princ (apply-style :url (format nil "(~a)" url)) s)))) - (t (princ (or (getf child :content) "") s)))))))) - -(defun render-heading (node) - (let* ((level (or (getf (getf node :properties) :level) 1)) - (prefix (make-string (min level 6) :initial-element #\#)) - (text (render-inline (getf node :children))) - (color (cond ((= level 1) :bright-cyan) ((= level 2) :bright-yellow) - (t :bright-white)))) - (list (apply-style color (concatenate 'string prefix " " text))))) - -(defun render-paragraph (node) - (list (render-inline (getf node :children)))) - -(defun render-blockquote (node) - (list (apply-style :dim (concatenate 'string "> " (render-inline (getf node :children)))))) - -(defun render-code-block (node) - (let* ((language (or (getf (getf node :properties) :language) "")) - (content (or (getf node :content) "")) - (highlighted (unless (or (null language) (string= language "")) - (highlight-code content language))) - (lines nil)) - (when (and language (not (string= language ""))) - (push (apply-style :dim (format nil " ~~~~~~ ~a" language)) lines)) - (if highlighted - (let ((cl (make-array 0 :element-type 'character - :fill-pointer 0 :adjustable t)) - (output nil)) - (dolist (pair highlighted) - (let ((token (car pair)) (category (cdr pair))) - (cond ((string= token (string #\Newline)) - (push (apply-highlight-style cl) output) - (setf cl (make-array 0 :element-type 'character - :fill-pointer 0 :adjustable t))) - (t (let ((colored (apply-highlight-token token category))) - (loop for ch across colored - do (vector-push-extend ch cl))))))) - (when (> (length cl) 0) (push (apply-highlight-style cl) output)) - (setf lines (nconc lines (nreverse output)))) - (with-input-from-string (s content) - (loop for line = (read-line s nil nil) while line - do (push (apply-style :code line) lines)))) - (nreverse lines))) - -(defun render-diff-block (node) - (let* ((lines (getf (getf node :properties) :lines)) (result nil)) - (dolist (line (or lines - (and (getf node :content) - (let ((l (split-string-into-lines (getf node :content)))) - (loop for i from 0 below (length l) collect (aref l i)))))) - (let* ((class (classify-diff-line line)) - (color (case class - (:added "32") (:removed "31") - (:hunk-header "36") (:file-header "1;36") (t nil)))) - (if color - (push (format nil "~c[~am~a~c[0m" #\Esc color line #\Esc) result) - (push line result)))) - (nreverse result))) - -(defun render-thematic-break (node) - (declare (ignore node)) - (list (apply-style :dim "──────────────────────────────────────────────"))) - -(defun render-list-item (node) - (list (concatenate 'string - (if (eql (getf node :type) :ordered-item) " 1." " * ") - (render-inline (getf node :children))))) - -(defun render-md-node (node) - (let ((type (getf node :type))) - (case type - (:heading (render-heading node)) - (:paragraph (render-paragraph node)) - (:blockquote (render-blockquote node)) - (:code-block (render-code-block node)) - (:diff-block (render-diff-block node)) - (:thematic-break (render-thematic-break node)) - (:list-item (render-list-item node)) - (:ordered-item (render-list-item node)) - (t (list ""))))) - -(defun render-md (nodes) - (let ((lines nil)) - (dolist (node nodes) (setf lines (nconc lines (render-md-node node)))) - lines)) - -(defun render-markdown (text) - (unless text (return-from render-markdown "")) - (let ((nodes (parse-blocks text)) (parts nil)) - (dolist (line (render-md nodes)) (push line parts)) - (with-output-to-string (s) - (loop for part in (nreverse parts) - for first = t then nil - do (unless first (terpri s)) (princ part s))))) diff --git a/src/components/mouse-package.lisp b/src/components/mouse-package.lisp deleted file mode 100644 index 6e1d27a..0000000 --- a/src/components/mouse-package.lisp +++ /dev/null @@ -1,12 +0,0 @@ -(defpackage :cl-tty.mouse - (:use :cl :cl-tty.layout :cl-tty.input :cl-tty.box :cl-tty.rendering) - (:export - #:mouse-mixin - #:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll - #:handle-mouse-event - #:hit-test - #:selection #:get-selection #:copy-to-clipboard - #:make-selection #:selection-p - #:start-selection #:update-selection #:finalize-selection - #:selection-active-p - #:cell-link-at #:open-link-at)) diff --git a/src/components/mouse.lisp b/src/components/mouse.lisp deleted file mode 100644 index 5abfeea..0000000 --- a/src/components/mouse.lisp +++ /dev/null @@ -1,108 +0,0 @@ -(in-package :cl-tty.mouse) - -(defclass mouse-mixin () - ((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down) - (on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up) - (on-mouse-move :initarg :on-mouse-move :initform nil :accessor on-mouse-move) - (on-mouse-scroll :initarg :on-mouse-scroll :initform nil :accessor on-mouse-scroll))) - -(defun handle-mouse-event (component event) - (let* ((type (mouse-event-type event)) - (handler (case type - (:press (on-mouse-down component)) - (:release (on-mouse-up component)) - (:drag (on-mouse-move component)) - (t nil)))) - (when handler (funcall handler event)))) - -(defun hit-test (root x y) - "Find the deepest component at (X, Y) by testing layout-node bounds. -Recurses into component-children to find the innermost match. -Components without a layout-node or position return nil." - (labels ((recurse (node) - (let ((ln (ignore-errors (component-layout-node node))) - (best nil)) - (when ln - (let ((nx (layout-node-x ln)) - (ny (layout-node-y ln)) - (nw (layout-node-width ln)) - (nh (layout-node-height ln))) - ;; Check children first for deeper match - (dolist (child (ignore-errors (component-children node))) - (let ((child-hit (recurse child))) - (when child-hit - (setf best child-hit)))) - ;; If no child matched, check self - (or best - (when (and (>= x nx) (< x (+ nx nw)) - (>= y ny) (< y (+ ny nh))) - node))))))) - (recurse root))) - -(defvar *selection* nil) - -(defstruct (selection (:conc-name sel-)) - (start-x 0) (start-y 0) (end-x 0) (end-y 0) (text "")) - -(defun get-selection () - (when *selection* (sel-text *selection*))) - -(defun copy-to-clipboard (text) - #+linux - (cond - ((sb-ext:posix-getenv "WAYLAND_DISPLAY") - (sb-ext:run-program "wl-copy" nil :input text :wait nil)) - (t - (sb-ext:run-program "xclip" (list "-selection" "clipboard") - :input text :wait nil))) - #+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil)) - -(defvar *selection-active* nil - "T when a drag selection is in progress.") - -(defvar *selection-start* nil - "Cons (X . Y) of mouse-down position during drag.") - -(defvar *selection-end* nil - "Cons (X . Y) of current mouse position during drag.") - -(defun start-selection (x y) - "Begin a drag selection at (X Y)." - (setf *selection-start* (cons x y) - *selection-end* (cons x y) - *selection-active* t)) - -(defun update-selection (x y) - "Update the drag selection end position to (X Y)." - (setf *selection-end* (cons x y))) - -(defun selection-active-p () - "Return T if a drag selection is in progress." - *selection-active*) - -(defun finalize-selection (fb) - "End the drag selection and extract text from the framebuffer." - (setf *selection-active* nil) - (when (and *selection-start* *selection-end* fb) - (let* ((x1 (car *selection-start*)) - (y1 (cdr *selection-start*)) - (x2 (car *selection-end*)) - (y2 (cdr *selection-end*)) - (text (cl-tty.rendering:extract-text fb x1 y1 x2 y2))) - (setf *selection* (make-selection :start-x x1 :start-y y1 - :end-x x2 :end-y y2 - :text text)) - (setf *selection-start* nil *selection-end* nil) - text))) - -(defun cell-link-at (fb x y) - "Return the link URL at (X Y) in framebuffer FB, or nil." - (cl-tty.rendering:fb-cell-link-url fb x y)) - -(defun open-link-at (fb x y) - "If there is a link URL at (X Y) in FB, open it via xdg-open." - (let ((url (cell-link-at fb x y))) - (when url - #+linux (sb-ext:run-program "xdg-open" (list url) :wait nil) - #+darwin (sb-ext:run-program "open" (list url) :wait nil)) - url)) diff --git a/src/components/package.lisp b/src/components/package.lisp deleted file mode 100644 index 1d4ce2c..0000000 --- a/src/components/package.lisp +++ /dev/null @@ -1,37 +0,0 @@ -(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) diff --git a/src/components/render-tests.lisp b/src/components/render-tests.lisp deleted file mode 100644 index 387eed8..0000000 --- a/src/components/render-tests.lisp +++ /dev/null @@ -1,48 +0,0 @@ -(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)))) diff --git a/src/components/render.lisp b/src/components/render.lisp deleted file mode 100644 index c83537c..0000000 --- a/src/components/render.lisp +++ /dev/null @@ -1,72 +0,0 @@ -(in-package :cl-tty.box) - -;; ── Component Protocol ──────────────────────────────────────── - -(defgeneric component-layout-node (component) - (:documentation "Return the layout-node for COMPONENT.")) - -(defmethod component-layout-node ((bx box)) - (box-layout-node bx)) - -(defmethod component-layout-node ((tx text)) - (text-layout-node tx)) - -(defgeneric component-children (component) - (:documentation "Return the children of COMPONENT, or nil.") - (:method ((c t)) nil)) - -(defgeneric component-parent (component) - (:documentation "Return the parent of COMPONENT, or nil.") - (:method ((c t)) nil)) - -;; ── Rendering Pipeline ──────────────────────────────────────── - -(defgeneric render (component backend) - (:documentation "Render COMPONENT at its computed position using BACKEND.") - (:method ((c t) backend) - (declare (ignore backend)) - (values))) - -(defmethod render ((bx box) backend) - (render-box bx backend)) - -(defmethod render ((tx text) backend) - (render-text tx backend)) - -(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))) - -(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))) - -(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))) - -;; ── 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)))) diff --git a/src/components/scrollbox.lisp b/src/components/scrollbox.lisp deleted file mode 100644 index 8cc0dc7..0000000 --- a/src/components/scrollbox.lisp +++ /dev/null @@ -1,133 +0,0 @@ -(in-package #:cl-tty.container) - -(defclass scroll-box (dirty-mixin) - ((children :initform nil :initarg :children - :accessor scroll-box-children :type list) - (scroll-y :initform 0 :initarg :scroll-y - :accessor scroll-box-scroll-y :type fixnum) - (scroll-x :initform 0 :initarg :scroll-x - :accessor scroll-box-scroll-x :type fixnum) - (sticky-scroll-p :initform t :initarg :sticky-scroll-p - :accessor sticky-scroll-p :type boolean) - (layout-node :initform (make-layout-node) :accessor scroll-box-layout-node))) - -(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) - sticky-scroll-p) - (make-instance 'scroll-box - :children children - :scroll-y scroll-y - :scroll-x scroll-x - :sticky-scroll-p (if (null sticky-scroll-p) t sticky-scroll-p))) - -(defmethod component-children ((sb scroll-box)) - (scroll-box-children sb)) - -(defmethod component-layout-node ((sb scroll-box)) - (scroll-box-layout-node sb)) - -(defun clamp-scroll (sb) - "Clamp scroll offsets to valid range." - (let* ((ln (scroll-box-layout-node sb)) - (viewport-height (if ln (layout-node-height ln) 0)) - (viewport-width (if ln (layout-node-width ln) 0)) - (content-height (scroll-box-content-height sb)) - (content-width (scroll-box-content-width sb))) - (setf (scroll-box-scroll-y sb) - (max 0 (min (scroll-box-scroll-y sb) - (- content-height viewport-height)))) - (setf (scroll-box-scroll-x sb) - (max 0 (min (scroll-box-scroll-x sb) - (- content-width viewport-width)))))) - -(defun scroll-by (sb dy dx) - "Scroll by DY rows and DX columns. Clamps to valid range." - (incf (scroll-box-scroll-y sb) dy) - (incf (scroll-box-scroll-x sb) dx) - (clamp-scroll sb) - (mark-dirty sb)) - -(defun scroll-box-content-height (sb) - "Total height of all children." - (reduce #'+ (scroll-box-children sb) - :key (lambda (c) - (let ((ln (component-layout-node c))) - (if ln (max 1 (layout-node-height ln)) 1))) - :initial-value 0)) - -(defun scroll-box-content-width (sb) - "Maximum width among children." - (reduce #'max (scroll-box-children sb) - :key (lambda (c) - (let ((ln (component-layout-node c))) - (if ln (max 1 (layout-node-width ln)) 1))) - :initial-value 0)) - -(defmethod render ((sb scroll-box) backend) - "Render visible children with scroll offset applied. -Delegates to each child's `render` method, temporarily offsetting -its layout-node position for the scroll offset. Children outside -the viewport are clipped out." - (let* ((ln (scroll-box-layout-node sb)) - (vx 0) (vy 0) - (vw (if ln (layout-node-width ln) 80)) - (vh (if ln (layout-node-height ln) 24)) - (sy (scroll-box-scroll-y sb)) - (sx (scroll-box-scroll-x sb))) - (dolist (child (scroll-box-children sb)) - (let* ((cln (component-layout-node child)) - (ch (if cln (layout-node-height cln) 1)) - (cy vy)) - ;; Only render children that are visible in the viewport - (when (and (< (- cy sy) vh) - (> (+ (- cy sy) ch) 0)) - ;; Temporarily offset child's layout-node position for rendering - (let ((orig-x (if cln (layout-node-x cln) 0)) - (orig-y (if cln (layout-node-y cln) 0))) - (when cln - (setf (layout-node-x cln) (- vx sx) - (layout-node-y cln) (- vy sy))) - (unwind-protect - (render child backend) - (when cln - (setf (layout-node-x cln) orig-x - (layout-node-y cln) orig-y))))) - (incf vy ch))) - (draw-scrollbars sb backend vw vh))) - -(defun update-sticky-scroll (sb) - "If sticky-scroll-p is active and at bottom, keep at bottom." - (when (sticky-scroll-p sb) - (let* ((content-h (scroll-box-content-height sb)) - (ln (scroll-box-layout-node sb)) - (viewport-h (if ln (layout-node-height ln) 24))) - (when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1)) - (setf (scroll-box-scroll-y sb) - (max 0 (- content-h viewport-h))))))) - -(defun scrollbar-thumb (scroll-pos viewport-size content-size) - "Return the thumb position for a scrollbar (0.0 to 1.0)." - (if (> content-size viewport-size) - (/ (float scroll-pos) (- content-size viewport-size)) - 0.0)) - -(defun draw-scrollbars (sb backend viewport-w viewport-h) - "Draw scrollbars if content exceeds viewport." - (let* ((content-h (scroll-box-content-height sb)) - (content-w (scroll-box-content-width sb)) - (sy (scroll-box-scroll-y sb)) - (sx (scroll-box-scroll-x sb)) - (ln (scroll-box-layout-node sb)) - (ox (if ln (layout-node-x ln) 0)) - (oy (if ln (layout-node-y ln) 0))) - ;; Vertical scrollbar - (when (> content-h viewport-h) - (let* ((thumb (scrollbar-thumb sy viewport-h content-h)) - (thumb-pos (round (* thumb viewport-h)))) - (draw-rect backend (+ ox (1- viewport-w)) oy 1 viewport-h :bg :scrollbar-bg) - (draw-text backend (+ ox (1- viewport-w)) (+ oy thumb-pos) "█" nil nil))) - ;; Horizontal scrollbar - (when (> content-w viewport-w) - (let* ((thumb (scrollbar-thumb sx viewport-w content-w)) - (thumb-pos (round (* thumb viewport-w)))) - (draw-rect backend ox (+ oy (1- viewport-h)) viewport-w 1 :bg :scrollbar-bg) - (draw-text backend (+ ox thumb-pos) (+ oy (1- viewport-h)) "█" nil nil))))) diff --git a/src/components/select-package.lisp b/src/components/select-package.lisp deleted file mode 100644 index cd05491..0000000 --- a/src/components/select-package.lisp +++ /dev/null @@ -1,13 +0,0 @@ -(defpackage :cl-tty.select - (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) - (:export - #:select #:make-select - #:select-options #:select-filter - #:select-selected-index #:select-on-select - #:select-layout-node - #:select-filtered-options - #:select-next #:select-prev - #:select-visible-options - #:select-handle-key - #:render - #:fuzzy-match-p)) diff --git a/src/components/select.lisp b/src/components/select.lisp deleted file mode 100644 index fddb69f..0000000 --- a/src/components/select.lisp +++ /dev/null @@ -1,142 +0,0 @@ -(in-package #:cl-tty.select) - -(defclass select (dirty-mixin) - ((options :initform nil :initarg :options - :accessor select-options :type list) - (filter :initform nil :initarg :filter - :accessor select-filter :type (or string null)) - (selected-index :initform 0 :initarg :selected-index - :accessor select-selected-index :type fixnum) - (on-select :initform nil :initarg :on-select - :accessor select-on-select) - (layout-node :initform (make-layout-node) :initarg :layout-node - :accessor select-layout-node))) - -(defun make-select (&key options filter on-select) - (make-instance 'select - :options (or options nil) - :filter filter - :on-select on-select)) - -(defmethod component-layout-node ((sel select)) - (select-layout-node sel)) - -(defun select-filtered-options (sel) - "Return list of options matching the current filter, in display order. - Each item: (display-index original-index option-plist)." - (let* ((filter (select-filter sel)) - (all-options (select-options sel)) - (filtered (if (null filter) - all-options - (let ((lower (string-downcase filter))) - (remove-if-not - (lambda (opt) - (or (getf opt :category) - (let ((title (string-downcase (getf opt :title)))) - (or (search lower title) - (fuzzy-match-p lower title))))) - all-options))))) - (loop for opt in filtered - for i from 0 - collect (list i (position opt all-options) opt)))) - -(defun fuzzy-match-p (query target) - "T if character-set Jaccard similarity exceeds threshold (0.3)." - (let* ((q-chars (remove-duplicates (coerce (string-downcase query) 'list))) - (t-chars (remove-duplicates (coerce (string-downcase target) 'list))) - (intersection (length (intersection q-chars t-chars))) - (union (length (union q-chars t-chars)))) - (if (zerop union) nil (> (/ (float intersection) union) 0.3)))) - -(defun select-clamp-index (sel) - "Ensure selected-index is valid. Wraps if empty." - (let* ((filtered (select-filtered-options sel)) - (count (length filtered))) - (if (zerop count) - (setf (select-selected-index sel) 0) - (setf (select-selected-index sel) - (max 0 (min (select-selected-index sel) (1- count))))))) - -(defun select-next (sel) - "Move selection to next option. Wraps at end." - (let* ((filtered (select-filtered-options sel)) - (count (length filtered)) - (current (select-selected-index sel))) - (when (plusp count) - (loop for i from 1 below count - for idx = (mod (+ current i) count) - do (setf (select-selected-index sel) idx) - (mark-dirty sel) - (return))))) - -(defun select-prev (sel) - "Move selection to previous option. Wraps at start." - (let* ((filtered (select-filtered-options sel)) - (count (length filtered)) - (current (select-selected-index sel))) - (when (plusp count) - (loop for i from 1 below count - for idx = (mod (- current i) count) - do (setf (select-selected-index sel) idx) - (mark-dirty sel) - (return))))) - -(defun select-handle-key (sel event) - "Handle a key-event. Returns T if handled." - (let ((key (key-event-key event)) - (ctrl (key-event-ctrl event))) - (cond - ((or (eql key :down) (and ctrl (eql key :n))) - (select-next sel) t) - ((or (eql key :up) (and ctrl (eql key :p))) - (select-prev sel) t) - ((eql key :enter) - (let* ((filtered (select-filtered-options sel)) - (idx (select-selected-index sel)) - (item (when (< idx (length filtered)) - (third (nth idx filtered))))) - (when item - (let ((cb (select-on-select sel))) - (when cb (funcall cb item)))) - t)) - ((eql key :escape) nil) - (t nil)))) - -(defun select-visible-options (sel) - "Return filtered options that fit within the viewport." - (let* ((ln (select-layout-node sel)) - (height (if ln (layout-node-height ln) 80)) - (filtered (select-filtered-options sel)) - (sel-idx (select-selected-index sel)) - ;; Show items around the selection - (half (floor (1- height) 2)) - (start (max 0 (- sel-idx half))) - (end (min (length filtered) (+ start height)))) - (subseq filtered start end))) - -(defmethod render ((sel select) backend) - (let* ((ln (select-layout-node sel)) - (x (if ln (layout-node-x ln) 0)) - (y (if ln (layout-node-y ln) 0)) - (w (if ln (layout-node-width ln) 80)) - (visible (select-visible-options sel)) - (sel-idx (select-selected-index sel))) - (dolist (item visible) - (let* ((display-idx (first item)) - (option (third item)) - (title (getf option :title)) - (is-category (getf option :category)) - (is-selected (eql display-idx sel-idx)) - (display (if (> (length title) (1- w)) - (concatenate 'string (subseq title 0 (1- w)) "…") - title))) - (cond - (is-category - (draw-text backend x y display :text-muted nil)) - (is-selected - (draw-rect backend x y w 1 :bg :accent) - (draw-text backend x y display :background :accent)) - (t - (draw-text backend x y display nil nil))) - (incf y 1))) - (values))) diff --git a/src/components/slot-package.lisp b/src/components/slot-package.lisp deleted file mode 100644 index 5282534..0000000 --- a/src/components/slot-package.lisp +++ /dev/null @@ -1,9 +0,0 @@ -(defpackage :cl-tty.slot - (:use :cl) - (:export - #:defslot - #:slot-render - #:slot-p - #:clear-slot - #:list-slots - #:*slots*)) diff --git a/src/components/slot.lisp b/src/components/slot.lisp deleted file mode 100644 index 6ee7a27..0000000 --- a/src/components/slot.lisp +++ /dev/null @@ -1,59 +0,0 @@ -(in-package :cl-tty.slot) - -(defvar *slots* (make-hash-table :test 'equal) - "Hash table mapping slot name (string) -> plist of slot data. -Each entry: (:mode :entries <(order . render-fn) list>).") - -(defun defslot (name &key (order 0) render-fn (mode :stack)) - (let* ((key (string name)) - (slot (gethash key *slots*))) - (if (null slot) - ;; First registration — validate and set mode, create entry - (progn - (assert (member mode '(:stack :replace :single-winner)) () - "Invalid slot mode: ~S (use :stack, :replace, or :single-winner)" - mode) - (setf (gethash key *slots*) - (list :mode mode - :entries (list (cons order render-fn))))) - ;; Existing slot — respect frozen mode - (let ((entries (getf slot :entries))) - (ecase (getf slot :mode) - (:stack - (setf (getf slot :entries) - (sort (cons (cons order render-fn) entries) - #'< :key #'car))) - (:replace - (setf (getf slot :entries) - (list (cons order render-fn)))) - (:single-winner - ;; First registration already present — no-op - (values)))))) - render-fn) - -(defun slot-render (slot-name &rest args) - (let ((slot (gethash (string slot-name) *slots*))) - (when slot - (let ((mode (getf slot :mode)) - (entries (getf slot :entries))) - (ecase mode - (:stack - (mapcar (lambda (entry) - (let ((fn (cdr entry))) - (when fn (apply fn args)))) - entries)) - (:replace - (let ((fn (cdar (last entries)))) - (when fn (apply fn args)))) - (:single-winner - (let ((fn (cdar entries))) - (when fn (apply fn args))))))))) - -(defun slot-p (slot-name) - (nth-value 1 (gethash (string slot-name) *slots*))) - -(defun clear-slot (slot-name) - (remhash (string slot-name) *slots*)) - -(defun list-slots () - (loop for key being the hash-keys of *slots* collect key)) diff --git a/src/components/tabbar.lisp b/src/components/tabbar.lisp deleted file mode 100644 index 81eb50c..0000000 --- a/src/components/tabbar.lisp +++ /dev/null @@ -1,82 +0,0 @@ -(in-package #:cl-tty.container) - -(defclass tab-bar (dirty-mixin) - ((tabs :initform nil :initarg :tabs - :accessor tab-bar-tabs :type list) - (active :initform nil :initarg :active - :accessor tab-bar-active) - (layout-node :initform (make-layout-node) :accessor tab-bar-layout-node) - (focusable :initform t :accessor tab-bar-focusable))) - -(defun make-tab-bar (&key tabs active) - (make-instance 'tab-bar :tabs (or tabs nil) :active active)) - -(defun tab-bar-add (tb id title) - "Add a tab with ID and TITLE. Sets as active if first tab." - (setf (tab-bar-tabs tb) - (nconc (tab-bar-tabs tb) (list (list :id id :title title)))) - (unless (tab-bar-active tb) - (setf (tab-bar-active tb) id)) - id) - -(defmethod component-layout-node ((tb tab-bar)) - (tab-bar-layout-node tb)) - -(defun tab-bar-next (tb) - "Move to next tab." - (let* ((tabs (tab-bar-tabs tb)) - (current (tab-bar-active tb)) - (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) - (pos (position current ids))) - (when pos - (let ((next (nth (mod (1+ pos) (length ids)) ids))) - (setf (tab-bar-active tb) next) - (mark-dirty tb))))) - -(defun tab-bar-prev (tb) - "Move to previous tab." - (let* ((tabs (tab-bar-tabs tb)) - (current (tab-bar-active tb)) - (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) - (pos (position current ids))) - (when pos - (let ((prev (nth (mod (1- pos) (length ids)) ids))) - (setf (tab-bar-active tb) prev) - (mark-dirty tb))))) - -(defun tab-bar-select (tb id) - "Select a tab by ID." - (setf (tab-bar-active tb) id) - (mark-dirty tb)) - -(defun tab-bar-handle-key (tb event) - "Handle a key-event on a TabBar. Returns T if handled." - (case (key-event-key event) - (:left (tab-bar-prev tb) t) - (:right (tab-bar-next tb) t) - (t nil))) - -(defmethod render ((tb tab-bar) backend) - (let* ((ln (tab-bar-layout-node tb)) - (x (if ln (layout-node-x ln) 0)) - (y (if ln (layout-node-y ln) 0)) - (w (if ln (layout-node-width ln) 80)) - (active-id (tab-bar-active tb)) - (tabs (tab-bar-tabs tb)) - (x-pos x)) - (dolist (tab tabs) - (let* ((id (getf tab :id)) - (title (getf tab :title)) - (label (format nil " ~A " title)) - (label-len (length label)) - (is-active (eql id active-id)) - (fg (if is-active :accent :text-muted)) - (bg (if is-active :background-element nil))) - ;; Check if tab fits - (when (>= (+ x-pos label-len 2) (+ x w)) - (draw-text backend x-pos y "..." :text-muted nil) - (return)) - ;; Draw tab - (draw-text backend x-pos y label fg bg) - (incf x-pos (+ label-len 2)))) - (values))) diff --git a/src/components/text-input.lisp b/src/components/text-input.lisp deleted file mode 100644 index 924745c..0000000 --- a/src/components/text-input.lisp +++ /dev/null @@ -1,110 +0,0 @@ -(in-package #:cl-tty.input) - -(defclass text-input (dirty-mixin) - ((value :initform "" :initarg :value :accessor text-input-value - :type string) - (cursor :initform 0 :initarg :cursor :accessor text-input-cursor - :type fixnum) - (placeholder :initform "" :initarg :placeholder - :accessor text-input-placeholder :type string) - (max-length :initform nil :initarg :max-length - :accessor text-input-max-length) - (on-submit :initform nil :initarg :on-submit - :accessor text-input-on-submit) - (layout-node :initform (make-layout-node) :accessor text-input-layout-node) - (focusable :initform t :accessor text-input-focusable))) - -(defun make-text-input (&key value cursor placeholder max-length on-submit) - (make-instance 'text-input - :value (or value "") - :cursor (or cursor 0) - :placeholder (or placeholder "") - :max-length max-length - :on-submit on-submit)) - -(defun text-input-insert (input char) - (let* ((val (text-input-value input)) - (pos (text-input-cursor input)) - (max (text-input-max-length input))) - (when (and max (>= (length val) max)) (return-from text-input-insert)) - (setf (text-input-value input) (concatenate 'string (subseq val 0 pos) (string char) (subseq val pos))) - (incf (text-input-cursor input)) - (mark-dirty input))) - -(defun text-input-backspace (input) - (let* ((val (text-input-value input)) (pos (text-input-cursor input))) - (when (zerop pos) (return-from text-input-backspace)) - (setf (text-input-value input) (concatenate 'string (subseq val 0 (1- pos)) (subseq val pos))) - (decf (text-input-cursor input)) - (mark-dirty input))) - -(defun text-input-delete (input) - (let* ((val (text-input-value input)) (pos (text-input-cursor input))) - (when (>= pos (length val)) (return-from text-input-delete)) - (setf (text-input-value input) (concatenate 'string (subseq val 0 pos) (subseq val (1+ pos)))) - (mark-dirty input))) - -(defun text-input-move-left (input) - (when (plusp (text-input-cursor input)) (decf (text-input-cursor input))) - (mark-dirty input)) - -(defun text-input-move-right (input) - (when (< (text-input-cursor input) (length (text-input-value input))) (incf (text-input-cursor input))) - (mark-dirty input)) - -(defun text-input-move-home (input) - (setf (text-input-cursor input) 0) - (mark-dirty input)) - -(defun text-input-move-end (input) - (setf (text-input-cursor input) (length (text-input-value input))) - (mark-dirty input)) - -(defun text-input-delete-word-before (input) - (let* ((val (text-input-value input)) (pos (text-input-cursor input))) - (when (zerop pos) (return-from text-input-delete-word-before)) - (let* ((start (or (position-if (lambda (c) (not (char= c #\Space))) val :end pos :from-end t) 0)) - (word-start (or (and (plusp start) (position #\Space val :end start :from-end t)) 0)) - (delete-start (if (and (zerop word-start) (or (char/= (char val 0) #\Space) (zerop start))) - 0 - (if (zerop start) (1+ word-start) (1+ (or (position #\Space val :end start :from-end t) 0)))))) - (setf (text-input-value input) (concatenate 'string (subseq val 0 delete-start) (subseq val pos))) - (setf (text-input-cursor input) delete-start) - (mark-dirty input)))) - -(defun handle-text-input (input event) - (cond - ((key-event-ctrl event) - (case (key-event-key event) - (:a (text-input-move-home input)) - (:e (text-input-move-end input)) - (:w (text-input-delete-word-before input)) - (:u (progn (setf (text-input-value input) (subseq (text-input-value input) (text-input-cursor input))) - (setf (text-input-cursor input) 0) (mark-dirty input))) - (:k (progn (setf (text-input-value input) (subseq (text-input-value input) 0 (text-input-cursor input))) - (mark-dirty input))) - (t nil))) - (t - (case (key-event-key event) - (:left (text-input-move-left input)) - (:right (text-input-move-right input)) - (:home (text-input-move-home input)) - (:end (text-input-move-end input)) - (:backspace (text-input-backspace input)) - (:delete (text-input-delete input)) - (:enter (let ((cb (text-input-on-submit input))) (when cb (funcall cb (text-input-value input))))) - (:tab nil) (:escape nil) - (otherwise (let ((ch (code-char (key-event-code event)))) - (when (and ch (graphic-char-p ch)) (text-input-insert input ch)))))))) - -(defmethod render ((in text-input) (backend t)) - (let* ((ln (text-input-layout-node in)) - (x (if ln (layout-node-x ln) 0)) (y (if ln (layout-node-y ln) 0)) - (w (if ln (layout-node-width ln) 80)) - (value (text-input-value in)) (cursor (text-input-cursor in)) - (display (if (plusp (length value)) value (or (text-input-placeholder in) ""))) - (truncated (subseq display 0 (min (length display) w)))) - (draw-text backend x y truncated nil nil) - (when (plusp (length value)) - (let ((cursor-col (min cursor (length truncated)))) - (draw-text backend (+ x cursor-col) y "█" :bright-white nil))))) diff --git a/src/components/text.lisp b/src/components/text.lisp deleted file mode 100644 index 1d57555..0000000 --- a/src/components/text.lisp +++ /dev/null @@ -1,105 +0,0 @@ -(in-package :cl-tty.box) - -(defclass span () - ((text :initarg :text :accessor span-text) - (bold :initform nil :initarg :bold :accessor span-bold) - (italic :initform nil :initarg :italic :accessor span-italic) - (underline :initform nil :initarg :underline :accessor span-underline) - (reverse :initform nil :initarg :reverse :accessor span-reverse) - (dim :initform nil :initarg :dim :accessor span-dim) - (fg :initform nil :initarg :fg :accessor span-fg) - (bg :initform nil :initarg :bg :accessor span-bg))) - -(defun span (text &key bold italic underline reverse dim fg bg) - (make-instance 'span - :text text :bold bold :italic italic - :underline underline :reverse reverse :dim dim - :fg fg :bg bg)) - -(defclass text (dirty-mixin) - ((layout-node :initform (make-layout-node) :accessor text-layout-node - :initarg :layout-node) - (content :initform "" :initarg :content :accessor text-content) - (spans :initform nil :initarg :spans :accessor text-spans) - (fg :initform nil :initarg :fg :accessor text-fg) - (bg :initform nil :initarg :bg :accessor text-bg) - (wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode))) - -(defun make-text (content &key fg bg wrap-mode width height spans) - (make-instance 'text - :content content - :fg fg :bg bg - :wrap-mode (or wrap-mode :word) - :spans spans - :layout-node (make-layout-node :direction :column - :width width :height height))) - -(defun render-text (text-object backend) - "Render TEXT-OBJECT at its computed layout position using BACKEND." - (let ((ln (text-layout-node text-object)) - (content (text-content text-object)) - (fg (text-fg text-object)) - (bg (text-bg text-object)) - (wrap (text-wrap-mode text-object)) - (spans (text-spans text-object))) - (declare (ignore spans)) - (let ((x (layout-node-x ln)) - (y (layout-node-y ln)) - (w (layout-node-width ln)) - (h (layout-node-height ln))) - (when (or (zerop (length content)) (zerop w) (zerop h)) - (return-from render-text (values))) - (if (eql wrap :none) - (let ((display (subseq content 0 (min (length content) w)))) - (draw-text backend x y display fg bg)) - (let ((lines (word-wrap content w)) - (max-lines h)) - (loop for line in lines - for row from 0 below max-lines - do (draw-text backend x (+ y row) line fg bg))))))) - -(defun word-wrap (text max-width) - "Split TEXT into lines, each <= MAX-WIDTH chars." - (if (or (zerop max-width) (zerop (length text))) - (list "") - (let ((words (split-string text)) (lines nil) (current nil) (current-len 0)) - (dolist (word words) - (let ((wl (length word))) - (cond ((<= wl max-width) - (if (and current (<= (+ current-len 1 wl) max-width)) - (progn - (push word current) - (incf current-len (1+ wl))) - (progn - (when current - (push (format nil "~{~A~^ ~}" (nreverse current)) lines)) - (setf current (list word)) - (setf current-len wl)))) - (t - (when current - (push (format nil "~{~A~^ ~}" (nreverse current)) lines) - (setf current nil) - (setf current-len 0)) - (loop for i from 0 below wl by max-width - do (push (subseq word i (min (+ i max-width) wl)) lines)))))) - (when current - (push (format nil "~{~A~^ ~}" (nreverse current)) lines)) - (or (nreverse lines) (list ""))))) - -(defun split-string (string) - "Split STRING into words separated by whitespace." - (loop with words = nil - with start = 0 - with len = (length string) - while (< start len) - do (let ((ws-start (position-if (lambda (c) (find c '(#\Space #\Tab #\Newline))) - string :start start))) - (if ws-start - (progn - (when (> ws-start start) - (push (subseq string start ws-start) words)) - (setf start (1+ ws-start))) - (progn - (push (subseq string start) words) - (setf start len)))) - finally (return (nreverse words)))) diff --git a/src/components/textarea.lisp b/src/components/textarea.lisp deleted file mode 100644 index c6c2df6..0000000 --- a/src/components/textarea.lisp +++ /dev/null @@ -1,234 +0,0 @@ -(in-package #:cl-tty.input) - -(defclass textarea (dirty-mixin) - ((value :initform "" :initarg :value :accessor textarea-value :type string) - (cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum) - (cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum) - (selection-start :initform nil :accessor textarea-selection-start) - (undo-stack :initform (make-array 100 :fill-pointer 0) - :accessor textarea-undo-stack) - (redo-stack :initform (make-array 100 :fill-pointer 0) - :accessor textarea-redo-stack) - (on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit) - (layout-node :initform (make-layout-node) :accessor textarea-layout-node) - (focusable :initform t :accessor textarea-focusable))) - -(defun make-textarea (&key value on-submit) - (make-instance 'textarea - :value (or value "") - :on-submit on-submit)) - -(defun textarea-lines (ta) - "Split value into lines." - (%split-string (textarea-value ta) #\Newline)) - -(defun textarea-line-count (ta) - "Number of lines in value." - (length (textarea-lines ta))) - -(defun textarea-ensure-cursor (ta) - "Clamp cursor to valid range." - (let ((lines (textarea-lines ta))) - (setf (textarea-cursor-row ta) - (max 0 (min (textarea-cursor-row ta) (1- (length lines))))) - (let ((line-len (length (nth (textarea-cursor-row ta) lines)))) - (setf (textarea-cursor-col ta) - (max 0 (min (textarea-cursor-col ta) line-len))))) - (mark-dirty ta)) - -(defun %join-lines (lines) - "Join a sequence of strings with newlines." - (with-output-to-string (s) - (loop for line across (if (listp lines) (coerce lines 'vector) lines) - for first = t then nil - do (unless first (write-char #\Newline s)) - (write-string line s)))) - -(defun textarea-insert-char (ta char) - "Insert CHAR at the cursor position." - (textarea-push-undo ta) - (let* ((lines (coerce (textarea-lines ta) 'vector)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta))) - (if (< row (length lines)) - (let* ((line (aref lines row)) - (new-line (concatenate 'string - (subseq line 0 col) - (string char) - (subseq line col)))) - (setf (aref lines row) new-line) - (setf (textarea-value ta) - (%join-lines lines)) - (incf (textarea-cursor-col ta)) - (mark-dirty ta)) - (progn - (setf (textarea-value ta) - (concatenate 'string (textarea-value ta) (string char))) - (incf (textarea-cursor-col ta)) - (mark-dirty ta))))) - -(defun textarea-newline (ta) - "Insert a newline at the cursor." - (textarea-push-undo ta) - (let* ((lines (coerce (textarea-lines ta) 'vector)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta))) - (if (< row (length lines)) - (let* ((line (aref lines row)) - (before (subseq line 0 col)) - (after (subseq line col))) - (setf (aref lines row) before) - (let ((new-lines (concatenate 'vector - (subseq lines 0 (1+ row)) - (vector after) - (subseq lines (1+ row))))) - (setf (textarea-value ta) - (%join-lines new-lines))) - (incf (textarea-cursor-row ta)) - (setf (textarea-cursor-col ta) 0) - (mark-dirty ta)) - (progn - (setf (textarea-value ta) - (concatenate 'string (textarea-value ta) (string #\Newline))) - (incf (textarea-cursor-row ta)) - (setf (textarea-cursor-col ta) 0) - (mark-dirty ta))))) - -(defun textarea-backspace (ta) - "Delete character before cursor." - (textarea-push-undo ta) - (let* ((lines (coerce (textarea-lines ta) 'vector)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta))) - (cond - ((and (zerop row) (zerop col)) - nil) ;; nothing to delete - ((zerop col) - ;; Join with previous line - (let* ((prev (aref lines (1- row))) - (curr (aref lines row)) - (new-pos (length prev))) - (setf (aref lines (1- row)) - (concatenate 'string prev curr)) - (let ((new-lines (concatenate 'vector - (subseq lines 0 row) - (subseq lines (1+ row))))) - (setf (textarea-value ta) - (%join-lines new-lines))) - (decf (textarea-cursor-row ta)) - (setf (textarea-cursor-col ta) new-pos) - (mark-dirty ta))) - (t - (let* ((line (aref lines row)) - (new-line (concatenate 'string - (subseq line 0 (1- col)) - (subseq line col)))) - (setf (aref lines row) new-line) - (setf (textarea-value ta) - (%join-lines lines)) - (decf (textarea-cursor-col ta)) - (mark-dirty ta)))))) - -(defun textarea-move-up (ta) - (decf (textarea-cursor-row ta)) - (textarea-ensure-cursor ta)) - -(defun textarea-move-down (ta) - (incf (textarea-cursor-row ta)) - (textarea-ensure-cursor ta)) - -(defun textarea-push-undo (ta) - "Save current value on undo stack." - (let ((stack (textarea-undo-stack ta))) - (when (>= (length stack) (array-total-size stack)) - (loop for i from 1 below (length stack) - do (setf (aref stack (1- i)) (aref stack i))) - (decf (fill-pointer stack))) - (vector-push (textarea-value ta) stack) - (setf (fill-pointer (textarea-redo-stack ta)) 0))) - -(defun textarea-undo (ta) - (let ((stack (textarea-undo-stack ta))) - (when (plusp (length stack)) - (let ((prev (vector-pop stack))) - (vector-push (textarea-value ta) (textarea-redo-stack ta)) - (setf (textarea-value ta) prev) - (textarea-ensure-cursor ta) - (mark-dirty ta))))) - -(defun textarea-redo (ta) - (let ((stack (textarea-redo-stack ta))) - (when (plusp (length stack)) - (let ((next (vector-pop stack))) - (vector-push (textarea-value ta) (textarea-undo-stack ta)) - (setf (textarea-value ta) next) - (textarea-ensure-cursor ta) - (mark-dirty ta))))) - -(defun handle-textarea-input (ta event) - "Process a key-event on a textarea widget." - (cond - ((key-event-ctrl event) - (case (key-event-key event) - (:z (textarea-undo ta)) - (:y (textarea-redo ta)) - ;; Ctrl+A/E: home/end - (:a (setf (textarea-cursor-col ta) 0)) - (:e (let ((lines (textarea-lines ta))) - (when (< (textarea-cursor-row ta) (length lines)) - (setf (textarea-cursor-col ta) - (length (nth (textarea-cursor-row ta) lines)))))) - (t nil))) - (t - (case (key-event-key event) - (:left (decf (textarea-cursor-col ta)) - (textarea-ensure-cursor ta)) - (:right (incf (textarea-cursor-col ta)) - (textarea-ensure-cursor ta)) - (:up (textarea-move-up ta)) - (:down (textarea-move-down ta)) - (:home (setf (textarea-cursor-col ta) 0) - (textarea-ensure-cursor ta)) - (:end (let ((lines (textarea-lines ta))) - (when (< (textarea-cursor-row ta) (length lines)) - (setf (textarea-cursor-col ta) - (length (nth (textarea-cursor-row ta) lines)))) - (textarea-ensure-cursor ta))) - (:enter (let ((cb (textarea-on-submit ta))) - (if cb - (funcall cb (textarea-value ta)) - (textarea-newline ta)))) - (:backspace (textarea-backspace ta)) - (:delete (let* ((lines (textarea-lines ta)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta)) - (line (nth row lines))) - (when (and line (< col (length line))) - (textarea-push-undo ta) - (setf (nth row lines) - (concatenate 'string - (subseq line 0 col) - (subseq line (1+ col)))) - (setf (textarea-value ta) - (%join-lines lines)) - (mark-dirty ta)))) - ;; Character insertion - (otherwise - (let ((ch (code-char (key-event-code event)))) - (when (and ch (graphic-char-p ch)) - (textarea-insert-char ta ch)))))))) - -(defmethod render ((ta textarea) (backend t)) - "Render textarea lines at layout position." - (let* ((ln (textarea-layout-node ta)) - (x (if ln (layout-node-x ln) 0)) - (y (if ln (layout-node-y ln) 0)) - (w (if ln (layout-node-width ln) 80)) - (h (if ln (layout-node-height ln) 24)) - (lines (textarea-lines ta)) - (max-lines (min (length lines) h))) - (loop for i from 0 below max-lines - for line in lines - do (draw-text backend x (+ y i) - (subseq line 0 (min (length line) w)) - nil nil)))) diff --git a/src/components/theme-tests.lisp b/src/components/theme-tests.lisp deleted file mode 100644 index 96c0ef8..0000000 --- a/src/components/theme-tests.lisp +++ /dev/null @@ -1,61 +0,0 @@ -(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")))) diff --git a/src/components/theme.lisp b/src/components/theme.lisp deleted file mode 100644 index 4828e83..0000000 --- a/src/components/theme.lisp +++ /dev/null @@ -1,89 +0,0 @@ -(in-package :cl-tty.box) - -(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)) - -(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)) - -(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))) - -(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)))) - -(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")) - -(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")) diff --git a/src/layout/layout.lisp b/src/layout/layout.lisp deleted file mode 100644 index c5eaeb1..0000000 --- a/src/layout/layout.lisp +++ /dev/null @@ -1,181 +0,0 @@ -(defpackage :cl-tty.layout - (:use :cl) - (:export - #:layout-node #:make-layout-node - #:layout-node-add-child #:layout-node-remove-child - #:layout-node-children - #:layout-node-x #:layout-node-y - #:layout-node-width #:layout-node-height - #:layout-node-direction - #:compute-layout - #:vbox #:hbox #:spacer - ;; For tests - #:layout-node-parent #:layout-node-fixed-width - #:layout-node-fixed-height #:normalize-box - #:box-edge)) -(in-package :cl-tty.layout) - -(defun normalize-box (spec) - (cond ((null spec) (list :top 0 :right 0 :bottom 0 :left 0)) - ((numberp spec) (list :top spec :right spec :bottom spec :left spec)) - (t (loop with result = (list :top 0 :right 0 :bottom 0 :left 0) - for (key val) on spec by #'cddr - do (setf (getf result key) val) - finally (return result))))) - -(defun box-edge (box edge) - (or (getf box edge) 0)) - -(defclass layout-node () - ((parent :initform nil :accessor layout-node-parent) - (children :initform nil :accessor layout-node-children) - (x :initform 0 :accessor layout-node-x) - (y :initform 0 :accessor layout-node-y) - (width :initform 0 :accessor layout-node-width) - (height :initform 0 :accessor layout-node-height) - (direction :initform :column :initarg :direction :accessor layout-node-direction) - (grow :initform 0 :initarg :grow :accessor layout-node-grow) - (shrink :initform 1 :initarg :shrink :accessor layout-node-shrink) - (padding :initform (list :top 0 :right 0 :bottom 0 :left 0) :initarg :padding :accessor layout-node-padding) - (margin :initform (list :top 0 :right 0 :bottom 0 :left 0) :initarg :margin :accessor layout-node-margin) - (gap :initform 0 :initarg :gap :accessor layout-node-gap) - (position-type :initform :relative :initarg :position-type :accessor layout-node-position-type) - (position-offset :initform nil :initarg :position-offset :accessor layout-node-position-offset) - (fixed-width :initform nil :initarg :width :accessor layout-node-fixed-width) - (fixed-height :initform nil :initarg :height :accessor layout-node-fixed-height))) - -(defun make-layout-node (&key direction grow shrink padding margin gap - position-type position-offset width height) - (make-instance 'layout-node - :direction (or direction :column) - :grow (or grow 0) :shrink (or shrink 1) - :padding (normalize-box padding) :margin (normalize-box margin) - :gap (or gap 0) - :position-type (or position-type :relative) - :position-offset position-offset - :width width :height height)) - -(defun layout-node-add-child (parent child) - (setf (layout-node-parent child) parent) - (setf (layout-node-children parent) - (nconc (layout-node-children parent) (list child))) - child) - -(defun layout-node-remove-child (parent child) - (setf (layout-node-parent child) nil) - (setf (layout-node-children parent) - (delete child (layout-node-children parent))) - child) - -(defun distribute-sizes (children avail gap horizontal) - (let* ((n (length children)) - (gap-total (* gap (max 0 (1- n)))) - (base (mapcar (lambda (c) - (or (if horizontal - (layout-node-fixed-width c) - (layout-node-fixed-height c)) - 0)) - children)) - (base-total (reduce #'+ base)) - (remaining (- avail base-total gap-total)) - (grow-total (reduce #'+ (mapcar #'layout-node-grow children))) - (shrink-total (reduce #'+ (mapcar #'layout-node-shrink children)))) - (let ((sizes (mapcar (lambda (c b) - (let ((sz b)) - (when (and (plusp remaining) (plusp grow-total)) - (incf sz (round (* remaining (/ (layout-node-grow c) grow-total))))) - (when (and (minusp remaining) (plusp shrink-total)) - (decf sz (round (* (abs remaining) (/ (layout-node-shrink c) shrink-total))))) - (max 1 sz))) - children base))) - (when (or (and (plusp remaining) (plusp grow-total)) - (and (minusp remaining) (plusp shrink-total))) - (let ((delta (- avail gap-total (reduce #'+ sizes)))) - (when (/= delta 0) - (loop :for i :from 0 :below (min (abs delta) n) - :do (incf (nth i sizes) (signum delta)))))) - sizes))) - -(defun compute-layout (root available-width available-height) - (labels ((place-children (node x y max-w max-h) - (let* ((children (layout-node-children node)) - (is-row (eql (layout-node-direction node) :row)) - (pl (box-edge (layout-node-padding node) :left)) - (pt (box-edge (layout-node-padding node) :top)) - (pr (box-edge (layout-node-padding node) :right)) - (pb (box-edge (layout-node-padding node) :bottom)) - (cw (max 0 (- max-w pl pr))) - (ch (max 0 (- max-h pt pb))) - (gap (layout-node-gap node)) - (sizes (distribute-sizes children (if is-row cw ch) gap is-row))) - (setf (layout-node-x node) (+ x pl) - (layout-node-y node) (+ y pt)) - (loop :with pos = 0 - :for child :in children - :for size :in sizes - :do (if is-row - (setf (layout-node-width child) size - (layout-node-x child) (+ x pl pos) - (layout-node-height child) ch - (layout-node-y child) (+ y pt)) - (setf (layout-node-height child) size - (layout-node-y child) (+ y pt pos) - (layout-node-width child) cw - (layout-node-x child) (+ x pl))) - (place-children child - (layout-node-x child) - (layout-node-y child) - (if is-row size cw) - (if is-row ch size)) - (incf pos (+ size gap))) - (let ((last-child (car (last children)))) - (if is-row - (setf (layout-node-width node) - (or (layout-node-fixed-width node) - (if last-child - (+ (layout-node-x node) - (layout-node-width last-child) - pr) - max-w)) - (layout-node-height node) - max-h) - (setf (layout-node-height node) - (or (layout-node-fixed-height node) - (if last-child - (let ((last-y (layout-node-y last-child)) - (last-h (layout-node-height last-child))) - (+ last-y last-h pb)) - max-h)) - (layout-node-width node) - max-w)))))) - (place-children root 0 0 available-width available-height) - root)) - -(defmacro vbox ((&key grow shrink padding margin gap width height) &body children) - (let ((n (gensym))) - `(let ((,n (make-layout-node :direction :column - ,@(when grow `(:grow ,grow)) - ,@(when shrink `(:shrink ,shrink)) - ,@(when padding `(:padding ,padding)) - ,@(when margin `(:margin ,margin)) - ,@(when gap `(:gap ,gap)) - ,@(when width `(:width ,width)) - ,@(when height `(:height ,height))))) - ,@(loop for c in children collect `(layout-node-add-child ,n ,c)) - ,n))) - -(defmacro hbox ((&key grow shrink padding margin gap width height) &body children) - (let ((n (gensym))) - `(let ((,n (make-layout-node :direction :row - ,@(when grow `(:grow ,grow)) - ,@(when shrink `(:shrink ,shrink)) - ,@(when padding `(:padding ,padding)) - ,@(when margin `(:margin ,margin)) - ,@(when gap `(:gap ,gap)) - ,@(when width `(:width ,width)) - ,@(when height `(:height ,height))))) - ,@(loop for c in children collect `(layout-node-add-child ,n ,c)) - ,n))) - -(defmacro spacer (&key grow) - `(make-layout-node :grow ,(or grow 1))) diff --git a/src/layout/tests.lisp b/src/layout/tests.lisp deleted file mode 100644 index 1fb9e30..0000000 --- a/src/layout/tests.lisp +++ /dev/null @@ -1,167 +0,0 @@ -(defpackage :cl-tty-layout-test - (:use :cl :fiveam :cl-tty.layout) - (:export #:run-tests)) -(in-package :cl-tty-layout-test) - -(def-suite layout-suite :description "Layout engine tests") -(in-suite layout-suite) - -(defun run-tests () - (let ((result (run 'layout-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -(test make-layout-node-defaults - (let ((n (make-layout-node))) - (is (typep n 'layout-node)) - (is (eql (layout-node-direction n) :column)))) - -(test make-layout-node-row - (let ((n (make-layout-node :direction :row))) - (is (eql (layout-node-direction n) :row)))) - -(test add-child-sets-parent - (let ((parent (make-layout-node)) (child (make-layout-node))) - (layout-node-add-child parent child) - (is (eql (layout-node-parent child) parent)) - (is (= (length (layout-node-children parent)) 1)))) - -(test remove-child-clears-parent - (let ((parent (make-layout-node)) (child (make-layout-node))) - (layout-node-add-child parent child) - (layout-node-remove-child parent child) - (is (null (layout-node-parent child))) - (is (= (length (layout-node-children parent)) 0)))) - -(test column-two-children-vertical - (let* ((root (make-layout-node :direction :column)) - (c1 (make-layout-node :height 3)) - (c2 (make-layout-node :height 5))) - (layout-node-add-child root c1) (layout-node-add-child root c2) - (compute-layout root 20 20) - (is (= (layout-node-y c1) 0)) (is (= (layout-node-height c1) 3)) - (is (= (layout-node-y c2) 3)) (is (= (layout-node-height c2) 5)))) - -(test row-two-children-horizontal - (let* ((root (make-layout-node :direction :row)) - (c1 (make-layout-node :width 10)) - (c2 (make-layout-node :width 5))) - (layout-node-add-child root c1) (layout-node-add-child root c2) - (compute-layout root 20 10) - (is (= (layout-node-x c1) 0)) (is (= (layout-node-width c1) 10)) - (is (= (layout-node-x c2) 10)) (is (= (layout-node-width c2) 5)))) - -(test flex-grow-distributes-space - (let* ((root (make-layout-node :direction :row :width 20)) - (c1 (make-layout-node :width 4 :grow 1)) - (c2 (make-layout-node :width 4 :grow 2))) - (layout-node-add-child root c1) (layout-node-add-child root c2) - (compute-layout root 20 10) - (is (= (layout-node-width c1) 8)) (is (= (layout-node-width c2) 12)))) - -(test flex-grow-single-child - (let* ((root (make-layout-node :direction :row :width 20)) - (c (make-layout-node :width 5 :grow 1))) - (layout-node-add-child root c) - (compute-layout root 20 10) - (is (= (layout-node-width c) 20)))) - -(test flex-shrink-reduces-overflow - (let* ((root (make-layout-node :direction :row :width 10)) - (c1 (make-layout-node :width 8 :shrink 1)) - (c2 (make-layout-node :width 8 :shrink 1))) - (layout-node-add-child root c1) (layout-node-add-child root c2) - (compute-layout root 10 10) - (is (= (layout-node-width c1) 5)) (is (= (layout-node-width c2) 5)))) - -(test padding-reduces-content-area - (let* ((root (make-layout-node :direction :column :padding '(:top 1 :left 1 :bottom 1 :right 1))) - (c (make-layout-node :height 3))) - (layout-node-add-child root c) - (compute-layout root 20 10) - (is (= (layout-node-x c) 1)) (is (= (layout-node-y c) 1)) - (is (= (layout-node-height c) 3)))) - -(test gap-between-children - (let* ((root (make-layout-node :direction :column :gap 2)) - (c1 (make-layout-node :height 3)) - (c2 (make-layout-node :height 3))) - (layout-node-add-child root c1) (layout-node-add-child root c2) - (compute-layout root 20 20) - (is (= (layout-node-y c1) 0)) (is (= (layout-node-y c2) 5)))) - -(test vbox-macro - (let ((r (vbox () (make-layout-node :height 3) (make-layout-node :height 5)))) - (compute-layout r 20 20) - (is (= (length (layout-node-children r)) 2)) - (is (= (layout-node-y (elt (layout-node-children r) 1)) 3)))) - -(test hbox-macro - (let ((r (hbox () (make-layout-node :width 5) (make-layout-node :width 3)))) - (compute-layout r 20 10) - (is (= (length (layout-node-children r)) 2)) - (is (= (layout-node-x (elt (layout-node-children r) 1)) 5)))) - -(test spacer-takes-grow - (let ((r (hbox (:width 20) (make-layout-node :width 5) (spacer :grow 1) (make-layout-node :width 5)))) - (compute-layout r 20 10) - (let ((c (layout-node-children r))) - (is (= (layout-node-x (elt c 2)) 15)) (is (= (layout-node-width (elt c 1)) 10))))) - -(test nested-vbox-in-hbox - (let* ((sidebar (vbox (:width 5 :height 10) (make-layout-node :height 3) (make-layout-node :height 7))) - (main (vbox (:grow 1 :height 10) (make-layout-node :height 2) (make-layout-node :grow 1))) - (r (hbox (:width 30 :height 10) sidebar main))) - (compute-layout r 30 10) - (is (= (layout-node-width sidebar) 5)) - (is (>= (layout-node-width main) 20)) - (let ((sc (layout-node-children sidebar))) - (is (= (layout-node-y (elt sc 0)) 0)) - (is (= (layout-node-y (elt sc 1)) 3))))) - -(test empty-container-does-not-crash - (let ((r (make-layout-node))) - (compute-layout r 20 20) - (is (integerp (layout-node-width r))) - (is (integerp (layout-node-height r))))) - -(test single-child-in-column - (let* ((r (make-layout-node :direction :column :width 10 :height 20)) - (c (make-layout-node :height 5))) - (layout-node-add-child r c) - (compute-layout r 10 20) - (is (= (layout-node-y c) 0)) - (is (= (layout-node-height c) 5)))) - -(test zero-size-container - (let* ((r (make-layout-node :direction :column)) - (c (make-layout-node :height 5))) - (layout-node-add-child r c) - (compute-layout r 0 0) - (is (integerp (layout-node-x c))) - (is (integerp (layout-node-y c))))) - -(test deep-nesting-three-levels - (let* ((out (vbox () - (vbox (:grow 1) - (make-layout-node :height 2)))) - (leaf (elt (layout-node-children - (elt (layout-node-children out) 0)) 0))) - (compute-layout out 20 20) - (is (= (layout-node-y leaf) 0)))) - -(test large-padding-leaves-room - (let* ((r (make-layout-node :direction :column - :padding '(:top 5 :left 5 :bottom 5 :right 5))) - (c (make-layout-node :height 3))) - (layout-node-add-child r c) - (compute-layout r 20 20) - (is (= (layout-node-x c) 5)) - (is (= (layout-node-y c) 5)))) - -(test negative-grow-is-clamped - (let* ((r (make-layout-node :direction :row :width 10)) - (c (make-layout-node :width 5 :grow -1))) - (layout-node-add-child r c) - (compute-layout r 10 10) - (is (integerp (layout-node-width c))))) diff --git a/src/rendering/framebuffer.lisp b/src/rendering/framebuffer.lisp deleted file mode 100644 index 7485212..0000000 --- a/src/rendering/framebuffer.lisp +++ /dev/null @@ -1,223 +0,0 @@ -(defpackage :cl-tty.rendering - (:use :cl :cl-tty.backend) - (:export - #:cell #:make-cell #:cell-char #:cell-fg #:cell-bg - #:cell-bold #:cell-italic #:cell-underline #:cell-link-url - #:framebuffer-backend #:make-framebuffer-backend - #:make-framebuffer #:fb-framebuffer - #:framebuffer-width #:framebuffer-height - #:diff-framebuffers #:flush-framebuffer - #:with-scissor - #:extract-text #:fb-cell-link-url)) - -(in-package :cl-tty.rendering) - -(defstruct cell - "A single terminal cell — character, colors, and attributes." - (char #\space :type character) - (fg nil) - (bg nil) - (bold nil :type boolean) - (italic nil :type boolean) - (underline nil :type boolean) - (link-url nil)) - -(defun make-framebuffer (width height) - "Create a 2D array of CELL with dimensions HEIGHT x WIDTH." - (make-array (list height width) - :initial-element (make-cell) - :element-type 'cell)) - -(defun framebuffer-width (fb) - "Return the width (columns) of framebuffer FB." - (if (arrayp fb) (array-dimension fb 1) 0)) - -(defun framebuffer-height (fb) - "Return the height (rows) of framebuffer FB." - (if (arrayp fb) (array-dimension fb 0) 0)) - -(defclass framebuffer-backend (backend) - ((framebuffer :initform nil :accessor fb-framebuffer) - (scissor-x :initform 0 :accessor fb-scissor-x) - (scissor-y :initform 0 :accessor fb-scissor-y) - (scissor-w :initform nil :accessor fb-scissor-w) - (scissor-h :initform nil :accessor fb-scissor-h))) - -(defun make-framebuffer-backend (&key (width 80) (height 24)) - "Create a framebuffer-backend with a fresh framebuffer." - (let ((fb (make-instance 'framebuffer-backend))) - (setf (fb-framebuffer fb) (make-framebuffer width height)) - fb)) - -(defun %in-scissor-p (fb cx cy) - "Check if (CX, CY) falls within the current scissor rectangle." - (let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) - (sw (fb-scissor-w fb)) (sh (fb-scissor-h fb))) - (and (or (null sw) (and (>= cx sx) (< cx (+ sx sw)))) - (or (null sh) (and (>= cy sy) (< cy (+ sy sh))))))) - -(defun %set-cell (fb x y char &key fg bg bold italic underline link-url) - "Set cell (X, Y) if within bounds and scissor." - (let ((cells (fb-framebuffer fb))) - (when (and (>= y 0) (< y (framebuffer-height cells)) - (>= x 0) (< x (framebuffer-width cells)) - (%in-scissor-p fb x y)) - (setf (aref cells y x) - (make-cell :char char :fg fg :bg bg - :bold bold :italic italic :underline underline - :link-url link-url))))) - -(defmethod draw-text ((fb framebuffer-backend) x y string fg bg - &key bold italic underline reverse dim blink - (link-url nil link-url-p) - &allow-other-keys) - (declare (ignore reverse dim blink link-url-p)) - (loop for i from 0 below (length string) - do (%set-cell fb (+ x i) y (char string i) - :fg fg :bg bg - :bold bold :italic italic :underline underline - :link-url link-url))) - -(defmethod draw-text ((fb array) x y string fg bg - &key bold italic underline reverse dim blink - &allow-other-keys) - (declare (ignore reverse dim blink)) - (let ((h (array-dimension fb 0)) - (w (array-dimension fb 1))) - (loop for i from 0 below (length string) - for cx from x - while (< cx w) - when (and (< y h) (>= cx 0) (>= y 0)) - do (setf (aref fb y cx) - (make-cell :char (char string i) - :fg fg :bg bg - :bold bold :italic italic :underline underline))))) - -(defmethod backend-clear ((fb array)) - (dotimes (y (array-dimension fb 0)) - (dotimes (x (array-dimension fb 1)) - (setf (aref fb y x) (make-cell))))) - -(defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg) - (dotimes (row h) - (dotimes (col w) - (%set-cell fb (+ x col) (+ y row) #\space :fg nil :bg bg)))) - -(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg) - (let* ((chars (case style - (:single '(#\+ #\- #\|)) - (:double '(#\+ #\= #\|)) - (:rounded '(#\. #\- #\|)) - (t '(#\+ #\- #\|)))) - (tc (first chars)) (hc (second chars)) (vc (third chars))) - ;; Top edge - (%set-cell fb x y tc :fg fg :bg bg) - (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) y hc :fg fg :bg bg)) - (%set-cell fb (1- (+ x w)) y tc :fg fg :bg bg) - ;; Sides - (dotimes (row (- h 2)) - (%set-cell fb x (+ y row 1) vc :fg fg :bg bg) - (%set-cell fb (1- (+ x w)) (+ y row 1) vc :fg fg :bg bg)) - ;; Bottom edge - (%set-cell fb x (+ y h -1) tc :fg fg :bg bg) - (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) (+ y h -1) hc :fg fg :bg bg)) - (%set-cell fb (1- (+ x w)) (+ y h -1) tc :fg fg :bg bg) - ;; Title - (when title - (loop for i from 0 below (length title) - do (%set-cell fb (+ x 2 i) y (char title i) :fg fg :bg bg))))) - -(defmethod backend-clear ((fb framebuffer-backend)) - (let ((cells (fb-framebuffer fb))) - (dotimes (y (framebuffer-height cells)) - (dotimes (x (framebuffer-width cells)) - (setf (aref cells y x) (make-cell)))))) - -(defmethod draw-link ((fb framebuffer-backend) x y string url &key fg bg) - ;; OSC 8 links are not rendered in framebuffer — store as text - (draw-text fb x y string fg bg :link-url url)) - -(defmethod draw-ellipsis ((fb framebuffer-backend) x y width &key fg bg) - (dotimes (i (min 3 width)) - (%set-cell fb (+ x i) y #\. :fg fg :bg bg))) - -(defun cells-equal-p (a b) - "Return T if two cells have identical content and style." - (and (eql (cell-char a) (cell-char b)) - (eql (cell-fg a) (cell-fg b)) - (eql (cell-bg a) (cell-bg b)) - (eql (cell-bold a) (cell-bold b)) - (eql (cell-italic a) (cell-italic b)) - (eql (cell-underline a) (cell-underline b)) - (equal (cell-link-url a) (cell-link-url b)))) - -(defun diff-framebuffers (prev curr) - "Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes." - (let ((changes nil) - (h (min (framebuffer-height prev) (framebuffer-height curr))) - (w (min (framebuffer-width prev) (framebuffer-width curr)))) - (dotimes (y h) - (dotimes (x w) - (let ((a (aref prev y x)) (b (aref curr y x))) - (unless (cells-equal-p a b) - (push (list x y b) changes))))) - (nreverse changes))) - -(defun flush-framebuffer (prev-fb curr-fb backend) - "Diff PREV-FB and CURR-FB and flush changes to BACKEND. -Returns the number of changed cells." - (let* ((changes (diff-framebuffers prev-fb curr-fb)) - (count (length changes)) - (current-row -1)) - (when (plusp count) - (begin-sync backend) - (dolist (change changes) - (destructuring-bind (x y cell) change - (unless (= y current-row) - (cursor-move backend x y) - (setf current-row y)) - (draw-text backend x y (string (cell-char cell)) - (cell-fg cell) (cell-bg cell) - :bold (cell-bold cell) - :italic (cell-italic cell) - :underline (cell-underline cell)))) - (end-sync backend)) - count)) - -(defun fb-cell-link-url (fb x y) - "Return the link URL at (X Y) in framebuffer FB, or nil." - (when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0)) - (>= x 0) (< x (array-dimension fb 1))) - (let ((c (aref fb y x))) - (cell-link-url c)))) - -(defun extract-text (fb x1 y1 x2 y2) - "Extract visible text from the rectangle between (X1,Y1) and (X2,Y2)." - (let ((x-min (max 0 (min x1 x2))) (x-max (max 0 (max x1 x2))) - (y-min (max 0 (min y1 y2))) (y-max (max 0 (max y1 y2))) - (h (if (arrayp fb) (array-dimension fb 0) 0)) - (w (if (arrayp fb) (array-dimension fb 1) 0))) - (with-output-to-string (s) - (loop for y from y-min to (min y-max (1- h)) - do (loop for x from x-min to (min x-max (1- w)) - do (let ((c (aref fb y x))) - (princ (cell-char c) s))) - (when (< y y-max) (princ #\Newline s)))))) - -(defmacro with-scissor ((fb x y w h) &body body) - "Clip all drawing on FB to rectangle (X Y W H)." - (let ((old-x (gensym)) (old-y (gensym)) - (old-w (gensym)) (old-h (gensym))) - `(let ((,old-x (fb-scissor-x ,fb)) - (,old-y (fb-scissor-y ,fb)) - (,old-w (fb-scissor-w ,fb)) - (,old-h (fb-scissor-h ,fb))) - (setf (fb-scissor-x ,fb) ,x - (fb-scissor-y ,fb) ,y - (fb-scissor-w ,fb) ,w - (fb-scissor-h ,fb) ,h) - (unwind-protect (progn ,@body) - (setf (fb-scissor-x ,fb) ,old-x - (fb-scissor-y ,fb) ,old-y - (fb-scissor-w ,fb) ,old-w - (fb-scissor-h ,fb) ,old-h))))) diff --git a/tests/dialog-tests.lisp b/tests/dialog-tests.lisp deleted file mode 100644 index ee27b7c..0000000 --- a/tests/dialog-tests.lisp +++ /dev/null @@ -1,43 +0,0 @@ -;;; dialog-tests.lisp — Tests for cl-tty.dialog - -(defpackage :cl-tty-dialog-test - (:use :cl :cl-tty.dialog :fiveam)) - -(in-package :cl-tty-dialog-test) - -(def-suite dialog-suite :description "Dialog + Toast tests for cl-tty.dialog") -(in-suite dialog-suite) - -(def-test dialog-create () - (let ((d (make-instance 'dialog :title "Test"))) - (is-true (typep d 'dialog)) - (is (equal "Test" (dialog-title d))))) - -(def-test dialog-size-small () - (multiple-value-bind (w h) (dialog-size-pixels :small) - (is (= 40 w)) - (is (= 8 h)))) - -(def-test dialog-size-medium () - (multiple-value-bind (w h) (dialog-size-pixels :medium) - (is (= 60 w)) - (is (= 16 h)))) - -(def-test dialog-push-pop () - (let ((*dialog-stack* nil)) - (push-dialog (make-instance 'dialog :title "D1")) - (is (= 1 (length *dialog-stack*))) - (push-dialog (make-instance 'dialog :title "D2")) - (is (= 2 (length *dialog-stack*))) - (pop-dialog) - (is (= 1 (length *dialog-stack*))))) - -(def-test toast-create () - (let ((*toasts* nil)) - (toast "Hello" :variant :info :duration 0) - (is (= 1 (length *toasts*))))) - -(def-test toast-dismiss () - (let ((*toasts* (list (make-instance 'toast :message "T" :variant :info)))) - (dismiss-toast (first *toasts*)) - (is (= 0 (length *toasts*))))) diff --git a/tests/framebuffer-tests.lisp b/tests/framebuffer-tests.lisp deleted file mode 100644 index fc3cef2..0000000 --- a/tests/framebuffer-tests.lisp +++ /dev/null @@ -1,110 +0,0 @@ -(defpackage :cl-tty-framebuffer-test - (:use :cl :fiveam :cl-tty.rendering :cl-tty.backend)) -(in-package :cl-tty-framebuffer-test) - -(def-suite framebuffer-suite :description "Framebuffer rendering pipeline tests") -(in-suite framebuffer-suite) - -(test make-framebuffer-creates-correct-size - (let ((fb (make-framebuffer 80 24))) - (is (= 24 (framebuffer-height fb))) - (is (= 80 (framebuffer-width fb))))) - -(test cell-defaults-are-space - (let ((cell (aref (make-framebuffer 10 10) 0 0))) - (is (eql #\space (cell-char cell))) - (is (null (cell-fg cell))) - (is (null (cell-bg cell))))) - -(test draw-text-on-fb-sets-cells - (let ((fb (make-framebuffer-backend))) - (draw-text fb 2 3 "abc" :red nil) - (let ((cells (fb-framebuffer fb))) - (is (eql #\a (cell-char (aref cells 3 2)))) - (is (eql #\b (cell-char (aref cells 3 3)))) - (is (eql #\c (cell-char (aref cells 3 4)))) - (is (eql :red (cell-fg (aref cells 3 2))))))) - -(test draw-text-clips-at-bounds - (let ((fb (make-framebuffer-backend :width 10 :height 5))) - (draw-text fb 8 2 "hello" nil nil) - (let ((cells (fb-framebuffer fb))) - (is (eql #\h (cell-char (aref cells 2 8)))) - (is (eql #\e (cell-char (aref cells 2 9)))) - (is (eql #\space (cell-char (aref cells 2 0))) "out of bounds text is ignored")))) - -(test diff-identical-fbs-returns-empty - (let ((fb1 (make-framebuffer 80 24)) - (fb2 (make-framebuffer 80 24))) - (is (null (diff-framebuffers fb1 fb2))))) - -(test diff-changed-fb-returns-changes - (let* ((fb1 (make-framebuffer 10 10)) - (fb2 (make-framebuffer 10 10))) - (setf (aref fb2 5 5) (make-cell :char #\X :fg :red)) - (let ((changes (diff-framebuffers fb1 fb2))) - (is (= 1 (length changes))) - (destructuring-bind (x y cell) (first changes) - (is (= 5 x)) - (is (= 5 y)) - (is (eql #\X (cell-char cell))))))) - -(test with-scissor-clips-drawing - (let ((fb (make-framebuffer-backend :width 20 :height 10))) - (with-scissor (fb 5 5 3 3) - (draw-text fb 6 6 "ABC" nil nil) - (draw-text fb 1 1 "OUTSIDE" nil nil)) - (let ((cells (fb-framebuffer fb))) - (is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws") - (is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped")))) - -(test flush-different-sized-fbs-handles-edge-cells - (let* ((small-fb (make-framebuffer 5 5)) - (large-fb (make-framebuffer 10 10)) - (be (make-simple-backend :output-stream (make-string-output-stream)))) - (setf (aref small-fb 0 0) (make-cell :char #\X :fg :red)) - (let ((changes (diff-framebuffers small-fb large-fb))) - (is (= 1 (length changes)) "one cell changed in overlap region")) - (let ((changed (flush-framebuffer small-fb large-fb be))) - (is (= 1 changed) "flush reports 1 changed cell")) - (setf (aref large-fb 9 9) (make-cell :char #\Y :fg :blue)) - (let ((changes2 (diff-framebuffers large-fb small-fb))) - (is (= 1 (length changes2)) "only overlapping region diffed")) - (let ((changed2 (flush-framebuffer large-fb small-fb be))) - (is (= 1 changed2) "flush with shrunk fb reports 1 changed cell")))) - -(test flush-fb-copies-to-backend - (let* ((real-be (make-simple-backend :output-stream (make-string-output-stream))) - (fb (make-framebuffer-backend))) - (draw-text fb 0 0 "X" :red nil) - (let ((changed (flush-framebuffer (make-framebuffer 80 24) (fb-framebuffer fb) real-be))) - (is (>= changed 1))))) - -(test fb-cell-link-url-returns-nil-for-blank-cell - (let ((fb (make-framebuffer 10 10))) - (is (null (fb-cell-link-url fb 5 5))))) - -(test fb-cell-link-url-finds-link-url - (let ((fb (make-framebuffer-backend))) - (draw-text fb 0 0 "click" nil nil :link-url "https://example.com") - (is (equal "https://example.com" (fb-cell-link-url (fb-framebuffer fb) 0 0))) - (is (null (fb-cell-link-url (fb-framebuffer fb) 5 5))))) - -(test fb-cell-link-url-out-of-bounds-returns-nil - (let ((fb (make-framebuffer 5 5))) - (is (null (fb-cell-link-url fb 10 10))))) - -(test extract-text-single-row - (let ((fb (make-framebuffer-backend))) - (draw-text fb 0 0 "hello" nil nil) - (let ((cells (fb-framebuffer fb))) - (is (equal "hello" (extract-text cells 0 0 4 0)))))) - -(test extract-text-multi-row - (let ((fb (make-framebuffer-backend))) - (draw-text fb 0 0 "abc" nil nil) - (draw-text fb 0 1 "def" nil nil) - (let* ((cells (fb-framebuffer fb)) - (text (extract-text cells 0 0 2 1))) - (is (equal "abc -def" text))))) diff --git a/tests/input-tests.lisp b/tests/input-tests.lisp deleted file mode 100644 index a5cf952..0000000 --- a/tests/input-tests.lisp +++ /dev/null @@ -1,409 +0,0 @@ -(defpackage :cl-tty-input-test - (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) - (:export #:run-tests)) -(in-package :cl-tty-input-test) - -(def-suite input-suite :description "Text input and keybinding tests") -(in-suite input-suite) - -(defun run-tests () - (let ((result (run 'input-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -;; ── Key Event Tests ───────────────────────────────────────────── - -(test key-event-construction - "A key-event can be created and queried." - (let ((e (make-key-event :key :a :ctrl t :alt nil))) - (is (eql (key-event-key e) :a)) - (is-true (key-event-ctrl e)) - (is-false (key-event-alt e)))) - -(test key-event-defaults - "Fields default to NIL/nil." - (let ((e (make-key-event :key :space))) - (is (eql (key-event-key e) :space)) - (is-false (key-event-ctrl e)) - (is-false (key-event-alt e)) - (is-false (key-event-shift e)))) - -(test mouse-event-construction - "A mouse-event can be created and queried." - (let ((e (make-mouse-event :type :press :button :left :x 10 :y 5))) - (is (eql (mouse-event-type e) :press)) - (is (eql (mouse-event-button e) :left)) - (is (= (mouse-event-x e) 10)) - (is (= (mouse-event-y e) 5)))) - -;; ── UTF-8 Decode Tests ────────────────────────────────────────── - -(test utf8-decode-latin1-supplement - "0xC3 0xA9 (é) decodes to code point 233." - (is (= (cl-tty.input:utf8-decode '(#xc3 #xa9)) 233))) - -(test utf8-decode-euro-sign - "0xE2 0x82 0xAC (€) decodes to code point 8364." - (is (= (cl-tty.input:utf8-decode '(#xe2 #x82 #xac)) 8364))) - -(test utf8-decode-emoji - "0xF0 0x9F 0x92 0xA9 (💩) decodes to code point 128169." - (is (= (cl-tty.input:utf8-decode '(#xf0 #x9f #x92 #xa9)) 128169))) - -(test utf8-decode-invalid-short - "Invalid byte 0x80 alone returns nil." - (is-false (cl-tty.input:utf8-decode '(#x80)))) - -(test utf8-decode-invalid-overlong - "Overlong 2-byte sequence 0xC0 0x80 returns nil." - (is-false (cl-tty.input:utf8-decode '(#xc0 #x80)))) - -;; ── TextInput Tests ───────────────────────────────────────────── - -(test text-input-empty - "A newly created text-input has empty value and cursor at 0." - (let ((in (make-text-input))) - (is (string= (text-input-value in) "")) - (is (= (text-input-cursor in) 0)))) - -(test text-input-insert-char - "Inserting a character appends and moves cursor." - (let ((in (make-text-input))) - (handle-text-input in (make-key-event :key :a :code (char-code #\a))) - (is (string= (text-input-value in) "a")) - (is (= (text-input-cursor in) 1)))) - -(test text-input-insert-multiple - "Inserting multiple characters works left to right." - (let ((in (make-text-input))) - (handle-text-input in (make-key-event :key :h :code (char-code #\h))) - (handle-text-input in (make-key-event :key :e :code (char-code #\e))) - (handle-text-input in (make-key-event :key :l :code (char-code #\l))) - (handle-text-input in (make-key-event :key :l :code (char-code #\l))) - (handle-text-input in (make-key-event :key :o :code (char-code #\o))) - (is (string= (text-input-value in) "hello")) - (is (= (text-input-cursor in) 5)))) - -(test text-input-backspace - "Backspace removes the character before the cursor." - (let ((in (make-text-input :value "ab" :cursor 2))) - (handle-text-input in (make-key-event :key :backspace)) - (is (string= (text-input-value in) "a")) - (is (= (text-input-cursor in) 1)))) - -(test text-input-backspace-at-start - "Backspace at position 0 does nothing." - (let ((in (make-text-input :value "ab" :cursor 0))) - (handle-text-input in (make-key-event :key :backspace)) - (is (string= (text-input-value in) "ab")) - (is (= (text-input-cursor in) 0)))) - -(test text-input-delete - "Delete removes the character at the cursor." - (let ((in (make-text-input :value "abc" :cursor 1))) - (handle-text-input in (make-key-event :key :delete)) - (is (string= (text-input-value in) "ac")) - (is (= (text-input-cursor in) 1)))) - -(test text-input-cursor-left-right - "Cursor moves left and right." - (let ((in (make-text-input :value "ab" :cursor 2))) - (handle-text-input in (make-key-event :key :left)) - (is (= (text-input-cursor in) 1)) - (handle-text-input in (make-key-event :key :right)) - (is (= (text-input-cursor in) 2)))) - -(test text-input-cursor-bounds - "Cursor cannot move past start or end." - (let ((in (make-text-input :value "ab" :cursor 0))) - (handle-text-input in (make-key-event :key :left)) - (is (= (text-input-cursor in) 0)) - (setf (text-input-cursor in) 2) - (handle-text-input in (make-key-event :key :right)) - (is (= (text-input-cursor in) 2)))) - -(test text-input-home-end - "Home moves to start, End moves to end." - (let ((in (make-text-input :value "hello" :cursor 3))) - (handle-text-input in (make-key-event :key :home)) - (is (= (text-input-cursor in) 0)) - (handle-text-input in (make-key-event :key :end)) - (is (= (text-input-cursor in) 5)))) - -(test text-input-max-length - "Max-length prevents inserting beyond the limit." - (let ((in (make-text-input :max-length 3))) - (handle-text-input in (make-key-event :key :a :code (char-code #\a))) - (handle-text-input in (make-key-event :key :b :code (char-code #\b))) - (handle-text-input in (make-key-event :key :c :code (char-code #\c))) - (handle-text-input in (make-key-event :key :d :code (char-code #\d))) - (is (string= (text-input-value in) "abc")))) - -(test text-input-placeholder - "Placeholder is stored but does not affect value." - (let ((in (make-text-input :placeholder "Type here..."))) - (is (string= (text-input-placeholder in) "Type here...")) - (is (string= (text-input-value in) "")))) - -(test text-input-on-submit - "On-submit callback fires on Enter." - (let ((result (list nil))) - (let ((in (make-text-input :value "hello" - :on-submit (lambda (v) (setf (car result) v))))) - (handle-text-input in (make-key-event :key :enter)) - (is (string= (car result) "hello"))))) - -(test text-input-ctrl-a-e - "Ctrl+A moves to home, Ctrl+E moves to end." - (let ((in (make-text-input :value "abc" :cursor 2))) - (handle-text-input in (make-key-event :key :a :ctrl t)) - (is (= (text-input-cursor in) 0)) - (handle-text-input in (make-key-event :key :e :ctrl t)) - (is (= (text-input-cursor in) 3)))) - -(test text-input-insert-in-middle - "Inserting in the middle of text shifts rest right." - (let ((in (make-text-input :value "ab" :cursor 1))) - (handle-text-input in (make-key-event :key :x :code (char-code #\x))) - (is (string= (text-input-value in) "axb")) - (is (= (text-input-cursor in) 2)))) - -(test text-input-dirty-on-insert - "Inserting marks the widget dirty." - (let ((in (make-text-input))) - (mark-clean in) - (handle-text-input in (make-key-event :key :a :code (char-code #\a))) - (is-true (dirty-p in)))) - -;; ── Textarea Tests ────────────────────────────────────────────── - -(test textarea-empty - "New textarea has empty value and cursor at (0,0)." - (let ((a (make-textarea))) - (is (string= (textarea-value a) "")) - (is (= (textarea-cursor-row a) 0)) - (is (= (textarea-cursor-col a) 0)))) - -(test textarea-newline - "Enter inserts a newline." - (let ((a (make-textarea))) - (handle-textarea-input a (make-key-event :key :a :code (char-code #\a))) - (handle-textarea-input a (make-key-event :key :enter)) - (handle-textarea-input a (make-key-event :key :b :code (char-code #\b))) - (is (string= (textarea-value a) (format nil "a~Cb" #\Newline))))) - -(test textarea-cursor-up-down - "Cursor moves between lines maintaining column position." - (let ((a (make-textarea :value (format nil "abc~Cde~Cfghi" #\Newline #\Newline)))) - (setf (textarea-cursor-row a) 1) - (setf (textarea-cursor-col a) 1) - (handle-textarea-input a (make-key-event :key :up)) - (is (= (textarea-cursor-row a) 0)) - (is (= (textarea-cursor-col a) 1)) - (handle-textarea-input a (make-key-event :key :down)) - (is (= (textarea-cursor-row a) 1)) - (is (= (textarea-cursor-col a) 1)))) - -(test textarea-cursor-up-down-bounds - "Cursor cannot move past first or last line." - (let ((a (make-textarea :value (format nil "a~Cb" #\Newline)))) - (handle-textarea-input a (make-key-event :key :up)) - (is (= (textarea-cursor-row a) 0)) - (setf (textarea-cursor-row a) 1) - (handle-textarea-input a (make-key-event :key :down)) - (is (= (textarea-cursor-row a) 1)))) - -(test textarea-backspace-joins-lines - "Backspace at start of a line joins with previous." - (let ((a (make-textarea :value (format nil "hello~Cworld" #\Newline)))) - (setf (textarea-cursor-row a) 1) - (setf (textarea-cursor-col a) 0) - (handle-textarea-input a (make-key-event :key :backspace)) - (is (string= (textarea-value a) "helloworld")))) - -(test textarea-undo - "Ctrl+Z undoes the last edit." - (let ((a (make-textarea))) - (handle-textarea-input a (make-key-event :key :a :code (char-code #\a))) - (handle-textarea-input a (make-key-event :key :z :ctrl t)) - (is (string= (textarea-value a) "")))) - -(test textarea-undo-redo - "Ctrl+Y redoes an undone edit." - (let ((a (make-textarea))) - (handle-textarea-input a (make-key-event :key :a :code (char-code #\a))) - (handle-textarea-input a (make-key-event :key :z :ctrl t)) - (handle-textarea-input a (make-key-event :key :y :ctrl t)) - (is (string= (textarea-value a) "a")))) - -;; ── Keybinding Tests ──────────────────────────────────────────── -;; These tests verify the keymap dispatch system works correctly -;; when wired up. Note: dispatch-key-event is NOT called by the -;; demo's event loop — users MUST call it explicitly in their own -;; event loops if they want to use the defkeymap/dispatch-key-event -;; system. See src/components/keybindings.lisp for details. -;; -;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single -;; key specs work. The *chord-timeout* variable and list-of-lists -;; syntax are reserved for future implementation. - -(test keymap-simple - "A keymap dispatches to its handler on matching event." - (let ((called nil)) - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+p . ,(lambda (e) - (declare (ignore e)) - (setf called t)))))) - (is-true (dispatch-key-event (make-key-event :key :p :ctrl t))) - (is-true called))) - -(test keymap-no-match - "Non-matching event returns nil." - (let ((called nil)) - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+p . ,(lambda (e) - (declare (ignore e)) - (setf called t)))))) - (is-false (dispatch-key-event (make-key-event :key :a))) - (is-false called))) - -(test keymap-fallback - "Event not in local falls through to global." - (let ((global-called nil)) - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+q . ,(lambda (e) - (declare (ignore e)) - (setf global-called t)))))) - (dispatch-key-event (make-key-event :key :q :ctrl t)) - (is-true global-called))) - -(test key-spec-simple - "Keyword key-spec matches key+ctrl." - (is-true (key-match-p :ctrl+p (make-key-event :key :p :ctrl t))) - (is-false (key-match-p :ctrl+p (make-key-event :key :a :ctrl t))) - (is-false (key-match-p :ctrl+p (make-key-event :key :p)))) - -(test key-spec-alt-modifier - "Alt modifier is matched correctly." - (is-true (key-match-p :alt+x (make-key-event :key :x :alt t))) - (is-false (key-match-p :alt+x (make-key-event :key :x))) - (is-false (key-match-p :alt+x (make-key-event :key :x :ctrl t)))) - -(test key-spec-shift-modifier - "Shift modifier is matched correctly." - (is-true (key-match-p :shift+tab (make-key-event :key :tab :shift t))) - (is-false (key-match-p :shift+tab (make-key-event :key :tab)))) - -(test key-spec-plain - "Plain key spec matches unmodified keys." - (is-true (key-match-p :enter (make-key-event :key :enter))) - (is-true (key-match-p :escape (make-key-event :key :escape))) - (is-false (key-match-p :enter (make-key-event :key :escape)))) - -(test key-spec-list-form - "List-form spec (:ctrl+p) matches same as keyword :ctrl+p." - (is-true (key-match-p '(:ctrl+p) (make-key-event :key :p :ctrl t))) - (is-false (key-match-p '(:ctrl+p) (make-key-event :key :a :ctrl t)))) - -(test dispatch-return-value-match - "dispatch-key-event returns T on matching binding." - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e))))))) - (is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))) - -(test dispatch-return-value-no-match - "dispatch-key-event returns NIL when no binding matches." - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e))))))) - (is-false (dispatch-key-event (make-key-event :key :a)))) - -(test dispatch-empty-keymap - "dispatch-key-event returns NIL on empty keymap." - (setf (gethash :global *keymaps*) (make-keymap :name :global)) - (is-false (dispatch-key-event (make-key-event :key :a)))) - -(test dispatch-local-overrides-global - "Local keymap takes priority over global." - (let ((local-called nil) (global-called nil)) - (setf (gethash :local *keymaps*) - (make-keymap :name :local - :bindings `((:ctrl+p . ,(lambda (e) - (declare (ignore e)) - (setf local-called t)))))) - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+p . ,(lambda (e) - (declare (ignore e)) - (setf global-called t)))))) - (is-true (dispatch-key-event (make-key-event :key :p :ctrl t))) - (is-true local-called) - (is-false global-called))) - -(test dispatch-multiple-bindings - "dispatch-key-event finds the right binding among many." - (let ((called nil)) - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+a . (lambda (e) (declare (ignore e)))) - (:ctrl+b . (lambda (e) (declare (ignore e)))) - (:ctrl+c . ,(lambda (e) - (declare (ignore e)) - (setf called t))) - (:ctrl+d . (lambda (e) (declare (ignore e))))))) - (is-true (dispatch-key-event (make-key-event :key :c :ctrl t))) - (is-true called))) - -(test defkeymap-macro - "defkeymap macro registers a keymap." - (let ((called nil)) - (eval `(defkeymap :global - (:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t))))) - (dispatch-key-event (make-key-event :key :q :ctrl t)) - (is-true called))) - -(test defkeymap-macro-with-list-spec - "defkeymap macro works with list-form specs." - (let ((called nil)) - (eval `(defkeymap :global - ((:ctrl+w) ,(lambda (e) (declare (ignore e)) (setf called t))))) - (dispatch-key-event (make-key-event :key :w :ctrl t)) - (is-true called))) - -;; cleanup after keybinding tests -(test keybinding-cleanup-global - "Clean up global keymap after testing." - (remhash :global *keymaps*) - (remhash :local *keymaps*) - (is-false (gethash :global *keymaps*)) - (is-false (gethash :local *keymaps*))) - -;; cleanup after keybinding tests -(test keybinding-cleanup-global - "Clean up global keymap after testing." - (remhash :global *keymaps*) - (remhash :local *keymaps*) - (is-false (gethash :global *keymaps*)) - (is-false (gethash :local *keymaps*))) - -(test resize-event-check - "read-event returns :resize when *terminal-resized-p* is set" - (let ((b (make-instance 'cl-tty.backend:backend))) - (setf cl-tty.input:*terminal-resized-p* t) - (multiple-value-bind (type data) (cl-tty.input:read-event b :timeout 0) - (is (eq :resize type)) - (is (consp data)) - (is (integerp (car data))) - (is (integerp (cdr data)))) - (is-false cl-tty.input:*terminal-resized-p*))) - -(test with-terminal-macro-expands - "with-terminal macro expands and compiles" - (is (macro-function 'cl-tty.backend:with-terminal)) - (let ((expanded (macroexpand-1 '(cl-tty.backend:with-terminal (be) - (print be))))) - (is (listp expanded)))) diff --git a/tests/integration-tests.lisp b/tests/integration-tests.lisp deleted file mode 100644 index 63b12d8..0000000 --- a/tests/integration-tests.lisp +++ /dev/null @@ -1,243 +0,0 @@ -;;; integration-tests.lisp — Full pipeline integration tests for cl-tty -;;; -;;; Composes all major components through the rendering pipeline onto a -;;; framebuffer backend and verifies cell-level output. -;;; -;;; This file is tangled from org/integration-tests.org — do not edit directly. - -(defpackage :cl-tty-integration-test - (:use :cl :fiveam - :cl-tty.backend :cl-tty.box :cl-tty.layout - :cl-tty.input :cl-tty.select :cl-tty.container - :cl-tty.rendering :cl-tty.dialog)) - -(in-package :cl-tty-integration-test) - -(def-suite integration-suite - :description "Full pipeline integration tests for cl-tty") - -(in-suite integration-suite) - -(defun fb-string (fb x y &optional (len 1)) - "Read a string of LEN characters from framebuffer FB starting at (X,Y)." - (let* ((cells (fb-framebuffer fb)) - (w (framebuffer-width cells)) - (h (framebuffer-height cells))) - (declare (ignore h)) - (with-output-to-string (s) - (loop for i from 0 below len - for cx = (+ x i) - while (< cx w) - do (princ (cell-char (aref cells y cx)) s))))) - -(defun fb-lines (fb &key (start-row 0) (end-row nil)) - "Extract all lines from framebuffer FB as a list of strings." - (let* ((cells (fb-framebuffer fb)) - (w (framebuffer-width cells)) - (h (framebuffer-height cells)) - (max-row (min (or end-row h) h))) - (declare (ignore w)) - (loop for y from start-row below max-row - collect (fb-string fb 0 y (framebuffer-width cells))))) - -(defun fb-contains (fb text) - "Return T if framebuffer FB contains TEXT anywhere." - (let ((all-text (format nil "~{~a~^~%~}" (fb-lines fb)))) - (search text all-text :test #'char-equal))) - -(test box-title-renders-on-fb - "A Box with a title draws border and title text on framebuffer." - (let* ((fb (make-framebuffer-backend :width 40 :height 10)) - (bx (make-box :border-style :single :title "My Box" :width 40 :height 10))) - (compute-layout (box-layout-node bx) 40 10) - (render-box bx fb) - ;; Framebuffer uses ASCII border chars (+, -, |) - (is-true (fb-contains fb "My Box") "title text appears") - (is-true (fb-contains fb "+") "top-left corner appears") - (is-true (fb-contains fb "-") "horizontal border appears") - ;; Check the title at row 0, col 2 - (is (equal "My Box" (fb-string fb 2 1 6)) "title at correct position"))) - -(test text-component-on-fb - "Text component renders word-wrapped content on framebuffer." - (let* ((fb (make-framebuffer-backend :width 20 :height 6)) - (tx (make-text "Hello brave new world of terminal UI" - :wrap-mode :word :width 20 :height 4))) - (compute-layout (text-layout-node tx) 20 4) - (render-text tx fb) - (is-true (fb-contains fb "Hello") "first word appears") - (is-true (fb-contains fb "brave") "second word appears") - (is-true (fb-contains fb "world") "third word wraps"))) - -(test textinput-value-on-fb - "TextInput renders its value and cursor on framebuffer." - (let* ((fb (make-framebuffer-backend :width 40 :height 3)) - (ti (make-text-input :value "hello world" :cursor 11))) - (setf (text-input-layout-node ti) - (make-layout-node :width 40 :height 1)) - (compute-layout (text-input-layout-node ti) 40 1) - (render ti fb) - ;; Verify value via direct cell inspection - (is (equal "hello world" (fb-string fb 0 0 11)) "value appears at row 0") - ;; Check cursor block at position 11 - (let* ((cells (fb-framebuffer fb)) - (cursor-char (cell-char (aref cells 0 11)))) - (is (eql #\█ cursor-char) "cursor block is drawn at position 11")))) - -(test textinput-placeholder-on-fb - "TextInput with empty value shows placeholder text." - (let* ((fb (make-framebuffer-backend :width 40 :height 3)) - (ti (make-text-input :value "" :placeholder "Type here..."))) - (setf (text-input-layout-node ti) - (make-layout-node :width 40 :height 1)) - (compute-layout (text-input-layout-node ti) 40 1) - (render ti fb) - (is (equal "Type here..." (fb-string fb 0 0 12)) "placeholder appears at row 0"))) - -(test scrollbox-children-on-fb - "ScrollBox renders visible children offset by scroll position." - (let* ((fb (make-framebuffer-backend :width 40 :height 10)) - (children nil)) - ;; Create 8 text children, each 1 line tall - (dotimes (i 8) - (let ((tx (make-text (format nil "Line ~D" (1+ i)) - :wrap-mode :none :width 40 :height 1))) - (push tx children))) - (setf children (nreverse children)) - (let ((sb (make-scroll-box :children children :scroll-y 2))) - ;; Set scroll-box layout to 40x8 viewport using component-layout-node - (let ((ln (component-layout-node sb))) - (setf (layout-node-width ln) 40) - (setf (layout-node-height ln) 8)) - ;; Layout each child too - (dolist (c children) - (compute-layout (component-layout-node c) 40 1)) - (render sb fb) - ;; Because scroll-y=2, Line 1 and Line 2 are scrolled out - ;; Line 3 should be first visible - (is-true (fb-contains fb "Line 3") "scroll-y=2 shows Line 3 first") - (is-true (fb-contains fb "Line 4") "Line 4 is visible") - (is-true (fb-contains fb "Line 5") "Line 5 is visible") - ;; Line 1 and 2 should NOT be visible (scrolled out) - (is-false (fb-contains fb "Line 1") "Line 1 scrolled out") - (is-false (fb-contains fb "Line 2") "Line 2 scrolled out")))) - -(test select-options-on-fb - "Select renders option titles on framebuffer." - (let* ((fb (make-framebuffer-backend :width 40 :height 10)) - (sel (make-select - :options '((:title "Red" :value :red) - (:title "Green" :value :green) - (:title "Blue" :value :blue))))) - (let ((ln (select-layout-node sel))) - (setf (layout-node-width ln) 40) - (setf (layout-node-height ln) 5)) - (render sel fb) - (is-true (fb-contains fb "Red") "first option appears") - (is-true (fb-contains fb "Green") "second option appears") - (is-true (fb-contains fb "Blue") "third option appears"))) - -(test dialog-appears-on-fb - "Dialog renders a dimmed backdrop and dialog panel with title." - (let* ((fb (make-framebuffer-backend :width 80 :height 24)) - (d (make-instance 'dialog :title "Confirm" :size :small))) - (push-dialog d) - (render-dialog d fb 80 24) - ;; Dialog title appears somewhere in the output - (is-true (fb-contains fb "Confirm") "dialog title appears") - ;; Dialog border (ASCII) - (is-true (fb-contains fb "+") "dialog border appears") - (is-true (fb-contains fb "|") "dialog vertical border appears") - ;; Clean up - (pop-dialog))) - -(test dialog-push-pop-render - "Dialog push/pop cycle works with rendering." - (let* ((fb (make-framebuffer-backend :width 80 :height 24)) - (d1 (make-instance 'dialog :title "Dialog One")) - (d2 (make-instance 'dialog :title "Dialog Two"))) - (push-dialog d1) - (push-dialog d2) - (render-dialog (first *dialog-stack*) fb 80 24) - (is-true (fb-contains fb "Dialog Two") "top dialog renders") - (pop-dialog) - (backend-clear fb) - (render-dialog (first *dialog-stack*) fb 80 24) - (is-true (fb-contains fb "Dialog One") "second dialog renders after pop") - (pop-dialog))) - -(test toast-appears-on-fb - "Toast notification renders with colored background." - (let* ((fb (make-framebuffer-backend :width 80 :height 24))) - (toast "Hello from toast!" :variant :info :duration 0) - (render-toast (first *toasts*) fb 80) - (is-true (fb-contains fb "Hello from toast!") "toast message appears") - (dismiss-toast (first *toasts*)))) - -(test render-screen-pipeline - "render-screen processes a component tree through the full pipeline." - (let* ((fb (make-framebuffer-backend :width 40 :height 12)) - (root (make-box :border-style :single :title "Root" - :width 40 :height 12))) - (render-screen root fb) - (is-true (fb-contains fb "Root") "title renders via render-screen") - ;; Border characters (ASCII on framebuffer) - (is-true (fb-contains fb "+") "border renders"))) - -(test full-composition-via-fb - "All components compose correctly on a single framebuffer." - (let* ((fb (make-framebuffer-backend :width 60 :height 24))) - ;; - ;; 1. Box with title at top - ;; - (let ((bx (make-box :border-style :single :title "Dashboard" - :width 60 :height 24))) - (compute-layout (box-layout-node bx) 60 24) - (render-box bx fb)) - - ;; - ;; 2. Text content inside - ;; - (let ((tx (make-text "Welcome to the dashboard." - :wrap-mode :word :width 56 :height 3))) - (setf (layout-node-x (text-layout-node tx)) 2) - (setf (layout-node-y (text-layout-node tx)) 2) - (compute-layout (text-layout-node tx) 56 3) - (render-text tx fb)) - - ;; - ;; 3. TextInput - ;; - (let ((ti (make-text-input :value "search query" :cursor 12))) - (setf (text-input-layout-node ti) (make-layout-node)) - (setf (layout-node-x (text-input-layout-node ti)) 2) - (setf (layout-node-y (text-input-layout-node ti)) 6) - (setf (layout-node-width (text-input-layout-node ti)) 56) - (setf (layout-node-height (text-input-layout-node ti)) 1) - (render ti fb)) - - ;; - ;; 4. Select options - ;; - (let ((sel (make-select - :options '((:title "Option A" :value :a) - (:title "Option B" :value :b) - (:title "Option C" :value :c))))) - (setf (select-layout-node sel) (make-layout-node)) - (setf (layout-node-x (select-layout-node sel)) 2) - (setf (layout-node-y (select-layout-node sel)) 8) - (setf (layout-node-width (select-layout-node sel)) 56) - (setf (layout-node-height (select-layout-node sel)) 3) - (render sel fb)) - - ;; - ;; Verifications - ;; - (is-true (fb-contains fb "Dashboard") "box title appears") - (is-true (fb-contains fb "Welcome") "text content appears") - ;; Check TextInput value at its position - (is (equal "search query" (fb-string fb 2 6 12)) "TextInput value at row 6") - ;; Check Select options at their positions - (is-true (fb-contains fb "Option A") "Select option A appears") - (is-true (fb-contains fb "Option B") "Select option B appears") - (is-true (fb-contains fb "Option C") "Select option C appears"))) diff --git a/tests/markdown-tests.lisp b/tests/markdown-tests.lisp deleted file mode 100644 index 21a4505..0000000 --- a/tests/markdown-tests.lisp +++ /dev/null @@ -1,294 +0,0 @@ -;;; markdown-tests.lisp — Tests for cl-tty.markdown - -(defpackage :cl-tty-markdown-test - (:use :cl :cl-tty.markdown :fiveam)) - -(in-package :cl-tty-markdown-test) - -;; Test suite -(def-suite :cl-tty-markdown-test - :description "Markdown parser/renderer tests for cl-tty.markdown") - -(in-suite :cl-tty-markdown-test) - - -;; ─── Parser edge cases ───────────────────────────────────────── - -(def-test render-markdown-nil ( ) - "render-markdown handles nil gracefully." - (is (string= "" (render-markdown nil)))) - -(def-test render-markdown-empty ( ) - "render-markdown handles empty string." - (let ((result (render-markdown ""))) - (is (stringp result)) - (is (string= "" result)))) - -(def-test parse-blocks-nil ( ) - "parse-blocks handles nil gracefully." - (is-false (parse-blocks nil))) - -(def-test split-string-into-lines-nil ( ) - "parse-blocks handles nil input (tests internal split-string-into-lines)." - (is-false (parse-blocks nil))) - -(def-test nested-bold-inside-italic ( ) - "Nested formatting: bold inside italic." - (let ((children (parse-inline "***hello*** world"))) - (is (= 3 (length children))) - (let ((first-node (first children))) - (is-true (eql :bold (getf first-node :type)))))) - -(def-test nested-italic-inside-bold ( ) - "Nested formatting: italic inside bold." - (let ((children (parse-inline "**bold *italic* bold**"))) - (is (= 1 (length children))) - (let ((bold (first children))) - (is-true (eql :bold (getf bold :type))) - (let ((inner (getf bold :children))) - (is (= 3 (length inner))) - (is-true (eql :italic (getf (second inner) :type))))))) - -(def-test inline-code-inside-bold ( ) - "Code inside bold." - (let ((children (parse-inline "**bold `code` bold**"))) - (is (= 1 (length children))) - (let ((bold (first children))) - (is-true (eql :bold (getf bold :type))) - (let ((inner (getf bold :children))) - (is (= 3 (length inner))) - (is-true (eql :inline-code (getf (second inner) :type))))))) - -(def-test unclosed-code-block ( ) - "Unclosed code block accumulates remaining lines as content." - (let* ((lines '("```lisp" "(defun foo ())" " (bar)")) - (text (format nil "~{~a~%~}" lines)) - (result (parse-blocks text)) - (node (first result))) - (is-true (eql :code-block (getf node :type))) - (is (equal "lisp" (getf (getf node :properties) :language))) - (is-true (search "bar" (getf node :content))))) - -(def-test code-block-no-language ( ) - "Code block with no language is still parsed." - (let* ((lines '("```" "plain" "```")) - (text (format nil "~{~a~%~}" lines)) - (result (parse-blocks text)) - (node (first result))) - (is-true (eql :code-block (getf node :type))) - (is-false (getf (getf node :properties) :language)))) - -(def-test markdown-very-long-line ( ) - "A very long paragraph line does not cause issues." - (let* ((long-line (make-string 500 :initial-element #\x)) - (result (render-markdown long-line))) - (is (stringp result)) - (is-true (> (length result) 0)))) - -(def-test markdown-only-blank ( ) - "Only blank lines produce empty output." - (is (string= "" (render-markdown (format nil "~%~%"))))) - - -;; ─── Parser tests ───────────────────────────────────────────────────────────── - -(def-test heading-parsing ( ) - (let* ((result (parse-blocks "# Hello World")) (node (first result))) - (is-true (eql :heading (getf node :type))) - (is (= 1 (getf (getf node :properties) :level))))) - -(def-test heading-levels ( ) - (loop for level from 1 to 6 - do (let* ((hashes (make-string level :initial-element #\#)) - (text (format nil "~a Heading ~d" hashes level)) - (result (parse-blocks text)) - (node (first result))) - (is-true (eql :heading (getf node :type))) - (is (= level (getf (getf node :properties) :level)))))) - -(def-test heading-with-inline-formatting ( ) - (let* ((result (parse-blocks "# Hello **World**")) - (node (first result)) (children (getf node :children))) - (is-true (eql :heading (getf node :type))) - (is (= 2 (length children))) - (is-true (eql :text (getf (first children) :type))) - (is-true (eql :bold (getf (second children) :type))))) - - -(def-test paragraph-parsing ( ) - (let* ((result (parse-blocks "This is a paragraph.")) (node (first result))) - (is-true (eql :paragraph (getf node :type))))) - -(def-test paragraph-multi-line ( ) - (let* ((result (parse-blocks "Line one\nLine two")) (node (first result))) - (is-true (eql :paragraph (getf node :type))))) - - -(def-test bold-parsing ( ) - (let* ((children (parse-inline "hello **world** here")) - (bold-node (second children))) - (is (= 3 (length children))) - (is-true (eql :bold (getf bold-node :type))))) - -(def-test italic-parsing ( ) - (let* ((children (parse-inline "hello *world* here")) - (italic-node (second children))) - (is (= 3 (length children))) - (is-true (eql :italic (getf italic-node :type))))) - -(def-test bold-italic-combined ( ) - (let ((children (parse-inline "**bold** and *italic*"))) - (is (= 3 (length children))) - (is-true (eql :bold (getf (first children) :type))) - (is-true (eql :italic (getf (third children) :type))))) - -(def-test inline-code-parsing ( ) - (let* ((children (parse-inline "use `foo` here")) - (code-node (second children))) - (is (= 3 (length children))) - (is-true (eql :inline-code (getf code-node :type))) - (is (equal "foo" (getf code-node :content))))) - -(def-test link-parsing ( ) - (let* ((children (parse-inline "click [here](https://x.com)")) - (link-node (second children))) - (is (= 2 (length children))) - (is-true (eql :link (getf link-node :type))) - (is (equal "https://x.com" (getf link-node :url))) - (let ((link-text (getf link-node :children))) - (is (= 1 (length link-text))) - (is-true (eql :text (getf (first link-text) :type))) - (is (equal "here" (getf (first link-text) :content)))))) - - -(def-test code-block-parsing ( ) - (let* ((lines '("```lisp" "(defun hello ())" " (print \"hi\")" "```")) - (text (format nil "~{~a~%~}" lines)) - (result (parse-blocks text)) (node (first result))) - (is-true (eql :code-block (getf node :type))) - (is (equal "lisp" (getf (getf node :properties) :language))) - (is-true (search "(defun hello" (getf node :content))))) - -(def-test code-block-unknown-language ( ) - (let* ((lines '("```" "plain code" "```")) - (text (format nil "~{~a~%~}" lines)) - (result (parse-blocks text)) (node (first result))) - (is-true (eql :code-block (getf node :type))) - (is-false (getf (getf node :properties) :language)))) - - -(def-test blockquote-parsing ( ) - (let* ((result (parse-blocks "> This is a quote")) (node (first result))) - (is-true (eql :blockquote (getf node :type))))) - -(def-test list-item-parsing ( ) - (let* ((result (parse-blocks "- First item")) (node (first result))) - (is-true (eql :list-item (getf node :type))))) - -(def-test ordered-list-parsing ( ) - (let* ((result (parse-blocks "1. First item")) (node (first result))) - (is-true (eql :ordered-item (getf node :type))))) - -(def-test thematic-break-parsing ( ) - (let* ((result (parse-blocks "---")) (node (first result))) - (is-true (eql :thematic-break (getf node :type))))) - - -;; ─── Diff tests ─────────────────────────────────────────────────────────────── - -(def-test classify-diff-added ( ) - (is (eql :added (classify-diff-line "+this is added")))) - -(def-test classify-diff-removed ( ) - (is (eql :removed (classify-diff-line "-this is removed")))) - -(def-test classify-diff-hunk ( ) - (is (eql :hunk-header (classify-diff-line "@@ -1,3 +1,4 @@")))) - -(def-test classify-diff-context ( ) - (is (eql :context (classify-diff-line " normal context")))) - - -;; ─── Syntax highlighting tests ──────────────────────────────────────────────── -(def-test highlight-lisp-keyword ( ) - (let ((tokens (highlight-code "(defun hello ()" "lisp"))) - (is-true (some (lambda (pair) (and (search "defun" (car pair)) - (eql :keyword (cdr pair)))) - tokens)))) - -(def-test highlight-lisp-builtin ( ) - "Test that a Lisp builtin like nil is highlighted as :builtin." - (let ((tokens (highlight-code "(if t nil)" "lisp"))) - (is-true (some (lambda (pair) (and (string= (car pair) "nil") - (eql :builtin (cdr pair)))) - tokens)))) - -(def-test highlight-unknown-language ( ) - (let ((tokens (highlight-code "hello world" "unknown-xyz"))) - (every (lambda (pair) (eql :plain (cdr pair))) tokens))) - -(def-test highlight-comment ( ) - (let ((tokens (highlight-code "; this is a comment" "lisp"))) - (is-true (some (lambda (pair) (eql :comment (cdr pair))) tokens)))) - - -;; ─── Render tests ───────────────────────────────────────────────────────────── - -(def-test render-heading-output ( ) - (let* ((node (make-md-node :heading :properties (list :level 2) - :children (list (make-md-node :text :content "Test")))) - (lines (render-md-node node))) - (is (= 1 (length lines))) - (is-true (> (length (first lines)) 0)))) - -(def-test render-paragraph-output ( ) - (let* ((node (make-md-node :paragraph - :children (list (make-md-node :text :content "Hello")))) - (lines (render-md-node node))) - (is (= 1 (length lines))) - (is-true (search "Hello" (first lines))))) - -(def-test render-thematic-break-output ( ) - (let* ((node (make-md-node :thematic-break)) (lines (render-md-node node))) - (is (= 1 (length lines))))) - -(def-test render-code-block-output ( ) - (let* ((node (make-md-node :code-block :content "(print \"hello\")" - :properties (list :language "lisp"))) - (lines (render-md-node node))) - (is-true (> (length lines) 0)))) - -(def-test render-diff-block-output ( ) - (let* ((node (make-md-node :diff-block :properties - (list :lines - '("--- a/file" "+++ b/file" "@@ -1 +1 @@" - "+added" "-removed" " context")))) - (lines (render-md-node node))) - (is (= 6 (length lines))) - (is (search "added" (fourth lines))) - (is (search "removed" (fifth lines))))) - - -;; ─── Integration tests ──────────────────────────────────────────────────────── - -(def-test markdown-integration ( ) - (let* ((md (format nil "# Title~%~%This is **bold** and `code`.~%~%- Item 1~%~%- Item 2~%~%> A quote~%~%```lisp~%(defun hello ())~% (print \"hi\")~%```~%~%---")) - (nodes (parse-blocks md)) (lines (render-md nodes))) - (is-true (> (length lines) 5)) - (is-true (search "# Title" (first lines))))) - -(def-test render-markdown-string ( ) - (let ((result (render-markdown "**bold** text"))) - (is-true (stringp result)) - (is-true (> (length result) 0)))) - -(def-test md-node-text-simple ( ) - (let ((node (make-md-node :text :content "hello"))) - (is (equal "hello" (md-node-text node))))) - -(def-test md-node-text-nested ( ) - (let ((node (make-md-node :paragraph :children - (list (make-md-node :text :content "hello") - (make-md-node :bold :children - (list (make-md-node :text :content "world"))))))) - (is (equal "helloworld" (md-node-text node))))) diff --git a/tests/mouse-tests.lisp b/tests/mouse-tests.lisp deleted file mode 100644 index 96d4dce..0000000 --- a/tests/mouse-tests.lisp +++ /dev/null @@ -1,47 +0,0 @@ -(defpackage :cl-tty-mouse-test (:use :cl :cl-tty.mouse :fiveam)) -(in-package :cl-tty-mouse-test) - -(def-suite mouse-suite :description "Mouse tests") -(in-suite mouse-suite) - -(def-test mouse-mixin-create () - (let ((m (make-instance 'mouse-mixin))) - (is-true (typep m 'mouse-mixin)))) - -(def-test mouse-hit-test-point () - "hit-test returns nil when no component has position slots bound" - (let ((obj (make-instance 'mouse-mixin))) - (is-false (hit-test obj 0 0)) - (is-false (hit-test obj 100 100)))) - -(def-test selection-set-and-get () - (setf cl-tty.mouse::*selection* (make-selection :text "hello")) - (is (equal "hello" (get-selection)))) - -(def-test start-selection-initializes-state () - (start-selection 5 10) - (is-true (selection-active-p)) - (is (equal '(5 . 10) cl-tty.mouse::*selection-start*)) - (is (equal '(5 . 10) cl-tty.mouse::*selection-end*)) - (setf cl-tty.mouse::*selection-active* nil - cl-tty.mouse::*selection-start* nil - cl-tty.mouse::*selection-end* nil)) - -(def-test update-selection-moves-end () - (start-selection 0 0) - (update-selection 3 7) - (is (equal '(3 . 7) cl-tty.mouse::*selection-end*)) - (setf cl-tty.mouse::*selection-active* nil - cl-tty.mouse::*selection-start* nil - cl-tty.mouse::*selection-end* nil)) - -(def-test finalize-selection-extracts-text () - (let* ((fb-be (cl-tty.rendering:make-framebuffer-backend)) - (fb (cl-tty.rendering:fb-framebuffer fb-be))) - (cl-tty.backend:draw-text fb-be 0 0 "hello" nil nil) - (cl-tty.backend:draw-text fb-be 0 1 "world" nil nil) - (start-selection 0 0) - (update-selection 4 1) - (let ((text (finalize-selection fb))) - (is (equal "hello -world" text))))) diff --git a/tests/scrollbox-tabbar-tests.lisp b/tests/scrollbox-tabbar-tests.lisp deleted file mode 100644 index f8e8b50..0000000 --- a/tests/scrollbox-tabbar-tests.lisp +++ /dev/null @@ -1,124 +0,0 @@ -(defpackage :cl-tty-scrollbox-test - (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container) - (:export #:run-tests)) -(in-package #:cl-tty-scrollbox-test) - -(def-suite scrollbox-suite :description "ScrollBox + TabBar tests") -(in-suite scrollbox-suite) - -(defun run-tests () - (let ((result (run 'scrollbox-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -(test scrollbox-creates - "A ScrollBox can be created with defaults." - (let ((sb (make-scroll-box))) - (is (typep sb 'scroll-box)) - (is (= (scroll-box-scroll-y sb) 0)) - (is (= (scroll-box-scroll-x sb) 0)) - (is-false (scroll-box-children sb)))) - -(test scrollbox-with-children - "A ScrollBox can have children." - (let ((sb (make-scroll-box :children (list (make-text "hello"))))) - (is (= (length (scroll-box-children sb)) 1)))) - -(test scrollbox-scroll-by - "ScrollBy adjusts offset clamped to valid range." - (let ((sb (make-scroll-box :scroll-y 0))) - (scroll-by sb 5 0) - (is (>= (scroll-box-scroll-y sb) 0)))) - -(test scrollbox-component-children - "Component protocol: children are accessible." - (let* ((child (make-text "hello")) - (sb (make-scroll-box :children (list child)))) - (is (eql (first (component-children sb)) child)))) - -(test scrollbox-render-noop - "Rendering a ScrollBox with no children does not error." - (let* ((stream (make-string-output-stream)) - (backend (make-simple-backend :output-stream stream)) - (sb (make-scroll-box))) - (render sb backend) - (is-true t))) - -(test tabbar-creates - "A TabBar can be created with defaults." - (let ((tb (make-tab-bar))) - (is (typep tb 'tab-bar)) - (is-false (tab-bar-active tb)) - (is-false (tab-bar-tabs tb)))) - -(test tabbar-add-tab - "Adding a tab returns the id and updates tabs." - (let ((tb (make-tab-bar))) - (let ((id (tab-bar-add tb :tab1 "Tab One"))) - (is (eql id :tab1)) - (is (= (length (tab-bar-tabs tb)) 1)) - (is (string= (getf (first (tab-bar-tabs tb)) :title) "Tab One"))))) - -(test tabbar-active-tab - "Setting active tab works." - (let ((tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (setf (tab-bar-active tb) :tab2) - (is (eql (tab-bar-active tb) :tab2)))) - -(test tabbar-render-noop - "Rendering a TabBar does not error." - (let* ((stream (make-string-output-stream)) - (backend (make-simple-backend :output-stream stream)) - (tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (setf (tab-bar-active tb) :tab1) - (render tb backend) - (is-true t))) - -(test tabbar-next-prev - "TabBar next/prev wraps around through tabs." - (let ((tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (tab-bar-add tb :tab3 "Three") - (is (eql (tab-bar-active tb) :tab1)) - (tab-bar-next tb) - (is (eql (tab-bar-active tb) :tab2)) - (tab-bar-next tb) - (is (eql (tab-bar-active tb) :tab3)) - (tab-bar-next tb) - (is (eql (tab-bar-active tb) :tab1) "wrap around past last") - (tab-bar-prev tb) - (is (eql (tab-bar-active tb) :tab3) "wrap around past first"))) - -(test tabbar-select - "TabBar select activates the specified tab." - (let ((tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (tab-bar-select tb :tab2) - (is (eql (tab-bar-active tb) :tab2)))) - -(test tabbar-handle-key - "TabBar handle-key dispatches left/right." - (let ((tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (setf (tab-bar-active tb) :tab1) - (tab-bar-handle-key tb (make-key-event :key :right)) - (is (eql (tab-bar-active tb) :tab2)) - (tab-bar-handle-key tb (make-key-event :key :left)) - (is (eql (tab-bar-active tb) :tab1)))) - -(test scrollbox-scroll-clamp - "ScrollBox clamp prevents scrolling past bounds." - (let ((sb (make-scroll-box :scroll-y 5 :scroll-x 3))) - (setf (scroll-box-scroll-y sb) -1) - (clamp-scroll sb) - (is (= (scroll-box-scroll-y sb) 0) "clamps below 0") - (setf (scroll-box-scroll-y sb) 1000000) - (clamp-scroll sb) - (is (= (scroll-box-scroll-y sb) 0) "clamps above max (no children = 0 content)"))) diff --git a/tests/select-tests.lisp b/tests/select-tests.lisp deleted file mode 100644 index 87670c3..0000000 --- a/tests/select-tests.lisp +++ /dev/null @@ -1,120 +0,0 @@ -(defpackage :cl-tty-select-test - (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.select) - (:export #:run-tests)) -(in-package #:cl-tty-select-test) - -(def-suite select-suite :description "Select widget tests") -(in-suite select-suite) - -(defun run-tests () - (let ((result (run 'select-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -(test select-creates - "A Select can be created with defaults." - (let ((sel (make-select))) - (is (typep sel 'select)) - (is-false (select-options sel)) - (is-false (select-filter sel)) - (is (= (select-selected-index sel) 0)))) - -(test select-with-options - "A Select stores options." - (let ((sel (make-select :options '((:title "Red" :value :red) - (:title "Blue" :value :blue))))) - (is (= (length (select-options sel)) 2)))) - -(test select-filtered-exact - "Filter returns case-insensitive substring matches." - (let ((sel (make-select - :options '((:title "Red" :value :red) - (:title "Green" :value :green) - (:title "Blue" :value :blue))))) - (setf (select-filter sel) "bl") - (let ((filtered (select-filtered-options sel))) - (is (= (length filtered) 1)) - (is (eql (getf (third (first filtered)) :value) :blue))))) - -(test select-filtered-all - "Nil filter returns all options." - (let ((sel (make-select - :options '((:title "Red" :value :red) - (:title "Blue" :value :blue))))) - (let ((filtered (select-filtered-options sel))) - (is (= (length filtered) 2))))) - -(test select-navigation - "Select-next and select-prev navigate through options." - (let ((sel (make-select - :options '((:title "A" :value :a) - (:title "B" :value :b) - (:title "C" :value :c))))) - (is (= (select-selected-index sel) 0)) - (select-next sel) - (is (= (select-selected-index sel) 1)) - (select-next sel) - (is (= (select-selected-index sel) 2)) - (select-next sel) - (is (= (select-selected-index sel) 0) "wraps forward") - (select-prev sel) - (is (= (select-selected-index sel) 2) "wraps backward"))) - -(test select-navigation-skips-categories - "Navigation skips category header options." - (let ((sel (make-select - :options '((:title "Colors" :category t) - (:title "Red" :value :red) - (:title "Green" :value :green) - (:title "Shapes" :category t) - (:title "Circle" :value :circle))))) - (is (= (select-selected-index sel) 0)) - (select-next sel) - (is (= (select-selected-index sel) 1) "skipped category header at 0") - (select-next sel) - (is (= (select-selected-index sel) 2)) - (select-next sel) - (is (= (select-selected-index sel) 4) "skipped category header at 3"))) - -(test select-handle-key - "Select handle-key dispatches navigation and selection." - (let* ((result (list nil)) - (sel (make-select - :options '((:title "A" :value :a) (:title "B" :value :b)) - :on-select (lambda (opt) (setf (car result) (getf opt :value)))))) - (select-handle-key sel (make-key-event :key :down)) - (is (= (select-selected-index sel) 1)) - (select-handle-key sel (make-key-event :key :up)) - (is (= (select-selected-index sel) 0)) - (select-handle-key sel (make-key-event :key :enter)) - (is (eql (car result) :a)))) - -(test select-handle-key-ctrl - "Ctrl+N and Ctrl+P navigate like down/up." - (let ((sel (make-select - :options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c))))) - (select-handle-key sel (make-key-event :key :n :ctrl t)) - (is (= (select-selected-index sel) 1)) - (select-handle-key sel (make-key-event :key :p :ctrl t)) - (is (= (select-selected-index sel) 0)))) - -(test select-visible-count - "Visible options respects viewport height." - (let* ((ln (make-layout-node)) - (sel (make-select - :options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i))))) - (setf (select-layout-node sel) ln) - (setf (layout-node-height ln) 5) - (let ((visible (select-visible-options sel))) - (is (<= (length visible) 5))))) - -(test select-fuzzy-fallback - "Fuzzy filter catches near-misses." - (let ((sel (make-select - :options '((:title "Nord" :value :nord) - (:title "Tokyo Night" :value :tokyo) - (:title "Catppuccin" :value :cat))))) - (setf (select-filter sel) "nrd") - (let ((filtered (select-filtered-options sel))) - (is (= (length filtered) 1)) - (is (eql (getf (third (first filtered)) :value) :nord))))) diff --git a/tests/slot-tests.lisp b/tests/slot-tests.lisp deleted file mode 100644 index 706997e..0000000 --- a/tests/slot-tests.lisp +++ /dev/null @@ -1,55 +0,0 @@ -(defpackage :cl-tty-slot-test (:use :cl :cl-tty.slot :fiveam)) -(in-package :cl-tty-slot-test) - -(def-suite slot-suite :description "Slot system tests") -(in-suite slot-suite) - -(def-test defslot-register () - (clear-slot :test-slot) - (defslot :test-slot :order 1 :render-fn (lambda () "hello")) - (is-true (slot-p :test-slot))) - -(def-test slot-render-calls () - (clear-slot :test-slot) - (defslot :test-slot :order 1 :render-fn (lambda () "a")) - (defslot :test-slot :order 2 :render-fn (lambda () "b")) - (is (equal '("a" "b") (slot-render :test-slot)))) - -(def-test slot-render-empty () - (clear-slot :ghost) - (is-false (slot-render :ghost))) - -(def-test clear-slot-removes () - (clear-slot :test-slot) - (defslot :test-slot :order 1 :render-fn (lambda () "x")) - (clear-slot :test-slot) - (is-false (slot-p :test-slot))) - -(def-test stack-mode-multiple-entries () - (clear-slot :stack-test) - (defslot :stack-test :order 1 :render-fn (lambda () "first")) - (defslot :stack-test :order 2 :render-fn (lambda () "second")) - (defslot :stack-test :order 3 :render-fn (lambda () "third")) - (is (equal '("first" "second" "third") (slot-render :stack-test)))) - -(def-test replace-mode-last-wins () - (clear-slot :replace-test) - (defslot :replace-test :mode :replace :order 1 :render-fn (lambda () "old")) - (defslot :replace-test :mode :replace :order 2 :render-fn (lambda () "new")) - (is (equal "new" (slot-render :replace-test)))) - -(def-test single-winner-mode-first-wins () - (clear-slot :winner-test) - (defslot :winner-test :mode :single-winner :order 1 - :render-fn (lambda () "alpha")) - (defslot :winner-test :mode :single-winner :order 2 - :render-fn (lambda () "beta")) - (is (equal "alpha" (slot-render :winner-test)))) - -(def-test clear-slot-removes-mode () - (clear-slot :mode-test) - (defslot :mode-test :mode :replace :render-fn (lambda () "only")) - (clear-slot :mode-test) - (defslot :mode-test :mode :stack :render-fn (lambda () "fresh")) - (is-true (slot-p :mode-test)) - (is (equal '("fresh") (slot-render :mode-test))))