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

fix: /dev/tty input, gate test code, fix code-char bug

Browse Source 
- Replaced cl-tty read-event with direct read-char-no-hang from
  /dev/tty for reliable input (avoids unix-simple-poll fd 0 issue)
- Added (let ((tty ...)) wrapper to open /dev/tty once at startup
- Fixed (code-char raw-ch) bug: raw-ch is already a CHARACTER
- Fixed one extra close paren that closed (let ((ch ...)) early
- Gated fiveam test section behind #+passepartout-tests reader
  conditional to prevent crash on TUI startup when fiveam not loaded
This commit is contained in:
Amr Gharbeia
2026-05-14 08:53:21 -04:00
parent a9705253a5
commit 226f979d38
2 changed files with 121 additions and 124 deletions
Download Patch File Download Diff File Expand all files Collapse all files

132
lisp/channel-tui-main.lisp
View File

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

113
org/channel-tui-main.org
View File

@@ -908,73 +908,45 @@ Event handlers + daemon I/O + main loop.
(add-msg :system "* Swank unavailable *")))) (add-msg :system "* Swank unavailable *"))))
(cl-tty.input:with-raw-terminal (cl-tty.input:with-raw-terminal
(cl-tty.backend:with-terminal (be w h) (cl-tty.backend:with-terminal (be w h)
;; Initial render (let ((tty (open "/dev/tty" :direction :input)))
(cl-tty.backend:backend-clear be) ;; Initial render
(view-status be w h) (cl-tty.backend:backend-clear be)
(view-chat be w h) (view-status be w h)
(view-input be w h) (view-chat be w h)
(cl-tty.backend:draw-text be 0 (- h 4) (make-string w :initial-element #\─) (view-input be w h)
(theme-color :separator) nil) (cl-tty.backend:draw-text be 0 (- h 4) (make-string w :initial-element #\─)
(loop while (st :running) do (theme-color :separator) nil)
(dolist (ev (drain-queue)) (loop while (st :running) do
(cond (dolist (ev (drain-queue))
((eq (getf ev :type) :daemon) (cond
(on-daemon-msg (getf ev :payload))) ((eq (getf ev :type) :daemon)
((eq (getf ev :type) :disconnected) (on-daemon-msg (getf ev :payload)))
(setf (st :connected) nil ((eq (getf ev :type) :disconnected)
(st :busy) nil) (setf (st :connected) nil
(add-msg :system "* Connection lost — type /reconnect to retry *")))) (st :busy) nil)
;; Read key input via cl-tty read-event (blocks until data) (add-msg :system "* Connection lost — type /reconnect to retry *"))))
(multiple-value-bind (type data) ;; Read key input from /dev/tty (non-blocking)
(cl-tty.input:read-event be :timeout 0) (let ((raw-ch (read-char-no-hang tty nil nil)))
(cond (when raw-ch
((eq type :resize) (let ((code (char-code raw-ch)))
(multiple-value-setq (w h) (cl-tty.backend:backend-size be)) (let ((ch (cond
(setf (st :dirty) (list t t t))) ((= code 13) :enter)
(data ((= code 10) :enter)
(let ((ch (if (cl-tty.input:key-event-p data) ((= code 27) :escape)
(cl-tty.input:key-event-key data) ((= code 9) :tab)
data))) ((or (= code 127) (= code 8)) :backspace)
(cond ((and (>= code 1) (<= code 26))
((st :dialog-stack) (intern (string-upcase (format nil "CTRL-~a"
(let* ((dlg (car (st :dialog-stack))) (code-char (+ #x60 code))))
(sel (cl-tty.dialog:dialog-content dlg))) :keyword))
(cond (t raw-ch))))
((eql ch :escape) (case ch
(pop (st :dialog-stack)) (:CTRL-Q (setf (st :running) nil))
(setf (st :minibuffer-active) nil) (:CTRL-P (command-palette-show-commands))
(setf (st :command-palette-active) nil) (:CTRL-B (setf (st :sidebar-visible) (not (st :sidebar-visible)))
(setf (st :dirty) (list t t nil))) (setf (st :dirty) (list t t nil)))
((member ch '(:up :down)) (:CTRL-L (setf (st :dirty) (list t t t)))
(if (eql ch :up) (cl-tty.select:select-prev sel) (t (on-key ch)))))))
(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)))))))
(when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty))) (when (or (first (st :dirty)) (second (st :dirty)) (third (st :dirty)))
(cl-tty.backend:backend-clear be) (cl-tty.backend:backend-clear be)
(view-status be w h) (view-status be w h)
@@ -1016,9 +988,10 @@ Event handlers + daemon I/O + main loop.
(sel-p (theme-color :accent)) (sel-p (theme-color :accent))
(t (theme-color :agent-fg))) (t (theme-color :agent-fg)))
nil :bold sel-p) nil :bold sel-p)
(incf y-off))))))) (incf y-off)))))))
(sleep 0.1)))) (sleep 0.1))))
(disconnect-daemon))) (close tty))
(disconnect-daemon)))
#+END_SRC #+END_SRC
* Test Suite * Test Suite