Amr Gharbeia
55e0c962f4
TDD cycle: contract → RED test → GREEN implementation for each item. - Unicode width (char-width): 6 tests, 11 assertions. ASCII/CJK/emoji/combining. - Status bar fix: timestamp right-aligned, focus at :x 1. No overlap. - Ctrl key bindings: Ctrl+D/Q/L/U/W, Ctrl+A/E, Ctrl+X+E. 6 tests. - External editor: Ctrl+X prefix state tracking + Ctrl+E chord. - Deeper autocomplete: /theme subcommand, /focus directory, @ file paths. - Scroll notification: :scroll-notify flag set when scrolled up on new msg. - Pre-existing tests: messages init-state assertion fixed (nil→vectorp). Remaining: scroll pads (needs Croatoan terminal), setup wizard (v0.8.0).
719 lines
31 KiB
Common Lisp
719 lines
31 KiB
Common Lisp
(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))))))
|
|
|
|
(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))))))
|
|
|
|
(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 *")))
|
|
|
|
(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))))
|
|
|
|
(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))))
|