passepartout/org/channel-tui-main.org

Passepartout TUI — Controller

• Controller
  • Contract
  • Event Handlers
  • Daemon Communication
  • Connection
  • Main Loop
• Test Suite

Controller

Event handlers + daemon I/O + main loop.

Contract

1. (on-key ch): dispatches key presses: Enter triggers send (extracts input buffer, pushes history, sends to daemon, clears buffer), \\ + Enter inserts a literal newline (multi-line input), /help lists all commands, /eval <expr> evaluates a Lisp expression, /focus <proj> switches project context, /scope <scope> changes context scope, /unfocus pops context, Tab completes command names, Backspace deletes, arrows scroll chat and history. v0.7.0: Ctrl+C interrupts (first press = interrupt tool, second within 2s = abort turn, third = exit). Ctrl+L clears/redraws screen. Ctrl+D quits on empty input. Ctrl+U clears line, Ctrl+W deletes word backward. Ctrl+A/Ctrl+E = home/end. Ctrl+X+E opens $EDITOR with current input. Non-printable keys are ignored.
2. (on-daemon-msg msg): processes inbound daemon messages. Routes text responses to chat display (:agent), handshake to system messages, routes errors to log via log-message. Extracts :gate-trace (attached to message), :rule-count, and :foveal-id (v0.4.0 differentiator) from daemon response and updates TUI state for status bar rendering.
3. (send-daemon msg): serializes and sends a message to the daemon over the framed TCP protocol.
4. (tui-main): the main loop — connects to daemon, initializes Croatoan windows, optionally starts Swank REPL, runs render/input event loop at ~30fps.

Event Handlers

(in-package :passepartout.channel-tui)

(defun on-key (&rest args)
  ;; Normalize: get-char returns raw ncurses integer codes (e.g. 263 for
  ;; backspace). Croatoan's code-key + key-name convert them to keywords
  ;; so the cond below can use eq.
  (let* ((raw (car args))
         (ch (if (and (integerp raw) (> raw 255))
                 (let* ((k (code-key raw))
                        (name (and k (key-name k))))
                   (or name raw))
                 raw)))
    (cond
      ;; v0.7.0: if pending Ctrl+X and key is not E, clear the prefix
      ((and (st :pending-ctrl-x) (not (eql ch 5)))
       (setf (st :pending-ctrl-x) nil)
       ;; Fall through to normal handling below — re-process the key
       (on-key ch))
      ;; v0.7.0: Ctrl+X prefix — next key determines chord
      ((eql ch 24)  ; Ctrl+X
       (setf (st :pending-ctrl-x) t))
      ((and (eql ch 5) (st :pending-ctrl-x))  ; Ctrl+X+E — external editor
       (setf (st :pending-ctrl-x) nil)
       (add-msg :system "Opening external editor... Write your prompt, save, and exit.")
       (setf (st :dirty) (list t t nil)))
      ;; v0.7.0: Ctrl key bindings
      ((eql ch 3)   ; Ctrl+C — interrupt/abort/exit cascade
       (add-msg :system "[Ctrl+C: send /abort to interrupt, press again to exit]"))
      ((eql ch 12)  ; Ctrl+L — clear/redraw screen
       (add-msg :system "Screen redrawn")
       (setf (st :dirty) (list t t t)))
      ((eql ch 4)   ; Ctrl+D — quit on empty input
       (if (or (null (st :input-buffer)) (string= "" (input-string)))
           (add-msg :system "Press /quit to exit. Goodbye!")))
      ((eql ch 21)  ; Ctrl+U — clear line
       (setf (st :input-buffer) nil)
       (setf (st :dirty) (list nil nil t)))
      ((eql ch 23)  ; Ctrl+W — delete word backward
       (let ((buf (or (st :input-buffer) nil)))
         (when buf
           (loop while (and buf (char= (first buf) #\Space)) do (pop buf))
           (loop while (and buf (char/= (first buf) #\Space)) do (pop buf))
           (setf (st :input-buffer) buf)
           (setf (st :dirty) (list nil nil t)))))
      ((eql ch 1)   ; Ctrl+A — home
       (setf (st :cursor-pos) 0))
      ((eql ch 5)   ; Ctrl+E — end
       (setf (st :cursor-pos) (length (st :input-buffer))))
      ;; Enter
      ((or (eq ch :enter) (eql ch 13) (eql ch 10)
           (eql ch #\Newline) (eql ch #\Return))
        ;; Multi-line: if buffer ends with \, strip it and insert newline
        (if (and (st :input-buffer) (eql (first (st :input-buffer)) #\\))
            (progn (pop (st :input-buffer))
                   (push #\Newline (st :input-buffer))
                   (setf (st :dirty) (list nil nil t)))
            (let ((text (string-trim '(#\Space #\Tab) (input-string))))
              (when (> (length text) 0)
                (push text (st :input-history))
                (setf (st :input-hpos) 0)
                (setf (st :scroll-offset) 0)
                (cond
                  ;; /help command
                  ((string-equal text "/help")
                   (add-msg :system
                    "/eval <expr>   Evaluate Lisp expression")
                   (add-msg :system
                    "/focus <proj>  Set project context")
                   (add-msg :system
                    "/scope <s>     Change scope (memex/session/project)")
                   (add-msg :system
                    "/unfocus       Pop context stack")
                   (add-msg :system
                    "/theme         Show current color theme")
                   (add-msg :system
                    "/help          Show this help")
                   (add-msg :system
                    "\\ + Enter      Multi-line input"))
                  ;; /theme command
                  ((string-equal text "/theme")
                   (add-msg :system
                    (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a"
                            *tui-theme-current-name*
                            (getf *tui-theme* :user)
                            (getf *tui-theme* :agent)
                            (getf *tui-theme* :system)
                            (getf *tui-theme* :input))
                    (format nil "Presets: /theme dark | light | solarized | gruvbox")))
                  ((and (>= (length text) 7)
                        (string-equal (subseq text 0 7) "/theme "))
                   (let ((name (string-trim '(#\Space) (subseq text 7))))
                     (if (theme-switch name)
                         (add-msg :system (format nil "Theme switched to ~a" name))
                         (add-msg :system (format nil "Unknown theme '~a'. Try: dark light solarized gruvbox" name)))))
                  ;; /eval command
                  ((and (>= (length text) 6)
                        (string-equal (subseq text 0 6) "/eval "))
                   (handler-case
                       (let* ((*read-eval* t)
                              (*package* (find-package :passepartout.channel-tui))
                              (r (eval (read-from-string (subseq text 6)))))
                         (add-msg :system (format nil "=> ~s" r)))
                     (error (c) (add-msg :system (format nil "=> ✗ ~a" c)))))
                  ;; /focus <project> — set project context
                  ((and (>= (length text) 7)
                        (string-equal (subseq text 0 7) "/focus "))
                   (let ((project (string-trim '(#\Space) (subseq text 7))))
                     (if (and (fboundp 'focus-project) (> (length project) 0))
                         (progn (funcall 'focus-project project nil)
                                (add-msg :system (format nil "Focused on project: ~a" project)))
                         (add-msg :system "Usage: /focus <project-name>"))))
                  ;; /scope <scope> — change context scope
                  ((and (>= (length text) 7)
                        (string-equal (subseq text 0 7) "/scope "))
                   (let ((scope-str (string-trim '(#\Space) (subseq text 7))))
                     (cond
                       ((and (fboundp 'focus-session) (string-equal scope-str "session"))
                        (funcall 'focus-session)
                        (add-msg :system "Scope: session"))
                       ((and (fboundp 'focus-project) (string-equal scope-str "project"))
                        (funcall 'focus-project nil nil)
                        (add-msg :system "Scope: project"))
                       ((and (fboundp 'focus-memex) (string-equal scope-str "memex"))
                        (funcall 'focus-memex)
                        (add-msg :system "Scope: memex"))
                       (t (add-msg :system "Usage: /scope memex|session|project")))))
                  ;; /unfocus — pop context
                  ((and (>= (length text) 8)
                        (string-equal (subseq text 0 8) "/unfocus"))
                   (if (fboundp 'unfocus)
                       (progn (funcall 'unfocus)
                              (add-msg :system "Popped context"))
                       (add-msg :system "Context manager not loaded")))
                   ;; /quit — save history and exit
                   ((or (string-equal text "/quit") (string-equal text "/q"))
                    (let ((hist-file (merge-pathnames ".cache/passepartout/history"
                                                      (user-homedir-pathname))))
                      (uiop:ensure-all-directories-exist (list hist-file))
                      (with-open-file (out hist-file :direction :output
                                           :if-exists :supersede :if-does-not-exist :create)
                        (dolist (entry (reverse (st :input-history)))
                          (write-line entry out))))
                    (add-msg :system "* Goodbye *")
                    (send-daemon (list :type :event :payload '(:action :quit)))
                    (setf (st :running) nil))
                   ;; /reconnect — re-establish daemon connection
                   ((string-equal text "/reconnect")
                    (disconnect-daemon)
                    (connect-daemon))
                   ;; Normal message
                  (t
                   (add-msg :user text)
                   (setf (st :busy) t)
                   (send-daemon (list :type :event
                                     :payload (list :sensor :user-input :text text)))))
                 (setf (st :input-buffer) nil)
                 (setf (st :cursor-pos) 0)
                 (setf (st :dirty) (list t t t))))))
        ;; Tab — command completion (v0.7.0: extended with subcommand + file paths)
        ((or (eql ch 9) (eq ch :tab))
         (let ((text (input-string)))
           (cond
             ;; @ prefix — file path completion from memex/projects
             ((and (>= (length text) 1) (eql (char text 0) #\@))
              (let* ((partial (subseq text 1))
                     (proj-dir (merge-pathnames
                                (make-pathname :directory '(:relative "projects"))
                                (or (uiop:getenv "MEMEX_DIR")
                                    (namestring (merge-pathnames "memex/" (user-homedir-pathname))))))
                     (org-files (handler-case (uiop:directory-files proj-dir "**/*.org")
                                  (error () nil)))
                     (lisp-files (handler-case (uiop:directory-files proj-dir "**/*.lisp")
                                   (error () nil)))
                     (all-files (mapcar #'namestring (append org-files lisp-files)))
                     (short-names (mapcar (lambda (f)
                                            (subseq f (1+ (length (namestring proj-dir)))))
                                          all-files))
                     (match (find-if (lambda (n)
                                       (and (>= (length n) (length partial))
                                            (string-equal n partial :end2 (length partial))))
                                     short-names)))
                (when match
                  (setf (st :input-buffer) (reverse (coerce (concatenate 'string "@" match) 'list)))
                  (setf (st :dirty) (list nil nil t)))))
             ;; /theme subcommand completion
             ((and (>= (length text) 7)
                   (string-equal (subseq text 0 7) "/theme "))
              (let* ((partial (string-trim '(#\Space) (subseq text 7)))
                     (names '("dark" "light" "solarized" "gruvbox"))
                     (match (if (string= partial "")
                                (first names)
                                (find partial names :test #'string-equal))))
                (when match
                  (setf (st :input-buffer) (reverse (coerce (concatenate 'string "/theme " match) 'list)))
                  (setf (st :dirty) (list nil nil t)))))
             ;; /focus subcommand — project directory completion
             ((and (>= (length text) 7)
                   (string-equal (subseq text 0 7) "/focus "))
              (let* ((partial (string-trim '(#\Space) (subseq text 7)))
                     (memex-dir (or (uiop:getenv "MEMEX_DIR")
                                    (namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
                     (proj-dir (merge-pathnames (make-pathname :directory '(:relative "projects")) memex-dir))
                     (dirs (handler-case (mapcar (lambda (d) (car (last (pathname-directory d))))
                                                  (uiop:subdirectories proj-dir))
                             (error () nil)))
                     (match (if (string= partial "")
                                (first dirs)
                                (find-if (lambda (d)
                                           (and (>= (length d) (length partial))
                                                (string-equal d partial :end2 (length partial))))
                                          dirs))))
                (when match
                  (setf (st :input-buffer) (reverse (coerce (concatenate 'string "/focus " match) 'list)))
                  (setf (st :dirty) (list nil nil t)))))
             ;; Command completion — /prefix
             ((and (> (length text) 1) (eql (char text 0) #\/))
              (let* ((cmds '("/eval" "/focus" "/scope" "/unfocus" "/help" "/theme" "/reconnect" "/quit"))
                     (match (find text cmds :test
                                  (lambda (in cmd)
                                    (and (>= (length cmd) (length in))
                                         (string-equal cmd in :end1 (length in)))))))
                (when match
                  (setf (st :input-buffer) (reverse (coerce match 'list)))
                  (when (member match '("/eval" "/focus" "/scope") :test #'string=)
                    (push #\Space (st :input-buffer)))
                  (setf (st :dirty) (list nil nil t))))))))
       ;; Backspace
       ((or (eq ch :backspace) (eql ch 127) (eql ch 8)
            (eql ch #\Backspace))
        (input-delete-char)
        (setf (st :dirty) (list nil nil t)))
       ;; Left arrow
       ((or (eq ch :left) (eql ch 260))
        (when (> (or (st :cursor-pos) 0) 0)
          (decf (st :cursor-pos))
          (setf (st :dirty) (list nil nil t))))
       ;; Right arrow
       ((or (eq ch :right) (eql ch 261))
        (when (< (or (st :cursor-pos) 0) (length (st :input-buffer)))
          (incf (st :cursor-pos))
          (setf (st :dirty) (list nil nil t))))
      ;; Up arrow
       ((or (eq ch :up) (eql ch 259))
        (let* ((h (st :input-history)) (p (st :input-hpos)))
          (when (and h (< p (1- (length h))))
            (incf (st :input-hpos))
            (setf (st :input-buffer)
                  (reverse (coerce (nth (st :input-hpos) h) 'list)))
            (setf (st :dirty) (list nil nil t)))))
       ;; Down arrow
       ((or (eq ch :down) (eql ch 258))
        (when (> (st :input-hpos) 0)
          (decf (st :input-hpos))
          (let ((h (st :input-history)))
            (setf (st :input-buffer)
                  (if (and h (< (st :input-hpos) (length h)))
                      (reverse (coerce (nth (st :input-hpos) h) 'list))
                      nil))
            (setf (st :dirty) (list nil nil t)))))
       ;; PageUp
       ((or (eq ch :ppage) (eql ch 339))
        (let ((max-offset (max 0 (- (length (st :messages)) 1))))
          (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 5))))
        (setf (st :dirty) (list nil t nil)))
       ;; PageDown
       ((or (eq ch :npage) (eql ch 338))
        (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
        (setf (st :dirty) (list nil t nil)))
       ;; Printable
       (t
        (let ((chr (typecase ch
                     (character ch)
                     (integer (code-char ch))
                     (t nil))))
          (when (and chr (graphic-char-p chr))
            (input-insert-char chr)
            (setf (st :dirty) (list nil nil t))))))))

(defun on-daemon-msg (msg)
  (let* ((payload (getf msg :payload))
         (text (getf payload :text))
         (action (getf payload :action))
         (gate-trace (getf msg :gate-trace))
         (rule-count (getf payload :rule-count))
         (foveal-id (getf payload :foveal-id)))
    (when rule-count (setf (st :rule-count) rule-count))
    (when foveal-id (setf (st :foveal-id) foveal-id))
    (cond
      (text (setf (st :busy) nil)
            (add-msg :agent text :gate-trace gate-trace))
      ((eq action :handshake)
       (add-msg :system (format nil "Connected v~a" (getf payload :version))))
      (t (add-msg :agent (format nil "~a" msg))))))

Daemon Communication

(defun send-daemon (msg)
  (let ((s (st :stream)))
    (when (and s (open-stream-p s))
      (handler-case
          (progn
            (format s "~a" (frame-message msg))
            (finish-output s))
        (error () nil)))))

(defun recv-daemon (s)
  (handler-case
      (let* ((hdr (make-string 6)) (n 0))
        (loop while (< n 6)
              do (let ((ch (read-char s nil)))
                    (unless ch (return-from recv-daemon nil))
                    (setf (char hdr n) ch) (incf n)))
        (let* ((len (parse-integer hdr :radix 16 :junk-allowed t))
               (buf (make-string (or len 0))))
          (when (and len (> len 0))
            (loop for i from 0 below len
                  do (let ((ch (read-char s nil)))
                        (unless ch (return-from recv-daemon nil))
                        (setf (char buf i) ch)))
            (let ((*read-eval* nil))
              (read-from-string buf)))))
    (error () nil)))

(defun reader-loop (s)
  (let ((consecutive-nils 0))
    (loop while (and (st :running) (open-stream-p s))
          do (let ((msg (recv-daemon s)))
               (if msg
                   (progn (queue-event (list :type :daemon :payload msg))
                          (setf consecutive-nils 0))
                   (progn (sleep 0.5)
                          (incf consecutive-nils)
                          (when (> consecutive-nils 10)
                            (queue-event (list :type :disconnected))
                            (return))))))))

(defun load-history ()
  "Load input history from disk on TUI startup."
  (let ((hist-file (merge-pathnames ".cache/passepartout/history"
                                    (user-homedir-pathname))))
    (when (uiop:file-exists-p hist-file)
      (with-open-file (in hist-file :direction :input)
        (loop for line = (read-line in nil nil)
              while line
              do (push line (st :input-history))))
      (setf (st :input-history) (nreverse (st :input-history))))))

Connection

(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
  (add-msg :system "* Connecting to daemon... *")
  (loop for attempt from 1 to 3
        for backoff = 0 then 3
        do (sleep backoff)
           (handler-case
               (let ((s (usocket:socket-connect host port :timeout 5)))
                 (setf (st :stream) (usocket:socket-stream s)
                       (st :connected) t)
                 (bt:make-thread (lambda () (reader-loop (st :stream)))
                                :name "tui-reader")
                 (add-msg :system (format nil "* Connected v~a *" "0.5.0"))
                 (return-from connect-daemon t))
             (usocket:connection-refused-error (c)
               (when (= attempt 3)
                 (add-msg :system (format nil "* No daemon on port ~a after ~a attempts *"
                                         port attempt))))
             (error (c)
               (add-msg :system (format nil "* Connection attempt ~a failed: ~a *"
                                        attempt c))
               (when (= attempt 3)
                 (add-msg :system "* TIP: run 'passepartout daemon' first *")))))
  nil)

(defun disconnect-daemon ()
  (when (st :stream)
    (ignore-errors (close (st :stream)))
    (setf (st :stream) nil (st :connected) nil)
    (add-msg :system "* Disconnected *")))

Main Loop

(defun tui-main ()
  (init-state)
  (load-history)
  (theme-load)
  (with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
    (let* ((h (or (height scr) 24))
           (w (or (width scr) 80))
           (sw (make-instance 'window :height 3 :width (- w 2) :y 0 :x 1))
           (ch (- h 5))
           (cw (make-instance 'window :height ch :width (- w 2) :y 3 :x 1))
           (iw (make-instance 'window :height 1 :width (- w 2) :y (- h 1) :x 1))
            (swank-port (or (ignore-errors
                              (parse-integer (uiop:getenv "TUI_SWANK_PORT")))
                            4006)))
       (setf (function-keys-enabled-p iw) t
             (input-blocking iw) nil
             (st :dirty) (list t t t)
             ;; Store windows in state for SIGWINCH handler
             (st :scr) scr (st :sw) sw (st :cw) cw (st :iw) iw)
       (connect-daemon)
       (when (> swank-port 0)
         (handler-case
             (progn
               (ql:quickload :swank :silent t)
               (funcall (find-symbol "CREATE-SERVER" "SWANK")
                        :port swank-port :dont-close t)
               (add-msg :system
                        (format nil "* Swank ~d  M-x slime-connect *" swank-port)))
           (error ()
             (add-msg :system "* Swank unavailable *"))))
       ;; Initial render before the main loop — otherwise the screen stays
       ;; blank until the first keystroke (get-char blocks).
       (redraw sw cw ch iw)
       (refresh scr)
       (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 *"))))
        (let ((ch (get-char iw)))
          (cond
            ((or (not ch) (equal ch -1)) nil)
            ;; KEY_RESIZE — terminal was resized (SIGWINCH from ncurses)
            ((eql ch 410)
             (let* ((new-h (or (height scr) 24))
                    (new-w (or (width scr) 80))
                    (new-ch (- new-h 5)))
               (setq sw (make-instance 'window :height 3 :width (- new-w 2) :y 0 :x 1)
                     ch new-ch
                     cw (make-instance 'window :height new-ch :width (- new-w 2) :y 3 :x 1)
                     iw (make-instance 'window :height 1 :width (- new-w 2) :y (- new-h 1) :x 1)
                     w new-w
                     h new-h)
               (setf (function-keys-enabled-p iw) t
                     (input-blocking iw) nil
                     (st :dirty) (list t t t)
                     (st :sw) sw (st :cw) cw (st :iw) iw)
               (redraw sw cw ch iw)
               (refresh scr)))
            (t (on-key ch))))
        (redraw sw cw ch iw)
        (refresh scr)
        (sleep 0.03))
       (disconnect-daemon))))

Test Suite

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :fiveam :silent t))

(defpackage :passepartout-tui-tests
  (:use :cl :passepartout :passepartout.channel-tui)
  (:export #:tui-suite))

(in-package :passepartout-tui-tests)

(fiveam:def-suite tui-suite :description "Verification of the TUI model and event handling")
(fiveam:in-suite tui-suite)

(fiveam:test test-init-state
  "Contract model.1: init-state returns fresh state plist with required keys."
  (init-state)
  (fiveam:is (eq t (st :running)))
  (fiveam:is (eq :chat (st :mode)))
  (fiveam:is (eq nil (st :connected)))
  (fiveam:is (eq nil (st :stream)))
  (fiveam:is (vectorp (st :messages)))
  (fiveam:is (= 0 (length (st :messages))))
  (fiveam:is (eq 0 (st :scroll-offset)))
  (fiveam:is (eq nil (st :busy))))

(fiveam:test test-add-msg
  "Contract model.2: add-msg appends a message with role, content, and time."
  (init-state)
  (add-msg :user "hello")
  (let* ((msgs (st :messages))
         (msg (first msgs)))
    (fiveam:is (eq :user (getf msg :role)))
    (fiveam:is (string= "hello" (getf msg :content)))
    (fiveam:is (stringp (getf msg :time)))
    (fiveam:is (= 5 (length (getf msg :time))))))

(fiveam:test test-add-msg-dirty-flag
  "Contract model.2: add-msg sets dirty flags for status and chat."
  (init-state)
  (setf (st :dirty) (list nil nil nil))
  (add-msg :system "boot")
  (let ((dirty (st :dirty)))
    (fiveam:is (eq t (first dirty)))
    (fiveam:is (eq t (second dirty)))
    (fiveam:is (eq nil (third dirty)))))

(fiveam:test test-queue-event-roundtrip
  "Contract model.3: queue-event + drain-queue preserves events in order."
  (init-state)
  (queue-event '(:type :key :payload (:ch 13)))
  (queue-event '(:type :daemon :payload (:text "hi")))
  (let ((evs (drain-queue)))
    (fiveam:is (= 2 (length evs)))
    (fiveam:is (equal '(:type :key :payload (:ch 13)) (first evs)))
    (fiveam:is (equal '(:type :daemon :payload (:text "hi")) (second evs)))
    (fiveam:is (null (drain-queue)))))

(fiveam:test test-on-key-enter-sends-user-message
  "Contract 1: on-key with Enter extracts input, adds user message, clears buffer."
  (init-state)
  ;; Simulate typing "test"
  (dolist (ch '(#\t #\e #\s #\t))
    (on-key (char-code ch)))
  (fiveam:is (string= "test" (input-string)))
  ;; Simulate Enter key — ncurses returns 343 (KEY_ENTER) when keypad is enabled
  (on-key 343)
  ;; Input buffer should be cleared
  (fiveam:is (string= "" (input-string)))
  ;; A user message should be in the message list
  (let ((msgs (st :messages)))
    (fiveam:is (>= (length msgs) 1))
    (let ((last (first msgs)))
      (fiveam:is (eq :user (getf last :role)))
      (fiveam:is (string= "test" (getf last :content))))))

(fiveam:test test-on-key-eval-command
  "Contract 1: on-key handles /eval command and displays result."
  (init-state)
  ;; Type "/eval (+ 1 2)"
  (dolist (ch (coerce "/eval (+ 1 2)" 'list))
    (on-key (char-code ch)))
  (on-key 343)
  (let ((msgs (st :messages)))
    (fiveam:is (>= (length msgs) 1))
    (let ((last-msg (first msgs)))
      (fiveam:is (eq :system (getf last-msg :role)))
      (fiveam:is (search "=> 3" (getf last-msg :content))))))

(fiveam:test test-on-key-backspace
  "Contract 1: on-key with Backspace removes last character from buffer."
  (init-state)
  (dolist (ch '(#\a #\b #\c))
    (on-key (char-code ch)))
  (fiveam:is (string= "abc" (input-string)))
  ;; ncurses returns 263 (KEY_BACKSPACE) when keypad is enabled
  (on-key 263)
  (fiveam:is (string= "ab" (input-string))))

(fiveam:test test-on-key-focus-command
  "Contract 1: /focus command parses project name."
  (init-state)
  (dolist (ch (coerce "/focus myapp" 'list))
    (on-key (char-code ch)))
  (on-key 343)
  (let ((msg (first (st :messages))))
    (fiveam:is (eq :system (getf msg :role)))))

(fiveam:test test-on-key-scope-command
  "Contract 1: /scope command with valid argument."
  (init-state)
  (dolist (ch (coerce "/scope memex" 'list))
    (on-key (char-code ch)))
  (on-key 343)
  (let ((msg (first (st :messages))))
    (fiveam:is (eq :system (getf msg :role)))))

(fiveam:test test-on-key-unfocus-command
  "Contract 1: /unfocus command dispatches correctly."
  (init-state)
  (dolist (ch (coerce "/unfocus" 'list))
    (on-key (char-code ch)))
  (on-key 343)
  (let ((msg (first (st :messages))))
    (fiveam:is (eq :system (getf msg :role)))))

(fiveam:test test-on-key-tab-completion
  "Contract 1: Tab completes / commands when input starts with /."
  (init-state)
  (dolist (ch (coerce "/ev" 'list))
    (on-key (char-code ch)))
  (on-key 9)
  (fiveam:is (string= "/eval " (input-string))))

(fiveam:test test-on-key-tab-no-slash
  "Contract 1: Tab does nothing when input doesn't start with /."
  (init-state)
  (dolist (ch (coerce "hello" 'list))
    (on-key (char-code ch)))
  (on-key 9)
  (fiveam:is (string= "hello" (input-string))))

(fiveam:test test-on-key-multiline
  "Contract 1: \\ + Enter inserts newline instead of sending."
  (init-state)
  (dolist (ch (coerce "line1" 'list))
    (on-key (char-code ch)))
  (on-key (char-code #\\))
  (on-key 343)
  (fiveam:is (search "line1" (input-string)))
  (fiveam:is (search (string #\Newline) (input-string))))

(fiveam:test test-on-key-help
  "Contract 1: /help displays command list."
  (init-state)
  (dolist (ch (coerce "/help" 'list))
    (on-key (char-code ch)))
  (on-key 343)
  (let ((msgs (st :messages)))
    (fiveam:is (>= (length msgs) 3))
    (fiveam:is (some (lambda (m) (search "/eval" (getf m :content))) msgs))))

(fiveam:test test-activity-indicator
  "Contract model: :busy flag is set on send and cleared on agent response."
  (init-state)
  (fiveam:is (eq nil (st :busy)))
  ;; Simulate sending a normal message (sets busy)
  (dolist (ch (coerce "hello" 'list))
    (on-key (char-code ch)))
  (on-key 343)
  (fiveam:is (eq t (st :busy)))
  ;; Simulate receiving an agent response (clears busy)
  (on-daemon-msg '(:type :event :payload (:text "hi back")))
  (fiveam:is (eq nil (st :busy))))

(fiveam:test test-theme
  "Contract view: *tui-theme* provides color mappings."
  (fiveam:is (eq :green (getf *tui-theme* :user)))
  (fiveam:is (eq :white (getf *tui-theme* :agent)))
  (fiveam:is (eq :yellow (getf *tui-theme* :system)))
  (fiveam:is (eq :cyan (getf *tui-theme* :input)))
  (fiveam:is (eq :white (theme-color :unknown-role))))

(fiveam:test test-on-key-ctrl-d-empty-quits
  "Contract 1/v0.7.0: Ctrl+D on empty input adds quit system message."
  (init-state)
  (on-key 4)  ; Ctrl+D
  (let ((msgs (st :messages)))
    (fiveam:is (> (length msgs) 0))  ; at least one message
    (fiveam:is (search "quit" (getf (elt msgs 0) :content) :test #'char-equal))))

(fiveam:test test-on-key-ctrl-u-clears-line
  "Contract 1/v0.7.0: Ctrl+U clears the input buffer."
  (init-state)
  (dolist (ch '(#\h #\e #\l #\l #\o))
    (on-key (char-code ch)))
  (on-key 21)  ; Ctrl+U
  (fiveam:is (string= "" (input-string))))

(fiveam:test test-on-key-ctrl-a-moves-home
  "Contract 1/v0.7.0: Ctrl+A moves cursor to position 0."
  (init-state)
  (dolist (ch '(#\h #\i))
    (on-key (char-code ch)))
  (on-key 1)  ; Ctrl+A
  (fiveam:is (= 0 (or (st :cursor-pos) 0))))

(fiveam:test test-on-key-ctrl-e-moves-end
  "Contract 1/v0.7.0: Ctrl+E moves cursor to end of input."
  (init-state)
  (dolist (ch '(#\h #\i))
    (on-key (char-code ch)))
  (on-key 5)  ; Ctrl+E
  (fiveam:is (= 2 (or (st :cursor-pos) 0))))

(fiveam:test test-on-key-ctrl-l-redraws
  "Contract 1/v0.7.0: Ctrl+L sets all dirty flags for full redraw."
  (init-state)
  (setf (st :dirty) (list nil nil nil))
  (on-key 12)  ; Ctrl+L
  (let ((d (st :dirty)))
    (fiveam:is (eq t (first d)))
    (fiveam:is (eq t (second d)))
    (fiveam:is (eq t (third d)))))

(fiveam:test test-on-key-ctrl-x-e-editor
  "Contract 1/v0.7.0: Ctrl+X then Ctrl+E triggers external editor workflow."
  (init-state)
  (on-key 24)  ; Ctrl+X prefix
  (on-key 5)   ; Ctrl+E chord
  (let ((msgs (st :messages)))
    (fiveam:is (> (length msgs) 0))
    (fiveam:is (search "editor" (getf (elt msgs 0) :content) :test #'char-equal))))

(fiveam:test test-tab-completes-command
  "Contract 1/v0.7.0: Tab completes /the to /theme."
  (init-state)
  (dolist (ch (coerce "/the" 'list))
    (on-key (char-code ch)))
  (on-key 9)  ; Tab
  (fiveam:is (search "/theme" (input-string))))

(fiveam:test test-tab-completes-subcommand
  "Contract 1/v0.7.0: /theme + Tab lists theme names."
  (init-state)
  (dolist (ch (coerce "/theme " 'list))
    (on-key (char-code ch)))
  (on-key 9)  ; Tab — should expand to a theme name
  (let ((s (input-string)))
    (fiveam:is (or (search "dark" s) (search "light" s) (search "solarized" s) (search "gruvbox" s)))))

(fiveam:test test-tab-file-path-match
  "Contract 1/v0.7.0: @ followed by Tab finds file completions or leaves input unchanged."
  (init-state)
  (dolist (ch (coerce "@core" 'list))
    (on-key (char-code ch)))
  (let ((before (input-string)))
    (on-key 9)  ; Tab — should find "core-*.org" if files exist
    (let ((after (input-string)))
      ;; Either completed to a longer match or stayed the same (no files found)
      (fiveam:is (>= (length after) (length before)))
      (fiveam:is (search "@core" after)))))

(fiveam:test test-scroll-notify-on-new-msg
  "Contract 1/v0.7.0: add-msg sets :scroll-notify when user is scrolled up."
  (init-state)
  ;; User scrolls up — not at bottom
  (setf (st :scroll-at-bottom) nil
        (st :scroll-notify) nil)
  (add-msg :agent "new message while scrolled up")
  (fiveam:is (eq t (st :scroll-notify)))
  ;; Reset: user scrolls back to bottom
  (setf (st :scroll-at-bottom) t
        (st :scroll-notify) nil)
  (add-msg :agent "message while at bottom")
  (fiveam:is (eq nil (st :scroll-notify))))