Amr Gharbeia
3c1ed77c85
- Colored chat: green user, white agent, yellow system, cyan input - Clean handshake display (Connected v0.2.0) - LLM routing fix: action-dispatch routes to :tui when reply-stream present - /eval command works with proper *package* binding - Swank REPL on port 4006 (configurable) - Backspace support with Croatoan integer key codes - Confirmed end-to-end: type message → LLM responds → displayed in TUI - Chat messages truncated with :n to prevent overlap
254 lines
9.6 KiB
Common Lisp
254 lines
9.6 KiB
Common Lisp
(defpackage :passepartout.gateway-tui
|
|
(:use :cl :croatoan :passepartout :usocket :bordeaux-threads)
|
|
(:export :tui-main))
|
|
(in-package :passepartout.gateway-tui)
|
|
|
|
(defvar *state* nil)
|
|
(defvar *event-queue* nil)
|
|
(defvar *event-lock* (bt:make-lock "tui-event-lock"))
|
|
|
|
(defun st (key) (getf *state* key))
|
|
(defun (setf st) (val key) (setf (getf *state* key) val))
|
|
|
|
(defun init-state ()
|
|
(setf *state*
|
|
(list :running t :mode :chat :connected nil :stream nil
|
|
:input-buffer nil :input-history nil :input-hpos 0
|
|
:messages nil :scroll-offset 0 :dirty (list nil nil nil))))
|
|
|
|
(defun now ()
|
|
(multiple-value-bind (h m) (get-decoded-time)
|
|
(format nil "~2,'0d:~2,'0d" h m)))
|
|
|
|
(defun input-string ()
|
|
(coerce (reverse (st :input-buffer)) 'string))
|
|
|
|
(defun add-msg (role content)
|
|
(push (list :role role :content content :time (now)) (st :messages))
|
|
(setf (st :dirty) (list t t nil)))
|
|
|
|
(defun view-status (win)
|
|
(clear win)
|
|
(box win 0 0)
|
|
(add-string win
|
|
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a"
|
|
(if (st :connected) "● Connected" "○ Disconnected")
|
|
(string-upcase (string (st :mode)))
|
|
(length (st :messages))
|
|
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0"))
|
|
:y 1 :x 1 :fgcolor (if (st :connected) :green :red))
|
|
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor :yellow)
|
|
(refresh win))
|
|
|
|
(defun view-chat (win h)
|
|
(clear win)
|
|
(box win 0 0)
|
|
(let* ((w (or (width win) 78))
|
|
(msgs (reverse (st :messages)))
|
|
(max-lines (- h 2))
|
|
(total (length msgs))
|
|
(start (max 0 (- total max-lines (st :scroll-offset))))
|
|
(y 1))
|
|
(loop for i from start below total
|
|
while (< y (1- h))
|
|
do (let ((msg (nth i msgs)))
|
|
(let* ((role (getf msg :role))
|
|
(content (getf msg :content))
|
|
(time (or (getf msg :time) ""))
|
|
(label (case role
|
|
(:user (format nil "⬆ [~a] ~a" time content))
|
|
(:agent (format nil "⬇ [~a] ~a" time content))
|
|
(:system (format nil " [~a] ~a" time content))
|
|
(t (format nil " [~a] ~a" time content))))
|
|
(color (case role
|
|
(:user :green)
|
|
(:agent :white)
|
|
(:system :yellow)
|
|
(t :white))))
|
|
(add-string win label :y y :x 1 :n (1- w) :fgcolor color)
|
|
(incf y)))))
|
|
(refresh win))
|
|
|
|
(defun view-input (win)
|
|
(let* ((text (input-string))
|
|
(w (or (width win) 78))
|
|
(clip (min (length text) (1- w))))
|
|
(clear win)
|
|
(add-string win (format nil "~a " text) :y 0 :x 0 :n (1- w) :fgcolor :cyan)
|
|
(setf (cursor-position win) (list 0 clip)))
|
|
(refresh win))
|
|
|
|
(defun queue-event (ev)
|
|
(bt:with-lock-held (*event-lock*) (push ev *event-queue*)))
|
|
|
|
(defun drain-queue ()
|
|
(bt:with-lock-held (*event-lock*)
|
|
(let ((evs (nreverse *event-queue*)))
|
|
(setf *event-queue* nil) evs)))
|
|
|
|
(defun on-key (&rest args)
|
|
(let ((ch (car args)))
|
|
(cond
|
|
((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: evaluate Lisp form
|
|
((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)))))
|
|
;; Normal message: send to daemon
|
|
(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)))))
|
|
((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)))
|
|
((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)))))
|
|
((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)))))
|
|
((or (eq ch :ppage) (eql ch 339))
|
|
(incf (st :scroll-offset) 5)
|
|
(setf (st :dirty) (list nil t nil)))
|
|
((or (eq ch :npage) (eql ch 338))
|
|
(setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
|
|
(setf (st :dirty) (list nil t nil)))
|
|
(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 redraw (sw cw ch iw)
|
|
(destructuring-bind (sd cd id) (st :dirty)
|
|
(when sd (view-status sw))
|
|
(when cd (view-chat cw ch))
|
|
(when id (view-input iw))
|
|
(setf (st :dirty) (list nil nil nil))))
|
|
|
|
(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)
|
|
;; Start Swank REPL (optional - set TUI_SWANK_PORT=0 to disable)
|
|
(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 (c)
|
|
(add-msg :system "* Swank unavailable *"))))
|
|
;; Main loop
|
|
(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))))
|