Phase 5: workflow surface (workflow + steps + step-enforcer + runner)
ober
e8d743242e82e65074527593977d06e8f9738992
--- a/build-binary.ss +++ b/build-binary.ss @@ -112,6 +112,8 @@ "lib/jcode/core/log" "lib/jcode/core/errors" "lib/jcode/core/hardware" + "lib/jcode/core/steps" + "lib/jcode/core/workflow" "lib/jcode/core/session" "lib/jcode/core/message" "lib/jcode/core/secrets" @@ -139,6 +141,8 @@ "lib/jcode/guardrails/validator" "lib/jcode/guardrails/respond" "lib/jcode/guardrails/guardrails" + "lib/jcode/guardrails/step-enforcer" + "lib/jcode/core/workflow-runner" "lib/jcode/provider/sampling" "lib/jcode/provider/provider" "lib/jcode/tool/registry" --- a/src/jcode/core/errors.ss +++ b/src/jcode/core/errors.ss @@ -21,7 +21,30 @@ raise-unsupported-model &hardware-detection hardware-detection-error? hardware-detection-error-detail - raise-hardware-detection) + raise-hardware-detection + ;; ── workflow / runner family (Phase 5) ── + &tool-call-error tool-call-error? tool-call-error-raw-response + raise-tool-call-error + &tool-execution-error tool-execution-error? tool-execution-error-tool + raise-tool-execution-error + &tool-resolution-error tool-resolution-error? tool-resolution-error-tool + raise-tool-resolution-error + &workflow-cancelled workflow-cancelled-error? + workflow-cancelled-error-iteration workflow-cancelled-error-completed + raise-workflow-cancelled + &max-iterations max-iterations-error? + max-iterations-error-iterations max-iterations-error-pending + raise-max-iterations + &step-enforcement step-enforcement-error? + step-enforcement-error-terminal step-enforcement-error-attempts + step-enforcement-error-pending + raise-step-enforcement + &prerequisite-error prerequisite-error? + prerequisite-error-tool prerequisite-error-violations + prerequisite-error-missing + raise-prerequisite-error) + +(import :std/misc/string) ;; Root of the forge family. Derives from R6RS &error so error? holds and it ;; threads through the existing message-condition?/condition-message handling. @@ -64,3 +87,113 @@ (make-who-condition 'detect-hardware) (make-message-condition (string-append "Hardware probe produced unparseable output: " detail))))) + +;; ── Workflow / runner error family (forge errors.py) ───────────────── +;; All raisers take already-stringified lists where forge carried lists/dicts. + +(def (join-names xs) (string-join xs ", ")) + +;; ToolCallError — model failed to produce a valid tool call after retries. +(define-condition-type &tool-call-error &forge-error + make-tool-call-error tool-call-error? + (raw-response tool-call-error-raw-response)) + +(def (raise-tool-call-error msg raw-response) + (raise + (condition + (make-tool-call-error raw-response) + (make-who-condition 'workflow-runner) + (make-message-condition msg)))) + +;; ToolExecutionError — a tool callable raised during execution. +(define-condition-type &tool-execution-error &forge-error + make-tool-execution-error tool-execution-error? + (tool tool-execution-error-tool)) + +(def (raise-tool-execution-error tool-name cause-str) + (raise + (condition + (make-tool-execution-error tool-name) + (make-who-condition 'workflow-runner) + (make-message-condition + (string-append "Tool '" tool-name "' raised: " cause-str))))) + +;; ToolResolutionError — args valid but data didn't resolve. The privileged +;; "retry with different args" signal: NOT a &forge-error (forge-error? is #f), +;; so the runner catches it explicitly and does NOT count it against the budget. +(define-condition-type &tool-resolution-error &error + make-tool-resolution-error tool-resolution-error? + (tool tool-resolution-error-tool)) + +(def (raise-tool-resolution-error msg . opt) + (let ((tool-name (and (pair? opt) (car opt)))) + (raise + (condition + (make-tool-resolution-error tool-name) + (make-message-condition msg))))) + +;; WorkflowCancelledError — cancel-event set before completion. +(define-condition-type &workflow-cancelled &forge-error + make-workflow-cancelled workflow-cancelled-error? + (iteration workflow-cancelled-error-iteration) + (completed workflow-cancelled-error-completed)) + +(def (raise-workflow-cancelled completed-list iteration) + (raise + (condition + (make-workflow-cancelled iteration completed-list) + (make-who-condition 'workflow-runner) + (make-message-condition + (string-append "Workflow cancelled at iteration " + (number->string iteration) ". Completed steps: " + (join-names completed-list)))))) + +;; MaxIterationsError — exceeded max-iterations without the terminal tool. +(define-condition-type &max-iterations &forge-error + make-max-iterations max-iterations-error? + (iterations max-iterations-error-iterations) + (pending max-iterations-error-pending)) + +(def (raise-max-iterations iterations completed-list pending-list) + (raise + (condition + (make-max-iterations iterations pending-list) + (make-who-condition 'workflow-runner) + (make-message-condition + (string-append "Max iterations (" (number->string iterations) + ") exceeded. Completed: " (join-names completed-list) + ", Pending: " (join-names pending-list)))))) + +;; StepEnforcementError — model called the terminal tool prematurely too often. +(define-condition-type &step-enforcement &forge-error + make-step-enforcement step-enforcement-error? + (terminal step-enforcement-error-terminal) + (attempts step-enforcement-error-attempts) + (pending step-enforcement-error-pending)) + +(def (raise-step-enforcement terminal-tool attempts pending-list) + (raise + (condition + (make-step-enforcement terminal-tool attempts pending-list) + (make-who-condition 'workflow-runner) + (make-message-condition + (string-append "Model called '" terminal-tool "' prematurely " + (number->string attempts) " times without completing required steps: " + (join-names pending-list)))))) + +;; PrerequisiteError — model called a tool without satisfying its prerequisites. +(define-condition-type &prerequisite-error &forge-error + make-prerequisite-error prerequisite-error? + (tool prerequisite-error-tool) + (violations prerequisite-error-violations) + (missing prerequisite-error-missing)) + +(def (raise-prerequisite-error tool-name violations missing-list) + (raise + (condition + (make-prerequisite-error tool-name violations missing-list) + (make-who-condition 'workflow-runner) + (make-message-condition + (string-append "Tool '" tool-name "' called " (number->string violations) + " times without satisfying prerequisites: " + (join-names missing-list)))))) new file mode 100644 --- /dev/null +++ b/src/jcode/core/steps.ss @@ -0,0 +1,111 @@ +;;; jcode required-step tracking + prerequisite enforcement +;;; +;;; Faithful port of forge's core/steps.py (StepTracker + PrerequisiteCheck). +;;; The tracker lives on the workflow runner, OUTSIDE the message history, so +;;; compaction can never invalidate step completion (forge P0-1). +;;; +;;; Representations (matching workflow.ss): +;;; * completed — a list of tool names in first-completion order. forge uses +;;; dict[str,None] as an insertion-ordered set; a deduped list reproduces +;;; both the membership test and the ordered iteration summary-hint needs. +;;; * executed — assoc (tool-name . (args-assoc ...)) recording every call's +;;; args in call order, for arg-matched prerequisite checking. +;;; * args — an assoc ((arg-name-string . value) ...); a missing key +;;; reads as #f, matching forge's dict.get(...) -> None. +;;; * prereq — a string (name-only) OR a pair (tool-name . match-arg), +;;; mirroring forge's str | {"tool":..., "match_arg":...}. + +(export make-prerequisite-check prerequisite-check? + prerequisite-check-satisfied prerequisite-check-missing + make-step-tracker step-tracker? + step-tracker-required step-tracker-completed step-tracker-executed + step-tracker-record! step-tracker-satisfied? step-tracker-pending + step-tracker-check-prerequisites step-tracker-summary-hint + assoc-ref) + +(import :std/misc/string) + +(defstruct prerequisite-check (satisfied missing)) + +;; Private carrier; public API uses step-tracker-* wrappers below. +(defstruct strk (required completed executed)) + +(def (make-step-tracker required-steps) + (make-strk required-steps '() '())) + +(def (step-tracker? x) (strk? x)) +(def (step-tracker-required t) (strk-required t)) +(def (step-tracker-completed t) (strk-completed t)) +(def (step-tracker-executed t) (strk-executed t)) + +(def (assoc-ref alist key) + (let ((p (assoc key alist))) (and p (cdr p)))) + +;; Append VAL to the list stored at KEY, preserving order; create if absent. +(def (assoc-append alist key val) + (let loop ((xs alist) (acc '()) (found #f)) + (cond + ((null? xs) + (if found (reverse acc) + (reverse (cons (cons key (list val)) acc)))) + ((equal? (caar xs) key) + (loop (cdr xs) (cons (cons key (append (cdar xs) (list val))) acc) #t)) + (else (loop (cdr xs) (cons (car xs) acc) found))))) + +(def (step-tracker-record! t tool-name args) + "Record a successful tool execution. ARGS is an assoc list (or '())." + (unless (member tool-name (strk-completed t)) + (strk-completed-set! t (append (strk-completed t) (list tool-name)))) + (strk-executed-set! t (assoc-append (strk-executed t) tool-name (or args '())))) + +(def (step-tracker-satisfied? t) + "True if every required step has been completed." + (let loop ((rs (strk-required t))) + (cond + ((null? rs) #t) + ((member (car rs) (strk-completed t)) (loop (cdr rs))) + (else #f)))) + +(def (step-tracker-pending t) + "Required steps not yet completed, in original order." + (filter (lambda (s) (not (member s (strk-completed t)))) (strk-required t))) + +(def (any-call-matches? calls match-arg required-value) + (let loop ((cs calls)) + (cond + ((null? cs) #f) + ((equal? (assoc-ref (car cs) match-arg) required-value) #t) + (else (loop (cdr cs)))))) + +(def (step-tracker-check-prerequisites t tool-name args prerequisites) + "Return a prerequisite-check. A name-only prereq is satisfied by any prior + call to that tool; an arg-matched (tool . match-arg) prereq needs a prior + call whose MATCH-ARG value equals this call's MATCH-ARG value." + (let loop ((ps prerequisites) (missing '())) + (cond + ((null? ps) + (make-prerequisite-check (null? missing) (reverse missing))) + (else + (let ((prereq (car ps))) + (if (pair? prereq) + ;; arg-matched: (prereq-tool . match-arg) + (let* ((prereq-tool (car prereq)) + (match-arg (cdr prereq)) + (required-value (assoc-ref args match-arg)) + (calls (assoc-ref (strk-executed t) prereq-tool))) + (cond + ((not calls) + (loop (cdr ps) (cons prereq-tool missing))) + ((not (any-call-matches? calls match-arg required-value)) + (loop (cdr ps) (cons prereq-tool missing))) + (else (loop (cdr ps) missing)))) + ;; name-only + (if (assoc-ref (strk-executed t) prereq) + (loop (cdr ps) missing) + (loop (cdr ps) (cons prereq missing))))))))) + +(def (step-tracker-summary-hint t) + "Human-readable hint for injection into compacted summaries." + (if (null? (strk-completed t)) + "[No steps completed yet]" + (string-append "[Steps completed: " (string-join (strk-completed t) ", ") "]"))) new file mode 100644 --- /dev/null +++ b/src/jcode/core/workflow-runner.ss @@ -0,0 +1,249 @@ +;;; jcode workflow runner — the agentic tool-calling loop +;;; +;;; Faithful port of forge's core/runner.py WorkflowRunner.run loop body +;;; (steps 3.0 → 3e + step 4), decoupled from forge's run_inference / +;;; ContextManager / LLMClient (which jcode models elsewhere). +;;; +;;; The seam is an INJECTED RESPONDER — a closure +;;; (responder messages tool-specs step-index) -> response +;;; standing in for forge's run_inference. RESPONSE is either a text-response +;;; (the model chose prose over tools), a single wtool-call, or a list of +;;; wtool-call. Production wires the responder to the jcode provider + the +;;; Phase 2 validator/rescue/error-tracker retry loop; tests pass a scripted +;;; closure. The responder is assumed to have already validated/retried, so +;;; ONE responder call == ONE iteration here (forge folds retries into the +;;; iteration count internally; the seam moves that bookkeeping out). +;;; +;;; What the runner still owns, byte-for-byte with forge: +;;; 3.0 cancellation check (a cancel? thunk replaces asyncio.Event) +;;; 3b premature-terminal enforcement → StepEnforcementError when exhausted +;;; 3b.2 prerequisite enforcement → PrerequisiteError when exhausted +;;; 3c batch tool execution (ToolResolutionError is privileged) +;;; 3d error-budget bookkeeping → ToolExecutionError when exhausted +;;; 3e terminal-tool return +;;; 4 MaxIterationsError +;;; +;;; Messages are jcode `message` structs. forge tags each with a MessageType in +;;; metadata; jcode derives type from message shape (Phase 4), so the runner +;;; emits plain role/content messages and lets compaction-strategy re-derive. + +(export run-workflow) + +(import :jcode/core/workflow + :jcode/core/steps + :jcode/core/message + :jcode/core/errors + :jcode/guardrails/step-enforcer + :jcode/guardrails/error-tracker + :jcode/guardrails/nudge + :std/text/json) + +(def (opt-ref alist key) (let ((p (assoc key alist))) (and p (cdr p)))) + +;; Render a tool's return value the way forge does: a string passes through, +;; anything else is JSON-encoded. (forge: result_val if isinstance(str) else +;; json.dumps(result_val).) +(def (result->string v) + (cond + ((string? v) v) + ((number? v) (number->string v)) + (else (json-object->string v)))) + +;; Best-effort text for a raised condition. jcode conditions carry no class +;; name, so the [ToolError] path can't reproduce forge's "TypeName: msg" — +;; the message alone is used (documented fidelity gap). +(def (condition->string e) + (cond + ((string? e) e) + ((and (condition? e) (message-condition? e)) (condition-message e)) + (else (call-with-string-output-port (lambda (p) (display-condition e p)))))) + +;; Run one tool callable, classifying the outcome: +;; (ok . value) — succeeded +;; (resolution . text) — ToolResolutionError (privileged: no error budget) +;; (error . text) — any other exception (counts against error budget) +;; The callable receives the args assoc as its single argument. +(def (run-one-tool fn args) + (guard (e [(tool-resolution-error? e) (cons 'resolution (condition->string e))] + [#t (cons 'error (condition->string e))]) + (cons 'ok (fn args)))) + +(def (reasoning-of tool-calls) + (and (pair? tool-calls) (wtool-call-reasoning (car tool-calls)))) + +(def (wtool-calls->data tool-calls) + (map (lambda (tc) (make-tool-call (wtool-call-tool tc) (wtool-call-args tc))) + tool-calls)) + +(def (find-terminal-name workflow tool-calls) + (let loop ((tcs tool-calls)) + (cond + ((null? tcs) #f) + ((workflow-terminal-tool? workflow (wtool-call-tool (car tcs))) + (wtool-call-tool (car tcs))) + (else (loop (cdr tcs)))))) + +;; Re-evaluate prerequisites against the tracker to find the first violating +;; tool (for PrerequisiteError). Returns (tool-name . missing-list). +(def (first-prereq-violation enforcer tool-calls tool-prereqs) + (let loop ((tcs tool-calls)) + (cond + ((null? tcs) (cons #f '())) + (else + (let ((prereqs (opt-ref tool-prereqs (wtool-call-tool (car tcs))))) + (if (and prereqs (pair? prereqs)) + (let ((r (step-tracker-check-prerequisites + (step-enforcer-tracker enforcer) + (wtool-call-tool (car tcs)) + (wtool-call-args (car tcs)) prereqs))) + (if (prerequisite-check-satisfied r) + (loop (cdr tcs)) + (cons (wtool-call-tool (car tcs)) (prerequisite-check-missing r)))) + (loop (cdr tcs)))))))) + +;; ── Batch execution (forge 3c → 3e) ────────────────────────────────── +;; Returns (terminal . value) when a terminal tool succeeded, else 'continue. +;; May raise ToolExecutionError when the error budget is exhausted. +(def (execute-batch! emit! workflow enforcer error-tracker tool-calls) + (let ((reasoning (reasoning-of tool-calls)) + (tc-data (wtool-calls->data tool-calls))) + (when reasoning (emit! (make-assistant-message reasoning))) + (emit! (make-assistant-message "" tc-data)) + (let loop ((tcs tool-calls) (tds tc-data) + (had-error #f) (last-error #f) (terminal 'none)) + (cond + ((null? tcs) + ;; 3d — post-batch bookkeeping + (if had-error + (begin + (error-tracker-record-result! error-tracker #f) + (when (error-tracker-tool-errors-exhausted? error-tracker) + (raise-tool-execution-error (car last-error) (cdr last-error)))) + (begin + (error-tracker-reset-errors! error-tracker) + (step-enforcer-reset-premature! enforcer) + (step-enforcer-reset-prereq-violations! enforcer))) + ;; 3e — terminal success returns its value; an errored terminal does not + (if (and (pair? terminal) (eq? (car terminal) 'ok)) + (cons 'terminal (cdr terminal)) + 'continue)) + (else + (let* ((tc (car tcs)) + (td (car tds)) + (tc-id (tool-call-id td)) + (name (wtool-call-tool tc)) + (terminal? (workflow-terminal-tool? workflow name)) + (outcome (run-one-tool (workflow-get-callable workflow name) + (wtool-call-args tc)))) + (case (car outcome) + ((resolution) + ;; privileged: emit result, no error-budget hit + (emit! (make-tool-result tc-id (string-append "[ToolResolutionError] " (cdr outcome)))) + (loop (cdr tcs) (cdr tds) had-error last-error + (if terminal? 'errored terminal))) + ((error) + (emit! (make-tool-result tc-id (string-append "[ToolError] " (cdr outcome)))) + (loop (cdr tcs) (cdr tds) #t (cons name (cdr outcome)) + (if terminal? 'errored terminal))) + (else ; ok + (step-enforcer-record! enforcer name (wtool-call-args tc)) + (emit! (make-tool-result tc-id (result->string (cdr outcome)))) + (loop (cdr tcs) (cdr tds) had-error last-error + (if terminal? (cons 'ok (cdr outcome)) terminal)))))))))) + +;; ── Nudge-as-tool-error emission (forge 3b / 3b.2) ──────────────────── +;; forge surfaces premature/prereq violations as TOOL results (not a trailing +;; user nudge) — models are pretrained on "tool failed → try something else". +(def (emit-nudge-batch! emit! tool-calls prefix nudge) + (when (reasoning-of tool-calls) + (emit! (make-assistant-message (reasoning-of tool-calls)))) + (let ((tc-data (wtool-calls->data tool-calls))) + (emit! (make-assistant-message "" tc-data)) + (for-each + (lambda (td) + (emit! (make-tool-result (tool-call-id td) + (string-append prefix (nudge-content nudge))))) + tc-data))) + +(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: + max-iterations (10) max-retries-per-step (3) max-tool-errors (2) + on-message (#f) prompt-vars ('()) initial-messages (#f) + cancel? (thunk -> bool, default never). + Raises MaxIterationsError / StepEnforcementError / PrerequisiteError / + ToolExecutionError / WorkflowCancelledError on the corresponding conditions." + (let* ((o (if (pair? opt) (car opt) '())) + (max-iterations (or (opt-ref o 'max-iterations) 10)) + (max-retries (or (opt-ref o 'max-retries-per-step) 3)) + (max-tool-errors (or (opt-ref o 'max-tool-errors) 2)) + (on-message (opt-ref o 'on-message)) + (prompt-vars (or (opt-ref o 'prompt-vars) '())) + (initial-msgs (opt-ref o 'initial-messages)) + (cancel? (or (opt-ref o 'cancel?) (lambda () #f))) + (messages (if initial-msgs initial-msgs '()))) + (define (emit! msg) + (set! messages (append messages (list msg))) + (when on-message (on-message msg))) + ;; Step 1 — seed system prompt + user input (unless replaying history) + (unless initial-msgs + (emit! (make-system-message (workflow-build-system-prompt workflow prompt-vars))) + (emit! (make-user-message user-message))) + ;; Step 2 — guardrail middleware + (let* ((tool-prereqs (workflow-tool-prerequisites workflow)) + (enforcer (make-step-enforcer (workflow-required-steps workflow) + (workflow-terminal-tools workflow) + tool-prereqs)) + (error-tracker (make-error-tracker max-retries max-tool-errors)) + (tool-specs (workflow-get-tool-specs workflow))) + ;; Step 3 — main loop (one responder call per iteration) + (let loop ((iteration 0)) + (cond + ((>= iteration max-iterations) + (raise-max-iterations max-iterations + (step-enforcer-completed enforcer) + (step-enforcer-pending enforcer))) + ((cancel?) + (raise-workflow-cancelled (step-enforcer-completed enforcer) iteration)) + (else + (let ((response (responder messages tool-specs iteration))) + (cond + ;; Intentional text response — emit and consume an iteration. + ((text-response? response) + (emit! (make-assistant-message (text-response-content response))) + (loop (+ iteration 1))) + (else + (let ((tool-calls (if (list? response) response (list response)))) + ;; 3b — premature terminal + (let ((step-check (step-enforcer-check enforcer tool-calls))) + (cond + ((step-check-needs-nudge step-check) + (when (step-enforcer-premature-exhausted? enforcer) + (raise-step-enforcement + (find-terminal-name workflow tool-calls) + (step-enforcer-premature-attempts enforcer) + (step-enforcer-pending enforcer))) + (emit-nudge-batch! emit! tool-calls "[StepEnforcementError] " + (step-check-nudge step-check)) + (loop (+ iteration 1))) + (else + ;; 3b.2 — prerequisites + (let ((prereq-check (step-enforcer-check-prerequisites enforcer tool-calls))) + (cond + ((step-check-needs-nudge prereq-check) + (when (step-enforcer-prereq-exhausted? enforcer) + (let ((v (first-prereq-violation enforcer tool-calls tool-prereqs))) + (raise-prerequisite-error + (car v) + (step-enforcer-prereq-violations enforcer) + (cdr v)))) + (emit-nudge-batch! emit! tool-calls "[PrerequisiteError] " + (step-check-nudge prereq-check)) + (loop (+ iteration 1))) + (else + ;; 3c → 3e — execute the batch + (let ((outcome (execute-batch! emit! workflow enforcer + error-tracker tool-calls))) + (if (and (pair? outcome) (eq? (car outcome) 'terminal)) + (cdr outcome) + (loop (+ iteration 1)))))))))))))))))))) new file mode 100644 --- /dev/null +++ b/src/jcode/core/workflow.ss @@ -0,0 +1,168 @@ +;;; jcode workflow definitions +;;; +;;; Port of forge's core/workflow.py: ToolSpec / ToolDef / ToolCall / +;;; TextResponse / Workflow. forge uses Pydantic to turn a JSON Schema into a +;;; validated params model; jcode has no Pydantic, so a ToolSpec stores the +;;; raw JSON-Schema dict verbatim (it is already the canonical wire form) and +;;; from-json-schema / get-json-schema are identity-ish round-trips. +;;; +;;; Representations chosen for jcode: +;;; * tool-call args — an assoc list ((key-string . value) ...). forge uses +;;; a dict; assoc keeps tests trivial and matches prereq arg-matching. +;;; * prerequisites — a list whose elements are either a string (name-only: +;;; any prior call satisfies it) or a pair (tool-name . match-arg) for +;;; arg-matched prereqs (forge's {"tool":..., "match_arg":...}). +;;; * terminal-tool — accepted as a string or list at construction; +;;; normalized to a list of names. +;;; +;;; make-workflow runs forge's __post_init__ validation and raises on any +;;; violation (these are construction-time ValueErrors, not runtime forge +;;; errors). + +(export make-wtool-call wtool-call? wtool-call-tool wtool-call-args wtool-call-reasoning + make-text-response text-response? text-response-content + make-tool-spec tool-spec? tool-spec-name tool-spec-description + tool-spec-parameters tool-spec-from-json-schema tool-spec-get-json-schema + make-tool-def tool-def? tool-def-spec tool-def-callable + tool-def-prerequisites tool-def-name + make-workflow workflow? workflow-name workflow-description + workflow-tools workflow-required-steps workflow-terminal-tools + workflow-system-prompt-template + workflow-terminal-tool? workflow-tool-names workflow-tool-prerequisites + workflow-build-system-prompt workflow-get-tool-specs + workflow-get-callable workflow-get-tool-def + prerequisite-name) + +(import :std/misc/string) + +;; ── Response shapes (forge ToolCall / TextResponse) ────────────────── +(defstruct wtool-call (tool args reasoning)) +(defstruct text-response (content)) + +;; ── ToolSpec — declarative schema the LLM sees ─────────────────────── +(defstruct tool-spec (name description parameters)) + +(def (tool-spec-from-json-schema name description schema) + ;; schema is the OpenAI-style "parameters" JSON-Schema object (hash or + ;; assoc). jcode keeps it as-is; there is no Pydantic model to build. + (make-tool-spec name description schema)) + +(def (tool-spec-get-json-schema spec) + (tool-spec-parameters spec)) + +;; ── ToolDef — binds a spec to its callable + prerequisites ─────────── +(defstruct tool-def (spec callable prerequisites)) +(def (tool-def-name td) (tool-spec-name (tool-def-spec td))) + +(def (prerequisite-name prereq) + ;; name-only prereq → the string; arg-matched (tool . match-arg) → the tool. + (if (pair? prereq) (car prereq) prereq)) + +;; ── Workflow (private carrier wf + validating constructor) ─────────── +(defstruct wf (name description tools required-steps terminal-tools system-prompt-template)) + +(def (workflow? x) (wf? x)) +(def (workflow-name w) (wf-name w)) +(def (workflow-description w) (wf-description w)) +(def (workflow-tools w) (wf-tools w)) +(def (workflow-required-steps w) (wf-required-steps w)) +(def (workflow-terminal-tools w) (wf-terminal-tools w)) +(def (workflow-system-prompt-template w) (wf-system-prompt-template w)) + +(def (workflow-tool-names w) + (map tool-def-name (wf-tools w))) + +(def (workflow-terminal-tool? w name) + (and (member name (wf-terminal-tools w)) #t)) + +(def (make-workflow name description tools required-steps terminal-tool system-prompt-template) + "Validating constructor (forge Workflow.__post_init__). TOOLS is a list of + tool-def; TERMINAL-TOOL is a string or list of names." + (let* ((terminal-tools (if (list? terminal-tool) terminal-tool (list terminal-tool))) + (names (map tool-def-name tools))) + ;; Duplicate tool names would silently shadow in a dict — reject. + (let loop ((ns names) (seen '())) + (unless (null? ns) + (when (member (car ns) seen) + (error 'make-workflow "duplicate tool name" (car ns))) + (loop (cdr ns) (cons (car ns) seen)))) + ;; required_steps ⊂ tools + (for-each + (lambda (step) + (unless (member step names) + (error 'make-workflow "required step not in tools" step names))) + required-steps) + ;; terminal ⊂ tools AND terminal ∉ required_steps + (for-each + (lambda (tt) + (unless (member tt names) + (error 'make-workflow "terminal tool not in tools" tt names)) + (when (member tt required-steps) + (error 'make-workflow "terminal tool cannot also be a required step" tt))) + terminal-tools) + ;; every prerequisite resolves to a known tool + (for-each + (lambda (td) + (for-each + (lambda (prereq) + (let ((pn (prerequisite-name prereq))) + (unless (member pn names) + (error 'make-workflow "prerequisite not in tools" pn (tool-def-name td))))) + (tool-def-prerequisites td))) + tools) + (make-wf name description tools required-steps terminal-tools system-prompt-template))) + +;; ── Helpers ────────────────────────────────────────────────────────── + +(def (workflow-get-tool-def w name) + (let loop ((ts (wf-tools w))) + (cond + ((null? ts) #f) + ((equal? (tool-def-name (car ts)) name) (car ts)) + (else (loop (cdr ts)))))) + +(def (workflow-get-callable w name) + (let ((td (workflow-get-tool-def w name))) + (if td (tool-def-callable td) + (error 'workflow-get-callable "no such tool" name)))) + +(def (workflow-get-tool-specs w) + (map tool-def-spec (wf-tools w))) + +(def (workflow-tool-prerequisites w) + ;; assoc (tool-name . prereqs) for tools that declare prerequisites. + (let loop ((ts (wf-tools w)) (acc '())) + (cond + ((null? ts) (reverse acc)) + ((pair? (tool-def-prerequisites (car ts))) + (loop (cdr ts) (cons (cons (tool-def-name (car ts)) + (tool-def-prerequisites (car ts))) acc))) + (else (loop (cdr ts) acc))))) + +(def (workflow-build-system-prompt w vars) + "Render the system-prompt template, replacing each {name} with its value + from VARS (assoc (name-string . value-string)). forge uses str.format." + (let loop ((tmpl (wf-system-prompt-template w)) (vs vars)) + (if (null? vs) tmpl + (loop (str-replace-all tmpl (string-append "{" (caar vs) "}") (cdar vs)) + (cdr vs))))) + +(def (str-index s sub) + ;; First index of SUB in S, or #f. Naive; fine for prompt templates. + (let ((slen (string-length s)) (nlen (string-length sub))) + (if (= nlen 0) 0 + (let loop ((i 0)) + (cond + ((> (+ i nlen) slen) #f) + ((string=? (substring s i (+ i nlen)) sub) i) + (else (loop (+ i 1)))))))) + +(def (str-replace-all s old new) + (let ((oldlen (string-length old))) + (if (= oldlen 0) s + (let loop ((rest s) (acc "")) + (let ((idx (str-index rest old))) + (if idx + (loop (substring rest (+ idx oldlen) (string-length rest)) + (string-append acc (substring rest 0 idx) new)) + (string-append acc rest))))))) new file mode 100644 --- /dev/null +++ b/src/jcode/guardrails/step-enforcer.ss @@ -0,0 +1,114 @@ +;;; jcode step enforcement — premature-terminal + prerequisite guardrail +;;; +;;; Faithful port of forge's guardrails/step_enforcer.py (StepEnforcer + +;;; StepCheck). Stateful — instantiate one per session/task. It wraps a +;;; step-tracker and layers two escalating defences: +;;; +;;; * premature terminal — if the batch calls a terminal tool before the +;;; required steps are done, emit an escalating step nudge (tier 1→3). +;;; After max-premature exceeded, the runner raises StepEnforcementError. +;;; * prerequisites — if any tool in the batch has unmet prerequisites, +;;; emit a prerequisite nudge. After max-prereq exceeded, the runner raises +;;; PrerequisiteError. Whole-batch blocking: one violation blocks the batch. +;;; +;;; terminal-tools is a list of names (forge uses a frozenset); membership is +;;; the only operation. tool-prerequisites is an assoc (tool-name . prereqs). + +(export make-step-check step-check? step-check-nudge step-check-needs-nudge + make-step-enforcer step-enforcer? + step-enforcer-tracker + step-enforcer-check step-enforcer-check-prerequisites + step-enforcer-record! step-enforcer-satisfied? step-enforcer-pending + step-enforcer-terminal-reached? + step-enforcer-premature-attempts step-enforcer-premature-exhausted? + step-enforcer-prereq-violations step-enforcer-prereq-exhausted? + step-enforcer-reset-premature! step-enforcer-reset-prereq-violations! + step-enforcer-completed step-enforcer-summary-hint) + +(import :jcode/core/steps + :jcode/core/workflow + :jcode/guardrails/nudge) + +(defstruct step-check (nudge needs-nudge)) + +;; Private carrier; public API uses step-enforcer-* wrappers below. +(defstruct senf + (tracker terminal-tools tool-prerequisites + max-premature max-prereq premature-attempts prereq-violations)) + +(def (make-step-enforcer required-steps terminal-tools . opt) + "OPT (positional): tool-prerequisites assoc, max-premature (3), max-prereq (2)." + (let* ((tp (if (>= (length opt) 1) (list-ref opt 0) '())) + (mp (if (>= (length opt) 2) (list-ref opt 1) 3)) + (mq (if (>= (length opt) 3) (list-ref opt 2) 2))) + (make-senf (make-step-tracker required-steps) + terminal-tools (or tp '()) mp mq 0 0))) + +(def (step-enforcer? x) (senf? x)) +(def (step-enforcer-tracker e) (senf-tracker e)) +(def (step-enforcer-premature-attempts e) (senf-premature-attempts e)) +(def (step-enforcer-prereq-violations e) (senf-prereq-violations e)) +(def (step-enforcer-premature-exhausted? e) + (> (senf-premature-attempts e) (senf-max-premature e))) +(def (step-enforcer-prereq-exhausted? e) + (> (senf-prereq-violations e) (senf-max-prereq e))) +(def (step-enforcer-satisfied? e) (step-tracker-satisfied? (senf-tracker e))) +(def (step-enforcer-pending e) (step-tracker-pending (senf-tracker e))) +(def (step-enforcer-completed e) (step-tracker-completed (senf-tracker e))) +(def (step-enforcer-summary-hint e) (step-tracker-summary-hint (senf-tracker e))) +(def (step-enforcer-record! e tool-name args) + (step-tracker-record! (senf-tracker e) tool-name args)) +(def (step-enforcer-reset-premature! e) (senf-premature-attempts-set! e 0)) +(def (step-enforcer-reset-prereq-violations! e) (senf-prereq-violations-set! e 0)) + +(def (batch-terminal-name e tool-calls) + "First terminal tool name in the batch, or #f." + (let loop ((tcs tool-calls)) + (cond + ((null? tcs) #f) + ((member (wtool-call-tool (car tcs)) (senf-terminal-tools e)) + (wtool-call-tool (car tcs))) + (else (loop (cdr tcs)))))) + +(def (step-enforcer-check e tool-calls) + "Premature-terminal check. If the batch calls a terminal tool before the + required steps are satisfied, increment the attempt counter and return a + StepCheck carrying an escalating step nudge (tier = min(attempts, 3))." + (let ((attempted (batch-terminal-name e tool-calls))) + (if (and attempted (not (step-tracker-satisfied? (senf-tracker e)))) + (begin + (senf-premature-attempts-set! e (+ 1 (senf-premature-attempts e))) + (let ((tier (min (senf-premature-attempts e) 3))) + (make-step-check + (make-step-nudge attempted (step-tracker-pending (senf-tracker e)) tier) + #t))) + (make-step-check #f #f)))) + +(def (step-enforcer-check-prerequisites e tool-calls) + "Prerequisite check (evaluated against pre-batch state). The first tool with + an unmet prerequisite increments the violation counter and returns a + StepCheck with a prerequisite nudge; whole-batch blocking." + (let loop ((tcs tool-calls)) + (cond + ((null? tcs) (make-step-check #f #f)) + (else + (let ((prereqs (assoc-ref (senf-tool-prerequisites e) (wtool-call-tool (car tcs))))) + (if (or (not prereqs) (null? prereqs)) + (loop (cdr tcs)) + (let ((result (step-tracker-check-prerequisites + (senf-tracker e) (wtool-call-tool (car tcs)) + (wtool-call-args (car tcs)) prereqs))) + (if (prerequisite-check-satisfied result) + (loop (cdr tcs)) + (begin + (senf-prereq-violations-set! e (+ 1 (senf-prereq-violations e))) + (make-step-check + (make-prerequisite-nudge (wtool-call-tool (car tcs)) + (prerequisite-check-missing result)) + #t)))))))))) + +(def (step-enforcer-terminal-reached? e tool-calls) + "True if a terminal tool is in the batch AND the required steps are done." + (and (batch-terminal-name e tool-calls) + (step-tracker-satisfied? (senf-tracker e)) + #t)) --- a/src/jcode/ui/cli.ss +++ b/src/jcode/ui/cli.ss @@ -28,6 +28,8 @@ :jcode/provider/sampling :jcode/core/hardware :jcode/core/compaction-strategy + :jcode/core/workflow + :jcode/core/workflow-runner :jcode/mcp/client :jcode/tool/lsp :jcode/core/plugin @@ -301,11 +303,53 @@ EXAMPLES: (printf " vram tier 4096 tokens (no GPU detected)~n"))) (printf "Toggle with /forge on | /forge off | /forge sampling off|on|strict~n")) +;; Built-in example workflow: search (required) then answer (terminal, +;; prereq=search). Used by /forge workflow to describe and self-test the +;; injected-responder engine without touching a live provider. +(def (forge-example-workflow) + (make-workflow + "research" + "Search for context, then answer." + (list + (make-tool-def + (make-tool-spec "search" "Search for a query." + '(("type" . "object"))) + (lambda (args) "search results") + '()) + (make-tool-def + (make-tool-spec "answer" "Give the final answer." + '(("type" . "object"))) + (lambda (args) "ANSWER delivered") + '("search"))) ; answer requires a prior search + '("search") ; required steps + "answer" ; terminal tool + "You are a research agent. {extra}")) + +(def (forge-print-workflow) + (let ((w (forge-example-workflow))) + (printf "Workflow engine: available (injected-responder runner).~n") + (printf "Example workflow: ~a — ~a~n" (workflow-name w) (workflow-description w)) + (printf " tools ~a~n" (string-join (workflow-tool-names w) ", ")) + (printf " required steps ~a~n" (string-join (workflow-required-steps w) ", ")) + (printf " terminal ~a~n" (string-join (workflow-terminal-tools w) ", ")) + ;; Self-test: drive the workflow with a scripted responder. + (let* ((script (list (list (make-wtool-call "search" '(("q" . "jerboa")) "search first")) + (list (make-wtool-call "answer" '(("text" . "done")) "now answer")))) + (n 0) + (responder (lambda (messages tool-specs step) + (let ((r (if (< n (length script)) (list-ref script n) + (make-text-response "stuck")))) + (set! n (+ n 1)) r))) + (result (run-workflow w "look up jerboa" responder + '((max-iterations . 6))))) + (printf " self-test ran ~a iterations, terminal returned: ~a~n" n result)) + (printf "Define workflows in jerboa .ss with make-workflow; run via run-workflow.~n"))) + (def (handle-command input session-id) (let ((cmd (string-trim (substring input 1 (string-length input))))) (cond ((equal? cmd "help") - (display "\nCommands:\n /help Show this help\n /model [name] Show or set model\n /provider [name] Show or set provider\n /plan Switch to PLAN mode (read-only)\n /build Switch to BUILD mode (read+write)\n /mode Show current mode\n /mcp Toggle MCP tools on/off\n /tools List available tools\n /clear Start a new session\n /sessions List saved sessions\n /compact Show message count\n /undo [N] Revert last N checkpoint(s) (default 1)\n /checkpoints List recent shadow-git checkpoints\n /forge [on|off] Show or toggle forge guardrails\n /forge sampling <off|on|strict> Per-model sampling policy\n /quit Exit\n\nMulti-line: end a line with \\ to continue on the next line.\n\n")) + (display "\nCommands:\n /help Show this help\n /model [name] Show or set model\n /provider [name] Show or set provider\n /plan Switch to PLAN mode (read-only)\n /build Switch to BUILD mode (read+write)\n /mode Show current mode\n /mcp Toggle MCP tools on/off\n /tools List available tools\n /clear Start a new session\n /sessions List saved sessions\n /compact Show message count\n /undo [N] Revert last N checkpoint(s) (default 1)\n /checkpoints List recent shadow-git checkpoints\n /forge [on|off] Show or toggle forge guardrails\n /forge sampling <off|on|strict> Per-model sampling policy\n /forge workflow Describe + self-test the workflow engine\n /quit Exit\n\nMulti-line: end a line with \\ to continue on the next line.\n\n")) ((equal? cmd "model") (printf "Provider: ~a~n" (or (current-provider-override) (config-provider))) (printf "Model: ~a~n" (or (current-model-override) (config-model))) @@ -392,6 +436,8 @@ EXAMPLES: (for-each (lambda (n) (printf " ~a~n" n)) file-skills)))) ((or (equal? cmd "forge") (equal? cmd "forge status")) (forge-print-status)) + ((equal? cmd "forge workflow") + (forge-print-workflow)) ((or (equal? cmd "forge on") (equal? cmd "forge enforce") (equal? cmd "forge enforce on")) (forge-respond-enforced? #t) --- a/test/run.ss +++ b/test/run.ss @@ -18,7 +18,11 @@ (jcode core errors) (jcode provider sampling) (jcode core hardware) - (jcode core compaction-strategy)) + (jcode core compaction-strategy) + (jcode core workflow) + (jcode core steps) + (jcode guardrails step-enforcer) + (jcode core workflow-runner)) ;; ── Helpers ────────────────────────────────────────────────────── @@ -756,6 +760,255 @@ (check-pred! "vram-tier-budget: int ≥ 4096" (vram-tier-budget) (lambda (x) (and (integer? x) (>= x 4096))))) +;; ── Workflow / steps / step-enforcer / runner (Phase 5) ─────────── + +(define (raises? thunk) (guard (e [#t #t]) (thunk) #f)) +(define (raises-pred? thunk pred) (guard (e [(pred e) #t] [#t #f]) (thunk) #f)) + +(define (scripted-responder responses) + (let ([i 0] [v (list->vector responses)]) + (lambda (messages tool-specs step) + (let ([r (if (< i (vector-length v)) (vector-ref v i) + (make-text-response "exhausted"))]) + (set! i (+ i 1)) r)))) + +;; search (required) → answer (terminal, prereq search). lookup is optional. +(define (mk-research-wf) + (make-workflow "research" "Search then answer." + (list + (make-tool-def (make-tool-spec "search" "s" '(("type" . "object"))) (lambda (a) "search results") '()) + (make-tool-def (make-tool-spec "lookup" "l" '(("type" . "object"))) (lambda (a) "looked") '()) + (make-tool-def (make-tool-spec "answer" "a" '(("type" . "object"))) (lambda (a) "ANSWER delivered") '("search"))) + '("search") "answer" "You are an agent. {extra}")) + +;; write requires read; finish terminal; no required steps. +(define (mk-prereq-wf) + (make-workflow "prq" "Read then write." + (list + (make-tool-def (make-tool-spec "read" "r" '(("type" . "object"))) (lambda (a) "read-ok") '()) + (make-tool-def (make-tool-spec "write" "w" '(("type" . "object"))) (lambda (a) "wrote") '("read")) + (make-tool-def (make-tool-spec "finish" "f" '(("type" . "object"))) (lambda (a) "FINISHED") '())) + '() "finish" "p")) + +(section "=== workflow construction ===") +(let ([w (mk-research-wf)]) + (check! "tool names" (workflow-tool-names w) '("search" "lookup" "answer")) + (check! "required steps" (workflow-required-steps w) '("search")) + (check! "terminal tools" (workflow-terminal-tools w) '("answer")) + (check! "terminal? answer" (workflow-terminal-tool? w "answer") #t) + (check! "terminal? search" (workflow-terminal-tool? w "search") #f) + (check! "get-tool-def name" (tool-def-name (workflow-get-tool-def w "answer")) "answer") + (check! "get-callable runs" ((workflow-get-callable w "search") '()) "search results") + (check! "tool-specs count" (length (workflow-get-tool-specs w)) 3) + (check! "tool-prerequisites" (workflow-tool-prerequisites w) '(("answer" . ("search")))) + (check-pred! "build-system-prompt subst" + (workflow-build-system-prompt w '(("extra" . "Be terse."))) + (lambda (s) (str-contains? s "Be terse."))) + (check! "prereq-name string" (prerequisite-name "search") "search") + (check! "prereq-name pair" (prerequisite-name (cons "open" "file")) "open")) + +(let ([sp (tool-spec-from-json-schema "n" "d" '(("type" . "object")))]) + (check! "tool-spec name" (tool-spec-name sp) "n") + (check! "tool-spec schema round-trip" (tool-spec-get-json-schema sp) '(("type" . "object")))) + +(section "=== workflow validation ===") +(define (mk-bad tools req term) (lambda () (make-workflow "x" "d" tools req term "p"))) +(check! "dup tool name raises" + (raises? (mk-bad (list (make-tool-def (make-tool-spec "a" "" '()) (lambda (x) 1) '()) + (make-tool-def (make-tool-spec "a" "" '()) (lambda (x) 1) '())) + '() "a")) #t) +(check! "required ∉ tools raises" + (raises? (mk-bad (list (make-tool-def (make-tool-spec "a" "" '()) (lambda (x) 1) '())) + '("nope") "a")) #t) +(check! "terminal ∉ tools raises" + (raises? (mk-bad (list (make-tool-def (make-tool-spec "a" "" '()) (lambda (x) 1) '())) + '() "zzz")) #t) +(check! "terminal also required raises" + (raises? (mk-bad (list (make-tool-def (make-tool-spec "a" "" '()) (lambda (x) 1) '())) + '("a") "a")) #t) +(check! "prereq ∉ tools raises" + (raises? (mk-bad (list (make-tool-def (make-tool-spec "a" "" '()) (lambda (x) 1) '("ghost"))) + '() "a")) #t) + +(section "=== step tracker ===") +(let ([t (make-step-tracker '("a" "b"))]) + (check! "fresh not satisfied" (step-tracker-satisfied? t) #f) + (check! "fresh pending" (step-tracker-pending t) '("a" "b")) + (check! "fresh hint" (step-tracker-summary-hint t) "[No steps completed yet]") + (step-tracker-record! t "a" '()) + (check! "after a not satisfied" (step-tracker-satisfied? t) #f) + (check! "after a pending" (step-tracker-pending t) '("b")) + (step-tracker-record! t "b" '()) + (check! "after b satisfied" (step-tracker-satisfied? t) #t) + (check! "after b pending" (step-tracker-pending t) '()) + (step-tracker-record! t "a" '()) + (check! "record dedups completed" (step-tracker-completed t) '("a" "b")) + (check! "hint lists completed" (step-tracker-summary-hint t) "[Steps completed: a, b]")) + +;; name-only prereq +(let ([t (make-step-tracker '())]) + (step-tracker-record! t "x" '()) + (check! "name-only satisfied" + (prerequisite-check-satisfied (step-tracker-check-prerequisites t "y" '() '("x"))) #t) + (check! "name-only missing"