Replace retroactive trim-messages with upfront tool output truncation
ober
cd1966abaa1a530bbf8c42a934b22defdd8005cd
--- a/lib/jcode/core/agent.sls +++ b/lib/jcode/core/agent.sls @@ -10,8 +10,9 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (std text json) (std misc thread) (jcode core config) - (jcode core log) (jcode core message) (jcode core session) + (std text json) (std misc thread) (std misc string) + (std os path) (jcode core config) (jcode core log) + (jcode core message) (jcode core session) (jcode provider provider) (jcode tool registry) (jerboa core) (jerboa runtime)) (def logger (make-logger "agent")) @@ -38,8 +39,8 @@ (def current-tool-cb (make-parameter #f)) (def current-usage-cb (make-parameter #f)) (def *max-tool-rounds* 100) - (def *prune-protect-chars* 16000) - (def *tool-result-stub* "[Old tool result cleared]") + (def *max-tool-lines* 2000) + (def *max-tool-bytes* 51200) (def (refresh-system-prompt messages) "Replace the leading system message (if any) with a fresh one reflecting\n the current mode. Returns a NEW list — does not mutate. If there's no\n leading system message, prepends one." (let ([fresh (make-system-message (system-prompt))]) @@ -48,52 +49,50 @@ [(equal? (message-role (car messages)) "system") (cons fresh (cdr messages))] [else (cons fresh messages)]))) - (def (trim-messages messages) - "Prune old tool results: walk backwards, protect recent ones, stub the rest." - (let* ([reversed (reverse messages)] - [tool-chars 0] - [pruned 0] - [total-before (apply - + - (map (lambda (m) - (string-length - (json-object->string - (message->json m)))) - messages))]) - (let ([result (reverse - (map (lambda (m) - (if (and (equal? (message-role m) "tool") - (message-content m)) - (let ([size (string-length - (message-content m))]) - (set! tool-chars (+ tool-chars size)) - (if (> tool-chars - *prune-protect-chars*) - (begin - (set! pruned (+ pruned 1)) - (make-tool-result - (or (message-tool-call-id m) - "") - *tool-result-stub*)) - m)) - m)) - reversed))]) - (let ([total-after (apply - + - (map (lambda (m) - (string-length - (json-object->string - (message->json m)))) - result))]) - (log-info - logger - "trim-messages" - `((msgs . ,(length messages)) - (before-bytes . ,total-before) - (after-bytes . ,total-after) - (tool-chars . ,tool-chars) - (pruned . ,pruned)))) - result))) + (def (truncated-dir) + "Return ~/.jcode/truncated/, creating it if needed." + (let ([dir (path-join (jcode-home) "truncated")]) + (unless (file-exists? dir) (mkdir dir)) + dir)) + (def (truncate-tool-output text) + "Cap tool output at *max-tool-lines* / *max-tool-bytes*. If truncated,\n save the full output to ~/.jcode/truncated/ and return a preview + hint." + (let* ([lines (string-split text #\newline)] + [total-bytes (string-length text)] + [total-lines (length lines)]) + (if (and (<= total-lines *max-tool-lines*) + (<= total-bytes *max-tool-bytes*)) + text + (let loop ([remaining lines] [count 0] [bytes 0] [acc '()]) + (if (or (null? remaining) + (>= count *max-tool-lines*) + (>= bytes *max-tool-bytes*)) + (let* ([preview (string-join (reverse acc) "\n")] + [file (path-join + (truncated-dir) + (format + "tool-~a.txt" + (time-second (current-time))))] + [removed (if (> total-bytes *max-tool-bytes*) + (format + "~a bytes" + (- total-bytes + (string-length preview))) + (format + "~a lines" + (- total-lines count)))]) + (with-output-to-file file (lambda () (display text))) + (string-append + preview + (format + "\n\n...~a truncated...\n\nFull output saved to: ~a\nUse grep to search or read with specific line ranges." + removed + file))) + (let ([line (car remaining)]) + (loop + (cdr remaining) + (+ count 1) + (+ bytes (string-length line) 1) + (cons line acc)))))))) (def (agent-run session-id user-input) (log-info logger "agent-run" `((session . ,session-id))) (let ([existing (session-get-messages session-id)]) @@ -116,7 +115,7 @@ (def (agent-loop session-id messages round) (let* ([provider (get-current-provider)] [tools (get-tool-schemas)] - [msgs (trim-messages (refresh-system-prompt messages))] + [msgs (refresh-system-prompt messages)] [response (provider-chat provider msgs tools)]) (log-debug logger @@ -132,7 +131,7 @@ (for-each (lambda (r) (session-add-message session-id r)) results) - (let* ([final-msgs (trim-messages + (let* ([final-msgs (refresh-system-prompt (session-get-messages session-id))] [final (provider-chat provider final-msgs '())]) (session-add-message session-id final) @@ -145,12 +144,12 @@ results) (agent-loop session-id - (trim-messages (session-get-messages session-id)) + (session-get-messages session-id) (+ round 1)))]))) (def (agent-loop-stream session-id messages round) (let* ([provider (get-current-provider)] [tools (get-tool-schemas)] - [msgs (trim-messages (refresh-system-prompt messages))]) + [msgs (refresh-system-prompt messages)]) (let-values ([(content tool-calls usage) (provider-stream-chat provider @@ -174,7 +173,7 @@ (let-values ([(fc _tc _u) (provider-stream-chat provider - (trim-messages + (refresh-system-prompt (session-get-messages session-id)) '() (current-stream-cb))]) @@ -190,7 +189,7 @@ results) (agent-loop-stream session-id - (trim-messages (session-get-messages session-id)) + (session-get-messages session-id) (+ round 1)))]))))) (def (execute-tool-calls tool-calls) (log-info @@ -228,7 +227,8 @@ raw-args))) (begin (when cb (cb 'start name args)) - (let ([result (tool-execute name args)]) + (let* ([raw-result (tool-execute name args)] + [result (truncate-tool-output raw-result)]) (log-debug logger "tool-result" @@ -254,7 +254,7 @@ (agent-chat-loop-stream provider messages tools 0) (agent-chat-loop provider messages tools 0)))) (def (agent-chat-loop provider messages tools round) - (let* ([msgs (trim-messages messages)] + (let* ([msgs messages] [response (provider-chat provider msgs tools)]) (cond [(not (message-tool-calls response)) @@ -262,8 +262,7 @@ [(>= round *max-tool-rounds*) (let* ([results (execute-tool-calls (message-tool-calls response))] - [new-messages (trim-messages - (append msgs (list response) results))] + [new-messages (append msgs (list response) results)] [final (provider-chat provider new-messages '())]) (or (message-content final) ""))] [else @@ -276,7 +275,7 @@ tools (+ round 1)))]))) (def (agent-chat-loop-stream provider messages tools round) - (let* ([msgs (trim-messages messages)]) + (let* ([msgs messages]) (let-values ([(content tool-calls usage) (provider-stream-chat provider @@ -290,8 +289,7 @@ (if (string=? content "") #f content) tool-calls)] [results (execute-tool-calls tool-calls)] - [new-msgs (trim-messages - (append msgs (list response) results))]) + [new-msgs (append msgs (list response) results)]) (let-values ([(fc _tc _u) (provider-stream-chat provider --- a/lib/jcode/provider/provider.sls +++ b/lib/jcode/provider/provider.sls @@ -10,10 +10,10 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (std text json) (std net request) (std net tls-rustls) - (std net tcp) (std misc string) (std misc retry) - (jcode core log) (jcode core message) (jerboa core) - (jerboa runtime)) + (std text json) (except (std net request) http-post-stream) + (std net tls-rustls) (std net tcp) (std misc string) + (std misc retry) (jcode core log) (jcode core message) + (jerboa core) (jerboa runtime)) (def logger (make-logger "provider")) (def *api-retry-policy* (make-retry-policy 3 1.0 30.0 #t)) (def (retryable-error? e) --- a/src/jcode/core/agent.ss +++ b/src/jcode/core/agent.ss @@ -11,6 +11,8 @@ (import :std/text/json :std/misc/thread + :std/misc/string + :std/os/path ./config ./log ./message @@ -72,8 +74,8 @@ Prefer using the edit tool over write for modifying existing files." (def current-usage-cb (make-parameter #f)) (def *max-tool-rounds* 100) -(def *prune-protect-chars* 16000) ;; ~4k tokens of recent tool results to keep -(def *tool-result-stub* "[Old tool result cleared]") +(def *max-tool-lines* 2000) +(def *max-tool-bytes* 51200) ;; 50KB (def (refresh-system-prompt messages) "Replace the leading system message (if any) with a fresh one reflecting @@ -86,42 +88,42 @@ Prefer using the edit tool over write for modifying existing files." (cons fresh (cdr messages))) (else (cons fresh messages))))) -(def (trim-messages messages) - "Prune old tool results: walk backwards, protect recent ones, stub the rest." - (let* ((reversed (reverse messages)) - (tool-chars 0) - (pruned 0) - (total-before (apply + (map (lambda (m) - (string-length - (json-object->string (message->json m)))) - messages)))) - (let ((result - (reverse - (map (lambda (m) - (if (and (equal? (message-role m) "tool") - (message-content m)) - (let ((size (string-length (message-content m)))) - (set! tool-chars (+ tool-chars size)) - (if (> tool-chars *prune-protect-chars*) - (begin - (set! pruned (+ pruned 1)) - (make-tool-result - (or (message-tool-call-id m) "") - *tool-result-stub*)) - m)) - m)) - reversed)))) - (let ((total-after (apply + (map (lambda (m) - (string-length - (json-object->string (message->json m)))) - result)))) - (log-info logger "trim-messages" - `((msgs . ,(length messages)) - (before-bytes . ,total-before) - (after-bytes . ,total-after) - (tool-chars . ,tool-chars) - (pruned . ,pruned)))) - result))) +(def (truncated-dir) + "Return ~/.jcode/truncated/, creating it if needed." + (let ((dir (path-join (jcode-home) "truncated"))) + (unless (file-exists? dir) (mkdir dir)) + dir)) + +(def (truncate-tool-output text) + "Cap tool output at *max-tool-lines* / *max-tool-bytes*. If truncated, + save the full output to ~/.jcode/truncated/ and return a preview + hint." + (let* ((lines (string-split text #\newline)) + (total-bytes (string-length text)) + (total-lines (length lines))) + (if (and (<= total-lines *max-tool-lines*) + (<= total-bytes *max-tool-bytes*)) + text + ;; Truncate: keep first N lines up to byte limit + (let loop ((remaining lines) (count 0) (bytes 0) (acc '())) + (if (or (null? remaining) + (>= count *max-tool-lines*) + (>= bytes *max-tool-bytes*)) + ;; Save full output, return preview + hint + (let* ((preview (string-join (reverse acc) "\n")) + (file (path-join (truncated-dir) + (format "tool-~a.txt" (time-second (current-time))))) + (removed (if (> total-bytes *max-tool-bytes*) + (format "~a bytes" (- total-bytes (string-length preview))) + (format "~a lines" (- total-lines count))))) + (with-output-to-file file (lambda () (display text))) + (string-append preview + (format "\n\n...~a truncated...\n\nFull output saved to: ~a\nUse grep to search or read with specific line ranges." + removed file))) + (let ((line (car remaining))) + (loop (cdr remaining) + (+ count 1) + (+ bytes (string-length line) 1) + (cons line acc)))))))) (def (agent-run session-id user-input) (log-info logger "agent-run" `((session . ,session-id))) @@ -136,7 +138,7 @@ Prefer using the edit tool over write for modifying existing files." (def (agent-loop session-id messages round) (let* ((provider (get-current-provider)) (tools (get-tool-schemas)) - (msgs (trim-messages (refresh-system-prompt messages))) + (msgs (refresh-system-prompt messages)) (response (provider-chat provider msgs tools))) (log-debug logger "got-response" `((role . ,(message-role response)))) (session-add-message session-id response) @@ -146,7 +148,7 @@ Prefer using the edit tool over write for modifying existing files." (log-warn logger "max-rounds" `((round . ,round))) (let ((results (execute-tool-calls (message-tool-calls response)))) (for-each (lambda (r) (session-add-message session-id r)) results) - (let* ((final-msgs (trim-messages (session-get-messages session-id))) + (let* ((final-msgs (refresh-system-prompt (session-get-messages session-id))) (final (provider-chat provider final-msgs '()))) (session-add-message session-id final) final))) @@ -155,13 +157,13 @@ Prefer using the edit tool over write for modifying existing files." (for-each (lambda (result) (session-add-message session-id result)) results) - (agent-loop session-id (trim-messages (session-get-messages session-id)) (+ round 1))))))) + (agent-loop session-id (session-get-messages session-id) (+ round 1))))))) (def (agent-loop-stream session-id messages round) ;; Streaming version: calls (current-stream-cb) for each text token. (let* ((provider (get-current-provider)) (tools (get-tool-schemas)) - (msgs (trim-messages (refresh-system-prompt messages)))) + (msgs (refresh-system-prompt messages))) (let-values (((content tool-calls usage) (provider-stream-chat provider msgs tools (current-stream-cb)))) (when (and usage (current-usage-cb)) @@ -178,7 +180,7 @@ Prefer using the edit tool over write for modifying existing files." (for-each (lambda (r) (session-add-message session-id r)) results) (let-values (((fc _tc _u) (provider-stream-chat provider - (trim-messages (session-get-messages session-id)) + (refresh-system-prompt (session-get-messages session-id)) '() (current-stream-cb)))) (let ((final (make-assistant-message (if (string=? fc "") #f fc) #f))) @@ -187,7 +189,7 @@ Prefer using the edit tool over write for modifying existing files." (else (let ((results (execute-tool-calls tool-calls))) (for-each (lambda (r) (session-add-message session-id r)) results) - (agent-loop-stream session-id (trim-messages (session-get-messages session-id)) (+ round 1))))))))) + (agent-loop-stream session-id (session-get-messages session-id) (+ round 1))))))))) (def (execute-tool-calls tool-calls) (log-info logger "executing-tools" `((count . ,(length tool-calls)))) @@ -216,7 +218,8 @@ Prefer using the edit tool over write for modifying existing files." (format "Error: malformed tool arguments JSON — ~a" raw-args))) (begin (when cb (cb 'start name args)) - (let ((result (tool-execute name args))) + (let* ((raw-result (tool-execute name args)) + (result (truncate-tool-output raw-result))) (log-debug logger "tool-result" `((tool . ,name) (result-length . ,(string-length result)))) (when cb (cb 'end name args)) (make-tool-result (tool-call-id tc) result)))))) @@ -240,13 +243,13 @@ Prefer using the edit tool over write for modifying existing files." (agent-chat-loop provider messages tools 0)))) (def (agent-chat-loop provider messages tools round) - (let* ((msgs (trim-messages messages)) + (let* ((msgs messages) (response (provider-chat provider msgs tools))) (cond ((not (message-tool-calls response)) (message-content response)) ((>= round *max-tool-rounds*) (let* ((results (execute-tool-calls (message-tool-calls response))) - (new-messages (trim-messages (append msgs (list response) results))) + (new-messages (append msgs (list response) results)) (final (provider-chat provider new-messages '()))) (or (message-content final) ""))) (else @@ -255,7 +258,7 @@ Prefer using the edit tool over write for modifying existing files." (agent-chat-loop provider new-messages tools (+ round 1))))))) (def (agent-chat-loop-stream provider messages tools round) - (let* ((msgs (trim-messages messages))) + (let* ((msgs messages)) (let-values (((content tool-calls usage) (provider-stream-chat provider msgs tools (current-stream-cb)))) (cond @@ -265,7 +268,7 @@ Prefer using the edit tool over write for modifying existing files." (if (string=? content "") #f content) tool-calls)) (results (execute-tool-calls tool-calls)) - (new-msgs (trim-messages (append msgs (list response) results)))) + (new-msgs (append msgs (list response) results))) (let-values (((fc _tc _u) (provider-stream-chat provider new-msgs '() (current-stream-cb)))) fc))) --- a/src/jcode/provider/provider.ss +++ b/src/jcode/provider/provider.ss @@ -9,7 +9,7 @@ provider-model) (import :std/text/json - :std/net/request + (except (std net request) http-post-stream) :std/net/tls-rustls :std/net/tcp :std/misc/string