Amr Gharbeia
cd86509e3a
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s
- TUI: Fix stale contract (remove handle-return/*incoming-msgs*), rewrite 10->13 tests (38 checks, 100% pass). Export missing symbols from TUI package. Fix view-chat contract arity. - Gateway messaging: Add :configured key to registry (boolean, nil default). Fix contract to match (vault-based, not env-var-based). - Async Embedding Gateway: Add *embedding-backend* var, embeddings-compute function. Modify ingest-ast to populate vectors on new objects. Add EMBEDDING_PROVIDER env var support. Add Contract + 4 tests (8 checks). - Context Manager: Add /focus, /scope, /unfocus commands to TUI on-key handler. Commands degrade gracefully when context-manager not loaded. - Export hygiene: Remove 30+ ghost exports (undefined symbols). Remove duplicate/mismatched names. Exports now match actual definitions.
346 lines
13 KiB
Common Lisp
346 lines
13 KiB
Common Lisp
(in-package :passepartout.gateway-tui)
|
|
|
|
(defun on-key (&rest args)
|
|
(let ((ch (car args)))
|
|
(cond
|
|
;; Enter
|
|
((or (eql ch 10) (eql ch 13) (eq ch :enter)
|
|
(eql ch #\Newline) (eql ch #\Return))
|
|
(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
|
|
;; /eval command
|
|
((and (>= (length text) 6)
|
|
(string-equal (subseq text 0 6) "/eval "))
|
|
(handler-case
|
|
(let* ((*read-eval* t)
|
|
(*package* (find-package :passepartout.gateway-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")))
|
|
;; Normal message
|
|
(t
|
|
(add-msg :user text)
|
|
(send-daemon (list :type :event
|
|
:payload (list :sensor :user-input :text text)))))
|
|
(setf (st :input-buffer) nil)
|
|
(setf (st :dirty) (list t t t)))))
|
|
;; Backspace
|
|
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
|
(when (st :input-buffer) (pop (st :input-buffer)))
|
|
(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))
|
|
(incf (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))
|
|
(push chr (st :input-buffer))
|
|
(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)))
|
|
(cond
|
|
(text (add-msg :agent text))
|
|
((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 (c) (log-message "TUI-SEND: ~a" c))))))
|
|
|
|
(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 (c) (log-message "TUI-RECV: ~a" c) nil)))
|
|
|
|
(defun reader-loop (s)
|
|
(loop while (and (st :running) (open-stream-p s))
|
|
do (let ((msg (recv-daemon s)))
|
|
(when msg (queue-event (list :type :daemon :payload msg))))))
|
|
|
|
(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
|
|
(handler-case
|
|
(let ((s (usocket:socket-connect host port :element-type 'character)))
|
|
(setf (st :stream) (usocket:socket-stream s) (st :connected) t)
|
|
(bt:make-thread (lambda () (reader-loop (st :stream))) :name "tui-reader")
|
|
(add-msg :system "* Connected *")
|
|
t)
|
|
(error (c)
|
|
(add-msg :system (format nil "* Connection failed: ~a *" c))
|
|
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)
|
|
(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
|
|
(st :dirty) (list t t t))
|
|
(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 *"))))
|
|
(loop while (st :running) do
|
|
(dolist (ev (drain-queue))
|
|
(when (eq (getf ev :type) :daemon)
|
|
(on-daemon-msg (getf ev :payload))))
|
|
(let ((ch (get-char iw)))
|
|
(when (and ch (not (equal ch -1)))
|
|
(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.gateway-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 (eq nil (st :messages)))
|
|
(fiveam:is (eq 0 (st :scroll-offset))))
|
|
|
|
(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 (char code 13)
|
|
(on-key 13)
|
|
;; 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 13)
|
|
(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)))
|
|
(on-key 127) ; Backspace
|
|
(fiveam:is (string= "ab" (input-string))))
|
|
|
|
(fiveam:test test-disconnect-daemon
|
|
"Contract 4: disconnect-daemon sets connected to nil and adds disconnect message."
|
|
(init-state)
|
|
(setf (st :connected) t
|
|
(st :stream) (make-string-output-stream))
|
|
(disconnect-daemon)
|
|
(fiveam:is (eq nil (st :connected)))
|
|
(fiveam:is (eq nil (st :stream)))
|
|
(let ((msgs (st :messages)))
|
|
(fiveam:is (>= (length msgs) 1))
|
|
(fiveam:is (search "Disconnected" (getf (first msgs) :content)))))
|
|
|
|
(fiveam:test test-on-daemon-msg-handshake
|
|
"Contract 2: on-daemon-msg handles handshake action."
|
|
(init-state)
|
|
(on-daemon-msg '(:type :event :payload (:action :handshake :version "9.9")))
|
|
(let ((msg (first (st :messages))))
|
|
(fiveam:is (eq :system (getf msg :role)))
|
|
(fiveam:is (search "Connected v9.9" (getf msg :content)))))
|
|
|
|
(fiveam:test test-on-daemon-msg-text
|
|
"Contract 2: on-daemon-msg routes text payload to agent message."
|
|
(init-state)
|
|
(on-daemon-msg '(:type :event :payload (:text "hello world")))
|
|
(let ((msg (first (st :messages))))
|
|
(fiveam:is (eq :agent (getf msg :role)))
|
|
(fiveam:is (string= "hello world" (getf msg :content)))))
|
|
|
|
(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 13)
|
|
(let ((msg (first (st :messages))))
|
|
;; When context-manager is loaded, shows "Focused"; otherwise shows "Usage"
|
|
(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 13)
|
|
(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 13)
|
|
(let ((msg (first (st :messages))))
|
|
(fiveam:is (eq :system (getf msg :role)))))
|