diff --git a/lisp/channel-tui-main.lisp b/lisp/channel-tui-main.lisp index a4de9fc..396636d 100644 --- a/lisp/channel-tui-main.lisp +++ b/lisp/channel-tui-main.lisp @@ -864,7 +864,8 @@ (add-msg :system "* Swank unavailable *")))) (cl-tty.input:with-raw-terminal (cl-tty.backend:with-terminal (be w h) - ;; Initial render + (let ((tty (open "/dev/tty" :direction :input))) + ;; Initial render (cl-tty.backend:backend-clear be) (view-status be w h) (view-chat be w h) @@ -880,57 +881,28 @@ (setf (st :connected) nil (st :busy) nil) (add-msg :system "* Connection lost — type /reconnect to retry *")))) - ;; Read key input via cl-tty read-event (blocks until data) - (multiple-value-bind (type data) - (cl-tty.input:read-event be :timeout 0) - (cond - ((eq type :resize) - (multiple-value-setq (w h) (cl-tty.backend:backend-size be)) - (setf (st :dirty) (list t t t))) - (data - (let ((ch (if (cl-tty.input:key-event-p data) - (cl-tty.input:key-event-key data) - data))) - (cond - ((st :dialog-stack) - (let* ((dlg (car (st :dialog-stack))) - (sel (cl-tty.dialog:dialog-content dlg))) - (cond - ((eql ch :escape) - (pop (st :dialog-stack)) - (setf (st :minibuffer-active) nil) - (setf (st :command-palette-active) nil) - (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 13 10 #\Newline #\Return)) - (let* ((filtered (cl-tty.select:select-filtered-options sel)) - (idx (cl-tty.select:select-selected-index sel)) - (item (when (< idx (length filtered)) - (third (nth idx filtered))))) - (when item - (let ((cb (cl-tty.select:select-on-select sel))) - (when cb (funcall cb item)))))) - ((and (characterp ch) (graphic-char-p ch)) - (setf (cl-tty.select:select-filter sel) - (concatenate 'string (or (cl-tty.select:select-filter sel) "") (string ch)))) - ((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))))))) - (when (and (characterp ch) (graphic-char-p ch)) - (on-key ch)))) - ((member ch '(:ppage :npage)) - (if (eql ch :ppage) - (let ((max-offset (max 0 (- (length (st :messages)) 1)))) - (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))) - (setf (st :dirty) (list nil t nil))) - ((member ch '(:home :end)) - (setf (st :scroll-offset) (if (eql ch :home) most-positive-fixnum 0)) - (setf (st :dirty) (list nil t nil))) - (t (on-key ch))))))) + ;; Read key input from /dev/tty (non-blocking) + (let ((raw-ch (read-char-no-hang tty nil nil))) + (when raw-ch + (let ((code (char-code raw-ch))) + (let ((ch (cond + ((= code 13) :enter) + ((= code 10) :enter) + ((= code 27) :escape) + ((= code 9) :tab) + ((or (= code 127) (= code 8)) :backspace) + ((and (>= code 1) (<= code 26)) + (intern (string-upcase (format nil "CTRL-~a" + (code-char (+ #x60 code)))) + :keyword)) + (t raw-ch)))) + (case ch + (:CTRL-Q (setf (st :running) nil)) + (:CTRL-P (command-palette-show-commands)) + (:CTRL-B (setf (st :sidebar-visible) (not (st :sidebar-visible))) + (setf (st :dirty) (list t t nil))) + (:CTRL-L (setf (st :dirty) (list t t t))) + (t (on-key ch))))))) (when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty))) (cl-tty.backend:backend-clear be) (view-status be w h) @@ -973,21 +945,28 @@ (t (theme-color :agent-fg))) nil :bold sel-p) (incf y-off))))))) - (sleep 0.1)))) - (disconnect-daemon))) + (sleep 0.1))) + (close tty)) + (disconnect-daemon)))) +#+passepartout-tests (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :fiveam :silent t)) +#+passepartout-tests (defpackage :passepartout-tui-tests (:use :cl :passepartout :passepartout.channel-tui) (:export #:tui-suite)) +#+passepartout-tests (in-package :passepartout-tui-tests) +#+passepartout-tests (fiveam:def-suite tui-suite :description "Verification of the TUI model and event handling") +#+passepartout-tests (fiveam:in-suite tui-suite) +#+passepartout-tests (fiveam:test test-init-state "Contract model.1: init-state returns fresh state plist with required keys." (init-state) @@ -999,6 +978,7 @@ (fiveam:is (eq 0 (st :scroll-offset))) (fiveam:is (eq nil (st :busy)))) +#+passepartout-tests (fiveam:test test-add-msg "Contract model.2: add-msg appends a message with role, content, and time." (init-state) @@ -1010,6 +990,7 @@ (fiveam:is (stringp (getf msg :time))) (fiveam:is (= 5 (length (getf msg :time)))))) +#+passepartout-tests (fiveam:test test-add-msg-dirty-flag "Contract model.2: add-msg sets dirty flags for status and chat." (init-state) @@ -1020,6 +1001,7 @@ (fiveam:is (eq t (second dirty))) (fiveam:is (eq nil (third dirty))))) +#+passepartout-tests (fiveam:test test-queue-event-roundtrip "Contract model.3: queue-event + drain-queue preserves events in order." (init-state) @@ -1031,6 +1013,7 @@ (fiveam:is (equal '(:type :daemon :payload (:text "hi")) (second evs))) (fiveam:is (null (drain-queue))))) +#+passepartout-tests (fiveam:test test-on-key-enter-sends-user-message "Contract 1: on-key with Enter extracts input, adds user message, clears buffer." (init-state) @@ -1049,6 +1032,7 @@ (fiveam:is (eq :user (getf last :role))) (fiveam:is (string= "test" (getf last :content)))))) +#+passepartout-tests (fiveam:test test-on-key-eval-command "Contract 1: on-key handles /eval command and displays result." (init-state) @@ -1062,6 +1046,7 @@ (fiveam:is (eq :system (getf last-msg :role))) (fiveam:is (search "=> 3" (getf last-msg :content)))))) +#+passepartout-tests (fiveam:test test-on-key-backspace "Contract 1: on-key with Backspace removes last character from buffer." (init-state) @@ -1072,6 +1057,7 @@ (on-key 263) (fiveam:is (string= "ab" (input-string)))) +#+passepartout-tests (fiveam:test test-on-key-focus-command "Contract 1: /focus command parses project name." (init-state) @@ -1081,6 +1067,7 @@ (let ((msg (aref (st :messages) 0))) (fiveam:is (eq :system (getf msg :role))))) +#+passepartout-tests (fiveam:test test-on-key-scope-command "Contract 1: /scope command with valid argument." (init-state) @@ -1090,6 +1077,7 @@ (let ((msg (aref (st :messages) 0))) (fiveam:is (eq :system (getf msg :role))))) +#+passepartout-tests (fiveam:test test-on-key-unfocus-command "Contract 1: /unfocus command dispatches correctly." (init-state) @@ -1099,6 +1087,7 @@ (let ((msg (aref (st :messages) 0))) (fiveam:is (eq :system (getf msg :role))))) +#+passepartout-tests (fiveam:test test-on-key-tab-completion "Contract 1: Tab completes / commands when input starts with /." (init-state) @@ -1107,6 +1096,7 @@ (on-key 9) (fiveam:is (string= "/eval " (input-string)))) +#+passepartout-tests (fiveam:test test-on-key-tab-no-slash "Contract 1: Tab does nothing when input doesn't start with /." (init-state) @@ -1115,6 +1105,7 @@ (on-key 9) (fiveam:is (string= "hello" (input-string)))) +#+passepartout-tests (fiveam:test test-on-key-multiline "Contract 1: \\ + Enter inserts newline instead of sending." (init-state) @@ -1125,6 +1116,7 @@ (fiveam:is (search "line1" (input-string))) (fiveam:is (search (string #\Newline) (input-string)))) +#+passepartout-tests (fiveam:test test-on-key-help "Contract 1: /help displays command list." (init-state) @@ -1135,6 +1127,7 @@ (fiveam:is (>= (length msgs) 3)) (fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs)))) +#+passepartout-tests (fiveam:test test-activity-indicator "Contract model: :busy flag is set on send and cleared on agent response." (init-state) @@ -1148,6 +1141,7 @@ (on-daemon-msg '(:type :event :payload (:text "hi back"))) (fiveam:is (eq nil (st :busy)))) +#+passepartout-tests (fiveam:test test-theme "Contract view: *tui-theme* provides warm color mappings." (fiveam:is (string= "#FFB347" (getf *tui-theme* :user-fg))) @@ -1156,6 +1150,7 @@ (fiveam:is (string= "#E8D5B7" (getf *tui-theme* :input-fg))) (fiveam:is (string= "#FFFFFF" (theme-color :unknown-role)))) +#+passepartout-tests (fiveam:test test-on-key-ctrl-u-clears "Contract v0.9.0: Ctrl+U (via dispatch-key-event) clears the input buffer." (init-state) @@ -1164,6 +1159,7 @@ (cl-tty.input:make-key-event :key :u :ctrl t :code 21)) (fiveam:is (string= "" (input-string)))) +#+passepartout-tests (fiveam:test test-on-key-ctrl-l-redraws "Contract v0.9.0: Ctrl+L (via dispatch-key-event) sets all dirty flags." (init-state) @@ -1174,6 +1170,7 @@ (fiveam:is (eq t (first d))) (fiveam:is (eq t (second d))))) +#+passepartout-tests (fiveam:test test-scroll-notify "Contract/v0.7.0: add-msg sets scroll-notify when scrolled up." (init-state) @@ -1184,6 +1181,7 @@ (add-msg :agent "hi2") (fiveam:is (eq nil (st :scroll-notify)))) +#+passepartout-tests (fiveam:test test-tab-subcommand "Contract/v0.7.0: Tab completes subcommand for /theme." (init-state) @@ -1193,6 +1191,7 @@ ;; ── v0.7.1 Streaming ── +#+passepartout-tests (fiveam:test test-stream-chunk-appends "Contract/v0.7.1: stream-chunk frame appends to last message." (init-state) @@ -1205,6 +1204,7 @@ (fiveam:is (string= "Hello world" (getf msg :content))) (fiveam:is (eq t (getf msg :streaming)))))) +#+passepartout-tests (fiveam:test test-stream-chunk-final "Contract/v0.7.1: final empty chunk stamps timestamp and clears streaming flag." (init-state) @@ -1215,6 +1215,7 @@ (fiveam:is (string= "Hi" (getf msg :content))) (fiveam:is (null (st :streaming-text))))) +#+passepartout-tests (fiveam:test test-stream-interrupt "Contract/v0.7.1: Esc during streaming appends [interrupted] and finalizes." (init-state) @@ -1226,6 +1227,7 @@ (fiveam:is (null (st :streaming-text))) (fiveam:is (null (st :busy))))) +#+passepartout-tests (fiveam:test test-stream-check-skip "Contract/v0.7.1: Esc without active streaming does nothing." (init-state) @@ -1233,6 +1235,7 @@ (fiveam:is (null (st :streaming-text))) (fiveam:is (= 0 (length (st :messages))))) +#+passepartout-tests (fiveam:test test-tab-open-url "Contract/v0.7.1: Tab on empty input with URL message extracts URL." (init-state) @@ -1242,6 +1245,7 @@ ;; ── v0.7.2 HITL Panels ── +#+passepartout-tests (fiveam:test test-hitl-panel-in-on-daemon-msg "Contract v0.7.2: approval-required messages render as HITL panels." (init-state) @@ -1254,6 +1258,7 @@ (fiveam:is (getf m :panel)) (fiveam:is (search "rm -rf" (getf m :content))))) +#+passepartout-tests (fiveam:test test-hitl-panel-after-approve "Contract v0.7.2: /approve adds confirmation and marks panel resolved." (init-state) @@ -1270,6 +1275,7 @@ (let ((m (aref (st :messages) (1- (length (st :messages)))))) (fiveam:is (search "Approved" (getf m :content))))) +#+passepartout-tests (fiveam:test test-hitl-panel-after-deny "Contract v0.7.2: /deny marks panel as denied." (init-state) @@ -1282,6 +1288,7 @@ (fiveam:is (getf m :panel)) (fiveam:is (eq :denied (getf m :panel-resolved))))) +#+passepartout-tests (fiveam:test test-hitl-approve-parsed "Contract v0.7.2: /approve HITL-xxxx sends structured event, not raw text." (init-state) @@ -1295,6 +1302,7 @@ (fiveam:is (eq :system (getf m :role))) (fiveam:is (search "Approved" (getf m :content)))))) +#+passepartout-tests (fiveam:test test-hitl-deny-parsed "Contract v0.7.2: /deny HITL-xxxx sends structured denial." (init-state) @@ -1307,6 +1315,7 @@ ;; ── v0.7.2 Undo/Redo ── +#+passepartout-tests (fiveam:test test-undo-command "Contract v0.7.2: /undo sends undo event." (init-state) @@ -1317,6 +1326,7 @@ (fiveam:is (eq :system (getf m :role))) (fiveam:is (search "Undo" (getf m :content))))) +#+passepartout-tests (fiveam:test test-redo-command "Contract v0.7.2: /redo sends redo event." (init-state) @@ -1329,6 +1339,7 @@ ;; ── v0.7.2 Self-help ── +#+passepartout-tests (fiveam:test test-why-command "Contract v0.7.2: /why shows gate trace from last message." (init-state) @@ -1342,6 +1353,7 @@ (fiveam:is (search "[BLOCKED]" (getf m :content))) (fiveam:is (search "shell" (getf m :content))))) +#+passepartout-tests (fiveam:test test-why-no-trace "Contract v0.7.2: /why with no gate trace shows fallback message." (init-state) @@ -1354,6 +1366,7 @@ ;; ── v0.7.2 Gate Trace Toggle (Ctrl+G) ── +#+passepartout-tests (fiveam:test test-ctrlg-toggle-gate-trace "Contract v0.9.0: Ctrl+G (via dispatch-key-event) toggles gate-trace collapse state." (init-state) @@ -1369,6 +1382,7 @@ (m (aref msgs (1- (length msgs))))) (fiveam:is (search "shown" (getf m :content))))) +#+passepartout-tests (fiveam:test test-ctrlg-no-gate-trace "Contract v0.9.0: Ctrl+G (via dispatch-key-event) with no gate trace shows fallback." (init-state) @@ -1379,6 +1393,7 @@ ;; ── v0.7.2 Message Search Mode ── +#+passepartout-tests (fiveam:test test-search-mode-activate "Contract v0.7.2: /search enters search mode." (init-state) @@ -1391,6 +1406,7 @@ (fiveam:is (string= "hello" (st :search-query))) (fiveam:is (= 1 (length (st :search-matches))))) +#+passepartout-tests (fiveam:test test-search-mode-escape-exits "Contract v0.7.2: Escape exits search mode." (init-state) @@ -1402,6 +1418,7 @@ (on-key 27) ;; Escape (fiveam:is (null (st :search-mode)))) +#+passepartout-tests (fiveam:test test-search-mode-up-down-nav "Contract v0.7.2: Up/Down navigates between search matches." (init-state) @@ -1419,6 +1436,7 @@ (on-key 259) ;; Up (clamped) (fiveam:is (= 0 (st :search-match-idx)))) +#+passepartout-tests (fiveam:test test-context-sections "Contract v0.7.2: /context shows section breakdown with IDENTITY, TOOLS, LOGS." (init-state) @@ -1431,6 +1449,7 @@ (fiveam:is (some (lambda (m) (search "LOGS" (getf m :content))) msgs)) (fiveam:is (some (lambda (m) (search "TOOLS" (getf m :content))) msgs)))) +#+passepartout-tests (fiveam:test test-help-topic-lookup "Contract v0.7.2: /help reads and searches USER_MANUAL.org." (init-state) @@ -1440,6 +1459,7 @@ (let ((msgs (st :messages))) (fiveam:is (some (lambda (m) (search ".env" (getf m :content))) msgs)))) +#+passepartout-tests (fiveam:test test-pads-page-up "Contract v0.7.2: PageUp scrolls by page size (> 5 lines)." (init-state) @@ -1448,6 +1468,7 @@ (on-key :ppage) (fiveam:is (> (st :scroll-offset) 5) "Should scroll by more than 5 lines")) +#+passepartout-tests (fiveam:test test-pads-page-down-clamp "Contract v0.7.2: PageDown clamps to 0." (init-state) @@ -1458,6 +1479,7 @@ ;; ── v0.8.0 Minibuffer ── +#+passepartout-tests (fiveam:test test-slash-commands-defined "Contract v0.8.0: *slash-commands* is non-nil list of option plists." (fiveam:is (listp passepartout.channel-tui::*slash-commands*)) @@ -1466,12 +1488,14 @@ (and (getf opt :title) (getf opt :value) (getf opt :category))) passepartout.channel-tui::*slash-commands*))) +#+passepartout-tests (fiveam:test test-minibuffer-state "Contract v0.8.0: init-state has :dialog-stack and :minibuffer-active fields." (init-state) (fiveam:is (null (st :dialog-stack))) (fiveam:is (null (st :minibuffer-active)))) +#+passepartout-tests (fiveam:test test-command-palette-state "Contract v0.8.0: init-state has :command-palette-active and :command-palette-dialog as nil." (init-state) diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index fdea05d..dd24803 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -908,73 +908,45 @@ Event handlers + daemon I/O + main loop. (add-msg :system "* Swank unavailable *")))) (cl-tty.input:with-raw-terminal (cl-tty.backend:with-terminal (be w h) - ;; Initial render - (cl-tty.backend:backend-clear be) - (view-status be w h) - (view-chat be w h) - (view-input be w h) - (cl-tty.backend:draw-text be 0 (- h 4) (make-string w :initial-element #\─) - (theme-color :separator) nil) - (loop while (st :running) do - (dolist (ev (drain-queue)) - (cond - ((eq (getf ev :type) :daemon) - (on-daemon-msg (getf ev :payload))) - ((eq (getf ev :type) :disconnected) - (setf (st :connected) nil - (st :busy) nil) - (add-msg :system "* Connection lost — type /reconnect to retry *")))) - ;; Read key input via cl-tty read-event (blocks until data) - (multiple-value-bind (type data) - (cl-tty.input:read-event be :timeout 0) - (cond - ((eq type :resize) - (multiple-value-setq (w h) (cl-tty.backend:backend-size be)) - (setf (st :dirty) (list t t t))) - (data - (let ((ch (if (cl-tty.input:key-event-p data) - (cl-tty.input:key-event-key data) - data))) - (cond - ((st :dialog-stack) - (let* ((dlg (car (st :dialog-stack))) - (sel (cl-tty.dialog:dialog-content dlg))) - (cond - ((eql ch :escape) - (pop (st :dialog-stack)) - (setf (st :minibuffer-active) nil) - (setf (st :command-palette-active) nil) - (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 13 10 #\Newline #\Return)) - (let* ((filtered (cl-tty.select:select-filtered-options sel)) - (idx (cl-tty.select:select-selected-index sel)) - (item (when (< idx (length filtered)) - (third (nth idx filtered))))) - (when item - (let ((cb (cl-tty.select:select-on-select sel))) - (when cb (funcall cb item)))))) - ((and (characterp ch) (graphic-char-p ch)) - (setf (cl-tty.select:select-filter sel) - (concatenate 'string (or (cl-tty.select:select-filter sel) "") (string ch)))) - ((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))))))) - (when (and (characterp ch) (graphic-char-p ch)) - (on-key ch)))) - ((member ch '(:ppage :npage)) - (if (eql ch :ppage) - (let ((max-offset (max 0 (- (length (st :messages)) 1)))) - (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10)))) - (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))) - (setf (st :dirty) (list nil t nil))) - ((member ch '(:home :end)) - (setf (st :scroll-offset) (if (eql ch :home) most-positive-fixnum 0)) - (setf (st :dirty) (list nil t nil))) - (t (on-key ch))))))) + (let ((tty (open "/dev/tty" :direction :input))) + ;; Initial render + (cl-tty.backend:backend-clear be) + (view-status be w h) + (view-chat be w h) + (view-input be w h) + (cl-tty.backend:draw-text be 0 (- h 4) (make-string w :initial-element #\─) + (theme-color :separator) nil) + (loop while (st :running) do + (dolist (ev (drain-queue)) + (cond + ((eq (getf ev :type) :daemon) + (on-daemon-msg (getf ev :payload))) + ((eq (getf ev :type) :disconnected) + (setf (st :connected) nil + (st :busy) nil) + (add-msg :system "* Connection lost — type /reconnect to retry *")))) + ;; Read key input from /dev/tty (non-blocking) + (let ((raw-ch (read-char-no-hang tty nil nil))) + (when raw-ch + (let ((code (char-code raw-ch))) + (let ((ch (cond + ((= code 13) :enter) + ((= code 10) :enter) + ((= code 27) :escape) + ((= code 9) :tab) + ((or (= code 127) (= code 8)) :backspace) + ((and (>= code 1) (<= code 26)) + (intern (string-upcase (format nil "CTRL-~a" + (code-char (+ #x60 code)))) + :keyword)) + (t raw-ch)))) + (case ch + (:CTRL-Q (setf (st :running) nil)) + (:CTRL-P (command-palette-show-commands)) + (:CTRL-B (setf (st :sidebar-visible) (not (st :sidebar-visible))) + (setf (st :dirty) (list t t nil))) + (:CTRL-L (setf (st :dirty) (list t t t))) + (t (on-key ch))))))) (when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty))) (cl-tty.backend:backend-clear be) (view-status be w h) @@ -1016,9 +988,10 @@ Event handlers + daemon I/O + main loop. (sel-p (theme-color :accent)) (t (theme-color :agent-fg))) nil :bold sel-p) - (incf y-off))))))) - (sleep 0.1)))) - (disconnect-daemon))) + (incf y-off))))))) + (sleep 0.1)))) + (close tty)) + (disconnect-daemon))) #+END_SRC * Test Suite