Implement loop director escalation
ober
8d9b7b96cf79d98dd998effcd2e53611255d3b27
--- a/src/jcode/core/agent.ss +++ b/src/jcode/core/agent.ss @@ -20,11 +20,22 @@ forge-respond-enforced? forge-max-repeated-calls forge-max-similar-search-calls + forge-max-identical-outputs forge-breaker-state make-forge-breaker-state forge-no-progress? forge-no-progress-nudge-used? forge-mark-no-progress-nudged! + forge-record-outputs! + forge-max-output-count + forge-escalate! + forge-nudge-text + forge-loop-restrict-directive + forge-restricted-allowlist + forge-note-loop! + forge-seed-from-memory! + forge-normalize-bash-command + *session-loop-memory* try-parse-text-tool-calls try-parse-xml-tool-calls) @@ -118,7 +129,8 @@ (current-local-provider-prompt? local?) (current-compact-tool-schemas compact?) (current-tool-allowlist - (if compact? *small-context-tools* (current-tool-allowlist)))) + (or (current-tool-allowlist) + (and compact? *small-context-tools*)))) (thunk)))) ;; Forge guardrail policy. The guardrail layer (unknown-tool nudge + retry @@ -146,29 +158,312 @@ "Do not rerun the same discovery commands. Use the tool results already " "in the conversation, choose a clearly different next file/action, or if " "you have enough evidence, write the requested file/final answer now.")) +;; Max times read-family calls may return byte-identical output in one +;; turn before it counts as a no-progress loop. #f disables. +(def forge-max-identical-outputs (make-parameter 3)) + +(def *forge-output-hash-tools* + '("read" "ls" "glob" "grep" "git_status" "git_diff" + "git_log" "git_show" "fetch" "websearch")) + +(def *forge-bash-read-prefixes* + '("cat " "sed " "grep " "tail " "head " "ls " "find " + "stat " "wc " "file " "readlink " "awk " "python3" "python ")) + +(def (forge-collapse-ws s) + (string-join + (filter (lambda (p) (not (string=? p ""))) + (string-split s #\space)) + " ")) + +(def (forge-strip-cd-prefixes cmd) + (if (and (string-prefix? "cd " cmd) + (string-contains cmd "&&")) + (let ((rest (substring cmd (+ (string-contains cmd "&&") 2) + (string-length cmd)))) + (forge-strip-cd-prefixes (string-trim rest))) + cmd)) + +(def (forge-normalize-bash-command cmd) + (let* ((no-cd (forge-strip-cd-prefixes (string-trim cmd))) + (first (car (string-split no-cd #\|)))) + (string-trim (forge-collapse-ws first)))) + +(def (forge-starts-with-any? s prefixes) + (cond + ((null? prefixes) #f) + ((string-prefix? (car prefixes) s) #t) + (else (forge-starts-with-any? s (cdr prefixes))))) + +(def (forge-bash-command tc) + (and (equal? (tool-call-name tc) "bash") + (chat-call-arg tc "command"))) + +(def (forge-bash-read-command? cmd) + (forge-starts-with-any? (forge-normalize-bash-command cmd) + *forge-bash-read-prefixes*)) + +(def (forge-output-hashable-call? tc) + (let ((name (tool-call-name tc))) + (cond + ((member name *forge-output-hash-tools*) #t) + ((equal? name "bash") + (let ((cmd (forge-bash-command tc))) + (and cmd (forge-bash-read-command? cmd)))) + (else #f)))) + +(def (forge-strip-truncation-trailer text) + (let ((marker (string-contains text "\n\n..."))) + (if (and marker (string-contains text "Full output saved to:")) + (substring text 0 marker) + text))) + +(def (forge-output-key text) + (let* ((core (forge-strip-truncation-trailer text)) + (len (string-length core)) + (head (substring core 0 (min 1024 len))) + (tail (substring core (max 0 (- len 1024)) len))) + (string-append (number->string len) "\x1;" head "\x1;" tail))) + +(def (forge-call-desc tc) + (let* ((name (tool-call-name tc)) + (args (tool-call-arguments tc)) + (raw (if (string? args) args (format "~a" args))) + (flat (forge-collapse-ws raw))) + (if (> (string-length flat) 140) + (string-append name "(" (substring flat 0 137) "...)") + (string-append name "(" flat ")")))) + +;; Accessors for an output-entry payload: (count . desc). +(def (forge-out-entry-count e) (car e)) +(def (forge-out-entry-desc e) (cdr e)) + +(def (forge-bump-output! st key desc) + (let ((hit (assoc key (vector-ref st 6)))) + (if hit + (set-cdr! hit (cons (+ (forge-out-entry-count (cdr hit)) 1) + desc)) + (vector-set! st 6 + (cons (cons key (cons 1 desc)) (vector-ref st 6)))))) + +(def (forge-max-output-count st) + (let loop ((rest (vector-ref st 6)) (mx 0)) + (if (null? rest) + mx + (loop (cdr rest) + (max mx (forge-out-entry-count (cdr (car rest)))))))) + +(def (forge-record-outputs! calls results) + (let ((st (forge-breaker-state))) + (when st + (for-each + (lambda (tc r) + (when (and (forge-output-hashable-call? tc) + (message-content r)) + (forge-bump-output! st + (forge-output-key (message-content r)) + (forge-call-desc tc)))) + calls results)))) +(def (forge-take-up-to lst n) + (if (or (null? lst) (<= n 0)) + '() + (cons (car lst) (forge-take-up-to (cdr lst) (- n 1))))) + +(def (forge-sig->desc sig) + (let ((flat (forge-collapse-ws sig))) + (if (> (string-length flat) 140) + (string-append (substring flat 0 137) "...") + flat))) + +(def (forge-top-repeats n) + (let ((st (forge-breaker-state))) + (if (not st) + '() + (let* ((from-calls + (map (lambda (e) (cons (forge-sig->desc (car e)) (cdr e))) + (vector-ref st 3))) + (from-outs + (map (lambda (e) + (cons (string-append (forge-out-entry-desc (cdr e)) + " [identical output]") + (forge-out-entry-count (cdr e)))) + (vector-ref st 6)))) + (forge-take-up-to + (list-sort (lambda (a b) (> (cdr a) (cdr b))) + (append from-calls from-outs)) + n))))) + +(def (forge-nudge-text) + (let ((repeats (forge-top-repeats 5))) + (string-append + "[jcode: loop detected] You re-ran calls that returned no new " + "information this turn:\n" + (if (null? repeats) + " (calls identical to earlier ones in this conversation)\n" + (string-join + (map (lambda (e) + (string-append " - " (car e) + " (x" (number->string (cdr e)) ")")) + repeats) + "\n")) + "\nTheir results are ALREADY in this conversation. Do NOT rerun " + "them or trivial variants (same file with slightly different " + "flags, ranges, or pipes).\n" + "Pick ONE next action:\n" + " 1. Found what you needed? Quote it and do the next task step now.\n" + " 2. Not found? Say so in one line, then use a DIFFERENT file, " + "pattern, or tool.\n" + " 3. Stuck? Write three lines — goal / what you learned / next " + "concrete step — then do that step."))) (def (make-forge-breaker-state) ;; #(last-batch-sig consecutive-count seen-batches seen-individual-calls - ;; seen-similar-search-paths no-progress-nudge-used?) - (vector #f 0 '() '() '() #f)) + ;; seen-similar-search-paths escalation-tier seen-outputs) + (vector #f 0 '() '() '() 0 '())) (def (forge-no-progress-nudge-used?) (let ((st (forge-breaker-state))) - (and st (vector-ref st 5)))) + (and st (>= (vector-ref st 5) 1)))) (def (forge-mark-no-progress-nudged!) (let ((st (forge-breaker-state))) - (when st (vector-set! st 5 #t)))) + (when st (vector-set! st 5 (max 1 (vector-ref st 5)))))) (def (forge-no-progress-nudge-available?) (and (forge-breaker-state) (not (forge-no-progress-nudge-used?)))) -(def (chat-call-signature tc) +(def (forge-escalate!) + (let ((st (forge-breaker-state))) + (if st + (let ((tier (min 3 (+ (vector-ref st 5) 1)))) + (vector-set! st 5 tier) + tier) + 3))) + +(def *forge-loop-restricted-tools* + '("todowrite" "write" "edit" "edit_block" "multi-edit" "patch" + "apply_patch" "git_status" "git_diff" "git_commit" + "mcp_jerboa_jerboa" "respond")) + +(def (forge-restricted-allowlist) + (let ((current (or (current-tool-allowlist) (list-tools)))) + (filter (lambda (t) (member t *forge-loop-restricted-tools*)) + current))) + +(def forge-loop-restrict-directive + (string-append + "[jcode: loop detector — discovery closed] You repeated discovery " + "calls again after being warned. Discovery tools (bash, read, grep, " + "glob, ls, fetch, git_log, git_show) are now DISABLED for the rest " + "of this turn; calling them returns an error. Everything you need " + "is already in this conversation. Do ONE of:\n" + " 1. Make the edit / write the file that completes the task.\n" + " 2. Update the todo list and give the final answer.\n" + " 3. If truly blocked: reply with the single specific question for " + "the user.")) + +(def forge-terminal-summary-directive + (string-append + "[jcode: loop detector] Tool use has been stopped for this turn: " + "repeated calls produced identical results. Tools are OFF now. " + "Using ONLY what is already in this conversation, write the final " + "reply with three short sections: (1) what the task needs, " + "(2) what you found so far, (3) the single most useful next action " + "for the user. Do NOT attempt tool calls.")) + +(def (forge-terminal-summary session-id provider round) + (log-warn logger "no-progress-break" (list (cons 'round round))) + (session-add-message session-id + (make-user-message forge-terminal-summary-directive)) + (let* ((msgs (refresh-system-prompt (session-get-messages session-id))) + (resp (chat-with-expert provider msgs '())) + (txt (message-content resp)) + (final (if (and txt (not (string=? txt ""))) + (make-assistant-message txt #f) + (make-assistant-message forge-no-progress-message #f)))) + (session-add-message session-id final) + final)) + +(def (forge-terminal-summary-stream session-id provider raw-cb round) + (log-warn logger "no-progress-break" (list (cons 'round round))) + (session-add-message session-id + (make-user-message forge-terminal-summary-directive)) + (let-values (((fc _tc _u) + (stream-chat-with-expert provider + (refresh-system-prompt (session-get-messages session-id)) + '() + (and raw-cb (make-tool-call-stream-filter raw-cb))))) + (let* ((use-fallback (or (not fc) (string=? fc ""))) + (msg (if use-fallback forge-no-progress-message fc))) + (when (and use-fallback raw-cb) (raw-cb msg)) + (let ((final (make-assistant-message msg #f))) + (session-add-message session-id final) + final)))) + +(def *session-loop-memory* (make-hash-table)) +(def *session-loop-memory-cap* 10) + +(def (forge-note-loop! session-id) + (when (and session-id (forge-breaker-state)) + (let* ((st (forge-breaker-state)) + (sigs (map car + (forge-take-up-to + (list-sort (lambda (a b) (> (cdr a) (cdr b))) + (vector-ref st 3)) + 5))) + (outs (map car + (forge-take-up-to + (list-sort + (lambda (a b) + (> (forge-out-entry-count (cdr a)) + (forge-out-entry-count (cdr b)))) + (vector-ref st 6)) + 5))) + (old (or (hash-get *session-loop-memory* session-id) + '(() ()))) + (new-sigs (forge-take-up-to (append sigs (car old)) + *session-loop-memory-cap*)) + (new-outs (forge-take-up-to (append outs (cadr old)) + *session-loop-memory-cap*))) + (hash-put! *session-loop-memory* session-id + (list new-sigs new-outs))))) + +(def (forge-seed-from-memory! session-id) + (when session-id + (let ((mem (hash-get *session-loop-memory* session-id)) + (st (forge-breaker-state)) + (limit (forge-max-repeated-calls)) + (out-limit (forge-max-identical-outputs))) + (when (and st mem) + (when (and limit (>= limit 2)) + (for-each + (lambda (sig) + (vector-set! st 3 + (cons (cons sig (- limit 1)) (vector-ref st 3)))) + (car mem))) + (when (and out-limit (>= out-limit 2)) + (for-each + (lambda (key) + (vector-set! st 6 + (cons (cons key (cons (- out-limit 1) + "repeated in an earlier turn")) + (vector-ref st 6)))) + (cadr mem))))))) + +(def (chat-call-signature/raw tc) (let ((a (tool-call-arguments tc))) (string-append (tool-call-name tc) "|" (if (string? a) a (format "~a" a))))) +(def (chat-call-signature tc) + (if (equal? (tool-call-name tc) "bash") + (let ((cmd (forge-bash-command tc))) + (if cmd + (string-append "bash|" (forge-normalize-bash-command cmd)) + (chat-call-signature/raw tc))) + (chat-call-signature/raw tc))) + (def (chat-calls-signature calls) (string-join (map chat-call-signature calls) @@ -242,13 +537,15 @@ (or (chat-call-search-path (car rest)) ""))) mx)))))) -;; Update the per-turn breaker state with CALLS; report whether executing them -;; now crosses the configured repeat limit. +;; Update the per-turn breaker state with CALLS; report whether executing +;; them now crosses the configured repeat limit. Also trips when earlier +;; read-family executions produced enough identical results. (def (forge-no-progress? calls) (let ((limit (forge-max-repeated-calls)) (similar-limit (forge-max-similar-search-calls)) + (out-limit (forge-max-identical-outputs)) (st (forge-breaker-state))) - (and st (pair? calls) (or limit similar-limit) + (and st (pair? calls) (or limit similar-limit out-limit) (let* ((sig (chat-calls-signature calls)) (batch-seen (if limit (forge-count-bump! st 2 sig) 0)) (call-seen (if limit (forge-max-call-count! st calls) 0)) @@ -262,10 +559,28 @@ (or (and limit (>= (vector-ref st 1) limit)) (and limit (>= batch-seen limit)) (and limit (>= call-seen limit)) - (and similar-limit (>= similar-seen similar-limit))))))) + (and similar-limit (>= similar-seen similar-limit)) + (and out-limit + (>= (forge-max-output-count st) out-limit))))))) + +(def (env-system-prompt) + (let ((v (getenv "JCODE_SYSTEM_PROMPT"))) + (and v (not (string=? v "")) v))) (def (system-prompt) - (format "You are an expert AI coding assistant. You help users with software development tasks. + (let ((override (env-system-prompt))) + (if override + (format "~a +Working directory: ~a +Current mode: ~a + +Structured function tools are available through the API schema. Invoke tools only through structured tool_calls. Do not write tool calls as text. +~a" + override + (current-directory) + (mode-label (current-mode)) + (mode-instructions (current-mode))) + (format "You are an expert AI coding assistant. You help users with software development tasks. Working directory: ~a Current mode: ~a @@ -285,6 +600,7 @@ IMPORTANT RULES: - ALWAYS read a file (with the read tool) before editing it. Do not invent file contents. - The edit tool requires old_str to match the file BYTE-FOR-BYTE. If edit returns 'old_str not found', do NOT retry with similar text — read the file to see real content, then edit. - Do NOT call the same tool repeatedly with the same or similar arguments. Use grep/glob to locate code instead of guessing paths. +- If a '[jcode: loop detected]' message appears, obey it at once — the flagged results are already in the conversation; re-running those calls wastes your remaining budget. - Dispatcher tools (e.g. mcp_jerboa_jerboa) take a `tool` name plus an `args` object. The `args` field's description lists each sub-tool's accepted argument names (! = required) — pass those EXACT names, do not guess. When unsure, first call with tool=\"describe\", args={\"name\":\"<tool>\"}. - ~a @@ -303,14 +619,14 @@ When the user asks you to do something: Be concise. Prefer edit over write for modifying existing files. ~a" - (current-directory) - (mode-label (current-mode)) - (system-tool-section) - (do-it-instructions) - (mode-instructions (current-mode)) - (expert-prompt-instructions) - (system-parallelism-rule) - (agent-instructions-for-prompt))) + (current-directory) + (mode-label (current-mode)) + (system-tool-section) + (do-it-instructions) + (mode-instructions (current-mode)) + (expert-prompt-instructions) + (system-parallelism-rule) + (agent-instructions-for-prompt))))) (def (do-it-instructions) (if (current-do-it-mode?) @@ -1413,6 +1729,7 @@ Be concise. Prefer edit over write for modifying existing files. response))) (def (agent-run-once session-id user-input) + (reset-turn-tool-calls!) ;; Defensively repair the session before the new turn — a previously ;; cancelled or crashed turn may have left an assistant tool_calls ;; message without matching tool result messages, which the @@ -1432,6 +1749,7 @@ Be concise. Prefer edit over write for modifying existing files. ;; across the tool-call rounds of this turn, then resets for the next. (let ((gr (make-guardrails (list-tools)))) (parameterize ((forge-breaker-state (make-forge-breaker-state))) + (forge-seed-from-memory! session-id) (if (current-stream-cb) (agent-loop-stream session-id (session-get-messages session-id) 0 gr) (agent-loop session-id (session-get-messages session-id) 0 gr)))))))) @@ -1528,27 +1846,37 @@ Be concise. Prefer edit over write for modifying existing files. (let ((final (make-assistant-message (respond-call->text rc) #f))) (session-add-message session-id final) final)) - ;; No-progress breaker: repeated tool calls get one corrective - ;; nudge. A second hit stops the turn. + ;; Loop director: repeated no-progress calls escalate through + ;; specific nudge, tool restriction, and terminal summary. ((forge-no-progress? calls) - (if (forge-no-progress-nudge-available?) - (begin - (forge-mark-no-progress-nudged!) - (log-warn logger "no-progress-nudge" `((round . ,round))) - (session-add-message session-id - (make-user-message forge-no-progress-nudge-message)) - (agent-loop session-id (session-get-messages session-id) (+ round 1) gr)) - (begin - (log-warn logger "no-progress-break" `((round . ,round))) - (let ((final (make-assistant-message forge-no-progress-message #f))) - (session-add-message session-id final) - final)))) + (forge-note-loop! session-id) + (let ((tier (forge-escalate!))) + (cond + ((= tier 1) + (log-warn logger "no-progress-nudge" + (list (cons 'round round))) + (session-add-message session-id + (make-user-message (forge-nudge-text))) + (agent-loop session-id (session-get-messages session-id) + (+ round 1) gr)) + ((= tier 2) + (log-warn logger "no-progress-restrict" + (list (cons 'round round))) + (session-add-message session-id + (make-user-message forge-loop-restrict-directive)) + (parameterize ((current-tool-allowlist + (forge-restricted-allowlist))) + (agent-loop session-id (session-get-messages session-id) + (+ round 1) gr))) + (else + (forge-terminal-summary session-id provider round))))) (else ;; If calls were rescued from bare text, effective is only the ;; text — rebuild it carrying the tool_calls so results stay paired. (let ((asst (if (null? tcs) (make-assistant-message #f calls) effective))) (session-add-message session-id asst) (let ((results (execute-tool-calls calls))) + (forge-record-outputs! calls results) (for-each (lambda (r) (session-add-message session-id r)) results) (guardrails-record gr (map tool-call-name calls)) (agent-loop session-id (session-get-messages session-id) @@ -1659,27 +1987,36 @@ Be concise. Prefer edit over write for modifying existing files. (let ((final (make-assistant-message msg #f))) (session-add-message session-id final) final))) - ;; No-progress breaker: repeated tool calls get one corrective - ;; nudge. A second hit stops the turn. + ;; Loop director: repeated no-progress calls escalate through + ;; specific nudge, tool restriction, and terminal summary. ((forge-no-progress? calls) - (if (forge-no-progress-nudge-available?) - (begin - (forge-mark-no-progress-nudged!) - (log-warn logger "no-progress-nudge" `((round . ,round))) - (session-add-message session-id - (make-user-message forge-no-progress-nudge-message)) - (agent-loop-stream session-id (session-get-messages session-id) (+ round 1) gr)) - (begin - (log-warn logger "no-progress-break" `((round . ,round))) - (let ((msg forge-no-progress-message)) - (when raw-cb (raw-cb msg)) - (let ((final (make-assistant-message msg #f))) - (session-add-message session-id final) - final))))) + (forge-note-loop! session-id) + (let ((tier (forge-escalate!))) + (cond + ((= tier 1) + (log-warn logger "no-progress-nudge" + (list (cons 'round round))) + (session-add-message session-id + (make-user-message (forge-nudge-text))) + (agent-loop-stream session-id + (session-get-messages session-id) (+ round 1) gr)) + ((= tier 2) + (log-warn logger "no-progress-restrict" + (list (cons 'round round))) + (session-add-message session-id + (make-user-message forge-loop-restrict-directive)) + (parameterize ((current-tool-allowlist + (forge-restricted-allowlist))) + (agent-loop-stream session-id + (session-get-messages session-id) (+ round 1) gr))) + (else + (forge-terminal-summary-stream + session-id provider raw-cb round))))) (else (let ((asst (if (null? tcs) (make-assistant-message #f calls) response))) (session-add-message session-id asst) (let ((results (execute-tool-calls calls))) + (forge-record-outputs! calls results) (for-each (lambda (r) (session-add-message session-id r)) results) (guardrails-record gr (map tool-call-name calls)) (agent-loop-stream session-id (session-get-messages session-id) --- a/test/run.ss +++ b/test/run.ss @@ -2449,6 +2449,130 @@ (forge-mark-no-progress-nudged!) (check! "agent breaker nudge marked used" (forge-no-progress-nudge-used?) #t)) + +(section "=== loop director: bash signature normalization ===") +;; Same semantic command, different cd/pipe/timeout → same signature → +;; counts as a repeat (the exact-match evasion from the field sessions). +(let ([mk (lambda (cmd timeout) + (list (make-tool-call "bash" + (string-append "{\"command\":\"" cmd + "\",\"timeout\":" (number->string timeout) + "}"))))]) + (parameterize ([forge-max-repeated-calls 3] + [forge-breaker-state (make-forge-breaker-state)]) + (check! "bash norm: first variant ok" + (forge-no-progress? (mk "cd /repo && cat Makefile | head -20" 5000)) #f) + (check! "bash norm: second variant ok" + (forge-no-progress? (mk "cat Makefile" 15000)) #f) + (check! "bash norm: third variant trips" + (forge-no-progress? (mk "cd /repo && cat Makefile|cat" 5000)) #t))) + +(section "=== loop director: identical-output detection ===") +;; The killer feature: same file re-read with DIFFERENT args producing +;; byte-identical output trips even when no two calls are identical. +(let ([sed-a (list (make-tool-call "bash" "{\"command\":\"sed -n '1,50p' x.ss\"}"))] + [sed-b (list (make-tool-call "bash" "{\"command\":\"sed -n '1,49p' x.ss | head\"}"))] + [cat-c (list (make-tool-call "bash" "{\"command\":\"cd /r && cat x.ss | tail -50\"}"))] + [out "line1\nline2\nline3\n...same bytes..."]) + (parameterize ([forge-max-repeated-calls 3] + [forge-max-identical-outputs 3] + [forge-breaker-state (make-forge-breaker-state)]) + (forge-record-outputs! sed-a (list (make-tool-result "t1" out))) + (check! "outputs: distinct batch after 1st identical ok" + (forge-no-progress? sed-b) #f) + (forge-record-outputs! sed-b (list (make-tool-result "t2" out))) + (check! "outputs: distinct batch after 2nd identical ok" + (forge-no-progress? cat-c) #f) + (forge-record-outputs! cat-c (list (make-tool-result "t3" out))) + (check! "outputs: 3 identical outputs trip on next batch" + (forge-no-progress? sed-a) #t))) +;; Changed output (file edited between reads) does not accumulate. +(let ([rd (list (make-tool-call "read" "{\"path\":\"x.ss\"}"))]) + (parameterize ([forge-max-identical-outputs 3] + [forge-breaker-state (make-forge-breaker-state)]) + (forge-record-outputs! rd (list (make-tool-result "a" "v1"))) + (forge-record-outputs! rd (list (make-tool-result "b" "v2-after-edit"))) + (forge-record-outputs! rd (list (make-tool-result "c" "v3-after-edit"))) + (check! "outputs: distinct contents never trip" + (forge-no-progress? rd) #f))) +;; Build/test commands are never output-hashed. +(let ([mk-build (list (make-tool-call "bash" "{\"command\":\"make build 2>&1\"}"))] + [fail "ld: 1 error"]) + (parameterize ([forge-max-identical-outputs 3] + [forge-breaker-state (make-forge-breaker-state)]) + (forge-record-outputs! mk-build (list (make-tool-result "a" fail))) + (forge-record-outputs! mk-build (list (make-tool-result "b" fail))) + (forge-record-outputs! mk-build (list (make-tool-result "c" fail))) + (check! "outputs: identical build failures do not trip output path" + (forge-max-output-count (forge-breaker-state)) 0))) +;; Truncation trailers (random paths) are stripped before hashing. +(let ([rd (list (make-tool-call "read" "{\"path\":\"big.ss\"}"))] + [core "aaaa-bbbb-core-bytes"] + [trailer "\n\n...90000 bytes truncated...\n\nFull output saved to: /tmp/tool-1-123.txt\nUse grep"]) + (parameterize ([forge-max-identical-outputs 2] + [forge-breaker-state (make-forge-breaker-state)]) + (forge-record-outputs! rd + (list (make-tool-result "a" (string-append core trailer "1")))) + (forge-record-outputs! rd + (list (make-tool-result "b" (string-append core trailer "2")))) + (check! "outputs: trailers with different paths count identical" + (forge-no-progress? rd) #t))) + +(section "=== loop director: escalation tiers ===") +(parameterize ([forge-breaker-state (make-forge-breaker-state)]) + (check! "tier starts unused" (forge-no-progress-nudge-used?) #f) + (check! "first escalate → 1" (forge-escalate!) 1) + (check! "nudge-used? true at tier 1" (forge-no-progress-nudge-used?) #t) + (check! "second escalate → 2" (forge-escalate!) 2) + (check! "third escalate → 3" (forge-escalate!) 3) + (check! "escalate clamps at 3" (forge-escalate!) 3)) +;; Nudge text names the offending call and its count. +(let ([cat-x (list (make-tool-call "bash" "{\"command\":\"cat x.ss\"}"))]) + (parameterize ([forge-max-repeated-calls 3] + [forge-breaker-state (make-forge-breaker-state)]) + (forge-no-progress? cat-x) + (forge-no-progress? cat-x) + (check! "trip on third" (forge-no-progress? cat-x) #t) + (let ([txt (forge-nudge-text)]) + (check-pred! "nudge names the call" + txt (lambda (s) (string-contains s "cat x.ss"))) + (check-pred! "nudge shows the count" + txt (lambda (s) (string-contains s "(x3)"))) + (check-pred! "nudge has next actions" + txt (lambda (s) (string-contains s "Pick ONE next action")))))) + +(section "=== loop director: session memory ===") +;; A loop recorded in one "turn" makes the next turn trip on the first +;; rerun (this is the continue→fumble→break→continue killer). +(let ([sid "test-session-loop-mem"] + [cat-x (list (make-tool-call "bash" "{\"command\":\"cat x.ss\"}"))]) + (parameterize ([forge-max-repeated-calls 3] + [forge-breaker-state (make-forge-breaker-state)]) + (forge-no-progress? cat-x) + (forge-no-progress? cat-x) + (forge-no-progress? cat-x) + (forge-note-loop! sid)) + (parameterize ([forge-max-repeated-calls 3] + [forge-breaker-state (make-forge-breaker-state)]) + (forge-seed-from-memory! sid) + (check! "seeded turn: first rerun of remembered call trips" + (forge-no-progress? cat-x) #t)) + (hash-remove! *session-loop-memory* sid)) + +(section "=== loop director: restriction allowlist ===") +(let ([allow (forge-restricted-allowlist)]) + (check-pred! "bash withheld" allow + (lambda (a) (not (member "bash" a)))) + (check-pred! "read withheld" allow + (lambda (a) (not (member "read" a)))) + (check-pred! "edit kept" allow + (lambda (a) (and (member "edit" a) #t))) + (check-pred! "todowrite kept" allow + (lambda (a) (and (member "todowrite" a) #t)))) +(parameterize ([current-tool-allowlist '("read" "edit" "bash")]) + (let ([allow (forge-restricted-allowlist)]) + (check! "tier 2 only narrows an existing allowlist" allow '("edit")))) + (section "=== expert escalation ===") (check-pred! "expert handoff preserves the active tool protocol" (expert-handoff-instruction "recoverable-tool-error-loop")