Shrink local model prompt surface
ober
2f308e13850ca445cabace35a249a37ff9efc2df
--- a/src/jcode/core/agent.ss +++ b/src/jcode/core/agent.ss @@ -10,6 +10,7 @@ current-usage-cb current-provider-override current-model-override + current-compact-agent-context get-current-provider forge-respond-enforced? forge-max-repeated-calls @@ -47,6 +48,37 @@ (def current-provider-override (make-parameter #f)) (def current-model-override (make-parameter #f)) +(def current-compact-agent-context (make-parameter #f)) + +(def *small-context-instruction-bytes* 3600) + +(def *small-context-tools* + '("apply_patch" "bash" "batch" "edit" "edit_block" "multi-edit" "patch" + "read" "write" "ls" "glob" "grep" "repomap" + "git_status" "git_diff" "git_log" "git_show" "git_commit" + "mcp_jerboa_jerboa")) + +(def (small-context-model? model-id) + (let ((win (model-context-window model-id))) + (and win (<= win 4096)))) + +(def (small-context-provider? provider) + (small-context-model? (provider-model provider))) + +(def (active-model-id) + (or (current-model-override) (config-ref "model") "")) + +(def (compact-agent-context?) + (or (current-compact-agent-context) + (small-context-model? (active-model-id)))) + +(def (with-provider-prompt-context provider thunk) + (let ((small? (small-context-provider? provider))) + (parameterize ((current-compact-agent-context small?) + (current-compact-tool-schemas small?) + (current-tool-allowlist + (if small? *small-context-tools* (current-tool-allowlist)))) + (thunk)))) ;; Forge guardrail policy. The guardrail layer (unknown-tool nudge + retry ;; budget + respond unwrap) is always-on for every provider. This parameter @@ -178,7 +210,6 @@ Working directory: ~a Current mode: ~a -You have access to these tools: ~a ~a @@ -194,7 +225,7 @@ IMPORTANT RULES: - 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. - 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>\"}. -- Use batch to parallelize independent reads. +- ~a CRITICAL — Tool invocation format: Invoke tools ONLY through the function-calling API (the structured tool_calls field of your response). NEVER write tool calls as @@ -212,9 +243,29 @@ Be concise. Prefer edit over write for modifying existing files. ~a" (current-directory) (mode-label (current-mode)) - (format-tool-list) + (system-tool-section) (mode-instructions (current-mode)) (expert-prompt-instructions) + (system-parallelism-rule) + (agent-instructions-for-prompt))) + +(def (system-tool-section) + (cond + ((compact-agent-context?) + "Structured function tools are available through the API schema. Use exact schema arg names. Prefer ls/read/grep/glob/repomap to inspect, edit/apply_patch for changes, bash for verification, and git_status/git_diff/git_commit for commits.") + (else + (string-append + "You have access to these tools:\n" + (format-tool-list))))) + +(def (system-parallelism-rule) + (if (compact-agent-context?) + "Use batch only when the schema is available and the calls are independent." + "Use batch to parallelize independent reads.")) + +(def (agent-instructions-for-prompt) + (if (compact-agent-context?) + (collect-agent-instructions-limited *small-context-instruction-bytes*) (collect-agent-instructions))) (def (format-tool-list) @@ -246,7 +297,7 @@ Be concise. Prefer edit over write for modifying existing files. (def *max-tool-rounds* 100) (def *max-tool-lines* 2000) (def *max-tool-bytes* 51200) ;; 50KB -(def *local-max-tool-bytes* 8192) +(def *local-max-tool-bytes* 2048) (def (refresh-system-prompt messages) "Replace the leading system message (if any) with a fresh one reflecting @@ -1254,53 +1305,58 @@ Be concise. Prefer edit over write for modifying existing files. ;; In respond-forcing mode, expose the synthetic respond tool so the model ;; has a structured way to answer the user while staying in tool-calling mode. (when (forge-respond-enforced?) (register-respond-tool!)) - (let ((existing (session-get-messages session-id))) - (when (null? existing) - (session-add-message session-id (make-system-message (system-prompt))))) - (session-add-message session-id (make-user-message (expand-mentions user-input))) - ;; One guardrails instance per user turn — its retry/error budget persists - ;; 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))) - (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))))) + (let ((provider (get-current-provider))) + (with-provider-prompt-context provider + (lambda () + (let ((existing (session-get-messages session-id))) + (when (null? existing) + (session-add-message session-id (make-system-message (system-prompt))))) + (session-add-message session-id (make-user-message (expand-mentions user-input))) + ;; One guardrails instance per user turn — its retry/error budget persists + ;; 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))) + (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)))))))) (def (agent-loop session-id messages round gr) - (let* ((provider (get-current-provider)) - (tools (get-tool-schemas)) - (msgs (refresh-system-prompt messages)) - (response (chat-with-expert provider msgs tools))) - (log-debug logger "got-response" `((role . ,(message-role response)))) - ;; Detect text-format tool calls (some models output tool calls as text) - (let* ((content (or (message-content response) "")) - (real-tcs (message-tool-calls response)) - (text-tcs (if (and (not real-tcs) (not (string=? content ""))) - (try-parse-text-tool-calls content) - '())) - (hermes-tcs (if (and (not real-tcs) (null? text-tcs) - (not (string=? content ""))) - (try-parse-hermes-tool-calls content) - '())) - (effective - (cond - ((not (null? text-tcs)) - (make-assistant-message #f text-tcs)) - ((not (null? hermes-tcs)) - (let ((clean (strip-hermes-blocks content))) - (make-assistant-message - (if (string=? clean "") #f clean) - hermes-tcs))) - (else response))) - (tcs (or (message-tool-calls effective) '()))) - (cond - ;; Bare text with respond-forcing off: a normal terminal answer. - ((and (null? tcs) (not (forge-respond-enforced?))) - (session-add-message session-id effective) - effective) - (else - (agent-guardrails-step - session-id provider effective content tcs round gr)))))) + (let ((provider (get-current-provider))) + (with-provider-prompt-context provider + (lambda () + (let* ((tools (get-tool-schemas)) + (msgs (refresh-system-prompt messages)) + (response (chat-with-expert provider msgs tools))) + (log-debug logger "got-response" `((role . ,(message-role response)))) + ;; Detect text-format tool calls (some models output tool calls as text) + (let* ((content (or (message-content response) "")) + (real-tcs (message-tool-calls response)) + (text-tcs (if (and (not real-tcs) (not (string=? content ""))) + (try-parse-text-tool-calls content) + '())) + (hermes-tcs (if (and (not real-tcs) (null? text-tcs) + (not (string=? content ""))) + (try-parse-hermes-tool-calls content) + '())) + (effective + (cond + ((not (null? text-tcs)) + (make-assistant-message #f text-tcs)) + ((not (null? hermes-tcs)) + (let ((clean (strip-hermes-blocks content))) + (make-assistant-message + (if (string=? clean "") #f clean) + hermes-tcs))) + (else response))) + (tcs (or (message-tool-calls effective) '()))) + (cond + ;; Bare text with respond-forcing off: a normal terminal answer. + ((and (null? tcs) (not (forge-respond-enforced?))) + (session-add-message session-id effective) + effective) + (else + (agent-guardrails-step + session-id provider effective content tcs round gr))))))))) ;; Apply the guardrail verdict to a (possibly tool-calling) response, then ;; act: stop on fatal, inject a corrective signal on retry, unwrap respond() @@ -1381,47 +1437,49 @@ Be concise. Prefer edit over write for modifying existing files. (def (agent-loop-stream session-id messages round gr) ;; Streaming version: calls (current-stream-cb) for each text token. - (let* ((provider (get-current-provider)) - (tools (get-tool-schemas)) - (msgs (refresh-system-prompt messages)) - (raw-cb (current-stream-cb)) - (cb (and raw-cb (make-tool-call-stream-filter raw-cb)))) - (let-values (((content tool-calls usage) - (stream-chat-with-expert provider msgs tools cb))) - (when (and usage (current-usage-cb)) - ((current-usage-cb) usage)) - ;; Detect text-format tool calls (some models output tool calls as text) - (let* ((text-tcs (if (and (null? tool-calls) (not (string=? content ""))) - (try-parse-text-tool-calls content) - '())) - (hermes-tcs (if (and (null? tool-calls) (null? text-tcs) - (not (string=? content ""))) - (try-parse-hermes-tool-calls content) - '())) - (effective-tcs - (cond - ((not (null? tool-calls)) tool-calls) - ((not (null? text-tcs)) text-tcs) - ((not (null? hermes-tcs)) hermes-tcs) - (else '()))) - (effective-content - (cond - ((not (null? text-tcs)) #f) - ((not (null? hermes-tcs)) - (let ((clean (strip-hermes-blocks content))) - (if (string=? clean "") #f clean))) - (else (if (string=? content "") #f content)))) - (response (make-assistant-message - effective-content - (if (null? effective-tcs) #f effective-tcs)))) - (cond - ;; Bare text with respond-forcing off: a normal terminal answer. - ((and (null? effective-tcs) (not (forge-respond-enforced?))) - (session-add-message session-id response) - response) - (else - (agent-guardrails-step-stream - session-id provider raw-cb response content effective-tcs round gr))))))) + (let ((provider (get-current-provider))) + (with-provider-prompt-context provider + (lambda () + (let* ((tools (get-tool-schemas)) + (msgs (refresh-system-prompt messages)) + (raw-cb (current-stream-cb)) + (cb (and raw-cb (make-tool-call-stream-filter raw-cb)))) + (let-values (((content tool-calls usage) + (stream-chat-with-expert provider msgs tools cb))) + (when (and usage (current-usage-cb)) + ((current-usage-cb) usage)) + ;; Detect text-format tool calls (some models output tool calls as text) + (let* ((text-tcs (if (and (null? tool-calls) (not (string=? content ""))) + (try-parse-text-tool-calls content) + '())) + (hermes-tcs (if (and (null? tool-calls) (null? text-tcs) + (not (string=? content ""))) + (try-parse-hermes-tool-calls content) + '())) + (effective-tcs + (cond + ((not (null? tool-calls)) tool-calls) + ((not (null? text-tcs)) text-tcs) + ((not (null? hermes-tcs)) hermes-tcs) + (else '()))) + (effective-content + (cond + ((not (null? text-tcs)) #f) + ((not (null? hermes-tcs)) + (let ((clean (strip-hermes-blocks content))) + (if (string=? clean "") #f clean))) + (else (if (string=? content "") #f content)))) + (response (make-assistant-message + effective-content + (if (null? effective-tcs) #f effective-tcs)))) + (cond + ;; Bare text with respond-forcing off: a normal terminal answer. + ((and (null? effective-tcs) (not (forge-respond-enforced?))) + (session-add-message session-id response) + response) + (else + (agent-guardrails-step-stream + session-id provider raw-cb response content effective-tcs round gr)))))))))) ;; Streaming twin of agent-guardrails-step: same verdict logic, but the ;; round-cap finalization streams its tokens and recursion stays on the @@ -1590,15 +1648,17 @@ Be concise. Prefer edit over write for modifying existing files. (make-provider provider-name api-key model))) (def (agent-chat user-input) - (let* ((provider (get-current-provider)) - (tools (get-tool-schemas)) - (messages (list - (make-system-message (system-prompt)) - (make-user-message user-input)))) - (parameterize ((forge-breaker-state (make-forge-breaker-state))) - (if (current-stream-cb) - (agent-chat-loop-stream provider messages tools 0) - (agent-chat-loop provider messages tools 0))))) + (let ((provider (get-current-provider))) + (with-provider-prompt-context provider + (lambda () + (let* ((tools (get-tool-schemas)) + (messages (list + (make-system-message (system-prompt)) + (make-user-message user-input)))) + (parameterize ((forge-breaker-state (make-forge-breaker-state))) + (if (current-stream-cb) + (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 messages) @@ -1659,10 +1719,12 @@ Be concise. Prefer edit over write for modifying existing files. built by the caller). Returns (values final-content final-messages) so callers — the resumable task tool — can persist the transcript and continue the same sub-agent conversation later." - (let ((provider (get-current-provider)) - (tools (get-tool-schemas))) - (parameterize ((forge-breaker-state (make-forge-breaker-state))) - (agent-chat-loop-track-stream provider messages tools 0)))) + (let ((provider (get-current-provider))) + (with-provider-prompt-context provider + (lambda () + (let ((tools (get-tool-schemas))) + (parameterize ((forge-breaker-state (make-forge-breaker-state))) + (agent-chat-loop-track-stream provider messages tools 0))))))) (def (agent-chat-loop-track-stream provider messages tools round) ;; Task/sub-agent conversations are not rendered token-by-token, but they @@ -1730,6 +1792,8 @@ Be concise. Prefer edit over write for modifying existing files. (agent-chat-loop-track provider new-messages tools (+ round 1))))))) (def (agent-step messages) - (let* ((provider (get-current-provider)) - (tools (get-tool-schemas))) - (chat-with-expert provider messages tools))) + (let ((provider (get-current-provider))) + (with-provider-prompt-context provider + (lambda () + (let ((tools (get-tool-schemas))) + (chat-with-expert provider messages tools)))))) --- a/src/jcode/core/agents-md.ss +++ b/src/jcode/core/agents-md.ss @@ -11,7 +11,8 @@ ;;; block. If no files are found we emit the empty string so the system ;;; prompt is unchanged. -(export collect-agent-instructions) +(export collect-agent-instructions + collect-agent-instructions-limited) (import :std/os/path :std/misc/string @@ -23,6 +24,12 @@ (def *agent-file-names* '("AGENTS.md" "CLAUDE.md" ".cursorrules" ".jcoderules")) +(def *instructions-prefix* + "\n--- Project instructions (hierarchical AGENTS.md / CLAUDE.md / .cursorrules) ---\n") + +(def *instructions-suffix* + "\n--- End project instructions ---\n") + (def (collect-agent-instructions) "Return a single string with all discovered instructions blocks, or the empty string if none were found." @@ -31,10 +38,58 @@ (cond ((null? blocks) "") (else - (string-append - "\n--- Project instructions (hierarchical AGENTS.md / CLAUDE.md / .cursorrules) ---\n" - (string-join blocks "\n\n") - "\n--- End project instructions ---\n"))))) + (format-agent-instructions blocks 0))))) + +(def (collect-agent-instructions-limited max-bytes) + "Return discovered instructions, keeping the most-specific files first when + MAX-BYTES forces truncation. This is used only for small local models where + global instruction files can exceed the whole practical prompt budget." + (let* ((paths (discover-agent-files)) + (blocks (filter-map read-block paths))) + (cond + ((null? blocks) "") + (else + (let ((picked (pick-specific-blocks blocks max-bytes))) + (format-agent-instructions (car picked) (cdr picked))))))) + +(def (format-agent-instructions blocks omitted) + (string-append + *instructions-prefix* + (if (> omitted 0) + (format "[omitted ~a older/global instruction block(s) for small local context]\n\n" + omitted) + "") + (string-join blocks "\n\n") + *instructions-suffix*)) + +(def (pick-specific-blocks blocks max-bytes) + (let loop ((remaining (reverse blocks)) + (used 0) + (acc '()) + (omitted 0)) + (cond + ((null? remaining) + (if (null? acc) + (let ((fallback (truncate-block (car (reverse blocks)) max-bytes))) + (cons (list fallback) (- (length blocks) 1))) + (cons acc omitted))) + (else + (let* ((block (car remaining)) + (cost (+ (string-length block) 2))) + (cond + ((<= (+ used cost) max-bytes) + (loop (cdr remaining) (+ used cost) (cons block acc) omitted)) + (else + (loop (cdr remaining) used acc (+ omitted 1))))))))) + +(def (truncate-block block max-bytes) + (let* ((budget (max 0 (- max-bytes 80))) + (n (min (string-length block) budget))) + (if (>= n (string-length block)) + block + (string-append + (substring block 0 n) + "\n[truncated for small local context]")))) (def (discover-agent-files) "Return absolute paths to instruction files, ordered global-first then --- a/src/jcode/tool/registry.ss +++ b/src/jcode/tool/registry.ss @@ -8,6 +8,8 @@ tool->openai-schema current-mode current-disabled-tools + current-tool-allowlist + current-compact-tool-schemas mode-allows-tool? mode-blocked-message write-tool-name? @@ -34,6 +36,8 @@ ;; AND rejected at execute time as a safety net. (def current-mode (make-parameter 'build)) (def current-disabled-tools (make-parameter '())) +(def current-tool-allowlist (make-parameter #f)) +(def current-compact-tool-schemas (make-parameter #f)) ;; Names of tools that mutate state (filesystem, processes, network sends, ;; git commits). Read-only tools (read, ls, glob, grep, git_status, git_diff, @@ -49,7 +53,9 @@ (not (write-tool-name? name)))) (def (tool-disabled? name) - (and (member name (current-disabled-tools)) #t)) + (let ((allow (current-tool-allowlist))) + (or (and (member name (current-disabled-tools)) #t) + (and allow (not (member name allow)))))) (def (mode-blocked-message name) (format "Tool '~a' is blocked in PLAN mode (read-only). Switch to BUILD mode with /build to run write tools." @@ -130,13 +136,16 @@ truncated))))))))))) (def (get-tool-schemas) - (map tool->openai-schema - (filter (lambda (t) - (and t - (not (hash-get t "internal")) - (mode-allows-tool? (hash-ref t "name" "")))) - (map (lambda (name) (hash-get *tools* name)) - (list-tools))))) + (let ((mapper (if (current-compact-tool-schemas) + tool->compact-openai-schema + tool->openai-schema))) + (map mapper + (filter (lambda (t) + (and t + (not (hash-get t "internal")) + (mode-allows-tool? (hash-ref t "name" "")))) + (map (lambda (name) (hash-get *tools* name)) + (list-tools)))))) (def (list-tools) (filter (lambda (name) (not (tool-disabled? name))) @@ -206,3 +215,59 @@ (hash-put! fn "parameters" (hash-ref tool "schema" (make-hash-table))) (hash-put! ht "function" fn)) ht)) + +(def (tool->compact-openai-schema tool) + "Small local models spend most of their time in prompt prefill when every + tool/property description is serialized. Keep the machine-readable shape + but omit prose descriptions." + (let ((ht (make-hash-table))) + (hash-put! ht "type" "function") + (let ((fn (make-hash-table))) + (hash-put! fn "name" (hash-ref tool "name" "")) + (hash-put! fn "description" "") + (hash-put! fn "parameters" + (compact-json-schema (hash-ref tool "schema" (make-hash-table)))) + (hash-put! ht "function" fn)) + ht)) + +(def (compact-json-schema schema) + (cond + ((not (hash-table? schema)) schema) + (else + (let ((out (make-hash-table))) + (let ((ty (hash-get schema "type"))) + (when ty (hash-put! out "type" ty))) + (let ((req (hash-get schema "required"))) + (when req (hash-put! out "required" req))) + (let ((props (hash-get schema "properties"))) + (when (hash-table? props) + (let ((out-props (make-hash-table))) + (for-each + (lambda (k) + (hash-put! out-props k + (compact-json-property (hash-get props k)))) + (hash-keys props)) + (hash-put! out "properties" out-props)))) + (let ((items (hash-get schema "items"))) + (when items (hash-put! out "items" (compact-json-schema items)))) + out)))) + +(def (compact-json-property prop) + (cond + ((not (hash-table? prop)) prop) + (else + (let ((out (make-hash-table))) + (let ((ty (hash-get prop "type"))) + (when ty (hash-put! out "type" ty))) + (let ((items (hash-get prop "items"))) + (when items (hash-put! out "items" (compact-json-schema items)))) + (let ((props (hash-get prop "properties"))) + (when (hash-table? props) + (let ((out-props (make-hash-table))) + (for-each + (lambda (k) + (hash-put! out-props k + (compact-json-property (hash-get props k)))) + (hash-keys props)) + (hash-put! out "properties" out-props)))) + out)))) --- a/test/run.ss +++ b/test/run.ss @@ -2100,6 +2100,14 @@ ;; Context-disabled tools: sub-agents use this to hide task from prompts, ;; structured schemas, text-tool recovery, and direct execution. (init-task-tool) +(define (schema-by-name schemas wanted) + (let loop ([xs schemas]) + (cond [(null? xs) #f] + [else + (let* ([fn (hashtable-ref (car xs) "function" #f)] + [name (and fn (hashtable-ref fn "name" #f))]) + (if (equal? name wanted) (car xs) (loop (cdr xs))))]))) + (parameterize ([current-disabled-tools '("task")]) (check! "disabled task hidden from list-tools" (and (member "task" (list-tools)) #t) #f) @@ -2117,6 +2125,36 @@ (tool-execute "task" (args "description" "x" "prompt" "x")) (lambda (s) (str-contains? s "unavailable in this context")))) +(parameterize ([current-tool-allowlist '("read")]) + (check! "allowlist hides task from list-tools" + (and (member "task" (list-tools)) #t) #f) + (check! "allowlist hides task from tool-exists?" + (tool-exists? "task") #f) + (check-pred! "allowlist execution rejected" + (tool-execute "task" (args "description" "x" "prompt" "x")) + (lambda (s) (str-contains? s "unavailable in this context")))) + +(parameterize ([current-compact-tool-schemas #t] + [current-tool-allowlist '("task")]) + (let* ([schema (schema-by-name (get-tool-schemas) "task")] + [fn (and schema (hashtable-ref schema "function" #f))] + [params (and fn (hashtable-ref fn "parameters" #f))] + [props (and params (hashtable-ref params "properties" #f))] + [desc-prop (and props (hashtable-ref props "description" #f))]) + (check! "compact schema keeps task visible" (and schema #t) #t) + (check! "compact schema omits function description" + (hashtable-ref fn "description" #f) "") + (check! "compact schema keeps required args" + (hashtable-ref params "required" #f) + '("description" "prompt")) + (check! "compact schema omits property description" + (hashtable-ref desc-prop "description" #f) #f))) + +(parameterize ([current-compact-agent-context #t]) + (check-pred! "compact system prompt uses structured schema note" + (system-prompt) + (lambda (s) (str-contains? s "Structured function tools are available")))) + ;; Task session store: put / resume-shape / eviction cap. (task-session-clear!) (task-session-put! "t1" "delegate" '(m1 m2))