amr/passepartout
1
0
Fork 0
Code Issues 15 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

v0.8.0: revert to stable e04b12c (undo typecase guard, navigation refactor, cursor calc changes)

Browse Source 
The typecase guard, explicit navigation keyword dispatch, and word-wrap
cursor calculation changes introduced two regressions:
1. Cursor shows letter before instead of on (off-by-one)
2. Right arrow sometimes moves backward

Reverting to e04b12c which had working arrow keys and single-line cursor.
The unconditional position-cursor fix will be re-applied separately.
This commit is contained in:
Amr Gharbeia
2026-05-18 15:33:39 -04:00
parent 7eab3c93d2
commit 5c4edb3d98
2 changed files with 314 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

300
org/channel-tui-view.org
View File

@@ -51,6 +51,19 @@ and current sidebar mode (:auto/:visible/:hidden)."
(or (eq mode :visible)
(and (eq mode :auto) (> w 120)))))
(defun word-wrap (text width)
"Wrap TEXT to at most WIDTH columns. Splits on word boundaries.
Returns a list of strings, one per line."
(let ((lines nil))
(loop while (> (length text) width)
do (let ((break (or (position #\Space text :end width :from-end t)
width)))
(push (subseq text 0 break) lines)
(setf text (string-left-trim '(#\Space)
(subseq text break)))))
(push text lines)
(nreverse lines)))
(defun view-status (fb w h)
(declare (ignore fb w h))
;; Status bar is now a clean black line — blends with global :bg.
@@ -63,7 +76,7 @@ and current sidebar mode (:auto/:visible/:hidden)."
(inner-w (- chat-w (* 2 hpad)))
(prompt-w (- inner-w 2))
(text (input-string))
(lines (cl-tty.box:word-wrap text prompt-w))
(lines (word-wrap text prompt-w))
(n-lines (max 1 (length lines)))
(panel-rows (max 4 (+ n-lines 2))))
(- h 4 panel-rows -1)))
@@ -206,7 +219,7 @@ and current sidebar mode (:auto/:visible/:hidden)."
(prompt-w (- inner-w 2))
(text (input-string))
(pos (or (st :cursor-pos) 0))
(lines (cl-tty.box:word-wrap text prompt-w))
(lines (word-wrap text prompt-w))
(n-lines (max 1 (length lines)))
(panel-rows (max 4 (+ n-lines 2)))
(panel-top (input-panel-top chat-w h))
@@ -218,18 +231,18 @@ and current sidebar mode (:auto/:visible/:hidden)."
;; Speaker lines for all input rows
(dotimes (r panel-rows)
(cl-tty.backend:draw-text fb hpad (+ panel-top r) "│" (theme-color :input-prompt) nil))
;; Draw each wrapped input line, tracking display position of cursor
(let ((accum 0) (cl 0) (cc 0))
;; Draw each wrapped input line
(let ((accum 0) (cursor-line 0) (cursor-col 0))
(dotimes (i n-lines)
(let* ((line (nth i lines))
(row (+ panel-top 1 i))
(len (length line)))
(when (>= row (- h 4)) (return))
(cl-tty.backend:draw-text fb (+ hpad 2) row line input-fg nil)
(when (and (>= pos accum) (or (< pos (+ accum len)) (= i (1- n-lines))))
(setf cl i cc (- pos accum)))
(incf accum len)))
(setf (st :cursor-line) cl (st :cursor-col) cc))
(when (and (>= pos accum) (<= pos (+ accum len)))
(setf cursor-line i
cursor-col (- pos accum)))
(incf accum (1+ len))))
;; Hint bar at h-2: F:/MCP: on left, token gauge + keybindings on right
(let* ((focal (or (st :foveal-id) "-"))
(focal-str (format nil "F:~a" focal))
@@ -251,7 +264,7 @@ and current sidebar mode (:auto/:visible/:hidden)."
(ctx-x (- hint-x 1 (length ctx-str))))
(cl-tty.backend:draw-text fb hpad (- h 2) left-str hint-fg (theme-color :bg))
(cl-tty.backend:draw-text fb ctx-x (- h 2) ctx-str ctx-fg (theme-color :bg))
(cl-tty.backend:draw-text fb hint-x (- h 2) hint-str hint-fg (theme-color :bg)))))
(cl-tty.backend:draw-text fb hint-x (- h 2) hint-str hint-fg (theme-color :bg))))))
#+end_src
** Sidebar
@@ -339,34 +352,194 @@ and current sidebar mode (:auto/:visible/:hidden)."
(when (sidebar-visible-p w)
(view-sidebar fb w h))
(cl-tty.backend:end-sync fb)
(position-cursor fb w h)
(setf (st :dirty) (list nil nil nil))))
(defun position-cursor (fb w h)
"Draw cursor at the input insertion point using reverse video (Emacs-style).
Uses cursor-line/cursor-col stored by view-input to stay aligned with rendering."
(let* ((text (input-string))
The character under the cursor is redrawn with foreground and background
swapped. If the cursor is past the end of the input string, a reversed
space is drawn."
(let* ((sw (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))
(cw (- w sw))
(hpad 2)
(text (input-string))
(text-len (length text))
(pos (or (st :cursor-pos) 0))
(cl (or (st :cursor-line) 0))
(cc (or (st :cursor-col) 0))
(hpad 2)
(sw (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))
(cw (- w sw))
(inner-w (- cw (* 2 hpad)))
(prompt-w (- inner-w 2))
(lines (cl-tty.box:word-wrap text prompt-w))
(n-lines (max 1 (length lines)))
(panel-rows (max 4 (+ n-lines 2)))
(panel-top (- h 4 panel-rows -1))
(prompt-w (- cw (* 2 hpad) 2))
(display-start (max 0 (- pos (1- prompt-w))))
(cx (+ hpad 2 (- pos display-start)))
(cy (- h 6))
(bg-i (theme-color :bg-input))
(input-fg (theme-color :input-fg)))
(let ((cx (+ hpad 2 cc))
(cy (+ panel-top 1 cl)))
(if (< pos text-len)
(let ((ch (char text pos)))
(cl-tty.backend:draw-text fb cx cy (string ch) bg-i input-fg))
(cl-tty.backend:draw-text fb cx cy " " bg-i input-fg))
(finish-output (cl-tty.backend::backend-output-stream fb)))))
(if (< pos text-len)
(let ((ch (char text pos)))
(cl-tty.backend:draw-text fb cx cy (string ch) bg-i input-fg))
(cl-tty.backend:draw-text fb cx cy " " bg-i input-fg))
(finish-output (cl-tty.backend::backend-output-stream fb))))
#+END_SRC
* Implementation — v0.7.0 additions
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp
(in-package :passepartout)
(defun char-width (ch)
"Returns the terminal column width of character CH.
ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
(let ((code (char-code ch)))
(cond
((= code 9) 8)
((< code 32) 0)
((<= code 127) 1)
((<= #x4E00 code #x9FFF) 2)
((<= #x3400 code #x4DBF) 2)
((<= #x3040 code #x309F) 2)
((<= #x30A0 code #x30FF) 2)
((<= #xAC00 code #xD7AF) 2)
((<= #xFF01 code #xFF60) 2)
((<= #xFFE0 code #xFFE6) 2)
((<= #x1F300 code #x1F9FF) 2)
((<= #x2600 code #x27BF) 2)
((<= #x0300 code #x036F) 0)
((<= #x20D0 code #x20FF) 0)
((<= #xFE00 code #xFE0F) 0)
(t 1))))
#+END_SRC
* v0.7.1 — Markdown Rendering
~render-styled~ accepts a ~(text . plist)~ segment list from the span
parser and emits ~draw-text~ calls. The ~w~ parameter is ignored (layout
is line-at-a-time, not fixed-width); ~theme-color~ is fully qualified
as ~passepartout.channel-tui:theme-color~ since this function lives in
the ~passepartout~ package but the theme API is in ~passepartout.channel-tui~.
The inline span parser (~parse-markdown-spans~) delegates punctuation
delimiters (**bold**, `code`, *italic*) to a local ~pick~ helper.
URLs are handled directly via ~url-end~ rather than through ~pick~,
so the ~:url~ clause was removed from ~pick~'s ~case~ form to avoid
dead code.
#+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-view.lisp
(in-package :passepartout)
(defun parse-markdown-spans (text)
"Parse inline markdown. Returns list of (text . (:bold/:underline/:code/:url ...))."
(let ((results nil) (pos 0) (len (length text)))
(labels ((earliest (a b) (cond ((and a (or (null b) (< a b))) a) (b b))))
(loop
(when (>= pos len) (return))
(let* ((bold (search "**" text :start2 pos))
(code (search "`" text :start2 pos))
(italic (search "*" text :start2 pos))
(http (search "http://" text :start2 pos))
(https (search "https://" text :start2 pos))
(url-s (or https http)))
(flet ((pick (tag delim)
(let ((end (search delim text :start2 (+ pos (length delim)))))
(when end
(push (cons (subseq text (+ pos (length delim)) end)
(case tag (:bold '(:bold t))
(:code '(:code t :bgcolor :dim))
(:underline '(:underline t))))
results)
(setf pos (+ end (length delim)))
t)))
(url-end (start)
(or (position-if (lambda (c) (find c '(#\Space #\Newline #\Tab #\))))
text :start start)
len)))
(let ((next (earliest (earliest (earliest bold code) italic) url-s)))
(cond ((and bold (eql bold next)) (unless (pick :bold "**") (incf pos 2)))
((and code (eql code next)) (unless (pick :code "`") (incf pos)))
((and italic (eql italic next)) (unless (pick :underline "*") (incf pos)))
((and url-s (eql url-s next))
(let ((ue (url-end url-s)))
(push (cons (subseq text url-s ue) '(:url t)) results)
(setf pos ue)))
(t (push (cons (subseq text pos) nil) results) (return))))))))
(nreverse results)))
(defun render-styled (fb segments y x w)
"Render markdown segments to cl-tty backend. Returns next y."
(declare (ignore w))
(dolist (seg segments)
(let* ((text (or (car seg) ""))
(attrs (cdr seg))
(bold (getf attrs :bold))
(code (getf attrs :code))
(url (getf attrs :url)))
(declare (ignore code))
(cl-tty.backend:draw-text fb x y text
(cond (url (passepartout.channel-tui:theme-color :accent))
(t (passepartout.channel-tui:theme-color (or (getf attrs :role) :agent-fg))))
(passepartout.channel-tui:theme-color :bg)
:bold bold)
(incf x (length text))))
y)
(defun parse-markdown-blocks (text)
"Split text at ``` code block boundaries."
(let ((r nil) (p 0) (l (length text)))
(loop
(when (>= p l) (return))
(let ((bs (search "```" text :start2 p)))
(unless bs
(push (cons (subseq text p) nil) r)
(return))
(when (> bs p)
(push (cons (subseq text p bs) nil) r))
(let* ((ao (+ bs 3))
(le (or (position #\Newline text :start ao) l))
(lang (string-trim " \r\n\t" (if (< le l) (subseq text ao le) "")))
(cs (if (< le l) (1+ le) l))
(cp (search "```" text :start2 cs))
(ce (or cp l))
(content (string-trim "\r\n" (subseq text cs ce))))
(push (list :code-block t :lang lang :content content) r)
(setf p (if cp (+ cp 3) l)))))
(nreverse r)))
(defun syntax-highlight (code lang)
"Highlight Lisp code: strings, comments, keywords, function calls."
(declare (ignore lang))
(let* ((r nil) (p 0) (l (length code))
(kw '("defun" "defvar" "defparameter" "let" "let*" "lambda" "if" "when" "unless"
"cond" "loop" "dolist" "dotimes" "progn" "prog1" "return"
"setf" "setq" "format" "and" "or" "not" "list" "cons"
"quote" "function" "declare" "ignore" "t" "nil")))
(flet ((wordp (c) (or (alphanumericp c) (find c "-*+/?!_=<>"))))
(loop
(when (>= p l) (return))
(let* ((ss (position #\" code :start p))
(sc (position #\; code :start p))
(sp (position #\( code :start p))
(next (min (or ss l) (or sc l) (or sp l))))
(when (> next p)
(push (cons (subseq code p next) nil) r)
(setf p next))
(when (>= p l) (return))
(cond
((eql p ss)
(let ((e (or (position #\" code :start (1+ p)) l)))
(push (cons (subseq code p (min (1+ e) l)) '(:fgcolor :string)) r)
(setf p (min (1+ e) l))))
((eql p sc)
(let ((e (or (position #\Newline code :start p) l)))
(push (cons (subseq code p e) '(:fgcolor :comment)) r)
(setf p e)))
((eql p sp)
(push (cons "(" nil) r)
(incf p)
(let ((fe (loop for i from p below l for c = (char code i)
while (wordp c) finally (return i))))
(when (> fe p)
(let ((fs (subseq code p fe)))
(push (cons fs (list :fgcolor (if (member fs kw :test #'string=)
:keyword :function))) r)
(setf p fe)))))))))
(nreverse r)))
#+END_SRC
* v0.7.2 — Gate Trace
@@ -413,6 +586,75 @@ Uses cursor-line/cursor-col stored by view-input to stay aligned with rendering.
(def-suite tui-view-suite :description "TUI view rendering helpers")
(in-suite tui-view-suite)
(test test-char-width-ascii
"Contract 5: ASCII characters (< 128) have width 1."
(is (= 1 (passepartout::char-width #\a)))
(is (= 1 (passepartout::char-width #\Space)))
(is (= 1 (passepartout::char-width #\@))))
(test test-char-width-tab
"Contract 5: tab character has width 8."
(is (= 8 (passepartout::char-width #\Tab))))
(test test-char-width-cjk
"Contract 5: CJK characters have width 2."
(is (= 2 (passepartout::char-width #\日))))
(test test-char-width-null
"Contract 5: null has width 0."
(is (= 0 (passepartout::char-width #\Nul))))
(test test-markdown-bold
"Contract 7: parse-markdown-spans detects **bold**."
(let ((segments (passepartout::parse-markdown-spans "hello **world**!")))
(is (= 3 (length segments)))))
(test test-markdown-plain
"Contract 7: plain text returns single segment."
(let ((segments (passepartout::parse-markdown-spans "plain")))
(is (= 1 (length segments)))
(is (string= "plain" (caar segments)))))
(test test-markdown-url
"Contract 7: parse-markdown-spans detects URLs."
(let ((segments (passepartout::parse-markdown-spans "see https://example.com for more")))
(is (>= (length segments) 2))
(is (find t segments :key (lambda (s) (getf (cdr s) :url))))))
(test test-markdown-blocks
"Contract 8: parse-markdown-blocks detects code blocks."
(let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after"))
(segs (passepartout::parse-markdown-blocks text)))
(is (= 3 (length segs)))
(let ((code (second segs)))
(is (eq t (getf code :code-block)))
(is (string= "lisp" (getf code :lang)))
(is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content)))))))
(test test-markdown-blocks-no-close
"Contract 8: unclosed code block returns content."
(let* ((text (format nil "```~%unclosed code"))
(segs (passepartout::parse-markdown-blocks text)))
(is (= 1 (length segs)))
(is (eq t (getf (first segs) :code-block)))))
(test test-syntax-highlight
"Contract 9: syntax-highlight colors Lisp code."
(let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp")))
(is (>= (length segs) 3))))
(test test-syntax-highlight-keyword
"Contract 9: syntax-highlight colors keywords."
(let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp")))
(is (>= (length segs) 2))
(is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-syntax-highlight-function
"Contract 9: syntax-highlight colors function calls."
(let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp")))
(is (>= (length segs) 2))
(is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
(test test-gate-trace-lines-passed
"Contract 9: gate-trace-lines for passed gate."
(let ((lines (passepartout::gate-trace-lines