679 lines
30 KiB
Common Lisp
679 lines
30 KiB
Common Lisp
(in-package :passepartout.channel-tui)
|
|
|
|
(defun view-status (win)
|
|
(clear win)
|
|
(box win 0 0)
|
|
(add-string win
|
|
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a"
|
|
(if (st :connected) "● Connected" "○ Disconnected")
|
|
(string-upcase (string (st :mode)))
|
|
(length (st :messages))
|
|
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
|
|
(or (st :rule-count) 0)
|
|
(if (st :streaming-text) " [streaming]"
|
|
(if (st :busy) " …thinking" "")))
|
|
:y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected)))
|
|
;; Second line: Focus map (left) + timestamp (right-aligned, v0.7.0)
|
|
(let ((focus-info (or (st :foveal-id) "")))
|
|
(when (and focus-info (> (length focus-info) 0))
|
|
(add-string win (format nil " [Focus: ~a]" focus-info)
|
|
:y 2 :x 1 :fgcolor (theme-color :timestamp))))
|
|
(add-string win (format nil " ~a" (now))
|
|
:y 2 :x (max 1 (- (width win) 12))
|
|
:fgcolor (theme-color :timestamp))
|
|
(refresh win))
|
|
|
|
;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown
|
|
(defun search-highlight (content query)
|
|
"Wrap occurrences of QUERY in CONTENT with **bold** markers."
|
|
(let ((lower-content (string-downcase content))
|
|
(lower-query (string-downcase query))
|
|
(result "") (pos 0))
|
|
(when (and query (> (length query) 0))
|
|
(loop
|
|
(let ((found (search lower-query lower-content :start2 pos)))
|
|
(unless found (return))
|
|
(setf result (concatenate 'string result
|
|
(subseq content pos found)
|
|
"**" (subseq content found (+ found (length query))) "**"))
|
|
(setf pos (+ found (length query)))))
|
|
(setf result (concatenate 'string result (subseq content pos)))
|
|
(if (string= result "") content result))))
|
|
|
|
(defun view-chat (win h)
|
|
(clear win)
|
|
(box win 0 0)
|
|
(let* ((w (or (width win) 78))
|
|
(msgs (st :messages))
|
|
(total (length msgs))
|
|
(max-lines (- h 2))
|
|
(is-search (st :search-mode))
|
|
(y 1))
|
|
;; v0.7.2: search mode header
|
|
(when is-search
|
|
(let* ((matches (st :search-matches))
|
|
(idx (st :search-match-idx))
|
|
(query (st :search-query))
|
|
(header (format nil "Search: ~d matches for '~a' (~d/~d) — Esc to exit"
|
|
(length matches) query (1+ idx) (length matches))))
|
|
(add-string win header :y y :x 1 :n (1- w) :fgcolor (theme-color :highlight))
|
|
(incf y)
|
|
(decf max-lines)))
|
|
;; Count visible messages from end, accounting for word wrap
|
|
(let* ((msg-count 0)
|
|
(lines-remaining max-lines))
|
|
(loop for i from (1- total) downto 0
|
|
while (> lines-remaining 0)
|
|
do (let* ((msg (aref msgs i))
|
|
(role (getf msg :role))
|
|
(content (getf msg :content))
|
|
(time (or (getf msg :time) ""))
|
|
(prefix (case role (:user "⬆") (:agent "⬇") (t " ")))
|
|
(content-show (if is-search
|
|
(search-highlight content (st :search-query))
|
|
content))
|
|
(line-text (format nil "~a [~a] ~a" prefix time content-show))
|
|
(wrapped (passepartout::word-wrap line-text (- w 2)))
|
|
(nlines (length wrapped)))
|
|
(if (<= nlines lines-remaining)
|
|
(progn (decf lines-remaining nlines) (incf msg-count))
|
|
(setf lines-remaining 0))))
|
|
;; Render from the correct starting message
|
|
(let* ((scroll-skip (st :scroll-offset))
|
|
(start (max 0 (- total msg-count scroll-skip))))
|
|
(loop for i from start below total
|
|
while (< y (1- h))
|
|
do (let* ((msg (aref msgs i))
|
|
(role (getf msg :role))
|
|
(content (getf msg :content))
|
|
(time (or (getf msg :time) ""))
|
|
(color (theme-color (case role (:user :user) (:agent :agent) (:system :system) (t :agent))))
|
|
(prefix (case role (:user "⬆") (:agent "⬇") (t " ")))
|
|
(is-panel (getf msg :panel))
|
|
(is-resolved (getf msg :panel-resolved))
|
|
(content-show (if is-search
|
|
(search-highlight content (st :search-query))
|
|
content))
|
|
(line-text (format nil "~a [~a] ~a" prefix time content-show))
|
|
(wrapped (passepartout::word-wrap line-text (- w 2))))
|
|
;; HITL panel: render with colored border
|
|
(when is-panel
|
|
(setf color (if is-resolved
|
|
(theme-color :dim)
|
|
(theme-color :hitl))))
|
|
(dolist (line wrapped)
|
|
(when (< y (1- h))
|
|
(if (eq role :agent)
|
|
(let ((segments (parse-markdown-spans line)))
|
|
(setf y (render-styled win segments y 1 w)))
|
|
(progn
|
|
(add-string win line :y y :x 1 :n (1- w) :fgcolor color)
|
|
(incf y)))))
|
|
;; v0.7.2: gate trace below agent messages
|
|
(let ((gate-trace (getf msg :gate-trace)))
|
|
(when (and gate-trace (not (member i (st :collapsed-gates))))
|
|
(dolist (entry (passepartout::gate-trace-lines gate-trace))
|
|
(when (< y (1- h))
|
|
(add-string win (car entry) :y y :x 3 :n (- w 4) :fgcolor (or (getf (cdr entry) :fgcolor) :dim))
|
|
(incf y))))))))))
|
|
(refresh win))
|
|
|
|
(defun view-input (win)
|
|
(let* ((text (input-string))
|
|
(w (or (width win) 78))
|
|
(pos (or (st :cursor-pos) 0))
|
|
(display-start (max 0 (- pos (1- w))))
|
|
(visible (subseq text display-start (min (length text) (+ display-start w)))))
|
|
(clear win)
|
|
(add-string win (format nil "~a " visible) :y 0 :x 0 :n (1- w) :fgcolor (theme-color :input))
|
|
(setf (cursor-position win) (list 0 (min (- pos display-start) (1- w)))))
|
|
(refresh win))
|
|
|
|
(defun redraw (sw cw ch iw)
|
|
(destructuring-bind (sd cd id) (st :dirty)
|
|
(when sd (view-status sw))
|
|
(when cd (view-chat cw ch))
|
|
(when id (view-input iw))
|
|
(setf (st :dirty) (list nil nil nil))))
|
|
|
|
(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))))
|
|
|
|
(defun word-wrap (text max-width)
|
|
"Split TEXT into lines that fit within MAX-WIDTH columns.
|
|
Word-breaks at spaces when possible; breaks mid-word if necessary.
|
|
Respects CJK/emoji char widths via char-width."
|
|
(let ((lines nil)
|
|
(start 0)
|
|
(end (length text)))
|
|
(loop while (< start end) do
|
|
(let* ((col 0)
|
|
(pos start)
|
|
(last-break start))
|
|
(loop while (< pos end)
|
|
for width = (char-width (char text pos)) do
|
|
(when (char= (char text pos) #\Space)
|
|
(setf last-break pos))
|
|
(when (> (+ col width) max-width)
|
|
(return))
|
|
(incf col width)
|
|
(incf pos)
|
|
(when (>= pos end) (return)))
|
|
(let ((line-end (if (> pos start) pos (1+ start))))
|
|
(when (>= line-end end) (setf line-end end))
|
|
(push (subseq text start line-end) lines)
|
|
(setf start (if (and (< line-end end) (char= (char text line-end) #\Space))
|
|
(1+ line-end)
|
|
line-end)))))
|
|
(nreverse lines)))
|
|
|
|
(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))
|
|
(:url '(:url 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 (win segments y x w)
|
|
"Render markdown segments to Croatoan window. Returns next y."
|
|
(dolist (seg segments)
|
|
(when (>= y (height win)) (return y))
|
|
(let* ((text (or (car seg) ""))
|
|
(attrs (cdr seg))
|
|
(bold (getf attrs :bold))
|
|
(code (getf attrs :code))
|
|
(underline (getf attrs :underline))
|
|
(url (getf attrs :url)))
|
|
(add-string win text :y y :x x :n (max 1 (- w x))
|
|
:bold bold :underline underline
|
|
:bgcolor (when code (theme-color :dim))
|
|
:fgcolor (cond (url (theme-color :highlight))
|
|
(t (theme-color (or (getf attrs :role) :agent)))))
|
|
(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)))
|
|
|
|
(in-package :passepartout)
|
|
|
|
(defun gate-trace-lines (trace)
|
|
"Convert gate-trace plist to display lines."
|
|
(let ((lines nil))
|
|
(dolist (entry trace)
|
|
(let* ((gate (getf entry :gate))
|
|
(result (getf entry :result))
|
|
(reason (getf entry :reason))
|
|
(name (or gate "unknown"))
|
|
(color (case result
|
|
(:passed :gate-passed)
|
|
(:blocked :gate-blocked)
|
|
(:approval :gate-approval)
|
|
(t :dim)))
|
|
(prefix (case result
|
|
(:passed " ✓ ")
|
|
(:blocked " ✗ ")
|
|
(:approval " → ")
|
|
(t " ? ")))
|
|
(text (format nil "~a~a~@[~a~]~@[~a~]"
|
|
prefix name
|
|
(when reason (format nil ": ~a" reason))
|
|
(if (eq result :approval) " (HITL required)" ""))))
|
|
(push (cons text (list :fgcolor color)) lines)))
|
|
(nreverse lines)))
|
|
|
|
(in-package :passepartout.channel-tui)
|
|
|
|
(defun view-sidebar (win)
|
|
"Render 42-column sidebar with 7 panels: Gate Trace, Focus, Rules, Context, Files, Cost, Protection."
|
|
(clear win)
|
|
(box win (theme-color :border) (theme-color :background))
|
|
(let* ((w (or (width win) 42))
|
|
(h (or (height win) 24))
|
|
(y 1)
|
|
(gate-trace (st :gate-trace))
|
|
(foveal-id (st :foveal-id))
|
|
(rule-count (or (st :rule-count) 0))
|
|
(context-usage (st :context-usage))
|
|
(modified-files (st :modified-files))
|
|
(session-cost (st :session-cost))
|
|
(block-counts (st :block-counts)))
|
|
;; Panel 1: Gate Trace
|
|
(add-string win "── Gate Trace ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
|
|
(incf y)
|
|
(if gate-trace
|
|
(dolist (entry (passepartout::gate-trace-lines gate-trace))
|
|
(when (< y (1- h))
|
|
(add-string win (car entry) :y y :x 2 :n (- w 4)
|
|
:fgcolor (or (getf (cdr entry) :fgcolor) (theme-color :dim)))
|
|
(incf y)))
|
|
(add-string win " (no trace)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
|
|
;; Panel 2: Focus
|
|
(incf y)
|
|
(add-string win "── Focus ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
|
|
(incf y)
|
|
(add-string win (format nil " ~a" (or foveal-id "(none)")) :y y :x 2 :n (- w 4) :fgcolor (theme-color :focus-map))
|
|
;; Panel 3: Rules
|
|
(incf y 2)
|
|
(add-string win "── Rules ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
|
|
(incf y)
|
|
(add-string win (format nil " Rules: ~d" rule-count) :y y :x 2 :n (- w 4) :fgcolor (theme-color :rule-count))
|
|
;; Panel 4: Context gauge
|
|
(incf y 2)
|
|
(add-string win "── Context ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
|
|
(incf y)
|
|
(let* ((pct (or context-usage 0))
|
|
(bar-width 30)
|
|
(filled (min bar-width (floor (* pct bar-width) 100)))
|
|
(gauge-color (cond ((< pct 50) (theme-color :connected))
|
|
((< pct 80) (theme-color :warning))
|
|
((< pct 95) (theme-color :tool-running))
|
|
(t (theme-color :error)))))
|
|
(add-string win (format nil " [~a~a] ~d%"
|
|
(make-string filled :initial-element #\█)
|
|
(make-string (- bar-width filled) :initial-element #\░)
|
|
pct)
|
|
:y y :x 2 :n (- w 4) :fgcolor gauge-color))
|
|
;; Panel 5: Files
|
|
(incf y 2)
|
|
(add-string win "── Files ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
|
|
(incf y)
|
|
(if modified-files
|
|
(dolist (f modified-files)
|
|
(when (< y (1- h))
|
|
(let ((fp (getf f :filepath))
|
|
(added (getf f :lines-added))
|
|
(removed (getf f :lines-removed)))
|
|
(add-string win (format nil " ~a~@[ +~d~]~@[ -~d~]"
|
|
(subseq fp (max 0 (- (length fp) 30)))
|
|
(when (> added 0) added)
|
|
(when (> removed 0) removed))
|
|
:y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))
|
|
(incf y))))
|
|
(add-string win " (no changes)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
|
|
;; Panel 6: Cost
|
|
(incf y 2)
|
|
(add-string win "── Cost ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
|
|
(incf y)
|
|
(if session-cost
|
|
(progn
|
|
(add-string win (format nil " Total: $~,4f" (getf session-cost :total))
|
|
:y y :x 2 :n (- w 4) :fgcolor (theme-color :agent))
|
|
(incf y)
|
|
(add-string win (format nil " Calls: ~d" (getf session-cost :calls))
|
|
:y y :x 2 :n (- w 4) :fgcolor (theme-color :agent)))
|
|
(add-string win " (no data)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
|
|
;; Panel 7: Protection
|
|
(incf y 2)
|
|
(add-string win "── Protection ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
|
|
(incf y)
|
|
(if (and block-counts (> (getf block-counts :total) 0))
|
|
(let ((by-gate (getf block-counts :by-gate)))
|
|
(dolist (entry (subseq by-gate 0 (min (length by-gate) 6)))
|
|
(when (< y (1- h))
|
|
(add-string win (format nil " ~a: ~d" (car entry) (cdr entry))
|
|
:y y :x 2 :n (- w 4) :fgcolor (theme-color :gate-blocked))
|
|
(incf y))))
|
|
(add-string win " (no blocks)" :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim)))
|
|
(refresh win)
|
|
(- y 1)))
|
|
|
|
(defun palette-filter (items query)
|
|
"Return items from categorized list whose :name or :desc contains QUERY (case-insensitive)."
|
|
(if (or (null query) (string= query ""))
|
|
items
|
|
(let ((q (string-downcase query)))
|
|
(loop for group in items
|
|
for category = (getf group :category)
|
|
for gitems = (getf group :items)
|
|
for filtered = (loop for item in gitems
|
|
when (or (search q (string-downcase (getf item :name)))
|
|
(search q (string-downcase (or (getf item :desc) ""))))
|
|
collect item)
|
|
when filtered
|
|
collect (list :category category :items filtered)))))
|
|
|
|
(defun view-palette (win)
|
|
"Render centered command palette overlay with filtered items, selection highlight."
|
|
(clear win)
|
|
(box win (theme-color :border) (theme-color :background))
|
|
(let* ((w (or (width win) 50))
|
|
(h (or (height win) 20))
|
|
(y 1)
|
|
(query (or (st :palette-filter) ""))
|
|
(items (palette-filter (st :palette-items) query))
|
|
(selected (st :palette-selected-idx))
|
|
(flat-index 0)
|
|
(visible-start (max 0 (- selected (floor (- h 6) 2)))))
|
|
(add-string win (format nil " Command Palette ") :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent))
|
|
(incf y)
|
|
(add-string win (format nil " > ~a" (if (> (length query) 0) query "type to filter..."))
|
|
:y y :x 2 :n (- w 4) :fgcolor (theme-color :input) :attributes '(:underline t))
|
|
(incf y)
|
|
(dolist (group items)
|
|
(let ((category (getf group :category))
|
|
(gitems (getf group :items)))
|
|
(when (and gitems (< y (1- h)))
|
|
(incf y)
|
|
(add-string win (format nil "── ~a ──" category) :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))
|
|
(dolist (item gitems)
|
|
(when (< y (1- h))
|
|
(incf y)
|
|
(let* ((name (getf item :name))
|
|
(desc (getf item :desc))
|
|
(shortcut (getf item :shortcut))
|
|
(is-selected (= flat-index selected))
|
|
(fg (if is-selected (theme-color :accent) (theme-color :agent))))
|
|
(when is-selected
|
|
(add-string win (make-string (- w 4) :initial-element #\Space) :y y :x 2 :n (- w 4)
|
|
:fgcolor (theme-color :dim) :bgcolor (theme-color :accent)))
|
|
(add-string win (format nil " ~a" name) :y y :x 3 :n (- w 6) :fgcolor fg)
|
|
(when (and shortcut (> (- w 6) (+ 4 (length shortcut))))
|
|
(add-string win shortcut :y y :x (- w (length shortcut) 3) :n (length shortcut) :fgcolor (theme-color :dim)))
|
|
(incf flat-index)))))))
|
|
(add-string win (format nil " ↑↓ Navigate Enter Execute Esc Close")
|
|
:y (- h 1) :x 2 :n (- w 4) :fgcolor (theme-color :dim))
|
|
(refresh win)
|
|
(- h 1)))
|
|
|
|
(defun view-wizard (win)
|
|
"Render setup wizard overlay: step title, prompt, input, error, progress."
|
|
(clear win)
|
|
(box win (theme-color :border) (theme-color :background))
|
|
(let* ((w (or (width win) 60))
|
|
(h (or (height win) 15))
|
|
(y 1)
|
|
(steps (passepartout.channel-tui::wizard-steps))
|
|
(step-idx (st :wizard-step))
|
|
(step (when (< step-idx (length steps)) (nth step-idx steps)))
|
|
(prompt (getf step :prompt))
|
|
(title (getf step :title))
|
|
(total (length steps))
|
|
(error-msg (st :wizard-error))
|
|
(input (or (st :wizard-input) "")))
|
|
(add-string win "Setup Wizard" :y y :x 2 :n (- w 4) :fgcolor (theme-color :accent))
|
|
(incf y 2)
|
|
(add-string win (format nil "Step ~d/~d" (1+ step-idx) total) :y y :x 2 :n (- w 4) :fgcolor (theme-color :dim))
|
|
(incf y)
|
|
(when title
|
|
(add-string win title :y y :x 3 :n (- w 6) :fgcolor (theme-color :accent))
|
|
(incf y))
|
|
(when prompt
|
|
(add-string win prompt :y y :x 3 :n (- w 6) :fgcolor (theme-color :agent))
|
|
(incf y))
|
|
(incf y)
|
|
(add-string win (format nil "> ~a" input) :y y :x 3 :n (- w 6) :fgcolor (theme-color :input))
|
|
(incf y)
|
|
(when error-msg
|
|
(add-string win (format nil "! ~a" error-msg) :y y :x 3 :n (- w 6) :fgcolor (theme-color :error))
|
|
(incf y))
|
|
(add-string win "Enter=Next Esc=Cancel Bksp=Edit" :y (- h 2) :x 2 :n (- w 4) :fgcolor (theme-color :dim))
|
|
(refresh win)
|
|
(- h 1)))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-tui-view-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:tui-view-suite))
|
|
|
|
(in-package :passepartout-tui-view-tests)
|
|
|
|
(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
|
|
'((:gate "path" :result :passed)))))
|
|
(is (= 1 (length lines)))
|
|
(is (eq :gate-passed (getf (cdar lines) :fgcolor)))))
|
|
|
|
(test test-gate-trace-lines-blocked
|
|
"Contract 9: gate-trace-lines for blocked gate."
|
|
(let ((lines (passepartout::gate-trace-lines
|
|
'((:gate "shell" :result :blocked :reason "rm")))))
|
|
(is (= 1 (length lines)))
|
|
(is (search "rm" (caar lines)))))
|
|
|
|
(test test-gate-trace-lines-approval
|
|
"Contract 9: gate-trace-lines for approval gate."
|
|
(let ((lines (passepartout::gate-trace-lines
|
|
'((:gate "network" :result :approval)))))
|
|
(is (= 1 (length lines)))
|
|
(is (search "HITL" (caar lines)))))
|
|
|
|
(test test-init-state-has-collapsed-gates
|
|
"Contract v0.7.2: init-state includes :collapsed-gates field."
|
|
(passepartout.channel-tui::init-state)
|
|
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
|
|
(is (null cg))))
|
|
|
|
(in-package :passepartout-tui-view-tests)
|
|
|
|
(test test-theme-hex-string-keys-exist
|
|
"v0.8.0: all 27 theme keys are present in *tui-theme*."
|
|
(let* ((theme passepartout.channel-tui::*tui-theme*)
|
|
(required '(:user :agent :system :input :timestamp :help :error :warning
|
|
:connected :disconnected :busy :idle
|
|
:gate-passed :gate-blocked :gate-approval :hitl
|
|
:tool-running :tool-success :tool-failure :tool-output
|
|
:scroll-indicator :border :background
|
|
:rule-count :focus-map
|
|
:dim :highlight :accent)))
|
|
(dolist (key required)
|
|
(is (getf theme key) (format nil "~a should be defined" key)))))
|
|
|
|
(test test-theme-presets-count
|
|
"v0.8.0: 8 presets defined: dark, light, solarized, gruvbox, nord, tokyonight, catppuccin, monokai."
|
|
(let* ((presets passepartout.channel-tui::*tui-theme-presets*)
|
|
(names '(:dark :light :solarized :gruvbox :nord :tokyonight :catppuccin :monokai)))
|
|
(dolist (name names)
|
|
(is (getf presets name) (format nil "~a preset should exist" name)))))
|
|
|
|
(test test-palette-filter-matches-substring
|
|
"Contract v0.8.0: palette-filter returns items matching query."
|
|
(let* ((items (list (list :category "Session" :items
|
|
(list (list :name "/focus" :desc "Set context" :shortcut nil :action nil)
|
|
(list :name "/scope" :desc "Change scope" :shortcut nil :action nil)))))
|
|
(filtered (passepartout.channel-tui::palette-filter items "focus")))
|
|
(is (= 1 (length (getf (first filtered) :items))))
|
|
(is (string= "/focus" (getf (first (getf (first filtered) :items)) :name)))))
|
|
|
|
(test test-palette-filter-case-insensitive
|
|
"Contract v0.8.0: palette-filter is case-insensitive."
|
|
(let* ((items (list (list :category "View" :items
|
|
(list (list :name "/theme" :desc "Switch color" :shortcut nil :action nil)))))
|
|
(filtered (passepartout.channel-tui::palette-filter items "THEME")))
|
|
(is (= 1 (length (getf (first filtered) :items))))))
|
|
|
|
(test test-palette-filter-no-match-empty
|
|
"Contract v0.8.0: palette-filter returns empty categories on no match."
|
|
(let* ((items (list (list :category "View" :items
|
|
(list (list :name "/theme" :desc "Colors" :shortcut nil :action nil)))))
|
|
(filtered (passepartout.channel-tui::palette-filter items "xyznonexistent")))
|
|
(is (null (getf (first filtered) :items)))))
|