forge phase 1: rescue unification + message types
ober
203d6878a1e6f2270b9f25bfb01665d970c59878
--- a/build-binary.ss +++ b/build-binary.ss @@ -131,6 +131,8 @@ "lib/jcode/core/builtin-skills" "lib/jcode/guardrails/nudge" "lib/jcode/guardrails/error-tracker" + "lib/jcode/guardrails/message-type" + "lib/jcode/guardrails/rescue" "lib/jcode/provider/provider" "lib/jcode/tool/registry" "lib/jcode/tool/file" new file mode 100644 --- /dev/null +++ b/src/jcode/guardrails/message-type.ss @@ -0,0 +1,55 @@ +;;; jcode guardrail message types +;;; +;;; Verbatim port of forge's MessageType enum (core/messages.py) plus the +;;; Nudge.kind → MessageType mapping (core/inference.py _NUDGE_KIND_TO_TYPE). +;;; A message-type is a metadata tag used to prioritize messages during +;;; context compaction (consumed by the tiered compaction strategy). Values +;;; are the exact forge string tags — do not rename. + +(export message-type-system-prompt + message-type-user-input + message-type-tool-call + message-type-tool-result + message-type-reasoning + message-type-text-response + message-type-step-nudge + message-type-prerequisite-nudge + message-type-retry-nudge + message-type-context-warning + message-type-summary + message-type? + nudge-kind->message-type) + +;; The 11 forge MessageType tags (string values, byte-identical to forge). +(def message-type-system-prompt "system_prompt") +(def message-type-user-input "user_input") +(def message-type-tool-call "tool_call") +(def message-type-tool-result "tool_result") +(def message-type-reasoning "reasoning") +(def message-type-text-response "text_response") +(def message-type-step-nudge "step_nudge") +(def message-type-prerequisite-nudge "prerequisite_nudge") +(def message-type-retry-nudge "retry_nudge") +(def message-type-context-warning "context_warning") +(def message-type-summary "summary") + +(def *all-message-types* + (list message-type-system-prompt message-type-user-input + message-type-tool-call message-type-tool-result + message-type-reasoning message-type-text-response + message-type-step-nudge message-type-prerequisite-nudge + message-type-retry-nudge message-type-context-warning + message-type-summary)) + +(def (message-type? x) + (and (string? x) (member x *all-message-types*) #t)) + +;; Nudge.kind → MessageType (forge core/inference.py _NUDGE_KIND_TO_TYPE). +;; Both "retry" and "unknown_tool" map to retry_nudge. Unknown kinds → #f. +(def (nudge-kind->message-type kind) + (cond + ((string=? kind "retry") message-type-retry-nudge) + ((string=? kind "unknown_tool") message-type-retry-nudge) + ((string=? kind "step") message-type-step-nudge) + ((string=? kind "prerequisite") message-type-prerequisite-nudge) + (else #f))) new file mode 100644 --- /dev/null +++ b/src/jcode/guardrails/rescue.ss @@ -0,0 +1,353 @@ +;;; jcode guardrail rescue — parse tool calls from free-text model output +;;; +;;; Canonical port of forge's rescue_tool_call (prompts/templates.py). When a +;;; local model emits a tool call as plain text instead of via the structured +;;; tool_calls field, this lifts it back out. Four strategies, tried in order; +;;; the first that yields any call wins (no double-counting): +;;; +;;; 1. JSON {"tool":"name","args":{...}} or {"name":..,"arguments":..} +;;; (also inside ``` fences, <tool_call> tags, or prose) +;;; 2. rehearsal name[ARGS]{...} +;;; 3. Qwen Coder <function=name><parameter=key>value</parameter></function> +;;; 4. Mistral [TOOL_CALLS]name{...} +;;; +;;; <think>…</think> and [THINK]…[/THINK] blocks are stripped first. Returns a +;;; list of jcode tool-calls (args stored as a JSON string, jcode convention). +;;; Provider-level rescue (provider.ss) will delegate here once the guardrail +;;; loop is wired in a later phase. + +(export rescue-tool-call + strip-think-tags) + +(import :std/text/json + :std/misc/string + :jcode/core/message) + +;; ── small string helpers ───────────────────────────────────────────── + +;; First index >= start where SUB occurs in S, or #f. +(def (str-find s sub start) + (let ((slen (string-length s)) (sublen (string-length sub))) + (let loop ((i start)) + (cond + ((> (+ i sublen) slen) #f) + ((string=? (substring s i (+ i sublen)) sub) i) + (else (loop (+ i 1))))))) + +;; Last index where single char CH occurs in S, or #f. +(def (last-char-index s ch) + (let loop ((i (- (string-length s) 1))) + (cond + ((< i 0) #f) + ((char=? (string-ref s i) ch) i) + (else (loop (- i 1)))))) + +(def (word-char? c) + (or (char-alphabetic? c) (char-numeric? c) (char=? c #\_))) + +(def (json-null v) (if (eq? v (void)) #f v)) + +;; Parse S as JSON, returning #f on any error (forge catches JSONDecodeError). +(def (safe-json s) + (guard (e [#t #f]) (string->json-object s))) + +;; forge: args = data.get("args"); if None: data.get("arguments", {}). +;; jcode stores args as a JSON string, so serialize whatever object we got. +(def (args->json-string args) + (if args (json-object->string args) "{}")) + +;; ── think-tag stripping ─────────────────────────────────────────────── + +;; Remove the earliest <think>…</think> or [THINK]…[/THINK] span. Returns +;; (values new-string changed?). An opener with no matching closer is left in +;; place (the forge regex would not match it). +(def (strip-one-think-pair s) + (let ((a (str-find s "<think>" 0)) + (b (str-find s "[THINK]" 0))) + (cond + ((and (not a) (not b)) (values s #f)) + (else + (let-values (((open-pos open-tag close-tag) + (cond + ((not a) (values b "[THINK]" "[/THINK]")) + ((not b) (values a "<think>" "</think>")) + ((<= b a) (values b "[THINK]" "[/THINK]")) + (else (values a "<think>" "</think>"))))) + (let ((close-pos (str-find s close-tag (+ open-pos (string-length open-tag))))) + (if (not close-pos) + (values s #f) + (values + (string-append + (substring s 0 open-pos) + (substring s (+ close-pos (string-length close-tag)) (string-length s))) + #t)))))))) + +;; Strip all think blocks, then trim. forge: _THINK_TAG_RE.sub("", text).strip() +(def (strip-think-tags text) + (let loop ((s text)) + (let-values (((s2 changed?) (strip-one-think-pair s))) + (if changed? (loop s2) (string-trim s))))) + +;; ── strategy 1: JSON brace-scan ────────────────────────────────────── + +;; Remove ```json / ``` code fences (forge strips them before the brace scan; +;; the scan itself is fence-agnostic, but we mirror forge for fidelity). +(def (strip-code-fences s) + (let loop ((s s)) + (let ((p (str-find s "```" 0))) + (cond + ((not p) s) + (else + (let* ((after (+ p 3)) + ;; skip an optional "json" language tag + following whitespace + (after (if (and (<= (+ after 4) (string-length s)) + (string=? (substring s after (+ after 4)) "json")) + (+ after 4) after)) + (after (skip-ws s after))) + (loop (string-append (substring s 0 p) (substring s after (string-length s)))))))))) + +(def (skip-ws s i) + (let ((slen (string-length s))) + (let lp ((j i)) + (if (and (< j slen) (char-whitespace? (string-ref s j))) (lp (+ j 1)) j)))) + +;; Naive brace-depth scan (NOT string-aware — matches forge extract_tool_call). +;; From index I (an open brace), return index of the matching close, or #f. +(def (naive-brace-end s i slen) + (let loop ((j i) (depth 0)) + (cond + ((>= j slen) #f) + (else + (let ((c (string-ref s j))) + (cond + ((char=? c #\{) (loop (+ j 1) (+ depth 1))) + ((char=? c #\}) + (let ((d (- depth 1))) + (if (= d 0) j (loop (+ j 1) d)))) + (else (loop (+ j 1) depth)))))))) + +;; Parse one balanced {…} candidate into a tool-call, or #f. +;; Accepts forge style {"tool",.."args"} and OpenAI style {"name",.."arguments"}. +(def (try-json-tool-call json-str tools) + (let ((data (safe-json json-str))) + (cond + ((not (hash-table? data)) #f) + (else + (let ((name (or (json-null (hash-ref data "tool" #f)) + (json-null (hash-ref data "name" #f))))) + (cond + ((not (and name (member name tools))) #f) + (else + (let ((args (let ((a (json-null (hash-ref data "args" #f)))) + (if a a (json-null (hash-ref data "arguments" #f)))))) + (make-tool-call name (args->json-string args)))))))))) + +(def (rescue-json cleaned tools) + (let* ((s (strip-code-fences cleaned)) + (slen (string-length s)) + (out (box '()))) + (let loop ((i 0)) + (cond + ((>= i slen) (reverse (unbox out))) + ((char=? (string-ref s i) #\{) + (let ((j (naive-brace-end s i slen))) + (cond + ((not j) (loop (+ i 1))) + (else + (let ((tc (try-json-tool-call (substring s i (+ j 1)) tools))) + (when tc (set-box! out (cons tc (unbox out))))) + (loop (+ j 1)))))) + (else (loop (+ i 1))))))) + +;; ── strategy 2: rehearsal name[ARGS]{…} ───────────────────────────── +;; forge regex (\w+)\[ARGS\](\{.*\}) is greedy/DOTALL: the args span runs from +;; the first '{' after [ARGS] to the LAST '}' in the text. That makes it a +;; single-call strategy in practice (two rehearsals → invalid JSON → none). + +(def (word-before s end) + (let loop ((i end)) + (cond + ((and (> i 0) (word-char? (string-ref s (- i 1)))) (loop (- i 1))) + ((= i end) #f) + (else (substring s i end))))) + +(def (rescue-rehearsal cleaned tools) + (let ((marker (str-find cleaned "[ARGS]" 0))) + (cond + ((not marker) '()) + (else + (let ((name (word-before cleaned marker))) + (cond + ((not (and name (member name tools))) '()) + (else + (let* ((after (+ marker (string-length "[ARGS]"))) + (ob (str-find cleaned "{" after)) + (cb (last-char-index cleaned #\}))) + (cond + ((not (and ob cb (< ob cb))) '()) + (else + (let ((data (safe-json (substring cleaned ob (+ cb 1))))) + (if (hash-table? data) + (list (make-tool-call name (json-object->string data))) + '())))))))))))) + +;; ── strategy 3: Qwen Coder XML ─────────────────────────────────────── +;; <function=NAME> <parameter=KEY>VALUE</parameter> … </function> +;; Each VALUE runs to the next </parameter>, <parameter=, </function>, or end. +;; One leading and one trailing newline are stripped (matches Qwen's parser). + +(def (strip-one-edge-newlines s) + (let* ((n0 (string-length s)) + (s1 (if (and (> n0 0) (char=? (string-ref s 0) #\newline)) + (substring s 1 n0) s)) + (n1 (string-length s1)) + (s2 (if (and (> n1 0) (char=? (string-ref s1 (- n1 1)) #\newline)) + (substring s1 0 (- n1 1)) s1))) + s2)) + +(def (min-present positions default) + (let loop ((ps positions) (best default)) + (cond + ((null? ps) best) + ((and (car ps) (< (car ps) best)) (loop (cdr ps) (car ps))) + (else (loop (cdr ps) best))))) + +(def (qwen-value-end body start) + (min-present + (list (str-find body "</parameter>" start) + (str-find body "<parameter=" start) + (str-find body "</function>" start)) + (string-length body))) + +(def (qwen-params->json body) + (let ((ht (make-hash-table))) + (let loop ((pos 0)) + (let ((ps (str-find body "<parameter=" pos))) + (cond + ((not ps) (json-object->string ht)) + (else + (let* ((key-start (+ ps (string-length "<parameter="))) + (gt (str-find body ">" key-start))) + (cond + ((not gt) (json-object->string ht)) + (else + (let* ((key (string-trim (substring body key-start gt))) + (val-start (+ gt 1)) + (val-end (qwen-value-end body val-start)) + (val (strip-one-edge-newlines (substring body val-start val-end)))) + (hash-put! ht key val) + (loop val-end))))))))))) + +(def (rescue-qwen cleaned tools) + (let ((out (box '()))) + (let loop ((pos 0)) + (let ((fs (str-find cleaned "<function=" pos))) + (cond + ((not fs) (reverse (unbox out))) + (else + (let* ((name-start (+ fs (string-length "<function="))) + (gt (str-find cleaned ">" name-start))) + (cond + ((not gt) (reverse (unbox out))) + (else + (let* ((name (string-trim (substring cleaned name-start gt))) + (fe (str-find cleaned "</function>" gt))) + (cond + ((not fe) (reverse (unbox out))) + (else + (let ((body (substring cleaned (+ gt 1) fe))) + (when (member name tools) + (set-box! out + (cons (make-tool-call name (qwen-params->json body)) + (unbox out)))) + (loop (+ fe (string-length "</function>")))))))))))))))) + +;; ── strategy 4: Mistral [TOOL_CALLS]NAME{…} ───────────────────────── +;; String-aware brace-balance scan (matches forge's _parse_mistral_*). + +(def (word-run-end s i) + (let ((slen (string-length s))) + (let loop ((j i)) + (if (and (< j slen) (word-char? (string-ref s j))) (loop (+ j 1)) j)))) + +;; Skip whitespace from I; return the index of the next '{' if that is the +;; first non-whitespace char, else #f (forge's \s*(?=\{) lookahead). +(def (skip-ws-to-brace s i) + (let ((slen (string-length s))) + (let loop ((j i)) + (cond + ((>= j slen) #f) + ((char-whitespace? (string-ref s j)) (loop (+ j 1))) + ((char=? (string-ref s j) #\{) j) + (else #f))))) + +(def (string-aware-brace-end s i slen) + (let loop ((j i) (depth 0) (in-str #f) (esc #f)) + (cond + ((>= j slen) #f) + (else + (let ((c (string-ref s j))) + (cond + (esc (loop (+ j 1) depth in-str #f)) + ((char=? c #\\) (loop (+ j 1) depth in-str #t)) + ((char=? c #\") (loop (+ j 1) depth (not in-str) #f)) + (in-str (loop (+ j 1) depth in-str #f)) + ((char=? c #\{) (loop (+ j 1) (+ depth 1) in-str #f)) + ((char=? c #\}) + (let ((d (- depth 1))) + (if (= d 0) j (loop (+ j 1) d in-str #f)))) + (else (loop (+ j 1) depth in-str #f)))))))) + +(def (rescue-mistral cleaned tools) + (let ((out (box '())) (slen (string-length cleaned))) + (let loop ((pos 0)) + (let ((ms (str-find cleaned "[TOOL_CALLS]" pos))) + (cond + ((not ms) (reverse (unbox out))) + (else + (let* ((name-start (+ ms (string-length "[TOOL_CALLS]"))) + (name-end (word-run-end cleaned name-start))) + (cond + ((= name-start name-end) (loop name-end)) ; \w+ needs ≥1 char + (else + (let ((ob (skip-ws-to-brace cleaned name-end))) + (cond + ((not ob) (loop name-end)) + (else + (let ((cb (string-aware-brace-end cleaned ob slen))) + (cond + ((not cb) (loop (+ ob 1))) + (else + (let ((name (substring cleaned name-start name-end)) + (data (safe-json (substring cleaned ob (+ cb 1))))) + (when (and (hash-table? data) (member name tools)) + (set-box! out + (cons (make-tool-call name (json-object->string data)) + (unbox out))))) + (loop (+ cb 1))))))))))))))))) + +;; ── top-level ──────────────────────────────────────────────────────── + +;; Return the first thunk result that is a non-empty list, else '(). +;; Lazy: later thunks aren't run once one yields a call (forge short-circuit). +(def (first-nonempty thunks) + (let loop ((ts thunks)) + (if (null? ts) + '() + (let ((r ((car ts)))) + (if (pair? r) r (loop (cdr ts))))))) + +;; Parse tool calls from TEXT, matching against TOOLS (list of valid names). +;; Returns a list of jcode tool-calls, or '() if nothing parseable. +(def (rescue-tool-call text tools) + (cond + ((or (not text) (not (string? text))) '()) + (else + (let ((cleaned (strip-think-tags text))) + (if (= (string-length cleaned) 0) + '() + (first-nonempty + (list (lambda () (rescue-json cleaned tools)) + (lambda () (rescue-rehearsal cleaned tools)) + (lambda () (rescue-qwen cleaned tools)) + (lambda () (rescue-mistral cleaned tools))))))))) --- a/test/run.ss +++ b/test/run.ss @@ -9,7 +9,9 @@ (jcode tool file) (jcode tool bash) (jcode guardrails nudge) - (jcode guardrails error-tracker)) + (jcode guardrails error-tracker) + (jcode guardrails message-type) + (jcode guardrails rescue)) ;; ── Helpers ────────────────────────────────────────────────────── @@ -325,6 +327,120 @@ (error-tracker-reset-errors! t) (check! "tool-errs reset" (error-tracker-tool-errors-exhausted? t) #f)) +;; ── Guardrails: message types ───────────────────────────────────── + +(section "=== guardrails: message types ===") + +(check! "mt system_prompt" message-type-system-prompt "system_prompt") +(check! "mt tool_call" message-type-tool-call "tool_call") +(check! "mt retry_nudge" message-type-retry-nudge "retry_nudge") +(check! "mt summary" message-type-summary "summary") +(check! "message-type? valid" (message-type? "tool_result") #t) +(check! "message-type? invalid" (message-type? "bogus") #f) +(check! "kind retry->retry_nudge" + (nudge-kind->message-type "retry") "retry_nudge") +(check! "kind unknown_tool->retry_nudge" + (nudge-kind->message-type "unknown_tool") "retry_nudge") +(check! "kind step->step_nudge" + (nudge-kind->message-type "step") "step_nudge") +(check! "kind prerequisite->prerequisite_nudge" + (nudge-kind->message-type "prerequisite") "prerequisite_nudge") +(check! "kind unknown->#f" + (nudge-kind->message-type "wat") #f) + +;; ── Guardrails: rescue ──────────────────────────────────────────── +;; Canonical 4-strategy tool-call rescue from free text. Args are stored as +;; a JSON string (jcode convention). + +(section "=== guardrails: rescue ===") + +(define (rescue1 text tools) + ;; (count . name . args) for the first recovered call + (let ([calls (rescue-tool-call text tools)]) + (list (length calls) + (and (pair? calls) (tool-call-name (car calls))) + (and (pair? calls) (tool-call-arguments (car calls)))))) + +;; strip-think-tags +(check! "strip <think>" + (strip-think-tags "before<think>secret</think>after") "beforeafter") +(check! "strip [THINK]" + (strip-think-tags "a[THINK]x[/THINK]b") "ab") +(check! "strip unterminated think left intact" + (strip-think-tags "keep <think> this") "keep <think> this") + +;; strategy 1: JSON (forge style + OpenAI style + fences + tags + prose) +(let ([r (rescue1 "{\"tool\":\"grep\",\"args\":{\"pattern\":\"x\"}}" '("grep"))]) + (check! "json forge-style count" (list-ref r 0) 1) + (check! "json forge-style name" (list-ref r 1) "grep") + (check-pred! "json forge-style args" (list-ref r 2) + (lambda (s) (str-contains? s "pattern")))) + +(let ([r (rescue1 "```json\n{\"name\":\"ls\",\"arguments\":{\"path\":\".\"}}\n```" '("ls"))]) + (check! "json openai+fence count" (list-ref r 0) 1) + (check! "json openai+fence name" (list-ref r 1) "ls")) + +(let ([r (rescue1 "Sure: <tool_call>{\"name\":\"ls\",\"arguments\":{\"path\":\".\"}}</tool_call> done" '("ls"))]) + (check! "json in <tool_call> tag" (list-ref r 1) "ls")) + +(let ([calls (rescue-tool-call + "{\"tool\":\"ls\",\"args\":{}} then {\"tool\":\"grep\",\"args\":{}}" + '("ls" "grep"))]) + (check! "json multi count" (length calls) 2) + (check! "json multi names" (map tool-call-name calls) '("ls" "grep"))) + +(check! "json unknown tool → none" + (length (rescue-tool-call "{\"tool\":\"nope\",\"args\":{}}" '("ls"))) 0) +(check! "non-tool json → none" + (length (rescue-tool-call "{\"foo\":1,\"bar\":2}" '("ls"))) 0) + +;; think block is stripped before rescue (a call inside it is ignored) +(let ([r (rescue1 "<think>{\"tool\":\"ls\",\"args\":{}}</think>{\"tool\":\"grep\",\"args\":{}}" + '("ls" "grep"))]) + (check! "think-block call ignored, body wins" (list-ref r 1) "grep")) + +;; strategy 2: rehearsal name[ARGS]{...} +(let ([r (rescue1 "Let me call grep[ARGS]{\"pattern\":\"defstruct\"}" '("grep"))]) + (check! "rehearsal count" (list-ref r 0) 1) + (check! "rehearsal name" (list-ref r 1) "grep") + (check-pred! "rehearsal args" (list-ref r 2) + (lambda (s) (str-contains? s "defstruct")))) + +;; strategy 3: Qwen Coder XML +(let ([r (rescue1 "<function=ls><parameter=path>.</parameter></function>" '("ls"))]) + (check! "qwen-xml count" (list-ref r 0) 1) + (check! "qwen-xml name" (list-ref r 1) "ls") + (check-pred! "qwen-xml args has path" (list-ref r 2) + (lambda (s) (str-contains? s "path")))) + +;; Qwen newline stripping: one leading + one trailing newline removed +(let ([r (rescue1 "<function=write><parameter=content>\nhello\n</parameter></function>" '("write"))]) + (check-pred! "qwen-xml value newline-stripped" (list-ref r 2) + (lambda (s) (str-contains? s "hello")))) + +;; strategy 4: Mistral [TOOL_CALLS]name{...} +(let ([r (rescue1 "[TOOL_CALLS]grep{\"pattern\":\"x\"}" '("grep"))]) + (check! "mistral count" (list-ref r 0) 1) + (check! "mistral name" (list-ref r 1) "grep")) + +(let ([r (rescue1 "[TOOL_CALLS]grep {\"pattern\":\"x\"}" '("grep"))]) + (check! "mistral whitespace before brace" (list-ref r 1) "grep")) + +;; string-aware brace scan: a '}' inside a JSON string must not close early +(let ([r (rescue1 "[TOOL_CALLS]bash{\"command\":\"echo }\"}" '("bash"))]) + (check! "mistral string-aware count" (list-ref r 0) 1) + (check-pred! "mistral string-aware args" (list-ref r 2) + (lambda (s) (str-contains? s "command")))) + +;; strategy ordering: JSON present → strategy 1 wins, rehearsal not double-counted +(let ([r (rescue1 "{\"tool\":\"ls\",\"args\":{}} and grep[ARGS]{\"pattern\":\"x\"}" + '("ls" "grep"))]) + (check! "ordering: json wins" (list-ref r 1) "ls")) + +;; nothing parseable +(check! "no tool call → empty" + (length (rescue-tool-call "Just a normal answer." '("ls" "grep"))) 0) + ;; ── Results ─────────────────────────────────────────────────────── (printf "~n~a passed, ~a failed~n" pass-count fail-count)