diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index 9b5b001..d0bf464 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -34,9 +34,7 @@ Event handlers + daemon I/O + main loop. #+BEGIN_SRC lisp :tangle /home/user/.local/share/passepartout/lisp/channel-tui-main.lisp (in-package :passepartout.channel-tui) -(defun on-key (key &key ctrl alt shift code) - (let ((ch key)) - (declare (ignore alt shift)) +(defun on-key (ch) (cond ;; v0.7.1: Esc — interrupt streaming ((and (or (eq ch :escape) (eql ch 27)) (st :streaming-text)) @@ -563,16 +561,16 @@ Event handlers + daemon I/O + main loop. (when (and chr (graphic-char-p chr)) (input-insert-char chr) (setf (st :dirty) (list nil nil t)) - (when (and (char= chr #\/) (null cl-tty.dialog:*dialog-stack*) + (when (and (char= chr #\/) (null (st :dialog-stack)) (= (length (st :input-buffer)) 1)) - (unified-menu-show "/")))))))) + (unified-menu-show "/"))))))) ;; v0.9.0 — unified command minibuffer (replaces separate palette and slash menus) (defun unified-menu-show (&optional initial-filter) "Open the command minibuffer with ALL commands. If INITIAL-FILTER is supplied (e.g. \"/\"), pre-fill the select filter with it." (let* ((on-select (lambda (opt) - (cl-tty.dialog:pop-dialog) + (pop (st :dialog-stack)) (let ((val (getf opt :value))) (cond ((stringp val) ;; Slash command — fill input buffer @@ -588,7 +586,7 @@ supplied (e.g. \"/\"), pre-fill the select filter with it." (when initial-filter (setf (cl-tty.select:select-filter sel) initial-filter)) (let ((dlg (make-instance 'cl-tty.dialog:dialog :title "Commands" :content sel))) - (cl-tty.dialog:push-dialog dlg)))) + (push dlg (st :dialog-stack))))) ;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny (defun resolve-hitl-panel (decision) @@ -880,8 +878,6 @@ Returns T on success, nil on failure. Does NOT wait or retry." (defvar *tty-in* nil "Stream from cat subprocess stdout (unused — direct stdin reads)") (defun tui-main () - (format t "~&;; Passepartout TUI starting...~%") - (finish-output) (init-state) (load-history) (theme-load) @@ -923,10 +919,8 @@ Returns T on success, nil on failure. Does NOT wait or retry." (loop while (and (st :running) (not (st :connected))) do (connect-daemon) (unless (st :connected) (sleep 5)))) - :name "daemon-auto-connect")) - ;; Force initial render before entering input loop - (redraw be w h) - (loop while (st :running) do + :name "daemon-auto-connect")) + (loop while (st :running) do (dolist (ev (drain-queue)) (cond ((eq (getf ev :type) :daemon) @@ -938,31 +932,28 @@ Returns T on success, nil on failure. Does NOT wait or retry." ((eq (getf ev :type) :key) (let* ((payload (getf ev :payload)) (ch (getf payload :ch))) - (case ch - (:CTRL-Q (setf (st :running) nil)) - (:CTRL-P (unified-menu-show)) - (:CTRL-B (setf (st :sidebar-mode) - (case (st :sidebar-mode) - (:auto :visible) - (:visible :hidden) - (:hidden :auto))) - (setf (st :dirty) (list t t t))) - (:CTRL-L (setf (st :dirty) (list t t t))) - ;; v0.8.0: dispatch known navigation keywords - ((:up :down :left :right :enter :backspace :tab :escape - :home :end :ppage :npage) - (if cl-tty.dialog:*dialog-stack* - (let* ((dlg (car cl-tty.dialog:*dialog-stack*)) + (case ch + (:CTRL-Q (setf (st :running) nil)) + (:CTRL-P (unified-menu-show)) + (:CTRL-B (setf (st :sidebar-mode) + (case (st :sidebar-mode) + (:auto :visible) + (:visible :hidden) + (:hidden :auto))) + (setf (st :dirty) (list t t t))) + (:CTRL-L (setf (st :dirty) (list t t t))) + (t (if (st :dialog-stack) + (let* ((dlg (car (st :dialog-stack))) (sel (cl-tty.dialog:dialog-content dlg))) (cond - ((eql ch :escape) - (cl-tty.dialog:pop-dialog) - (setf (st :dirty) (list t t nil))) + ((eql ch :escape) + (pop (st :dialog-stack)) + (setf (st :dirty) (list t t nil))) ((member ch '(:up :down)) (if (eql ch :up) (cl-tty.select:select-prev sel) (cl-tty.select:select-next sel))) - ((member ch '(:enter)) + ((member ch '(:enter 13 10)) (let* ((filtered (cl-tty.select:select-filtered-options sel)) (idx (cl-tty.select:select-selected-index sel)) (item (when (< idx (length filtered)) @@ -970,29 +961,20 @@ Returns T on success, nil on failure. Does NOT wait or retry." (when item (let ((cb (cl-tty.select:select-on-select sel))) (when cb (funcall cb item)))))) - ((member ch '(:backspace)) + ((let ((chr (if (characterp ch) ch + (and (integerp ch) (<= 32 ch 126) + (code-char ch))))) + (and chr (graphic-char-p chr)) + (setf (cl-tty.select:select-filter sel) + (concatenate 'string + (or (cl-tty.select:select-filter sel) "") + (string chr))))) + ((member ch '(:backspace 127 8)) (let ((f (cl-tty.select:select-filter sel))) (when (> (length f) 0) (setf (cl-tty.select:select-filter sel) - (subseq f 0 (1- f)))))) - (t nil))) - (on-key ch))) - ;; v0.8.0: typecase converts integers to characters - ;; so ctrl-byte keywords (:CTRL-A) are rejected - (t (let ((chr (typecase ch - (character ch) - ((integer 32 126) (code-char ch)) - (t nil)))) - (when chr - (if cl-tty.dialog:*dialog-stack* - (let* ((dlg (car cl-tty.dialog:*dialog-stack*)) - (sel (cl-tty.dialog:dialog-content dlg))) - (when (graphic-char-p chr) - (setf (cl-tty.select:select-filter sel) - (concatenate 'string - (or (cl-tty.select:select-filter sel) "") - (string chr))))) - (on-key chr :code (when (integerp ch) ch))))))))))) + (subseq f 0 (1- f)))))))) + (on-key ch)))))))) ;; Keyboard reader via read-raw-byte (proven CSI detection) (handler-case (let* ((b (cl-tty.input::read-raw-byte :timeout 0.1)) @@ -1036,9 +1018,9 @@ Returns T on success, nil on failure. Does NOT wait or retry." ;; Guard w and h before render (resize or other code may have set them to nil) (setq w (or (and (numberp w) (> w 0) w) 80) h (or (and (numberp h) (> h 0) h) 24)) - (unless cl-tty.dialog:*dialog-stack* - (redraw be w h)) - (let ((ds cl-tty.dialog:*dialog-stack*)) + (unless (st :dialog-stack) + (redraw be w h)) + (let ((ds (st :dialog-stack))) (when ds (cl-tty.backend:begin-sync be) (let* ((chat-w (- w (if (sidebar-visible-p w) (or (st :sidebar-width) 42) 0))) @@ -1093,9 +1075,11 @@ Returns T on success, nil on failure. Does NOT wait or retry." (format nil "> ~a" (or filter "")) (theme-color :input-prompt) bg-p)) (cl-tty.backend:end-sync be)) - (sleep 0.1)) - (position-cursor be w h)) - (progn (disconnect-daemon))))) + (sleep 0.1) + ;; Show terminal cursor at input position every frame + (unless (st :dialog-stack) + (passepartout.channel-tui:position-cursor be w h)))) + (progn (disconnect-daemon))))) #+END_SRC * Test Suite @@ -1593,7 +1577,7 @@ Returns T on success, nil on failure. Does NOT wait or retry." (fiveam:test test-minibuffer-state "Contract v0.8.0: init-state has :dialog-stack and :minibuffer-active fields." (init-state) - (fiveam:is (null cl-tty.dialog:*dialog-stack*)) + (fiveam:is (null (st :dialog-stack))) (fiveam:is (null (st :minibuffer-active)))) (fiveam:test test-command-palette-state diff --git a/org/channel-tui-view.org b/org/channel-tui-view.org index 56adb83..263a3f6 100644 --- a/org/channel-tui-view.org +++ b/org/channel-tui-view.org @@ -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