Fix $HOME checkpoint disaster; add /activity screen and /side tabs
ober
864a10529d3605dd9214b12597487f00333fa3bb
--- a/src/jcode/core/checkpoints.ss +++ b/src/jcode/core/checkpoints.ss @@ -6,8 +6,9 @@ ;;; ;;; Implementation: we don't copy files; we point an alternate git-dir ;;; at the user's cwd via `--git-dir=...checkpoints/.git --work-tree=.`. -;;; Adds are bounded by .jcode/checkpoints/.gitignore (ignored) and the -;;; usual respect for the user's gitignore. +;;; Adds honor the work-tree's own .gitignore for untracked files. +;;; We refuse to operate when cwd is $HOME or / -- `add -A` there would +;;; hash the user's entire world into the shadow repo. ;;; ;;; Config in jcode.json: ;;; @@ -51,6 +52,38 @@ (def (checkpoint-git-dir) (path-join (checkpoint-dir) ".git")) +(def (path-drop-trailing-slash p) + (let ((n (string-length p))) + (if (and (> n 1) (char=? (string-ref p (- n 1)) #\/)) + (substring p 0 (- n 1)) + p))) + +(def (checkpoint-worktree-allowed?) + ;; Refuse to shadow-track $HOME or / -- `git add -A` over those hashes + ;; the user's entire world into the shadow repo (observed: a 268 GB + ;; .git from a session launched in $HOME). + (let ((cwd (path-drop-trailing-slash (current-directory))) + (home (let ((h (getenv "HOME"))) (and h (path-drop-trailing-slash h))))) + (cond + ((equal? cwd "/") #f) + ((and home (equal? cwd home)) #f) + (else #t)))) + +(def (clean-stale-lock!) + ;; A jcode killed mid-snapshot leaves .git/index.lock behind and every + ;; later snapshot fails until someone removes it by hand. A lock older + ;; than 15 minutes cannot belong to a live checkpoint commit -- remove + ;; it. Younger locks are left alone (a concurrent git may hold them). + (let ((lock (path-join (checkpoint-git-dir) "index.lock"))) + (when (file-exists? lock) + (let-values (((out err code) + (try (shell/status + (format "find ~a -mmin +15 -print -delete" (shell-q lock)) + (current-directory)) + (catch (e) (values "" "" 1))))) + (when (and (= code 0) out (not (equal? (string-trim out) ""))) + (log-warn logger "removed-stale-lock" `((lock . ,lock)))))))) + (def (mkdir-p dir) (unless (file-exists? dir) (let ((parent (path-directory dir))) @@ -75,12 +108,20 @@ (let-values (((out err code) (try (shell/status cmd (current-directory)) (catch (e) (values "" (err->string e) 1))))) + ;; Surface git's stderr on failure -- without this, snapshot-failed + ;; warns logged an empty err while the real message (e.g. a stale + ;; index.lock) was silently dropped. + (when (and (not (= code 0)) err (not (equal? err ""))) + (log-warn logger "git-failed" `((exit . ,code) (err . ,err)))) (cons (or out "") code)))) (def (checkpoint-init!) "Create the shadow repo if it doesn't exist yet." (cond ((not (checkpoints-enabled?)) #f) + ((not (checkpoint-worktree-allowed?)) + (log-warn logger "refusing-worktree" `((cwd . ,(current-directory)))) + #f) ((file-exists? (checkpoint-git-dir)) #t) (else (mkdir-p (checkpoint-dir)) @@ -104,7 +145,9 @@ short commit hash, or #f if disabled / failed." (cond ((not (checkpoints-enabled?)) #f) + ((not (checkpoint-worktree-allowed?)) #f) (else + (clean-stale-lock!) (checkpoint-init!) (run-git-or-fail "add -A") (let* ((msg (format "~a" (or reason "snapshot"))) @@ -127,6 +170,10 @@ (cond ((not (checkpoints-enabled?)) "checkpoints disabled in config") + ((not (checkpoint-worktree-allowed?)) + ;; Never `checkout` old snapshots over $HOME or / -- that would + ;; overwrite files across the user's entire home directory. + "checkpoints refused for this directory ($HOME or /)") ((not (file-exists? (checkpoint-git-dir))) "no checkpoint repo yet") (else --- a/src/jcode/core/log.ss +++ b/src/jcode/core/log.ss @@ -10,6 +10,7 @@ tracing? open-trace-log! close-trace-log! + activity-tail err->string) (import :std/misc/string @@ -76,10 +77,44 @@ (def (err->string e) (with-output-to-string (lambda () (display-condition e)))) +;; ---- Activity ring ---- +;; In-memory tail of recent log records, regardless of log level, for +;; the TUI activity screen (/activity). Written from log-at inside +;; *log-mutex*; read from the TUI main thread. Entries are +;; (epoch-seconds . line). This is what makes "the harness is quietly +;; running git add -A on $HOME" visible without tailing a trace file. + +(def *activity-cap* 300) +(def *activity-ring* (make-vector 300 #f)) +(def *activity-pos* (cons 0 #f)) + +(def (activity-trunc s) + (if (> (string-length s) 220) + (string-append (substring s 0 219) "…") + s)) + +(def (activity-push! line) + (let ((pos (car *activity-pos*))) + (vector-set! *activity-ring* pos + (cons (time-second (current-time)) (activity-trunc line))) + (set-car! *activity-pos* (modulo (+ pos 1) *activity-cap*)))) + +(def (activity-tail n) + "Newest-last list of up to N (epoch-seconds . line) entries." + (let loop ((k 1) (acc '())) + (if (> k (min n *activity-cap*)) + acc + (let* ((idx (modulo (- (car *activity-pos*) k) *activity-cap*)) + (e (vector-ref *activity-ring* idx))) + (if e + (loop (+ k 1) (cons e acc)) + acc))))) + (def (log-at level label name msg data) (let* ((line (format "[~a] ~a: ~a" label name msg)) (suffix (if (null? data) "" (string-append " " (format-alist data))))) (with-mutex *log-mutex* + (activity-push! (string-append line suffix)) (when (level-enabled? level (*log-level*)) (fprintf (current-error-port) "~a~a~n" line suffix) (flush-output-port (current-error-port))) --- a/src/jcode/tool/lsp.ss +++ b/src/jcode/tool/lsp.ss @@ -246,15 +246,36 @@ ;; --- init --- +(def (lsp-root-unsafe? root) + ;; #t when ROOT is $HOME or / -- an LSP server pointed there indexes + ;; the user's entire world at 100% CPU for the whole session. + (let* ((strip (lambda (p) + (let ((n (string-length p))) + (if (and (> n 1) (char=? (string-ref p (- n 1)) #\/)) + (substring p 0 (- n 1)) + p)))) + (r (strip root)) + (home (let ((h (getenv "HOME"))) (and h (strip h))))) + (or (equal? r "/") + (and home (equal? r home))))) + (def (init-lsp-tools) "Start LSP server if configured and register tools." (let ((lsp-cfg (config-ref "lsp"))) (when (and lsp-cfg (hash-table? lsp-cfg)) - (let ((command (hash-ref lsp-cfg "command" #f)) - (args (or (hash-get lsp-cfg "args") '())) - (root (or (hash-get lsp-cfg "root") (current-directory)))) - (when command - (try + (let* ((command (hash-ref lsp-cfg "command" #f)) + (args (or (hash-get lsp-cfg "args") '())) + (cfg-root (hash-get lsp-cfg "root")) + (root (or cfg-root (current-directory)))) + (cond + ((not command) #f) + ((and (not cfg-root) (lsp-root-unsafe? root)) + ;; Only the *defaulted* root is gated -- an explicit "root" + ;; in the lsp config is the user's deliberate choice. + (log-warn logger "skipping" + `((reason . "default root is $HOME or /") (root . ,root)))) + (else + (try (let ((conn (lsp-start command (if (list? args) args '()) root))) (lsp-initialize conn) (let ((schema (make-lsp-schema))) @@ -270,4 +291,4 @@ (log-info logger "ready" `((tools . 3)))) (catch (e) (log-error logger "init-failed" - `((error . ,(err->string e))))))))))) + `((error . ,(err->string e)))))))))))) --- a/src/jcode/ui/tui.ss +++ b/src/jcode/ui/tui.ss @@ -139,15 +139,16 @@ sysmon ;; system utilization sampler memstats ;; local-model RAM breakdown sampler tabs ;; list of tab (snapshots; active tab's slot is stale) - active-tab) ;; integer: 0 = main jcode, 1..N = external CLI + active-tab ;; integer: 0 = main jcode, 1..N = side/external + view) ;; 'chat or 'activity (live harness log screen) transparent: #t) ;; Per-tab snapshot. The ACTIVE tab's live state lives in app-state's ;; flat fields above; non-active tabs are snapshotted into the list at ;; app-state-tabs. provider=#f marks the main jcode tab (always index 0). (defstruct tab - (provider ;; #f for main, symbol for external CLI tab - session-id ;; jcode session UUID (main) or CLI session UUID (external) + (provider ;; #f for main/side jcode tabs, symbol for external CLI tab + session-id ;; jcode session UUID (main/side) or CLI session UUID (external) messages input busy? @@ -156,7 +157,8 @@ tokens-in tokens-out cache-read cache-creation cost - tool-counts) + tool-counts + unread?) ;; #t when a background run finished while tab not visible transparent: #t) (def (make-fresh-state w h) @@ -188,7 +190,8 @@ mon mem '() ;; tabs (lazily seeded on first switch) - 0))) ;; active-tab (main jcode) + 0 ;; active-tab (main jcode) + 'chat))) ;; view ;; ---- Layout calculations ---- @@ -331,6 +334,11 @@ (when (app-state-agent-busy? state) (app-state-dirty?-set! state #t)) + ;; Activity screen refreshes every tick: ages advance and background + ;; runs keep logging even when this tab's agent is idle. + (when (eq? (app-state-view state) 'activity) + (app-state-dirty?-set! state #t)) + ;; Poll for terminal events (50ms timeout) (let ((ev (tb-peek-event 50))) (when ev @@ -445,36 +453,52 @@ (max 0 (- (app-state-scroll-offset state) (msg-area-height state)))) (app-state-dirty?-set! state #t)) - ;; Ctrl-C or ESC during agent: cancel. Orphan the worker (bump gen - ;; so its future events are discarded) and give immediate UI - ;; feedback. The worker will notice *tui-stream-abort* on its next - ;; callback and exit. + ;; ESC leaves the activity screen. Checked BEFORE agent-cancel so a + ;; busy agent keeps running; press Esc again in chat to cancel it. + ((and (= key TB_KEY_ESC) + (eq? (app-state-view state) 'activity)) + (tui-log " -> exit-activity-view") + (app-state-view-set! state 'chat) + (app-state-dirty?-set! state #t)) + + ;; Alt-1..9: switch tabs (Alt-1 = main, Alt-2.. = side/external) + ((and (>= ch 49) (<= ch 57) + (not (zero? (bitwise-and mod TB_MOD_ALT)))) + (tui-log " -> alt-digit tab switch ~a" (- ch 49)) + (ensure-tabs-seeded! state) + (switch-tab! state (- ch 49))) + + ;; Ctrl-C or ESC during agent: cancel THIS tab's run only. Other + ;; tabs' background runs keep going; their events are tagged with + ;; their own (sid . gen) and stay valid. ((and (or (= key TB_KEY_CTRL_C) (= key TB_KEY_ESC)) (app-state-agent-busy? state)) (tui-log " -> cancel-agent (key=~a)" key) (set-car! *tui-stream-abort* #t) (bump-tui-run-gen!) + (abort-agent-run! (app-state-session-id state)) (app-state-agent-busy?-set! state #f) (add-message! state (msg-block-system "(interrupted)")) (app-state-dirty?-set! state #t)) - ;; Input handling + ;; Input handling. Typing stays live while the agent is busy -- + ;; slash commands, /side tabs and composing the next message must + ;; not block behind a running turn. Submitting a chat message to a + ;; busy tab is refused in handle-submit! with a hint instead. (#t - (if (app-state-agent-busy? state) - (tui-log " -> ignored (agent busy)") - (let ((action (input-handle-key! (app-state-input state) ev))) - (tui-log " -> input action=~a text=~s cursor=~a" - action - (input-state-text (app-state-input state)) - (input-state-cursor-pos (app-state-input state))) - (case action - ((submit) (handle-submit! state)) - ((quit) (app-state-quit?-set! state #t)) - ((cancel) (input-clear! (app-state-input state))) - ((continue) (void))) - (app-state-input-height-set! state - (max 1 (min 8 (length (input-lines (app-state-input state)))))) - (app-state-dirty?-set! state #t))))))) + (let ((action (input-handle-key! (app-state-input state) ev))) + (tui-log " -> input action=~a text=~s cursor=~a" + action + (input-state-text (app-state-input state)) + (input-state-cursor-pos (app-state-input state))) + (case action + ((submit) (handle-submit! state)) + ((quit) (app-state-quit?-set! state #t)) + ((cancel) (input-clear! (app-state-input state))) + ((continue) (void))) + (app-state-input-height-set! state + (max 1 (min 8 (length (input-lines (app-state-input state)))))) + (app-state-dirty?-set! state #t)))))) (def (handle-mouse! state ev) (let ((key (tui-event-key ev))) @@ -508,12 +532,22 @@ (run-external-turn! state text)) ;; Normal message → agent (#t - (tui-log "submit: sending to agent") - (add-message! state (msg-block-user text)) - ;; Auto-scroll to bottom - (app-state-scroll-offset-set! state 0) - ;; Run agent (draws spinner before blocking API call) - (run-agent! state text)))))) + (cond + ((app-state-agent-busy? state) + ;; One run per tab: don't queue a second turn into a session + ;; mid-run. Typing is never blocked; submitting here is. + (tui-log "submit: refused, this tab's agent is busy") + (add-message! state + (msg-block-system + "Agent is busy -- Esc to interrupt, or /side to ask in a parallel tab.")) + (app-state-dirty?-set! state #t)) + (else + (tui-log "submit: sending to agent") + (add-message! state (msg-block-user text)) + ;; Auto-scroll to bottom + (app-state-scroll-offset-set! state 0) + ;; Run agent (draws spinner before blocking API call) + (run-agent! state text)))))))) (def (set-mode! state new-mode) "Switch to new-mode and announce it in the message stream." @@ -564,7 +598,10 @@ " /gemini [prompt] Open/focus a Gemini CLI tab (sessioned)" " /opencode [prompt] Open/focus an opencode tab (sessioned)" " /grok [prompt] Open/focus a Grok CLI tab (sessioned)" + " /side [prompt] Open a parallel jcode conversation (own tab)" + " /tab N Switch to tab N (also Alt-1..Alt-9)" " /tabs List open tabs" + " /activity Live harness activity screen (Esc returns)" " /jcode Switch back to the main jcode tab" " /close-tab Close the current external tab" " /expert <q> Force this prompt to the configured expert model" @@ -736,6 +773,20 @@ (write-scope-label (agent-def-write-scope d))))) (agent-def-names)) "\n"))))) + ((equal? cmd "activity") + (app-state-view-set! state + (if (eq? (app-state-view state) 'activity) 'chat 'activity)) + (app-state-dirty?-set! state #t)) + ((or (equal? cmd "side") (string-prefix? "side " cmd)) + (let ((rest (string-trim (substring cmd 4 (string-length cmd))))) + (open-side-tab! state rest))) + ((string-prefix? "tab " cmd) + (let ((n (string->number (string-trim (substring cmd 3 (string-length cmd)))))) + (if (and n (integer? n) (>= n 0)) + (begin + (ensure-tabs-seeded! state) + (switch-tab! state n)) + (add-message! state (msg-block-system "Usage: /tab <index> (see /tabs)"))))) ((equal? cmd "tabs") (add-message! state (msg-block-system (list-tabs-summary state)))) ((or (equal? cmd "close-tab") (equal? cmd "close")) @@ -976,6 +1027,29 @@ ;; Events from an orphaned generation are dropped at apply time. (send-agent-event! (cons gen ev))) +;; ---- Per-run registry ---- +;; One agent run per session-id. Tagging agent events with (sid . gen) +;; instead of the single global gen lets a background /side tab keep +;; streaming into its snapshot while another tab is visible. Aborting a +;; run flips its abort cell: the worker notices on its next callback, +;; and the tag check drops anything already in flight. + +(def *agent-runs* (make-hash-table)) ;; sid -> (gen . abort-cell) + +(def (register-agent-run! sid gen abort) + (hash-put! *agent-runs* sid (cons gen abort))) + +(def (abort-agent-run! sid) + (let ((r (hash-get *agent-runs* sid))) + (when r (set-car! (cdr r) #t)))) + +(def (agent-run-valid? sid gen) + (let ((r (hash-get *agent-runs* sid))) + (and r (= (car r) gen) (not (car (cdr r)))))) + +(def (send-run-event! sid gen ev) + (send-agent-event! (cons (cons sid gen) ev))) + (def (drain-agent-events! state) "Drain all pending agent events from the main thread's mailbox and apply them synchronously. Consecutive stream-token events of the current @@ -992,24 +1066,32 @@ (begin (apply-agent-events! state (reverse evs)) n) (collect (cons ev evs) (+ n 1)))))) -(def (stream-token-event? ev gen) - ;; #t when EV is a current-generation streaming token: (gen stream-token tok). - (and (pair? ev) (eqv? (car ev) gen) - (let ((body (cdr ev))) - (and (pair? body) (eq? (car body) 'stream-token))))) +(def (fg-stream-token-event? state ev) + ;; #t when EV is a live FOREGROUND streaming token (either tag shape): + ;; (gen stream-token tok) legacy global-gen + ;; ((sid . gen) stream-token tok) per-run, sid must be the visible tab + ;; Only foreground tokens coalesce; background ones are cheap appends. + (and (pair? ev) + (let ((tag (car ev)) (body (cdr ev))) + (and (pair? body) (eq? (car body) 'stream-token) + (cond + ((number? tag) (eqv? tag (tui-run-gen))) + ((pair? tag) + (and (agent-run-valid? (car tag) (cdr tag)) + (equal? (car tag) (app-state-session-id state)))) + (else #f)))))) (def (apply-agent-events! state evs) ;; Apply a drained event list in order, merging maximal runs of ;; current-generation stream-token events into a single tui-stream-token! ;; call (one reflow for the whole run). Non-token events — and stale-gen ;; tokens — go through apply-agent-event! unchanged. - (let ((gen (tui-run-gen))) - (let loop ((evs evs)) + (let loop ((evs evs)) (cond ((null? evs) (void)) - ((stream-token-event? (car evs) gen) + ((fg-stream-token-event? state (car evs)) (let run ((evs evs) (toks '())) - (if (and (pair? evs) (stream-token-event? (car evs) gen)) + (if (and (pair? evs) (fg-stream-token-event? state (car evs))) (run (cdr evs) (cons (caddr (car evs)) toks)) (begin (tui-stream-token! state (apply string-append (reverse toks))) @@ -1023,16 +1105,98 @@ (format "apply-agent-event ERROR: ~a" (with-output-to-string (lambda () (display-condition e))))))) (apply-agent-event! state (car evs))) - (loop (cdr evs))))))) + (loop (cdr evs)))))) (def (apply-agent-event! state ev) - ;; New-style events are (gen . body). Drop stale generations silently. - (when (and (pair? ev) (number? (car ev))) - (let ((gen (car ev)) (body (cdr ev))) - (if (= gen (tui-run-gen)) - (apply-agent-event-body! state body) - (tui-log "apply-agent-event: discarded stale gen=~a (current=~a)" - gen (tui-run-gen)))))) + ;; Two tag shapes: + ;; (gen . body) legacy global-gen events (compact, ask, ext tabs) + ;; ((sid . gen) . body) per-run agent events; sid routes background + ;; tabs' events into their snapshots + (cond + ((and (pair? ev) (number? (car ev))) + (let ((gen (car ev)) (body (cdr ev))) + (if (= gen (tui-run-gen)) + (apply-agent-event-body! state body) + (tui-log "apply-agent-event: discarded stale gen=~a (current=~a)" + gen (tui-run-gen))))) + ((and (pair? ev) (pair? (car ev))) + (let* ((tag (car ev)) (sid (car tag)) (gen (cdr tag)) (body (cdr ev))) + (cond + ((not (agent-run-valid? sid gen)) + (tui-log "apply-agent-event: discarded dead run sid=~a gen=~a" sid gen)) + ((equal? sid (app-state-session-id state)) + (apply-agent-event-body! state body)) + (else + (apply-background-event! state sid body))))) + (else (void)))) + +(def (find-tab-by-session state sid) + ;; (idx . tab-record) for the tab whose snapshot holds SID, else #f. + (let loop ((tabs (app-state-tabs state)) (i 0)) + (cond + ((null? tabs) #f) + ((and (tab? (car tabs)) (equal? (tab-session-id (car tabs)) sid)) + (cons i (car tabs))) + (else (loop (cdr tabs) (+ i 1)))))) + +(def (apply-background-event! state sid body) + ;; Apply an agent event to a NON-visible tab's snapshot. Mirrors the + ;; foreground handlers minimally: text accumulates into the snapshot's + ;; stream-buf/messages with no reflow or redraw -- switch-tab! runs + ;; reflow-all! when the tab becomes visible. + (let ((hit (find-tab-by-session state sid))) + (when hit + (let ((t (cdr hit))) + (match body + ((list 'stream-token token) + (let* ((msgs (tab-messages t)) + (last (and (pair? msgs) (car (reverse msgs)))) + (reuse? (and last + (streamed-reply-role? (msg-block-role last)) + (equal? (msg-block-content last) + (tab-stream-buf t))))) + (unless reuse? + (tab-stream-buf-set! t "") + (tab-messages-set! t + (append (tab-messages t) (list (msg-block-assistant ""))))) + (let ((new-buf (string-append (tab-stream-buf t) token))) + (tab-stream-buf-set! t new-buf) + (msg-block-content-set! + (car (reverse (tab-messages t))) new-buf)))) + ((list 'tool-event op name args) + ;; Round boundary: next token opens a fresh block. + (when (eq? op 'start) + (tab-stream-buf-set! t ""))) + ((list 'usage-update usage) + (tab-stream-buf-set! t "")) + ((list 'escalation prov model reason sentinel?) + (let ((notice (format "⚡ escalated to ~a/~a\n\n" prov model))) + (tab-messages-set! t + (append (tab-messages t) (list (msg-block-expert notice)))) + (tab-stream-buf-set! t notice))) + ((list 'agent-done) + (tab-busy?-set! t #f) + (tab-unread?-set! t #t) + (tab-stream-buf-set! t "") + (toast-add! 'info "Tab" + (format "side conversation (tab ~a) finished" (car hit))) + (app-state-dirty?-set! state #t)) + ((list 'agent-cancelled) + (tab-busy?-set! t #f) + (tab-stream-buf-set! t "") + (tab-messages-set! t + (append (tab-messages t) (list (msg-block-system "(interrupted)")))) + (app-state-dirty?-set! state #t)) + ((list 'agent-error msg) + (tab-busy?-set! t #f) + (tab-unread?-set! t #t) + (tab-stream-buf-set! t "") + (tab-messages-set! t + (append (tab-messages t) (list (msg-block-error msg)))) + (toast-add! 'error "Tab" + (format "side conversation (tab ~a) errored" (car hit))) + (app-state-dirty?-set! state #t)) + (_ (void))))))) (def (apply-agent-event-body! state ev) (match ev @@ -1140,11 +1304,13 @@ ;; real TTY that termbox owns in raw mode — the second invocation hangs ;; when the TTY's output buffer backs up. (let ((gen (tui-run-gen)) + (abort (cons #f #f)) ;; per-run abort cell (Esc on THIS tab only) (err-port (current-error-port)) (log-lvl (current-log-level))) + (register-agent-run! s-id gen abort) (spawn (lambda () - (tui-log "worker: entered gen=~a main-thread=~a" gen (*main-thread*)) + (tui-log "worker: entered gen=~a sid=~a main-thread=~a" gen s-id (*main-thread*)) (try (parameterize ((current-error-port err-port) @@ -1153,40 +1319,37 @@ (current-model-override m-override) (current-stream-cb (lambda (token) - (when (or (car *tui-stream-abort*) - (not (= gen (tui-run-gen)))) + (when (car abort) (error 'stream-aborted "interrupted by user")) - (send-worker-event! gen (list 'stream-token token)))) + (send-run-event! s-id gen (list 'stream-token token)))) (current-tool-cb (lambda (event name args) - (when (or (car *tui-stream-abort*) - (not (= gen (tui-run-gen)))) + (when (car abort) (error 'stream-aborted "interrupted by user")) (tui-log "worker: tool-cb ~a ~a" event name) - (send-worker-event! gen (list 'tool-event event name args)))) + (send-run-event! s-id gen (list 'tool-event event name args)))) (current-usage-cb (lambda (usage) - (send-worker-event! gen (list 'usage-update usage)))) + (send-run-event! s-id gen (list 'usage-update usage)))) (current-expert-cb (lambda (prov model reason sentinel?) - (when (or (car *tui-stream-abort*) - (not (= gen (tui-run-gen)))) + (when (car abort) (error 'stream-aborted "interrupted by user")) - (send-worker-event! gen + (send-run-event! s-id gen (list 'escalation prov model reason sentinel?))))) (tui-log "worker: calling agent-run") (agent-run s-id text) (tui-log "worker: agent-run returned, sending agent-done") - (send-worker-event! gen (list 'agent-done)) + (send-run-event! s-id gen (list 'agent-done)) (tui-log "worker: agent-done sent, worker exiting normally")) (catch (e) (let ((msg (err->string e))) (tui-log "worker: CAUGHT exception: ~a" msg) (cond ((string-contains msg "stream-aborted") - (send-worker-event! gen (list 'agent-cancelled))) + (send-run-event! s-id gen (list 'agent-cancelled))) (else - (send-worker-event! gen (list 'agent-error msg)))))))))))) + (send-run-event! s-id gen (list 'agent-error msg)))))))))))) ;; ---- /ask-* second-opinion runners ---- @@ -1758,8 +1921,10 @@ (tb-set-clear-attrs! (face-fg-attr 'default) bg) (tb-clear!) - ;; Message area - (draw-messages! state) + ;; Message area -- or the live activity screen (/activity) + (if (eq? (app-state-view state) 'activity) + (render-activity! state) + (draw-messages! state)) ;; Spinner during streaming (when (app-state-agent-busy? state) @@ -1786,18 +1951,22 @@ (let ((comp-h (length (input-state-completion inp)))) (render-completion! inp 0 (- iy comp-h) mw))))) - ;; Status bar - (render-status-bar! 0 (status-y state) (app-state-width state) - (or (current-provider-override) (config-provider)) - (or (current-model-override) (config-model)) - (app-state-tokens-in state) - (app-state-tokens-out state) - (app-state-cache-read state) - (app-state-cache-creation state) - (app-state-cost state) - (current-directory) - (current-mode) - (app-state-sysmon state)) + ;; Status bar. When the sidebar is visible, keep status in the main pane; + ;; the sidebar owns the full right edge including this row. + (let ((status-width (if (app-state-sidebar-visible? state) + (max 1 (- (sidebar-x state) 1)) + (app-state-width state)))) + (render-status-bar! 0 (status-y state) status-width + (or (current-provider-override) (config-provider)) + (or (current-model-override) (config-model)) + (app-state-tokens-in state) + (app-state-tokens-out state) + (app-state-cache-read state) + (app-state-cache-creation state) + (app-state-cost state) + (current-directory) + (current-mode) + (app-state-sysmon state))) ;; Sidebar (when (app-state-sidebar-visible? state) @@ -1806,7 +1975,7 @@ (app-state-memstats state) (sidebar-x state) 0 (app-state-sidebar-width state) - (- (app-state-height state) 1))) ;; don't overlap status bar + (app-state-height state))) ;; Dialog overlay (on top of everything) (when (app-state-dialog state) @@ -1908,6 +2077,54 @@ (render-msg-block! msg x start-row w avail (- mh avail)) (loop (cdr msgs) (- start-row 1) 0)))))))) +;; ---- Activity screen ---- +;; Live tail of every log record the harness emits (provider SSE +;; progress, tool execs, checkpoint git commands, LSP startup...), +;; newest at the bottom with ages. This is the "what on earth is it +;; doing" screen: a checkpoint quietly running `git add -A` on $HOME +;; shows up here as it happens. /activity toggles; Esc returns. + +(def (activity-clip s w) + (let ((w (max 0 w))) + (if (> (string-length s) w) (substring s 0 w) s))) + +(def (activity-age-str age) + (cond + ((< age 60) (format "~as" age)) + ((< age 3600) (format "~am" (quotient age 60))) + (else (format "~ah" (quotient age 3600))))) + +(def (activity-pad-left s n) + (if (>= (string-length s) n) + s + (string-append (make-string (- n (string-length s)) #\space) s))) + +(def (render-activity! state) + (let* ((w (msg-area-width state)) + (h (msg-area-height state)) + (fg (face-fg-attr 'default)) + (bg (face-bg-attr 'default)) + (hl (face-fg-attr 'spinner)) + (now (time-second (current-time))) + (rows (max 0 (- h 1))) + (entries (activity-tail rows)) + (n (length entries)) + (active (app-state-active-tools state)) + (head (format " ACTIVITY agent:~a~a [Esc returns to chat]" + (if (app-state-agent-busy? state) "busy" "idle") + (if (pair? active) + (format " tool:~a" (car active)) + "")))) + (tb-print! 0 0 hl bg (activity-clip head w)) + (let loop ((es entries) (y (+ 1 (max 0 (- rows n))))) + (when (and (pair? es) (< y h)) + (let* ((e (car es)) + (line (format "~a ~a" + (activity-pad-left (activity-age-str (- now (car e))) 4) + (cdr e)))) + (tb-print! 0 y fg bg (activity-clip line w)) + (loop (cdr es) (+ y 1))))))) + (def (draw-spinner! state) (let* ((frame-idx (modulo (app-state-tick state) (vector-length *spinner-frames*))) (frame (vector-ref *spinner-frames* frame-idx)) @@ -1994,7 +2211,8 @@ (app-state-cache-read state) (app-state-cache-creation state) (app-state-cost state) - (app-state-tool-counts state)))) + (app-state-tool-counts state) + #f))) ;; unread?: the active tab is, by definition, read (def (load-tab! state t) ;; Restore a tab record into app-state's flat fields. @@ -2036,9 +2254,11 @@ ((= new-idx old-idx) #f) (else (let* ((captured (snapshot-current-tab state)) - (with-old (list-replace tabs old-idx captured))) + (with-old (list-replace tabs old-idx captured)) + (target (list-ref with-old new-idx))) (app-state-tabs-set! state with-old) - (load-tab! state (list-ref with-old new-idx)) + (when (tab? target) (tab-unread?-set! target #f)) + (load-tab! state target) (app-state-active-tab-set! state new-idx) (reflow-all! state) (app-state-dirty?-set! state #t) @@ -2074,7 +2294,8 @@ '() ;; empty transcript (make-fresh-input) #f 0 "" 0 0 0 0 0.0 - (make-hash-table))) + (make-hash-table) + #f)) ;; unread? (snap (snapshot-current-tab state)) (cur-tabs (app-state-tabs state)) (cur-idx (app-state-active-tab state)) @@ -2096,6 +2317,41 @@ (reflow-all! state) (app-state-dirty?-set! state #t)))))) +(def (open-side-tab! state initial-prompt) + ;; A side conversation: a FRESH jcode session in its own tab, same + ;; agent and tools. Its run keeps streaming into the tab snapshot + ;; while other tabs are visible -- nothing blocks. + (ensure-tabs-seeded! state) + (let* ((sess (session-create "side conversation")) + (new-tab (make-tab + #f ;; provider: jcode-native + (session-id sess) + '() ;; messages + (make-fresh-input) + #f 0 "" 0 0 0 0 0.0 + (make-hash-table) + #f)) ;; unread? + (snap (snapshot-current-tab state)) + (cur-tabs (app-state-tabs state)) + (cur-idx (app-state-active-tab state)) + (with-cur (list-replace cur-tabs cur-idx snap)) + (new-tabs (append with-cur (list new-tab))) + (new-idx (- (length new-tabs) 1))) + (app-state-tabs-set! state new-tabs) + (load-tab! state new-tab) + (app-state-active-tab-set! state new-idx) + (add-message! state + (msg-block-system + (format "Side conversation (tab ~a). Alt-1..Alt-9 or /tab N to switch; /tabs to list; /close-tab to close." + new-idx))) + (when (and (string? initial-prompt) + (not (string=? (string-trim initial-prompt) ""))) + (add-message! state (msg-block-user initial-prompt)) + (run-agent! state initial-prompt)) + (app-state-scroll-offset-set! state 0) + (reflow-all! state) + (app-state-dirty?-set! state #t))) + (def (close-current-tab! state) (let* ((tabs (app-state-tabs state)) (idx (app-state-active-tab state))) @@ -2132,12 +2388,20 @@ (else (let* ((t (car tabs)) (provider (or (and (tab? t) (tab-provider t)) #f)) - (label (if provider (symbol->string provider) "jcode")) + (label (if provider + (symbol->string provider) + (if (= i 0) "jcode" "jcode-side"))) (marker (if (= i idx) "● " " ")) + (busy? (if (= i idx) + (app-state-agent-busy? state) + (and (tab? t) (tab-busy? t)))) + (unread? (and (not (= i idx)) (tab? t) (tab-unread? t))) (sid (or (and (tab? t) (tab-session-id t)) ""))) (loop (cdr tabs) (+ i 1) - (cons (format "~a[~a] ~a~a" + (cons (format "~a[~a] ~a~a~a~a" marker i label + (if busy? " ⚙ running" "") + (if unread? " ✦ new" "") (if (string=? sid "") "" (format " (session ~a)" sid))) lines))))))