Improve verified workflow recovery
ober
5b54248b760328605fe36f68ac23407ee8359822
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -1055,6 +1055,7 @@ (def (record-successful-edit! cwd path) (clear-pending-ss-create-repair! cwd path) + (reset-rejected-draft-state!) (reset-existing-ss-rewrite-state!) (reset-path-only-run-state!) (reset-failed-verify-inspections!) @@ -2740,6 +2741,42 @@ (string-contains content "(export") (string-contains content "(import"))) +(def meaningful-source-bytes-threshold 1000) +(def tiny-rewrite-bytes-threshold 500) + +(def (meaningful-source-file? path content) + (and (source-ss-path? path) + (> (string-length content) meaningful-source-bytes-threshold) + (or (string-contains content "(def ") + (string-contains content "(define ") + (string-contains content "(lambda")))) + +(def (diagnostic-stub-content? content) + (let ((s (string-downcase (string-trim content)))) + (or (< (string-length s) tiny-rewrite-bytes-threshold) + (string-contains s "(display \"hi") + (string-contains s "(display \"test") + (string-contains s "(display 'hi") + (string-contains s "(display 'test") + (and (not (string-contains s "(def ")) + (not (string-contains s "(define ")) + (not (string-contains s "(lambda")) + (not (string-contains s "(let ")) + (< (string-length s) meaningful-source-bytes-threshold))))) + +(def (destructive-rewrite-message path old-content new-content) + (and (current-after-failed-verify?) + (meaningful-source-file? path old-content) + (diagnostic-stub-content? new-content) + (string-append + "edit refused for " + path + ": refused destructive tiny rewrite after a verify failure. Do not replace a substantial Jerboa source file (" + (number->string (string-length old-content)) + " bytes) with a tiny or diagnostic stub (" + (number->string (string-length new-content)) + " bytes). The on-disk file was not changed. Repair the verifier error with line_edit, replace_def, or replace_range, or send a complete replacement that preserves the full implementation."))) + (def (reject-incomplete-ss-create path content kind) (current-pending-ss-create-repair path) (record-rejected-ss-draft! path content) @@ -3317,6 +3354,10 @@ (mkdir-p dir))) (when (file-exists? p) (let ((old (read-file-string p))) + (cond + ((destructive-rewrite-message path old content) + => (lambda (msg) + (raise-recoverable-tool-error msg 'edit)))) (let ((msg (partial-overwrite-error path old content))) (when msg (error 'edit msg))))) (let* ((balanced-content @@ -3465,6 +3506,16 @@ (error 'create_verified_jerboa_script (format "refusing write through symlink path component: ~a" path))) + ((and (file-exists? (abs-path cwd path)) + (let ((content (read-file-string (abs-path cwd path)))) + (or (meaningful-source-file? path content) + (current-after-failed-verify?)))) + (raise-recoverable-tool-error + (string-append + "create_verified_jerboa_script refused to reset existing meaningful source " + path + ". A scaffold is only for starting a new trivial script. The file already has meaningful code or has failed verification; repair it with verify, read/balance, line_edit, replace_def, replace_range, or a complete edit/write replacement.") + 'create_verified_jerboa_script)) (else (let* ((created-new? (not (file-exists? (abs-path cwd path)))) (result --- a/src/jcode/core/workflow-runner.ss +++ b/src/jcode/core/workflow-runner.ss @@ -36,6 +36,7 @@ :jcode/guardrails/step-enforcer :jcode/guardrails/error-tracker :jcode/guardrails/nudge + :std/misc/string :std/text/json) (def (opt-ref alist key) (let ((p (assoc key alist))) (and p (cdr p)))) @@ -231,6 +232,59 @@ (display ";" p)) tcs)))) +(def (workflow-has-tool? workflow name) + (and (member name (workflow-tool-names workflow)) #t)) + +(def (verified-workflow? workflow) + (string=? (workflow-name workflow) "verified-coding")) + +(def (verified-text-retry-message workflow enforcer raw retry-count) + (let* ((completed (step-enforcer-completed enforcer)) + (pending (step-enforcer-pending enforcer)) + (has-verify? (workflow-has-tool? workflow "verify")) + (has-edit? (workflow-has-tool? workflow "edit")) + (has-read? (workflow-has-tool? workflow "read")) + (has-balance? (workflow-has-tool? workflow "balance")) + (next-tools + (cond + ((and has-verify? (member "edit" completed)) + "verify()") + ((and has-edit? has-read?) + "read(path=\"...\") or edit(path=\"...\", content=<complete file>)") + (has-edit? "edit(path=\"...\", content=<complete file>)") + (has-verify? "verify()") + (else "one available structured tool")))) + (string-append + "VERIFIED WORKFLOW REQUIRES A STRUCTURED TOOL CALL NOW. " + "Your previous response was prose/text, not a valid tool call. " + "Do not explain, summarize, or ask questions. " + "Next response must be exactly one structured tool call.\n\n" + "Completed tools: " + (if (pair? completed) (string-join completed ", ") "(none)") + "\nPending required tools: " + (if (pair? pending) (string-join pending ", ") "(none)") + "\nRecommended next tool: " + next-tools + ".\n" + (if (and has-balance? (member "verify" completed)) + "If verify failed with syntax or delimiter errors, use balance(path=\"...\") or replace_range/replace_def with complete corrected code.\n" + "") + "If a scaffold or file already exists, call verify() before more prose. " + "If code must change, call edit/write/line_edit/replace_def/replace_range with complete concrete code, never placeholders.\n" + (if (> retry-count 1) + "This is a repeated prose-only response. Stop free-form text and issue the tool call now.\n" + "") + "Invalid previous text excerpt:\n" + (let ((s (if (string? raw) raw ""))) + (if (> (string-length s) 800) + (substring s 0 800) + s))))) + +(def (text-retry-message workflow enforcer raw retry-count) + (if (verified-workflow? workflow) + (verified-text-retry-message workflow enforcer raw retry-count) + (nudge-content (make-retry-nudge raw)))) + (def (run-workflow workflow user-message responder . opt) "Execute WORKFLOW with USER-MESSAGE, driving the loop through RESPONDER. Returns the terminal tool's value. OPT is an optional options assoc: @@ -293,7 +347,10 @@ "Model failed to produce a valid tool call after text-response retries." content)) (emit! (make-user-message - (nudge-content (make-retry-nudge content)))) + (text-retry-message + workflow enforcer content + (error-tracker-consecutive-retries + error-tracker)))) (loop (+ iteration 1))) (loop (+ iteration 1))))) (else --- a/src/jcode/ui/cli.ss +++ b/src/jcode/ui/cli.ss @@ -791,6 +791,64 @@ EXAMPLES: (put-json! ht "status_file" (or status-file #f)) ht)) +(def (usage-ref usage key) + (let ((p (assoc key usage))) (if p (cdr p) 0))) + +(def (usage-ref-any usage keys) + (let loop ((ks keys)) + (cond + ((null? ks) 0) + (else + (let ((v (usage-ref usage (car ks)))) + (if (and (number? v) (> v 0)) + v + (loop (cdr ks)))))))) + +(def (verified-usage-accumulator) + (let ((input 0) + (output 0) + (cache-read 0) + (cache-creation 0) + (reasoning 0) + (cost 0.0) + (saw-cost? #f)) + (values + (lambda (usage) + (when (list? usage) + (set! input + (+ input (or (usage-ref-any usage '(tokens-in input-tokens input_tokens prompt_tokens)) 0))) + (set! output + (+ output (or (usage-ref-any usage '(tokens-out output-tokens output_tokens completion_tokens)) 0))) + (set! cache-read + (+ cache-read (or (usage-ref-any usage '(cache-read cache_read cache_read_tokens cache_read_input_tokens cached_tokens)) 0))) + (set! cache-creation + (+ cache-creation (or (usage-ref-any usage '(cache-creation cache_creation cache_creation_tokens cache_creation_input_tokens)) 0))) + (set! reasoning + (+ reasoning (or (usage-ref-any usage '(reasoning reasoning-tokens reasoning_tokens reasoning_output_tokens)) 0))) + (let ((c (usage-ref-any usage '(cost cost-usd cost_usd total_cost_usd)))) + (when (number? c) + (set! saw-cost? #t) + (set! cost (+ cost (* 1.0 c))))))) + (lambda () + (let ((ht (make-hash-table))) + (put-json! ht "input_tokens" input) + (put-json! ht "output_tokens" output) + (put-json! ht "cache_read_tokens" cache-read) + (put-json! ht "cache_creation_tokens" cache-creation) + (put-json! ht "reasoning_tokens" reasoning) + (put-json! ht "cost_usd" (and saw-cost? cost)) + ht))))) + +(def (status-with-usage! status usage) + (hash-put! status "usage" usage) + (hash-put! status "input_tokens" (hash-ref usage "input_tokens" 0)) + (hash-put! status "output_tokens" (hash-ref usage "output_tokens" 0)) + (hash-put! status "cache_read_tokens" (hash-ref usage "cache_read_tokens" 0)) + (hash-put! status "cache_creation_tokens" (hash-ref usage "cache_creation_tokens" 0)) + (hash-put! status "reasoning_tokens" (hash-ref usage "reasoning_tokens" 0)) + (hash-put! status "cost_usd" (hash-ref usage "cost_usd" #f)) + status) + (def (write-status-file! path status) (when path (let ((out (open-file-output-port @@ -827,30 +885,36 @@ EXAMPLES: (if run-aliases? "on" "off") (if guidance-file guidance-file "none") task) - (guard (e [#t - (let* ((msg (err->string e)) - (etype (eval-error-type e)) - (status (verified-status #f task bestof verify-command work-cwd - scope run-aliases? guidance-file - status-file #f etype msg))) - (fprintf human-port "~n✗ verified-run stopped: ~a~n" msg) - (finish-verified-status! status json? status-file))]) - (let* ((guidance (read-guidance-file guidance-file)) - (opt (list (cons 'best-of bestof) - (cons 'on-message (lambda (msg) (vr-print-message-to human-port msg))) - (cons 'verify-command verify-command) - (cons 'cwd work-cwd) - (cons 'write-scope scope) - (cons 'run-aliases? run-aliases?) - (cons 'task-guidance guidance)))) - (let ((summary (parameterize ((current-output-port human-port)) - (verified-run provider task opt)))) - (fprintf human-port "~n✓ done: ~a~n" summary) - (finish-verified-status! - (verified-status #t task bestof verify-command work-cwd scope - run-aliases? guidance-file status-file - summary #f #f) - json? status-file)))))) + (let-values (((record-usage! usage-snapshot) (verified-usage-accumulator))) + (guard (e [#t + (let* ((msg (err->string e)) + (etype (eval-error-type e)) + (status (status-with-usage! + (verified-status #f task bestof verify-command work-cwd + scope run-aliases? guidance-file + status-file #f etype msg) + (usage-snapshot)))) + (fprintf human-port "~n✗ verified-run stopped: ~a~n" msg) + (finish-verified-status! status json? status-file))]) + (let* ((guidance (read-guidance-file guidance-file)) + (opt (list (cons 'best-of bestof) + (cons 'on-message (lambda (msg) (vr-print-message-to human-port msg))) + (cons 'verify-command verify-command) + (cons 'cwd work-cwd) + (cons 'write-scope scope) + (cons 'run-aliases? run-aliases?) + (cons 'task-guidance guidance)))) + (let ((summary (parameterize ((current-output-port human-port) + (current-usage-cb record-usage!)) + (verified-run provider task opt)))) + (fprintf human-port "~n✓ done: ~a~n" summary) + (finish-verified-status! + (status-with-usage! + (verified-status #t task bestof verify-command work-cwd scope + run-aliases? guidance-file status-file + summary #f #f) + (usage-snapshot)) + json? status-file))))))) (def (shell-words s) "Small shell-like splitter for slash-command flags. Handles whitespace, --- a/test/run.ss +++ b/test/run.ss @@ -1390,6 +1390,33 @@ #t] [else (loop (cdr ys))]))))) +(let* ([w (coding-workflow "true" "/tmp")] + [msgs '()] + [resp (scripted-responder + (list (make-text-response "I will explain instead of calling tools.") + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call "done" '(("summary" . "verified-text-retry-ok")) #f))))] + [result (run-workflow w "go" resp + (list (cons 'max-iterations 6) + (cons 'retry-text-responses? #t) + (cons 'on-message + (lambda (m) (set! msgs (cons m msgs))))))]) + (check! "verified retry-text workflow still reaches terminal" + result "verified-text-retry-ok") + (check-pred! "verified retry-text emits concrete tool-call nudge" + (reverse msgs) + (lambda (xs) + (let loop ([ys xs]) + (cond + [(null? ys) #f] + [(and (equal? (message-role (car ys)) "user") + (str-contains? (message-content (car ys)) + "VERIFIED WORKFLOW REQUIRES A STRUCTURED TOOL CALL NOW") + (str-contains? (message-content (car ys)) + "Do not explain, summarize, or ask questions")) + #t] + [else (loop (cdr ys))]))))) + ;; Opt-in text retries fail through ToolCallError instead of burning every ;; workflow iteration. (let* ([w (mk-research-wf)] @@ -3550,6 +3577,66 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-verified-replace-def-placeholder.ss"] + [target-path (string-append vr-dir "/" target)] + [initial "(import (jerboa prelude))\n\n(define (simulate grid)\n grid)\n\n(define (main)\n (displayln \"old\"))\n"] + [replacement "(define (simulate grid)\n (list grid 'fixed))\n"] + [tool-results '()] + [slurp (lambda (p) (call-with-input-file p (lambda (i) (get-string-all i))))]) + (safe-delete-test-file! target-path) + (write-test-output-file target-path + (lambda (o) (display initial o)) + 'replace) + (let* ([scope (parse-write-scope target)] + [wf (coding-workflow (string-append "grep -q fixed " target) vr-dir + (list (cons 'write-scope scope)))] + [resp (scripted-responder + (list + (list + (make-wtool-call + "replace_def" + (list (cons "path" target) + (cons "name" "simulate") + (cons "content" "...")) + #f)) + (list + (make-wtool-call + "replace_def" + (list (cons "path" target) + (cons "name" "simulate") + (cons "content" replacement)) + #f)) + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call "done" '(("summary" . "replace-def-placeholder-ok")) #f))))] + [result (parameterize ((current-write-scope scope)) + (run-workflow wf "repair placeholder replace_def" resp + (list (cons 'max-iterations 8) + (cons 'max-tool-errors 3) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results))))))))]) + (check! "verified-run: placeholder replace_def recovers" + result "replace-def-placeholder-ok") + (check-pred! "verified-run: placeholder replace_def did not destroy function" + (slurp target-path) + (lambda (s) + (and (str-contains? s "(list grid 'fixed)") + (str-contains? s "(define (main)"))))) + (check-pred! "verified-run: placeholder replace_def gives recoverable guidance" + (reverse tool-results) + (lambda (xs) + (let loop ([ys xs]) + (cond + [(null? ys) #f] + [(and (str-contains? (car ys) "[ToolRecoverableError]") + (str-contains? (car ys) "placeholder-only content")) + #t] + [else (loop (cdr ys))])))) + (safe-delete-test-file! target-path)) + +(let* ([vr-dir "/tmp"] [target "jcode-verified-replace-range.ss"] [target-path (string-append vr-dir "/" target)] [initial "(import (jerboa prelude))\n(define (bad)\n (displayln \"bad\")\n\n(define (ok) 1)\n"] @@ -4075,6 +4162,59 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-verified-scaffold-reset-existing.ss"] + [target-path (string-append vr-dir "/" target)] + [initial (string-append + "(import (jerboa prelude))\n\n" + ";; meaningful existing implementation\n" + (make-string 1100 #\x) + "\n\n(define (main)\n (displayln \"KEEP\")\n)\n\n(main)\n")] + [tool-results '()] + [slurp (lambda (p) (call-with-input-file p (lambda (i) (get-string-all i))))]) + (safe-delete-test-file! target-path) + (write-test-output-file target-path + (lambda (o) (display initial o)) + 'replace) + (let* ([scope (parse-write-scope target)] + [wf (coding-workflow (string-append "grep -q KEEP " target) vr-dir + (list (cons 'write-scope scope)))] + [resp (scripted-responder + (list + (list + (make-wtool-call + "create_verified_jerboa_script" + (list (cons "path" target) + (cons "kind" "minimal-pass")) + #f)) + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call "done" '(("summary" . "scaffold-reset-refused-ok")) #f))))] + [result (parameterize ((current-write-scope scope)) + (run-workflow wf "do not reset meaningful existing source" resp + (list (cons 'max-iterations 8) + (cons 'max-tool-errors 3) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results))))))))]) + (check! "verified-run: scaffold reset refusal still reaches verified done" + result "scaffold-reset-refused-ok") + (check! "verified-run: scaffold reset leaves meaningful source untouched" + (slurp target-path) initial) + (check-pred! "verified-run: scaffold reset refusal names existing source" + (reverse tool-results) + (lambda (xs) + (let loop ([ys xs]) + (cond + [(null? ys) #f] + [(and (str-contains? (car ys) "[ToolRecoverableError]") + (str-contains? (car ys) + "refused to reset existing meaningful source")) + #t] + [else (loop (cdr ys))]))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-verified-scaffold-rewrite.ss"] [target-path (string-append vr-dir "/" target)] [bad "(import (jerboa prelude))\n\n(define (main)\n (display \"bad\")\n"] @@ -5004,6 +5144,77 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-verified-destructive-tiny-rewrite.ss"] + [target-path (string-append vr-dir "/" target)] + [initial (string-append + "(import (jerboa prelude))\n\n" + "(define filler \"" + (make-string 1100 #\x) + "\")\n\n" + "(define (main)\n" + " (displayln \"KEEP\")\n" + ")\n\n" + "(main)\n")] + [tiny "(import (jerboa prelude))\n;; TODO: implement after failure\n(displayln \"stub\")\n"] + [fixed-line " (displayln \"PASS\")"] + [tool-results '()] + [slurp (lambda (p) (call-with-input-file p (lambda (i) (get-string-all i))))]) + (safe-delete-test-file! target-path) + (write-test-output-file target-path + (lambda (o) (display initial o)) + 'replace) + (let* ([scope (parse-write-scope target)] + [wf (coding-workflow (string-append "grep -q PASS " target) vr-dir + (list (cons 'write-scope scope)))] + [resp (scripted-responder + (list + (list (make-wtool-call "verify" '() #f)) + (list + (make-wtool-call + "edit" + (list (cons "path" target) + (cons "content" tiny)) + #f)) + (list + (make-wtool-call + "replace_range" + (list (cons "path" target) + (cons "start" 6) + (cons "end" 6) + (cons "content" fixed-line)) + #f)) + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call "done" '(("summary" . "tiny-rewrite-refused-ok")) #f))))] + [result (parameterize ((current-write-scope scope)) + (run-workflow wf "do not replace source with diagnostic stub" resp + (list (cons 'max-iterations 10) + (cons 'max-tool-errors 3) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results))))))))]) + (check! "verified-run: destructive tiny rewrite refusal still recovers" + result "tiny-rewrite-refused-ok") + (check-pred! "verified-run: destructive tiny rewrite leaves source repairable" + (slurp target-path) + (lambda (s) + (and (str-contains? s "(displayln \"PASS\")") + (str-contains? s "(define filler") + (not (str-contains? s "TODO: implement after failure"))))) + (check-pred! "verified-run: destructive tiny rewrite is refused recoverably" + (reverse tool-results) + (lambda (xs) + (let loop ([ys xs]) + (cond + [(null? ys) #f] + [(and (str-contains? (car ys) "[ToolRecoverableError]") + (str-contains? (car ys) "refused destructive tiny rewrite")) + #t] + [else (loop (cdr ys))]))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-verified-existing-full-write-lock.ss"] [target-path (string-append vr-dir "/" target)] [initial "(import (jerboa prelude))\n(define (main)\n (display \"ok\")\n (newline))\n(main)"]