Improve agent workflow guidance support
ober
493972d331e185a947e62cdea8628fb98f6d2d4b
--- a/.jerbuild +++ b/.jerbuild @@ -30,6 +30,7 @@ (extra-sources ("vendor/jerboa-sqlite/jerboa_sqlite_shim.c" cflags: "-Isupport") ("src/jcode/ui/jcode_tui_shim.c" cflags: "-DTB_OPT_ATTR_W=32 -Ivendor/termbox2") + ("support/debug-repl-socket-shim.c") ("support/landlock-shim.c")) (extra-archives "support/sqlite-bundled/target/release/libjcode_sqlite_bundled.a") --- a/docs/cli.md +++ b/docs/cli.md @@ -25,10 +25,17 @@ Parsed before any subcommand. | `--tui` | — | Launch the terminal UI. | | `--no-tui` | — | Force the line-mode REPL (the default). | | `--no-mcp` | — | Skip MCP server initialization. | +| `--no-expert` | — | Disable configured expert escalation for this process. | | `--repl-port` | `N` | Start a debug Scheme REPL on `localhost:N`. | | `--verbose` | — | Log TUI events to `~/jcode.log`. | | `--trace` | `FILE` | Trace everything — full HTTP (keys redacted), tool args/results, logs. Implies `--debug`. Also honours `$JCODE_TRACE`. | +## Environment Overrides + +| Variable | Effect | +|---|---| +| `JCODE_CONTEXT_WINDOW` | Overrides model context-window metadata for the current process. Useful when a configured MLX provider points at a remote host with more KV-cache headroom than the local default. | + ## Subcommands | Subcommand | Purpose | @@ -78,13 +85,16 @@ jcode connect HOST:PORT --host NAME [--token T] # controller side ### `verified` ``` -jcode verified "<task>" [--bestof K] [--verify CMD] [--cwd DIR] [--write-scope PATHS] +jcode verified "<task>" [--bestof K] [--verify CMD] [--cwd DIR] [--write-scope PATHS] [--guidance-file FILE] ``` Runs an edit→verify→done loop on the live model: it edits, runs `--verify CMD` (e.g. `make test`), and only declares success once the command passes — optionally drawing the best of `K` diverse candidates. `--write-scope` accepts `all`, `none`, or comma-separated path prefixes such as `src/tetris/,tests/`. +`--guidance-file` appends caller-supplied task context to the verified workflow +prompt; use it for cookbook-generated task bundles or other external examples +without baking task-specific knowledge into jcode. See [FORGE.md](FORGE.md#verify-gate). @@ -146,7 +156,7 @@ Useful built-in workflow skill: | `/forge verify` | Describe + self-test the verify-gate. | | `/forge bestofk` · `/forge best-of-k` | Describe + self-test best-of-k generation. | | `/forge breaker` · `/forge no-progress` | Describe + self-test the no-progress breaker. | -| `/forge run [opts] <task>` | Verify-gated coding on the live model. Supports `--verify`, `--bestof`, `--cwd`, and `--write-scope`. | +| `/forge run [opts] <task>` | Verify-gated coding on the live model. Supports `--verify`, `--bestof`, `--cwd`, `--write-scope`, and `--guidance-file`. | Each `/forge` self-test runs real code against scripted inputs (no live model), so it doubles as a smoke test. Full semantics in [FORGE.md](FORGE.md). --- a/docs/escalation.md +++ b/docs/escalation.md @@ -156,6 +156,10 @@ model with a short handoff note explaining why the primary model was escalated. The expert response replaces the primary response. If the expert call fails, `jcode` falls back to the primary response instead of dropping a usable answer. +For provider evaluation runs where the primary model must be the only model +called, pass `--no-expert` or set `JCODE_NO_EXPERT=1`. This disables both the +explicit `<expert/>` route and automatic escalation for that process. + ## Provider availability `jcode` requests and parses logprobs on its OpenAI-compatible provider path. --- a/src/jcode/core/debug-repl.ss +++ b/src/jcode/core/debug-repl.ss @@ -33,9 +33,42 @@ (guard (e [#t #f]) (load-shared-object #f))) -(def c-socket (foreign-procedure "socket" (int int int) int)) -(def c-bind (foreign-procedure "bind" (int void* int) int)) -(def c-listen (foreign-procedure "listen" (int int) int)) +(def c-socket #f) +(def c-bind #f) +(def c-listen #f) +(def c-accept #f) +(def c-close #f) +(def c-setsockopt #f) +(def c-htons #f) +(def c-getsockname #f) +(def c-fcntl #f) +(def c-dup #f) +(def c-errno-location #f) + +(def (missing-ffi! name) + (error 'debug-repl "missing socket FFI symbol" name)) + +(def (resolve-c-socket) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_socket" (int int int) int)) + (guard (e [#t #f]) + (foreign-procedure "socket" (int int int) int)) + (missing-ffi! "jcode_socket/socket"))) + +(def (resolve-c-bind) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_bind" (int void* int) int)) + (guard (e [#t #f]) + (foreign-procedure "bind" (int void* int) int)) + (missing-ffi! "jcode_bind/bind"))) + +(def (resolve-c-listen) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_listen" (int int) int)) + (guard (e [#t #f]) + (foreign-procedure "listen" (int int) int)) + (missing-ffi! "jcode_listen/listen"))) + ;; accept(2) is __collect_safe so it does not pin Chez's TC mutex while ;; parked in the kernel. Without that, a debug-repl accept thread sleeping ;; in accept() blocks every other green thread (watchdogs, the streaming @@ -44,32 +77,90 @@ ;; the syscall does block (e.g. fcntl was rejected silently, or a brief ;; in-kernel wait), the scheduler must keep running. Same pattern as ;; jerboa_tls_read in provider.ss. -(def c-accept (foreign-procedure __collect_safe "accept" (int void* void*) int)) -(def c-close (foreign-procedure "close" (int) int)) -(def c-setsockopt (foreign-procedure "setsockopt" (int int int void* int) int)) -(def c-htons (foreign-procedure "htons" (unsigned-short) unsigned-short)) -(def c-getsockname (foreign-procedure "getsockname" (int void* void*) int)) +(def (resolve-c-accept) + (or (guard (e [#t #f]) + (foreign-procedure __collect_safe "jcode_accept" (int void* void*) int)) + (guard (e [#t #f]) + (foreign-procedure __collect_safe "accept" (int void* void*) int)) + (missing-ffi! "jcode_accept/accept"))) + +(def (resolve-c-close) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_close" (int) int)) + (guard (e [#t #f]) + (foreign-procedure "close" (int) int)) + (missing-ffi! "jcode_close/close"))) + +(def (resolve-c-setsockopt) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_setsockopt" (int int int void* int) int)) + (guard (e [#t #f]) + (foreign-procedure "setsockopt" (int int int void* int) int)) + (missing-ffi! "jcode_setsockopt/setsockopt"))) + +(def (resolve-c-htons) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_htons" (unsigned-short) unsigned-short)) + (guard (e [#t #f]) + (foreign-procedure "htons" (unsigned-short) unsigned-short)) + (missing-ffi! "jcode_htons/htons"))) + +(def (resolve-c-getsockname) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_getsockname" (int void* void*) int)) + (guard (e [#t #f]) + (foreign-procedure "getsockname" (int void* void*) int)) + (missing-ffi! "jcode_getsockname/getsockname"))) + ;; P4.2: fcntl is varargs (int int, ...). On macOS arm64 fixed-args use ;; one register file and varargs another — declaring a fixed (int int int) ;; binding lands the third arg in the wrong slot and the kernel sees junk ;; (F_SETFL silently rejects, set-nonblocking! becomes a no-op, then the ;; accept thread blocks every other green thread). __varargs_after marks -;; the variadic boundary so Chez uses the right calling convention. -(def c-fcntl (foreign-procedure (__varargs_after 2) "fcntl" (int int int) int)) -(def c-dup (foreign-procedure "dup" (int) int)) - -(def c-errno-location +;; the variadic boundary so Chez uses the right calling convention. The +;; jcode_fcntl wrapper is fixed-arity, so it does not need varargs metadata. +(def (resolve-c-fcntl) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_fcntl" (int int int) int)) + (guard (e [#t #f]) + (foreign-procedure (__varargs_after 2) "fcntl" (int int int) int)) + (missing-ffi! "jcode_fcntl/fcntl"))) + +(def (resolve-c-dup) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_dup" (int) int)) + (guard (e [#t #f]) + (foreign-procedure "dup" (int) int)) + (missing-ffi! "jcode_dup/dup"))) + +(def (resolve-c-errno-location) ;; macOS: __error, glibc: __errno_location, Bionic (Android/Termux): __errno. ;; Try each in turn; bind to the first one that resolves. - (let ((names '("__error" "__errno_location" "__errno"))) - (let loop ((ns names)) - (cond - ((null? ns) - (lambda () 0)) ;; fallback — get-errno will return 0 - (#t - (let ((proc (guard (e [#t #f]) - (foreign-procedure (car ns) () void*)))) - (if proc proc (loop (cdr ns))))))))) + (or (guard (e [#t #f]) + (foreign-procedure "jcode_errno_location" () void*)) + (let ((names '("__error" "__errno_location" "__errno"))) + (let loop ((ns names)) + (cond + ((null? ns) + (lambda () 0)) ;; fallback — get-errno will return 0 + (#t + (let ((proc (guard (e [#t #f]) + (foreign-procedure (car ns) () void*)))) + (if proc proc (loop (cdr ns)))))))))) + +(def (ensure-socket-ffi!) + (unless c-socket + (set! c-socket (resolve-c-socket)) + (set! c-bind (resolve-c-bind)) + (set! c-listen (resolve-c-listen)) + (set! c-accept (resolve-c-accept)) + (set! c-close (resolve-c-close)) + (set! c-setsockopt (resolve-c-setsockopt)) + (set! c-htons (resolve-c-htons)) + (set! c-getsockname (resolve-c-getsockname)) + (set! c-fcntl (resolve-c-fcntl)) + (set! c-dup (resolve-c-dup)) + (set! c-errno-location (resolve-c-errno-location)))) (def (get-errno) (foreign-ref 'int (c-errno-location) 0)) @@ -458,6 +549,7 @@ auto-assign; host an IPv4 dotted quad to bind, default 127.0.0.1. Non-loopback binds serve TLS and require the auth token (baked at build from .repl-token, or JCODE_REPL_TOKEN at runtime)." (stop-jcode-repl!) + (ensure-socket-ffi!) (let* ((port (if (pair? args) (car args) 0)) (host (and (pair? args) (pair? (cdr args)) (cadr args))) (ip (if host --- a/src/jcode/core/expert.ss +++ b/src/jcode/core/expert.ss @@ -24,6 +24,7 @@ (export *expert-sentinel* wants-expert? strip-expert-sentinel + current-expert-disabled config-expert-enabled? get-expert-provider expert-prompt-instructions @@ -40,6 +41,11 @@ (def logger (make-logger "expert")) +;; Evaluation runs sometimes need to guarantee that the configured primary +;; provider is the only model called. The parameter is set by --no-expert; +;; JCODE_NO_EXPERT provides the same behavior for scripts. +(def current-expert-disabled (make-parameter #f)) + ;; Optional escalation hook. When set (e.g. by the TUI worker), it is invoked ;; on the streaming path INSTEAD of pushing the text banner through token-cb, ;; so the UI can render a structured indicator and colour the expert's reply @@ -80,7 +86,10 @@ content)) (def (config-expert-enabled?) - (and (config-ref "expert" "provider") + (and (not (current-expert-disabled)) + (let ((v (getenv "JCODE_NO_EXPERT"))) + (not (and v (not (string=? v "")) (not (string=? v "0"))))) + (config-ref "expert" "provider") (config-ref "expert" "model") #t)) --- a/src/jcode/core/models.ss +++ b/src/jcode/core/models.ss @@ -498,40 +498,51 @@ ;; Approximate context window (in tokens) by model family. Used by the ;; TUI status bar to render a ctx% indicator. Conservative — favours ;; under-reporting so we never claim we have headroom we don't. +(def (context-window-env-override) + (let ((raw (getenv "JCODE_CONTEXT_WINDOW"))) + (and raw + (not (string=? raw "")) + (let ((n (string->number raw))) + (and (number? n) + (> n 0) + (inexact->exact (floor n))))))) + (def (model-context-window model-id) - (let ((mid (or model-id ""))) - (cond - ((or (string-contains mid "claude-opus-4") - (string-contains mid "claude-sonnet-4") - (string-contains mid "claude-haiku-4")) 200000) - ((string-contains mid "claude-3-5-sonnet") 200000) - ((string-contains mid "claude-3") 200000) - ((string-contains mid "gpt-4o") 128000) - ((string-contains mid "gpt-4-turbo") 128000) - ((string-contains mid "gpt-4.1") 1000000) - ((string-contains mid "o1") 128000) - ((string-contains mid "o3") 200000) - ((string-contains mid "gemini-1.5") 1000000) - ((string-contains mid "gemini-2") 1000000) - ;; Local mlx_lm LoRAs: KV cache stays fp16 even when weights are - ;; quantized, so the Metal wired-memory cap (not the architectural - ;; ctx limit) dominates. Keep this conservative so compaction kicks - ;; in before prefill blows the 32 GB wired budget. - ((string-contains mid "jerboa-mlx") 16384) - ;; majentik TurboQuant local MLX builds (Qwen3.6-35B-A3B 6-bit): ~28 GB - ;; weights leave only ~4 GB under the 32 GB wired cap, so keep the window - ;; conservative — compaction must fire before prefill OOMs the GPU. - ((string-contains mid "TurboQuant") 16384) - ;; The local qwen3-coder-next MLX server stalls around large prefill - ;; turns. jcode's estimator does not include the fixed tool-schema - ;; overhead, so this is an effective working budget rather than the - ;; model's architectural context window. - ((string-contains mid "qwen3-coder-next-mlx") 3072) - ;; grok-build: Grok CLI proxy advertises a 512k context window in - ;; ~/.grok/models_cache.json (info.context_window). Hardcode here so - ;; the TUI ctx% bar has a value even before models_cache.json is read. - ((string-contains mid "grok-build") 512000) - ((string-contains mid "qwen3") 32768) - ((string-contains mid "llama-3") 131072) - ((string-contains mid "deepseek") 131072) - (else #f)))) + (or (context-window-env-override) + (let ((mid (or model-id ""))) + (cond + ((or (string-contains mid "claude-opus-4") + (string-contains mid "claude-sonnet-4") + (string-contains mid "claude-haiku-4")) 200000) + ((string-contains mid "claude-3-5-sonnet") 200000) + ((string-contains mid "claude-3") 200000) + ((string-contains mid "gpt-4o") 128000) + ((string-contains mid "gpt-4-turbo") 128000) + ((string-contains mid "gpt-4.1") 1000000) + ((string-contains mid "o1") 128000) + ((string-contains mid "o3") 200000) + ((string-contains mid "gemini-1.5") 1000000) + ((string-contains mid "gemini-2") 1000000) + ;; Local mlx_lm LoRAs: KV cache stays fp16 even when weights are + ;; quantized, so the Metal wired-memory cap (not the architectural + ;; ctx limit) dominates. Keep this conservative so compaction kicks + ;; in before prefill blows the 32 GB wired budget. + ((string-contains mid "jerboa-mlx") 16384) + ;; majentik TurboQuant local MLX builds (Qwen3.6-35B-A3B 6-bit): ~28 GB + ;; weights leave only ~4 GB under the 32 GB wired cap, so keep the window + ;; conservative — compaction must fire before prefill OOMs the GPU. + ((string-contains mid "TurboQuant") 16384) + ;; The local qwen3-coder-next MLX server stalls around large prefill + ;; turns. jcode's estimator does not include the fixed tool-schema + ;; overhead, so this is an effective working budget rather than the + ;; model's architectural context window. Set JCODE_CONTEXT_WINDOW for + ;; remote/proxy runs with a larger KV-cache budget. + ((string-contains mid "qwen3-coder-next-mlx") 3072) + ;; grok-build: Grok CLI proxy advertises a 512k context window in + ;; ~/.grok/models_cache.json (info.context_window). Hardcode here so + ;; the TUI ctx% bar has a value even before models_cache.json is read. + ((string-contains mid "grok-build") 512000) + ((string-contains mid "qwen3") 32768) + ((string-contains mid "llama-3") 131072) + ((string-contains mid "deepseek") 131072) + (else #f))))) --- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -49,6 +49,244 @@ (if (<= len n) s (string-join (list-tail lines (- len n)) "\n")))) +(def (parse-digits-at s start) + (let ((n (string-length s))) + (let loop ((i start) (acc '())) + (cond + ((or (>= i n) (not (char-numeric? (string-ref s i)))) + (and (pair? acc) + (string->number (list->string (reverse acc))))) + (else + (loop (+ i 1) (cons (string-ref s i) acc))))))) + +(def (find-line-number-after s marker) + (let ((idx (find-substring-from s marker 0))) + (and idx + (parse-digits-at s (+ idx (string-length marker)))))) + +(def (token-end-index s start) + (let ((n (string-length s))) + (let loop ((i start)) + (cond + ((>= i n) n) + ((char-whitespace? (string-ref s i)) i) + ((char=? (string-ref s i) #\)) i) + (else (loop (+ i 1))))))) + +(def (find-source-path-after s start) + (let ((idx (find-substring-from s " of " start))) + (and idx + (let* ((p0 (+ idx 4)) + (p1 (token-end-index s p0))) + (substring s p0 p1))))) + +(def (trimmed-line-starts-define? line) + (let ((s (string-trim line))) + (or (string-prefix? "(define " s) + (string-prefix? "(define(" s) + (string-prefix? "(def " s) + (string-prefix? "(def(" s)))) + +(def (line-at lines line-no) + (and (>= line-no 1) + (<= line-no (length lines)) + (list-ref lines (- line-no 1)))) + +(def (previous-define-line lines line-no) + (let loop ((n (min line-no (length lines)))) + (cond + ((<= n 0) #f) + ((trimmed-line-starts-define? (line-at lines n)) n) + (else (loop (- n 1)))))) + +(def (next-define-line lines line-no) + (let loop ((n (+ line-no 1))) + (cond + ((> n (length lines)) #f) + ((trimmed-line-starts-define? (line-at lines n)) n) + (else (loop (+ n 1)))))) + +(def (make-required-range-repair path start end line-no (kind #f) (candidate #f)) + (list (cons 'path path) + (cons 'start start) + (cons 'end end) + (cons 'line line-no) + (cons 'kind kind) + (cons 'candidate candidate))) + +(def (repair-ref repair key) + (let ((p (and repair (assoc key repair)))) + (and p (cdr p)))) + +(def (range-repair-instruction repair) + (let ((path (repair-ref repair 'path)) + (start (repair-ref repair 'start)) + (end (repair-ref repair 'end))) + (format + "Structural repair required before more probing: read(path=\"~a\", start=~a, end=~a) if needed, then replace_range(path=\"~a\", start=~a, end=~a, content=<complete corrected span>) and call verify." + path start end path start end))) + +(def (verification-source-path cwd detail line-no) + (let ((from-detail (find-source-path-after detail 0))) + (cond + ((and from-detail (file-exists? (abs-path cwd from-detail))) + from-detail) + ((and from-detail (source-ss-path? from-detail)) from-detail) + (else #f)))) + +(def (invalid-context-repair detail cwd) + (if (not (string-contains detail "invalid context for definition")) + #f + (let ((line-no (find-line-number-after detail " at line "))) + (if (not line-no) + #f + (let ((path (verification-source-path cwd detail line-no))) + (if (not path) + #f + (let ((p (abs-path cwd path))) + (if (not (file-exists? p)) + #f + (let* ((lines (string-split (read-file-string p) #\newline)) + (start (or (previous-define-line lines (- line-no 1)) + line-no)) + (end (if (< start line-no) + (- line-no 1) + (min (length lines) (+ start 40))))) + (make-required-range-repair path start end line-no 'context)))))))))) + +(def (invalid-syntax-repair detail cwd) + (if (not (string-contains detail "invalid syntax")) + #f + (let ((line-no (find-line-number-after detail " at line "))) + (if (not line-no) + #f + (let ((path (verification-source-path cwd detail line-no))) + (if (not path) + #f + (let ((p (abs-path cwd path))) + (if (not (file-exists? p)) + #f + (let* ((lines (string-split (read-file-string p) #\newline)) + (start (or (previous-define-line lines line-no) + line-no)) + (next (next-define-line lines line-no)) + (end (if next + (- next 1) + (min (length lines) (+ start 60))))) + (make-required-range-repair path start end line-no 'syntax)))))))))) + +(def (drop-last-close-delim line) + (let ((n (string-length line))) + (let loop ((i (- n 1)) (suffix '())) + (cond + ((< i 0) #f) + ((char-whitespace? (string-ref line i)) + (loop (- i 1) (cons (string-ref line i) suffix))) + ((close-delim? (string-ref line i)) + (string-append + (substring line 0 i) + (list->string suffix))) + (else #f))))) + +(def (unexpected-close-repair detail cwd) + (if (not (or (string-contains detail "unexpected close parenthesis") + (string-contains detail "Unexpected close"))) + #f + (let ((line-no (find-line-number-after detail " at line "))) + (if (not line-no) + #f + (let ((path (verification-source-path cwd detail line-no))) + (if (not path) + #f + (let ((p (abs-path cwd path))) + (if (not (file-exists? p)) + #f + (let* ((lines (string-split (read-file-string p) #\newline)) + (line (line-at lines line-no)) + (candidate (and line (drop-last-close-delim line)))) + (and candidate + (make-required-range-repair + path line-no line-no line-no 'delimiter candidate))))))))))) + +(def (verify-range-repair detail cwd) + (or (invalid-context-repair detail cwd) + (invalid-syntax-repair detail cwd) + (unexpected-close-repair detail cwd))) + +(def (invalid-context-diagnosis detail cwd) + (let ((repair (invalid-context-repair detail cwd))) + (and repair + (let ((label (format "~a lines ~a-~a" + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end)))) + (string-append + (format + "\n\nStructural diagnosis: verifier reported an invalid definition context in ~a near line ~a. The file is delimiter-balanced, so the preceding definition likely swallowed that top-level definition. Repair the whole suspect span with replace_range, not old_str or a full-file rewrite:\n read(path=\"~a\", start=~a, end=~a)\n replace_range(path=\"~a\", start=~a, end=~a, content=<complete corrected definition/span>)\nThen call verify again." + (repair-ref repair 'path) + (repair-ref repair 'line) + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end) + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end)) + (minimal-repair-candidate-text cwd repair label)))))) + +(def (invalid-syntax-diagnosis detail cwd) + (let ((repair (invalid-syntax-repair detail cwd))) + (and repair + (let ((span (repair-span-content cwd repair))) + (string-append + (format + "\n\nSyntax diagnosis: verifier reported invalid syntax in ~a near line ~a. Repair the whole enclosing top-level span with replace_range, not shell inspection or a full-file rewrite:\n read(path=\"~a\", start=~a, end=~a)\n replace_range(path=\"~a\", start=~a, end=~a, content=<complete corrected span>)\nThen call verify again." + (repair-ref repair 'path) + (repair-ref repair 'line) + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end) + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end)) + (if (and span (<= (string-length span) 4000)) + (string-append "\n\nSuspect span:\n" span) + "") + (let ((label (format "~a lines ~a-~a" + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end)))) + (best-repair-candidate-text cwd repair label))))))) + +(def (unexpected-close-diagnosis detail cwd) + (let ((repair (unexpected-close-repair detail cwd))) + (and repair + (let ((label (required-repair-label repair))) + (string-append + (format + "\n\nDelimiter diagnosis: verifier reported an unexpected close delimiter in ~a at line ~a. Repair that exact line with replace_range, then call verify again:\n read(path=\"~a\", start=~a, end=~a)\n replace_range(path=\"~a\", start=~a, end=~a, content=<corrected line>)" + (repair-ref repair 'path) + (repair-ref repair 'line) + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end) + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end)) + (best-repair-candidate-text cwd repair label)))))) + +(def (augment-verify-detail detail cwd) + (let ((diagnosis (or (invalid-context-diagnosis detail cwd) + (invalid-syntax-diagnosis detail cwd) + (unexpected-close-diagnosis detail cwd)))) + (if diagnosis + (string-append detail diagnosis) + detail))) + +(def (verify-output-forced-failure? out) + (or (string-contains out "invalid context for definition") + (string-contains out "Exception:") + (string-contains out "Exception in read:"))) + ;; Run CMD via the shell in CWD; return (pass? . detail). detail is the tail of ;; combined stdout+stderr so a failing build rides back to the model as the ;; [ToolError] text it repairs against. @@ -59,13 +297,67 @@ (if (and stderr (not (string=? stderr ""))) (string-append "\n" stderr) ""))) (detail (string-append "exit " (number->string exit-code) "\n" - (tail-lines out 40)))) - (cons (= exit-code 0) detail)))) + (tail-lines out 40))) + (augmented (augment-verify-detail detail cwd))) + (cons (and (= exit-code 0) + (not (verify-output-forced-failure? out))) + augmented)))) ;; ── coding workflow tools ────────────────────────────────────────────── (def (arg-ref args key default) (let ((p (assoc key args))) (if p (cdr p) default))) +(def *tool-path-suffixes* + '(".ss" ".scm" ".sls" ".md" ".txt" ".json" ".yaml" ".yml" + ".c" ".h" ".rs" ".py" ".sh" ".png" ".html" ".css" ".js" + ".ts" ".tsx" ".jsx")) + +(def (contains-newline? s) + (or (string-contains s "\n") + (string-contains s "\r"))) + +(def (path-suffix? s) + (let loop ((suffixes *tool-path-suffixes*)) + (cond + ((null? suffixes) #f) + ((string-suffix? (car suffixes) s) #t) + (else (loop (cdr suffixes)))))) + +(def (path-like-file-arg? v) + (and (string? v) + (> (string-length v) 0) + (< (string-length v) 4096) + (not (contains-newline? v)) + (or (string-contains v "/") + (string=? v ".") + (string=? v "..") + (path-suffix? v)))) + +(def (arg-primary-path args) + (or (arg-ref args "path" #f) + (arg-ref args "file_path" #f) + (arg-ref args "filepath" #f) + (arg-ref args "filename" #f) + (arg-ref args "target" #f) + (arg-ref args "target_path" #f))) + +(def (arg-path args default) + (or (arg-primary-path args) + (let ((v (arg-ref args "file" #f))) + (and (path-like-file-arg? v) v)) + default)) + +(def (arg-content args) + (or (arg-ref args "content" #f) + (arg-ref args "contents" #f) + (arg-ref args "new_content" #f) + (arg-ref args "body" #f) + (arg-ref args "text" #f) + (let ((v (arg-ref args "file" #f))) + (and (or (arg-primary-path args) + (not (path-like-file-arg? v))) + v)))) + (def (arg-int args key default) (let ((v (arg-ref args key default))) (cond @@ -82,30 +374,229 @@ (def current-pending-ss-create-repair (make-parameter #f)) +(def current-rejected-ss-draft + (make-parameter #f)) + +(def current-rejected-draft-inspections + (make-parameter 0)) + (def current-after-failed-verify? (make-parameter #f)) (def current-inspections-after-failed-verify (make-parameter 0)) -(def inspection-after-failed-verify-limit 12) +(def current-edited-since-verify? + (make-parameter #f)) + +(def current-inspections-after-edit + (make-parameter 0)) + +(def current-last-verify-detail + (make-parameter #f)) + +(def current-required-range-repair + (make-parameter #f)) + +(def current-required-repair-inspections + (make-parameter 0)) + +(def inspection-after-failed-verify-limit 6) + +(def inspection-after-edit-limit 4) + +(def rejected-draft-inspection-limit 2) (def (reset-failed-verify-inspections!) (current-after-failed-verify? #f) - (current-inspections-after-failed-verify 0)) + (current-inspections-after-failed-verify 0) + (current-last-verify-detail #f) + (current-required-range-repair #f) + (current-required-repair-inspections 0)) (def (record-verify-result! result) (current-after-failed-verify? (not (and (pair? result) (car result)))) + (current-edited-since-verify? #f) + (current-inspections-after-edit 0) + (current-last-verify-detail + (and (pair? result) (not (car result)) (cdr result))) + (when (and (pair? result) (car result)) + (current-required-range-repair #f)) + (current-required-repair-inspections 0) (current-inspections-after-failed-verify 0) result) +(def (record-successful-edit! cwd path) + (clear-pending-ss-create-repair! cwd path) + (reset-failed-verify-inspections!) + (current-edited-since-verify? #t) + (current-inspections-after-edit 0)) + +(def (inspection-limit-message who) + (string-append + "inspection limit reached after failed verify while calling " + (symbol->string who) + ". Stop inspecting and call line_edit, replace_range, replace_def, or edit with the concrete repair now." + (let ((detail (current-last-verify-detail))) + (if detail + (string-append "\n\nLast verify failure:\n" (tail-lines detail 20)) + "")))) + (def (note-inspection-after-failed-verify! who) - (when (current-after-failed-verify?) + (if (current-after-failed-verify?) (let ((n (+ (current-inspections-after-failed-verify) 1))) (current-inspections-after-failed-verify n) - (when (> n inspection-after-failed-verify-limit) - (error who - "inspection limit reached after failed verify. Stop inspecting and call line_edit, replace_range, replace_def, or edit with the concrete repair now."))))) + (if (> n inspection-after-failed-verify-limit) + (inspection-limit-message who) + #f)) + #f)) + +(def (inspection-after-edit-message who) + (string-append + "inspection limit reached after edits while calling " + (symbol->string who) + ". The file has changed since the last verify. Call verify now to get the current compiler/runtime error; then repair with line_edit, replace_range, replace_def, or edit.")) + +(def (note-inspection-after-edit! who) + (if (current-edited-since-verify?) + (let ((n (+ (current-inspections-after-edit) 1))) + (current-inspections-after-edit n) + (if (> n inspection-after-edit-limit) + (inspection-after-edit-message who) + #f)) + #f)) + +(def (required-repair-message who repair) + (string-append + "A structural verifier diagnosis is pending; do not use " + (symbol->string who) + " for unrelated inspection or edits. " + (range-repair-instruction repair))) + +(def (repair-path-matches? cwd repair path) + (and repair + path + (same-verified-path? cwd (repair-ref repair 'path) path))) + +(def (read-range-start args) + (let ((start-line (arg-int args "start" 0)) + (line-no (arg-int args "line" 0)) + (offset (arg-int args "offset" -1))) + (cond + ((> start-line 0) start-line) + ((> line-no 0) line-no) + ((>= offset 0) (+ offset 1)) + (else 0)))) + +(def (read-range-end args start) + (let ((end-line (arg-int args "end" 0)) + (limit (arg-int args "limit" 0))) + (cond + ((> end-line 0) end-line) + ((and (> start 0) (> limit 0)) (+ start limit -1)) + ((and (> start 0) (= limit 0)) start) + (else 0)))) + +(def (read-covers-required-repair? args repair) + (let* ((start (read-range-start args)) + (end (read-range-end args start))) + (and (> start 0) + (> end 0) + (if (eq? (repair-ref repair 'kind) 'delimiter) + (and (= start (repair-ref repair 'start)) + (= end (repair-ref repair 'end))) + (and (<= start (repair-ref repair 'start)) + (>= end (repair-ref repair 'end))))))) + +(def (required-repair-read-block-message cwd args) + (let ((repair (current-required-range-repair))) + (and repair + (let ((path (arg-path args #f))) + (and (not (rejected-draft-content cwd path)) + (not (and (repair-path-matches? cwd repair path) + (read-covers-required-repair? args repair))) + (let ((inspection-count (note-required-repair-inspection!))) + (if (> inspection-count 1) + (required-repair-action-message cwd repair) + (required-repair-message 'read repair)))))))) + +(def (required-repair-tool-block-message cwd who args) + (let ((repair (current-required-range-repair))) + (and repair + (required-repair-message who repair)))) + +(def (replace-range-covers-required-repair? cwd args repair) + (let ((path (arg-path args #f)) + (start-line (arg-int args "start" 0)) + (end-line (arg-int args "end" 0))) + (and (repair-path-matches? cwd repair path) + (<= start-line (repair-ref repair 'start)) + (>= end-line (repair-ref repair 'end))))) + +(def (required-repair-label repair) + (format "~a lines ~a-~a" + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end))) + +(def (required-repair-best-candidate cwd repair) + (or (repair-ref repair 'candidate) + (let ((span (repair-span-content cwd repair))) + (and span + (best-repair-candidate + span + (required-repair-label repair)))))) + +(def (syntax-required-repair? repair) + (eq? (repair-ref repair 'kind) 'syntax)) + +(def (required-repair-effective-content cwd repair content) + (if repair + (let ((candidate (required-repair-best-candidate cwd repair))) + (cond + ((and candidate (syntax-required-repair? repair)) + candidate) + ((and candidate + (not (locally-safe-required-repair-content? + (repair-ref repair 'path) + content))) + candidate) + (else content))) + content)) + +(def (generated-required-repair-content? cwd repair content) + (let ((candidate (and repair (required-repair-best-candidate cwd repair)))) + (and candidate + (string? content) + (string=? content candidate)))) + +(def (delimiter-balance-guard-message? msg) + (and (string? msg) + (string-contains msg "delimiter balance failed"))) + +(def (locally-safe-required-repair-content? path content) + (and (string? content) + (not (jerboa-syntax-guard-message path content)))) + +(def (required-repair-replace-range-block-message cwd args) + (let ((repair (current-required-range-repair))) + (and repair + (not (replace-range-covers-required-repair? cwd args repair)) + (required-repair-message 'replace_range repair)))) + +(def (structural-repair-rejection-message cwd path msg) + (let ((repair (current-required-range-repair))) + (if (and repair (repair-path-matches? cwd repair path)) + (let ((label (format "~a lines ~a-~a" + (repair-ref repair 'path) + (repair-ref repair 'start) + (repair-ref repair 'end)))) + (string-append + msg + "\nThe file was not written. Structural repair is still pending; do not switch to edit or a full-file rewrite. " + (range-repair-instruction repair) + (best-repair-candidate-text cwd repair label))) + (string-append msg "\n" (ss-repair-instruction path))))) (def (same-verified-path? cwd a b) (and (string? a) @@ -116,7 +607,7 @@ (string-append "The file was not written. Next tool call must be edit with complete corrected contents for " path - ". Do not call run/list/read/balance/verify until that file exists.")) + ". You may call read(path,start,end) or balance(path) to inspect the rejected draft, then rewrite the complete file. Do not call run/list/verify until that file exists.")) (def (pending-ss-create-repair-message cwd) (let ((path (current-pending-ss-create-repair))) @@ -127,12 +618,48 @@ " was rejected by the Jerboa syntax guard and the file still does not exist. " (ss-repair-instruction path))))) +(def (rejected-draft-content cwd path) + (let ((draft (current-rejected-ss-draft))) + (and (pair? draft) + (same-verified-path? cwd (car draft) path) + (cdr draft)))) + +(def (note-rejected-draft-inspection! path content) + (let ((n (+ (current-rejected-draft-inspections) 1))) + (current-rejected-draft-inspections n) + (and (> n rejected-draft-inspection-limit) + (string-append + "Rejected draft inspection limit reached for " path + ". Stop reading this rejected draft. Next call must be edit with complete corrected contents for missing-file creation, or balance/verify on the unchanged file if it already exists.\n" + "Last balance result: " + (balance-report content path))))) + +(def (rejected-draft-read-message cwd path args) + (let ((content (rejected-draft-content cwd path))) + (and content + (or (note-rejected-draft-inspection! path content) + (string-append + "Rejected draft for " path + " (not written to disk). Inspect only enough to repair, then call edit with complete corrected contents.\n" + (slice-content content args)))))) + +(def (rejected-draft-balance-message cwd path) + (let ((content (rejected-draft-content cwd path))) + (and content + (or (note-rejected-draft-inspection! path content) + (string-append + (balance-report content path) + "\nRejected draft for " path + " was not written to disk; call edit with complete corrected contents after repair."))))) + (def (clear-pending-ss-create-repair! cwd path) (let ((pending (current-pending-ss-create-repair))) (when (and pending (same-verified-path? cwd pending path) (file-exists? (abs-path cwd path))) - (current-pending-ss-create-repair #f)))) + (current-pending-ss-create-repair #f) + (current-rejected-ss-draft #f) + (current-rejected-draft-inspections 0)))) (def (absolute-path-string? path) (and (string? path) @@ -263,12 +790,12 @@ (shown (if (> limit 0) (take-up-to tail limit) tail))) (string-join shown "\n"))))) -(def (do-read args cwd) - (note-inspection-after-failed-verify! 'read) - (let ((path (arg-ref args "path" #f))) +(def (do-read-current args cwd) + (let ((path (arg-path args #f))) (if (not path) (error 'read "missing path arg") (let ((p (abs-path cwd path))) (cond + ((rejected-draft-read-message cwd path args) => (lambda (msg) msg)) ((pending-ss-create-repair-message cwd) => (lambda (msg) msg)) ((not (file-exists? p)) (string-append "(file does not exist: " path ")")) @@ -276,28 +803,58 @@ (string-append "(path is a directory: " path "; use list)")) (else (slice-content (read-file-string p) args))))))) +(def (do-read args cwd) + (cond + ((required-repair-read-block-message cwd args) => (lambda (msg) msg)) + ((current-required-range-repair) (do-read-current args cwd)) + ((note-inspection-after-failed-verify! 'read) => (lambda (msg) msg)) + ((note-inspection-after-edit! 'read) => (lambda (msg) msg)) + (else (do-read-current args cwd)))) + (def (do-list args cwd) - (note-inspection-after-failed-verify! 'list) - (let* ((path (or (arg-ref args "path" #f) ".")) - (p (abs-path cwd path))) - (cond - ((pending-ss-create-repair-message cwd) => (lambda (msg) msg))