diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,68 @@ ## Unreleased +## 0.3.0.0 - 2026-07-05 + +### Changed + +- **BREAKING** Combinator and budget semantics cleanup. `MajorityVote` now carries + its reducer, so `majorityVoteBy` applies its `TempSchedule` per sample (routed + temperatures reach the wire) and exposes the sub-program's `Params` once instead + of K times — parameter vectors saved from an old `majorityVoteBy` program no + longer load and must be re-saved. `chain` takes a `NonEmpty` (empty is a compile + error, not a runtime crash); `modal` and `sampleTemps` take/return `NonEmpty`. + `TempSpread` temperatures are clamped to `[0, 2]` (`TempFixed` values pass through + unclamped). A malformed numeric bound in a `Constrained` field + (e.g. `MinVal "abc"`) no longer crashes at schema-derivation time — the schema + keyword is omitted and every decode of the field fails with a located + `ValidationFailure` naming the bad symbol. `Shikumi.LLM.Budget.tryReserve` is + renamed `admitCall` with documented optimistic-admission semantics (concurrent + calls can overshoot the ceiling; no reservation is held). `refine` survives a + failed advice-generation call, returning its best-so-far output instead of + aborting. + +- **BREAKING** `Validatable` is now opt-in and enforced by the decode path in + every program runner. The catch-all `instance {-# OVERLAPPABLE #-} Validatable a` + has been removed, so a type's `Validatable` rule is no longer silently skipped + when a program runs through `runProgram`, `runProgramConc`, `streamProgram`, or + `chainOfThought` — a violated rule now surfaces as `Left (ValidationFailure …)`. + Migration: declare an instance for every `Predict` output type and every typed + tool input. A type with no rules needs one line — `instance Validatable Foo` + (the default `validate = Right` applies) or add `Validatable` to a + `deriving anyclass (…)` list. `runPredict`, `streamPredict`, `chainOfThought`, + and `chainOfThoughtRaw` gained a `Validatable o` constraint, and + `WithReasoning o` now has a delegating `Validatable` instance that runs the + wrapped value's rule. + +- **BREAKING** Derived JSON Schemas now satisfy OpenAI strict mode. A `Maybe` + field is emitted as required-but-nullable (listed in `required` with a nullable + schema) instead of being omitted from `required`, and `enumSchema` carries an + explicit `"type": "string"`. This changes the shape real OpenAI/Anthropic + requests send; the decode path is unchanged and still tolerates a missing key or + explicit `null` for `Maybe` fields. + +- Native structured-output requests are now coherent. When a program routes to a + native-capable model, the request carries a system prompt describing the JSON + object to produce and demos rendered as JSON — not `[[ ## field ## ]]` marker + sections — via a new native render channel (`attachNativeRender` / + `nativeRenderPieces`, swapped in by `routeLLM`/`translateForWire`). Fallback + models are unchanged. `parseResponse` now keeps the precise native decode error + for JSON reply bodies instead of masking it behind a misleading `MissingField` + from the marker parser. `Shikumi.Routing.translateForWire` widened to + `Model -> Context -> Options -> (Context, Options)`. + +- `streamProgram` now works against real providers. `routeLLM` rewrites the + `Stream` operation exactly as it rewrites `Complete` (ambient model, translated + and stripped metadata, native `Context` swap), so a routed streaming call sends + the real model id and wire options instead of the inert placeholder. `streamPredict` + reuses the blocking path's `effectiveSignature`, schema/native stamps, and the + dual-format `parseResponse` (both newly exported from `Shikumi.Program`), so a + native (JSON) stream decodes correctly. Stream failures now surface out-of-band: + a terminal `EventError` becomes a transient `ProviderFailure` thrown through + `Error ShikumiError` (so retry policies fire), and the budget is charged from the + terminal payload — success or error — before the throw. The event list returned + by `Shikumi.LLM.stream` never terminates in `EventError`. + ## 0.2.0.0 - 2026-06-28 ### Added diff --git a/shikumi.cabal b/shikumi.cabal --- a/shikumi.cabal +++ b/shikumi.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: shikumi -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Typed, structured, evaluable LM programs over baikai category: AI description: @@ -53,10 +53,10 @@ build-depends: , aeson - , baikai >=0.2 && <0.3 - , baikai-claude >=0.2 && <0.3 - , baikai-effectful >=0.2 && <0.3 - , baikai-openai >=0.2 && <0.3 + , baikai >=0.3 && <0.4 + , baikai-claude >=0.3 && <0.4 + , baikai-effectful >=0.3 && <0.4 + , baikai-openai >=0.3 && <0.4 , base >=4.20 && <5 , base64-bytestring , bytestring @@ -109,10 +109,10 @@ build-depends: , aeson - , baikai >=0.2 && <0.3 - , baikai-claude >=0.2 && <0.3 - , baikai-effectful >=0.2 && <0.3 - , baikai-openai >=0.2 && <0.3 + , baikai >=0.3 && <0.4 + , baikai-claude >=0.3 && <0.4 + , baikai-effectful >=0.3 && <0.4 + , baikai-openai >=0.3 && <0.4 , base , base64-bytestring , bytestring @@ -122,7 +122,7 @@ , generic-lens , lens , QuickCheck - , shikumi ^>=0.2.0.0 + , shikumi ^>=0.3.0.0 , stm , streamly-core , tasty diff --git a/src/Shikumi/Adapter.hs b/src/Shikumi/Adapter.hs --- a/src/Shikumi/Adapter.hs +++ b/src/Shikumi/Adapter.hs @@ -23,6 +23,16 @@ -- the router ("Shikumi.Routing".@routeLLM@) translates those into -- @responseFormat@\/@temperature@ against the real model and strips the keys before -- transport. +-- +-- The same channel also carries the /native render alternative/ (EP-33). Because +-- the runtime always renders the model-agnostic marker prompt, 'attachNativeRender' +-- additionally stamps the native-format system prompt under 'metaNativePromptKey' +-- and the native (JSON) demo assistant turns under 'metaNativeDemosKey' +-- ('nativeRenderPieces' produces both). For a native-capable model the router swaps +-- these into the @Context@ (so the model is told to reply as JSON and shown JSON +-- demos, not @[[ ## … ## ]]@ markers); for fallback models the marker prompt stands +-- and the keys are stripped. 'renderOutputNative' is the shared demo renderer, also +-- used by 'nativeAdapter' when a caller drives it directly. module Shikumi.Adapter ( -- * Input rendering ToPrompt (..), @@ -37,11 +47,17 @@ adapterFor, attachSchema, responseText, + assistantJSON, -- * The private request-metadata channel (consumed by "Shikumi.Routing") stampTemperature, metaResponseSchemaKey, metaTemperatureKey, + metaNativePromptKey, + metaNativeDemosKey, + attachNativeRender, + nativeRenderPieces, + renderOutputNative, ) where @@ -63,15 +79,17 @@ ) import Control.Lens (at, (&), (.~), (?~), (^.)) import Data.Aeson (Object, Value (..), eitherDecodeStrict, toJSON) +import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Kind (Type) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Vector qualified as V import GHC.Generics import Shikumi.Error (ShikumiError (..)) @@ -197,6 +215,21 @@ metaTemperatureKey :: Text metaTemperatureKey = "shikumi.temperature" +-- | Reserved 'Options.metadata' key carrying the full native-format system prompt +-- (instruction + native output guide) as a JSON string. Stamped by +-- 'Shikumi.Program.runPredict'; "Shikumi.Routing".@routeLLM@ swaps it into the +-- 'Context' for native-capable models and strips it before transport. Because +-- @runPredict@ renders model-agnostically (the marker prompt), this carries the +-- native alternative so the router can install it once the real model is known. +metaNativePromptKey :: Text +metaNativePromptKey = "shikumi.native.systemPrompt" + +-- | Reserved 'Options.metadata' key carrying the native-format demo assistant +-- turns, in order, as a JSON array of strings. Same lifecycle as +-- 'metaNativePromptKey'. +metaNativeDemosKey :: Text +metaNativeDemosKey = "shikumi.native.demos" + -- | Stamp the derived JSON schema onto a request's private metadata channel. This -- is no longer a no-op: it records the schema under 'metaResponseSchemaKey' so the -- router can attach a real @responseFormat@ once the ambient model is known. (The @@ -206,6 +239,28 @@ attachSchema schema opts = opts & #metadata . at metaResponseSchemaKey ?~ schema +-- | Stamp the native-format system prompt and demo assistant turns onto a +-- request's private metadata channel, under 'metaNativePromptKey' and +-- 'metaNativeDemosKey'. Mirrors 'attachSchema': the router swaps these into the +-- 'Context' for native-capable models and strips the keys before transport. +attachNativeRender :: Text -> [Text] -> Options -> Options +attachNativeRender sys demos opts = + opts + & #metadata . at metaNativePromptKey ?~ toJSON sys + & #metadata . at metaNativeDemosKey ?~ toJSON demos + +-- | The native-format render pieces for a signature: the system prompt a +-- native-capable model should see (instruction + native output guide, /not/ the +-- marker guide) and the demo assistant turns rendered as JSON objects, in order. +-- 'Shikumi.Program.runPredict' stamps these via 'attachNativeRender' so the router +-- can install them once the real model is known. +nativeRenderPieces :: + forall i o. (ToSchema o, ToPrompt o) => Signature i o -> (Text, [Text]) +nativeRenderPieces sig = + ( systemHeader sig <> nativeOutputGuide sig, + [renderOutputNative @o o | Demo _ o <- getDemos sig] + ) + -- | Stamp a per-sample temperature onto a request's private metadata channel under -- 'metaTemperatureKey'. Used by 'Shikumi.Program.runProgram' to thread a -- 'Shikumi.Program.MajorityVote' sample's temperature down to its 'Predict' nodes; @@ -225,7 +280,7 @@ Adapter { render = \sig i -> let sys = systemHeader sig <> nativeOutputGuide sig - ctx = buildContext sys (demoMessages sig ++ [userTurn i]) + ctx = buildContext sys (nativeDemoMessages sig ++ [userTurn i]) opts = attachSchema (deriveSchema @o) _Options in (ctx, opts), parse = \_sig resp -> assistantJSON resp >>= fromModelChecked @@ -252,11 +307,19 @@ -- | The XML adapter (EP-26). A third wire format on the same typed seam: @render@ -- asks the model to wrap each output field in @\…\@ tags, and -- @parse@ reads those tags back. Some models follow an XML shape more reliably than --- JSON or the @[[ ## … ## ]]@ markers. Opt-in — a caller selects it explicitly; --- 'adapterFor' does not auto-select it (XML is a caller choice, not a detectable --- model capability). Reuses the same 'sectionsToObject' + 'fromModelChecked' --- decode path as 'fallbackAdapter', so nested records and lists in tags coerce the --- same way. +-- JSON or the @[[ ## … ## ]]@ markers. Reuses the same 'sectionsToObject' + +-- 'fromModelChecked' decode path as 'fallbackAdapter', so nested records and lists +-- in tags coerce the same way. +-- +-- Reachability: 'xmlAdapter' is /not/ selectable by the runtime router. The router +-- ("Shikumi.Routing".@routeLLM@) picks between the native and fallback wire shapes +-- from the model's detected 'ModelCapability' (native vs. prompt-fallback); XML is a +-- caller choice, not a detectable capability, so 'adapterFor' never returns it. To +-- use it, hold the 'Adapter' value directly and render/parse with it inside an +-- 'Shikumi.Program.embed' node — the same way 'Shikumi.Module.twoStep' drives +-- 'fallbackAdapter' by hand. A per-node adapter selector through the 'Program' GADT +-- was considered and deferred (see the parent MasterPlan's scope), as it is +-- disproportionate to the need. xmlAdapter :: forall i o. (ToSchema o, FromModel o, Validatable o, ToPrompt i, ToPrompt o) => @@ -333,6 +396,26 @@ where one (Demo i o) = [user (toPrompt i), assistant (renderOutputSections o)] +-- | Render a demo output as the JSON object a native model is asked to reply +-- with. Reuses 'sectionsToObject' so each field's text coerces against the +-- derived schema exactly as the fallback parse path coerces marker sections — +-- one source of truth for the text-to-typed-JSON coercion (there is no @o -> +-- Value@ inverse to render directly, as 'FromModel' has no dual). +renderOutputNative :: forall o. (ToSchema o, ToPrompt o) => o -> Text +renderOutputNative o = + decodeUtf8 (LBS.toStrict (Aeson.encode obj)) + where + obj = sectionsToObject (deriveSchema @o) (Map.fromList (toPromptFields o)) + +-- | Demo turns for the native path: user prompt as usual, assistant turn as the +-- JSON object (not marker sections), so a native model sees examples in the same +-- shape as the reply it is asked to produce. +nativeDemoMessages :: + forall i o. (ToSchema o, ToPrompt i, ToPrompt o) => Signature i o -> [Message] +nativeDemoMessages sig = concatMap one (getDemos sig) + where + one (Demo i o) = [user (toPrompt i), assistant (renderOutputNative @o o)] + -- | Render a demo output as @[[ ## field ## ]]@ sections (shared by both adapters -- for demo presentation). renderOutputSections :: (ToPrompt o) => o -> Text @@ -376,7 +459,10 @@ responseText resp = T.concat [t | AssistantText (TextContent t) <- V.toList (flattenAssistantBlocks resp)] --- | Read the assistant text and parse it as a JSON value (native path). +-- | Read the assistant text and parse it as a JSON value (native path). Exported +-- for 'Shikumi.Program.parseResponse', which uses it to detect the wire shape: a +-- body that parses as JSON is the native shape and is decoded by the native +-- parser (keeping its located error), while a non-JSON body is the marker shape. assistantJSON :: Response -> Either ShikumiError Value assistantJSON resp = case eitherDecodeStrict (encodeUtf8 (responseText resp)) of diff --git a/src/Shikumi/Combinator.hs b/src/Shikumi/Combinator.hs --- a/src/Shikumi/Combinator.hs +++ b/src/Shikumi/Combinator.hs @@ -56,11 +56,14 @@ ) where +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE import Data.Text (Text) import Shikumi.Error (ShikumiError) import Shikumi.Program ( Program (Compose, Ensemble, MajorityVote, Map, Parallel, Retry, RetryWhen, Validate), TempSchedule (..), + modal, ) -- --------------------------------------------------------------------------- @@ -80,11 +83,11 @@ -- @pipeline@\/@Compose@; this n-ary helper is restricted to a single carried type -- because the GADT has no identity node to seed an empty fold.) -- --- Applying it to the empty list is a programmer error (there is no identity --- 'Program'). -chain :: [Program a a] -> Program a a -chain [] = error "Shikumi.Combinator.chain: empty stage list" -chain ps = foldr1 (>>>) ps +-- The argument is a 'NonEmpty' — there is no identity 'Program' to seed an empty +-- fold, so emptiness is unrepresentable rather than a runtime crash. Write +-- @chain (a ':|' [b, c])@ (or @chain (NE.fromList [a, b, c])@). +chain :: NonEmpty (Program a a) -> Program a a +chain ps = foldr1 (>>>) (NE.toList ps) -- --------------------------------------------------------------------------- -- Map @@ -148,16 +151,19 @@ -- --------------------------------------------------------------------------- -- | Sample a program @K@ times and return the modal output (most frequent under --- 'Eq', ties broken by first appearance). The 'TempSchedule' is carried and --- serialized but not yet applied to the wire — see 'TempSchedule'. +-- 'Eq', ties broken by first appearance). The 'TempSchedule' is live: each +-- sample's temperature is stamped onto its request and realized on the wire by the +-- router (see 'TempSchedule'). majorityVote :: (Eq o) => Int -> TempSchedule -> Program i o -> Program i o -majorityVote = MajorityVote +majorityVote k sched = MajorityVote k sched modal --- | Sample a program @K@ times and fold the @K@ outputs with a custom reducer, --- for outputs that are not usefully 'Eq'. Defined as an 'ensemble' over @K@ --- copies of the program. +-- | Sample a program @K@ times and fold the @K@ (non-empty) outputs with a custom +-- reducer, for outputs that are not usefully 'Eq'. Like 'majorityVote' it applies +-- the 'TempSchedule' per sample and exposes the sub-program's 'Params' once (not +-- @K@ times) — the samples are runs of a single node, not @K@ distinct 'ensemble' +-- members. majorityVoteBy :: Int -> TempSchedule -> ([o] -> o) -> Program i o -> Program i o -majorityVoteBy k _sched reducer p = Ensemble (replicate (max 1 k) p) reducer +majorityVoteBy k sched reducer = MajorityVote k sched (reducer . NE.toList) -- --------------------------------------------------------------------------- -- Ensemble diff --git a/src/Shikumi/Compaction.hs b/src/Shikumi/Compaction.hs --- a/src/Shikumi/Compaction.hs +++ b/src/Shikumi/Compaction.hs @@ -62,7 +62,8 @@ enabled cfg && (model ^. #contextWindow) > 0 && (usage ^. #inputTokens) >= overflowThreshold cfg model -- | Fold the older portion of an oldest-first list into one synthesized summary --- item, preserving the most recent 'keepRecent' items verbatim. +-- item, preserving the most recent 'keepRecent' items verbatim. A disabled +-- config is the identity and does not call the model. compactTail :: (LLM :> es, Error ShikumiError :> es) => CompactionConfig -> @@ -72,6 +73,7 @@ [a] -> Eff es [a] compactTail cfg model render inject xs + | not (enabled cfg) = pure xs | olderCount <= 0 = pure xs | otherwise = do requireErrorRow Nothing diff --git a/src/Shikumi/Error.hs b/src/Shikumi/Error.hs --- a/src/Shikumi/Error.hs +++ b/src/Shikumi/Error.hs @@ -36,6 +36,8 @@ Timeout !Text | -- | the running cost ceiling was reached; the call was refused BudgetExceeded !Text + | -- | generated code failed after exhausting correction attempts + CodeExecFailed !Text deriving stock (Eq, Show) -- | Total mapping from baikai's transport-level errors into shikumi's @@ -56,9 +58,10 @@ _ -> ProviderFailure (message e) -- | Which errors are worth retrying. Provider/transport failures and timeouts are --- transient; decode, schema, validation, and budget errors are deterministic and --- retrying cannot fix them. Centralizing the policy here keeps it auditable --- (the resilience interpreter in "Shikumi.LLM" consults exactly this predicate). +-- transient; decode, schema, validation, budget, and code-execution failures are +-- deterministic and retrying cannot fix them. Centralizing the policy here keeps +-- it auditable (the resilience interpreter in "Shikumi.LLM" consults exactly this +-- predicate). isTransient :: ShikumiError -> Bool isTransient = \case ProviderFailure {} -> True diff --git a/src/Shikumi/LLM.hs b/src/Shikumi/LLM.hs --- a/src/Shikumi/LLM.hs +++ b/src/Shikumi/LLM.hs @@ -53,6 +53,7 @@ Options, Response, TerminalPayload, + responseError, ) import Baikai.Effectful (Baikai, runBaikai, runBaikaiWith) import Baikai.Effectful qualified as BE @@ -68,7 +69,8 @@ ) import Control.Lens ((^.)) import Data.Generics.Labels () -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text qualified as T import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, IOE, liftIO, (:>)) import Effectful.Concurrent (Concurrent, threadDelay) import Effectful.Concurrent.STM (atomically) @@ -76,11 +78,18 @@ import Effectful.Error.Static (Error, catchError, throwError) import Effectful.Exception (bracket_, try) import Shikumi.Error (ShikumiError (..), fromBaikaiError, isTransient) -import Shikumi.LLM.Budget (Budget, recordCost, tryReserve) +import Shikumi.LLM.Budget (Budget, admitCall, recordCost) -- | The provider-neutral LM effect. 'Complete' is a blocking completion; -- 'Stream' returns the assembled list of typed events so callers that need -- deltas can fold them. +-- +-- Stream-error contract (all shikumi interpreters): the returned event list +-- never terminates with an @EventError@. A provider failure — which the +-- policy-free @Baikai@ transport surfaces in-band as a terminal @EventError@ — is +-- converted to an out-of-band 'ShikumiError' thrown through @Error ShikumiError@, +-- so 'stream' failures are transient-retryable and reported exactly like +-- 'complete' failures. data LLM :: Effect where Complete :: Model -> Context -> Options -> LLM m Response Stream :: Model -> Context -> Options -> LLM m [AssistantMessageEvent] @@ -119,9 +128,13 @@ -- | The bare handler, shared by both interpreters. It runs in the handler stack -- (@Baikai : es@), so it can call the @Baikai@ transport effect and throw --- through the @Error ShikumiError@ effect. The blocking path catches baikai's --- 'BaikaiError' (thrown by 'BE.complete') and remaps it; the streaming path --- surfaces failures in-band as a terminal @EventError@, so it does not catch. +-- through the @Error ShikumiError@ effect. The blocking path routes baikai's +-- in-band failure (an error-shaped 'Response') through 'raiseResponseError' — plus +-- a defensive 'try' for any residual thrown 'BaikaiError' — and remaps it; the +-- streaming path collects the events and, via 'raiseStreamError', converts a +-- terminal @EventError@ into the same out-of-band 'ShikumiError' — so callers of +-- 'stream' never receive an in-band error terminal and resilience/decoding treat +-- both operations identically. bareHandler :: (Baikai :> es, Error ShikumiError :> es) => LLM (Eff localEs) a -> @@ -129,8 +142,8 @@ bareHandler = \case Complete m c o -> do res <- try @BaikaiError (BE.complete m c o) - either (throwError . fromBaikaiError) pure res - Stream m c o -> BE.streamCollect m c o + either (throwError . fromBaikaiError) raiseResponseError res + Stream m c o -> BE.streamCollect m c o >>= raiseStreamError -- --------------------------------------------------------------------------- -- Resilience: retries, rate limiting, budget @@ -162,7 +175,9 @@ -- | Interpretation-time policy for 'runLLMResilient'. data LLMConfig = LLMConfig { retryPolicy :: !RetryPolicy, - -- | 'Nothing' = unlimited cost + -- | 'Nothing' = unlimited cost. Enforcement is optimistic admission, not + -- reservation: concurrent calls can overshoot the ceiling by up to the sum of + -- their in-flight costs (see "Shikumi.LLM.Budget"). budget :: !(Maybe Budget), -- | 'Nothing' = unbounded concurrency rateLimit :: !(Maybe RateLimiter), @@ -197,20 +212,28 @@ case res of Left be -> throwError (fromBaikaiError be) Right resp -> do + -- Charge before raising: an error-shaped 'Response' may still carry + -- billable usage (mirrors 'chargeBudgetFromEvents' on the stream path). liftIO (chargeBudget mb resp) - pure resp + raiseResponseError resp Stream m c o -> withBudget mb . withRateLimit mr . retrying rp $ do evs <- BE.streamCollect m c o + -- Charge from the terminal payload (success /or/ error) before raising: a + -- failed stream may still have consumed billable tokens. liftIO (chargeBudgetFromEvents mb evs) - pure evs + raiseStreamError evs where mb = budget cfg mr = rateLimit cfg rp = retryPolicy cfg --- | Optimistic pre-call budget gate. Refuses the call with 'BudgetExceeded' when --- the running total has already reached the ceiling. +-- | Optimistic pre-call budget gate (admission, not reservation). Refuses the +-- call with 'BudgetExceeded' when the recorded running total has already reached +-- the ceiling. Because 'admitCall' holds nothing, @N@ calls admitted concurrently +-- can each pass the gate and overshoot the ceiling by up to the sum of their costs; +-- the first call after the total reaches the ceiling is refused. See +-- "Shikumi.LLM.Budget". withBudget :: (IOE :> es, Error ShikumiError :> es) => Maybe Budget -> @@ -218,7 +241,7 @@ Eff es a withBudget Nothing act = act withBudget (Just b) act = do - ok <- liftIO (tryReserve b) + ok <- liftIO (admitCall b) if ok then act else throwError (BudgetExceeded "cost ceiling reached") -- | Bound concurrency to the limiter's permits, releasing on every exit path. @@ -269,8 +292,51 @@ responseCostUSD :: Response -> Rational responseCostUSD resp = resp ^. #message . #usage . #cost . #usd +-- | Enforce the stream-error posture: a terminal 'EventError' becomes an +-- out-of-band 'ShikumiError' — a 'ProviderFailure' carrying the terminal message's +-- @errorMessage@ (or the stop reason if none). A successful event list passes +-- through unchanged, so callers of 'stream' never see an in-band error terminal. +-- Because both interpreters call this /inside/ their retry loop, a transient stream +-- failure is retried exactly like a blocking one ('ProviderFailure' is transient +-- per 'isTransient'). +-- +-- The baikai version shikumi pins does not attach a structured 'BaikaiError' to a +-- terminal payload (its @TerminalPayload@ is @{reason, message}@; the failure detail +-- lives in the assembled message's @errorMessage@ and @stopReason@), so all stream +-- failures map to 'ProviderFailure' rather than through 'fromBaikaiError'. +raiseStreamError :: + (Error ShikumiError :> es) => [AssistantMessageEvent] -> Eff es [AssistantMessageEvent] +raiseStreamError evs = case [tp | EventError tp <- evs] of + (tp : _) -> throwError (streamTerminalError tp) + [] -> pure evs + +-- | Enforce the blocking-error posture, the 'complete' analogue of +-- 'raiseStreamError'. Since baikai 0.3, 'BE.complete' does not throw on +-- provider/registry/CLI failure: it returns an error-shaped 'Response' whose +-- 'responseError' is populated. Convert that in-band failure into the same +-- out-of-band 'ShikumiError' the rest of shikumi consumes, so an error response +-- never masquerades as success and 'runLLMResilient' still retries transient +-- failures (a 'ProviderFailure' thrown /inside/ the retry loop). A success +-- passes through unchanged. +raiseResponseError :: + (Error ShikumiError :> es) => Response -> Eff es Response +raiseResponseError resp = case responseError resp of + Just be -> throwError (fromBaikaiError be) + Nothing -> pure resp + +-- | Map a terminal 'EventError' payload to a 'ShikumiError'. +streamTerminalError :: TerminalPayload -> ShikumiError +streamTerminalError tp = ProviderFailure ("stream failed: " <> detail) + where + detail = case tp ^. #message of + AssistantMessage p -> fromMaybe (T.pack (show (tp ^. #reason))) (p ^. #errorMessage) + _ -> T.pack (show (tp ^. #reason)) + -- | Charge a completed streaming call's cost, read from the terminal event's --- assembled message. +-- assembled message. Note: an /error/ terminal ('EventError') is charged too — a +-- failed stream may still have consumed billable tokens, and the terminal +-- payload's assembled message carries the usage/cost baikai computed; not charging +-- would silently undercount real spend. chargeBudgetFromEvents :: Maybe Budget -> [AssistantMessageEvent] -> IO () chargeBudgetFromEvents Nothing _ = pure () chargeBudgetFromEvents (Just b) evs = diff --git a/src/Shikumi/LLM/Budget.hs b/src/Shikumi/LLM/Budget.hs --- a/src/Shikumi/LLM/Budget.hs +++ b/src/Shikumi/LLM/Budget.hs @@ -1,16 +1,24 @@ -- | A running US-dollar cost ceiling for LM calls. -- --- The budget is enforced /before/ a call by an optimistic 'tryReserve' check and --- updated /after/ each successful call with 'recordCost', reading baikai's --- per-response @Usage.cost.usd@ (a 'Rational', always populated). The semantics --- are deliberately simple: the budget refuses the /next/ call once the running --- total has reached the ceiling. A single in-flight call is never clipped --- mid-stream (baikai exposes no streaming cost preview), but once it pushes the --- total to/over the cap, every subsequent call fails fast. +-- The budget is checked /before/ a call by an optimistic 'admitCall' /admission/ +-- and updated /after/ each call with 'recordCost', reading baikai's per-response +-- @Usage.cost.usd@ (a 'Rational', always populated). Admission is /not/ a +-- reservation: nothing is held, because baikai exposes no pre-call cost estimate. +-- The honest contract is: +-- +-- * a call is admitted while the recorded running total is /strictly under/ the +-- ceiling; +-- * @N@ calls admitted concurrently — all seeing a total under the ceiling before +-- any of them records its cost — are all admitted and all charged, so the total +-- can overshoot the ceiling by up to the sum of those in-flight calls' costs; +-- * once the recorded total reaches (or exceeds) the ceiling, every subsequent +-- admission is refused. +-- +-- An unlimited budget (@ceilingUSD == Nothing@) always admits. module Shikumi.LLM.Budget ( Budget (..), newBudget, - tryReserve, + admitCall, recordCost, spentUSD, ) @@ -36,11 +44,14 @@ newBudget :: Maybe Rational -> IO Budget newBudget c = Budget c <$> newTVarIO 0 --- | Optimistic pre-call check: 'True' if a call is permitted (the running total --- has not yet reached the ceiling), 'False' once the ceiling is met/exceeded. --- An unlimited budget always permits. -tryReserve :: Budget -> IO Bool -tryReserve b = case ceilingUSD b of +-- | Optimistic pre-call admission (not a reservation — nothing is held): 'True' +-- if a call is permitted (the recorded running total is strictly under the +-- ceiling), 'False' once the ceiling is met/exceeded. Because it reserves nothing, +-- @N@ concurrent admissions can each see a sub-ceiling total and all succeed, +-- overshooting by up to the sum of their costs; the first admission after the +-- total reaches the ceiling is refused. An unlimited budget always admits. +admitCall :: Budget -> IO Bool +admitCall b = case ceilingUSD b of Nothing -> pure True Just cap -> atomically $ do s <- readTVar (spentRef b) diff --git a/src/Shikumi/Module.hs b/src/Shikumi/Module.hs --- a/src/Shikumi/Module.hs +++ b/src/Shikumi/Module.hs @@ -44,7 +44,7 @@ import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (complete) import Shikumi.Program (Program (FMap, Predict), embed, emptyParams) -import Shikumi.Schema (FromModel (..), ToSchema (..), Validatable) +import Shikumi.Schema (FromModel (..), ToSchema (..), Validatable (..)) import Shikumi.Schema.Types ( FieldMeta (..), FieldPath, @@ -104,6 +104,11 @@ imageFields _ = [] imageFieldNames _ = [] +-- | Validation delegates to the wrapped value; the free-form @reasoning@ text +-- carries no user rules. +instance (Validatable o) => Validatable (WithReasoning o) where + validate wr = (\v -> wr {value = v}) <$> validate (value wr) + -- | Look up a required field in a JSON object, locating a miss precisely. getField :: (FromModel a) => FieldPath -> Text -> Object -> Either ShikumiError a getField path nm o = case KM.lookup (Key.fromText nm) o of @@ -111,16 +116,17 @@ Just v -> fromModelP (pushField nm path) v -- | Chain-of-thought that yields the bare @o@: build the reasoning-augmented node, --- then 'FMap' out the answer. +-- then 'FMap' out the answer. The user's @Validatable o@ rule fires on the +-- unwrapped answer via the delegating @Validatable (WithReasoning o)@ instance. chainOfThought :: - (FromModel i, FromModel o, ToSchema o, ToPrompt i, ToPrompt o) => + (FromModel i, FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) => Signature i o -> Program i o chainOfThought sig = FMap value (chainOfThoughtRaw sig) -- | Chain-of-thought that keeps the reasoning visible in the output. chainOfThoughtRaw :: - (FromModel i, FromModel o, ToSchema o, ToPrompt i, ToPrompt o) => + (FromModel i, FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) => Signature i o -> Program i (WithReasoning o) chainOfThoughtRaw sig = Predict (withReasoningField sig) emptyParams @@ -129,6 +135,14 @@ -- instruction to ask for step-by-step reasoning before the answer. The input -- field metadata is carried over from the source signature; the output metadata is -- the two fields of 'WithReasoning' (matching its hand-written schema). +-- +-- Note: signature-level demos are /not/ carried onto the reasoning-augmented +-- node (@demos = []@), because a @Demo i o@ cannot be turned into a +-- @Demo i (WithReasoning o)@ without inventing reasoning text — and a fabricated +-- or empty reasoning string would teach the model to skip reasoning, defeating +-- the module's purpose. Demos supplied through the node's optimizer @Params@ +-- channel are unaffected: they are stored as JSON and decoded against +-- @WithReasoning o@, so they already include a @reasoning@ field. withReasoningField :: Signature i o -> Signature i (WithReasoning o) withReasoningField sig = Signature diff --git a/src/Shikumi/Program.hs b/src/Shikumi/Program.hs --- a/src/Shikumi/Program.hs +++ b/src/Shikumi/Program.hs @@ -64,6 +64,8 @@ modal, sampleTemps, withSampleTemp, + effectiveSignature, + parseResponse, -- * Parameter interface (the optimizer/compiler contract) paramsTraversal, @@ -84,6 +86,8 @@ import Data.Aeson (FromJSON, ToJSON, Value) import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -97,9 +101,12 @@ ( Adapter (..), ToPrompt, adapterFor, + assistantJSON, + attachNativeRender, attachSchema, fallbackAdapter, nativeAdapter, + nativeRenderPieces, stampTemperature, ) import Shikumi.Error (ShikumiError (..)) @@ -202,10 +209,15 @@ -- normalizing), 'Left' rejects with a reason surfaced as a -- 'ValidationFailure'. Validate :: (o -> Either Text o) -> Program i o -> Program i o - -- | Sample a program @K@ times and return the modal (most-frequent under - -- 'Eq', ties broken by first-seen) output. Each sample is run with its - -- 'TempSchedule' temperature applied to the wire (see 'TempSchedule'). - MajorityVote :: (Eq o) => Int -> TempSchedule -> Program i o -> Program i o + -- | Sample a program @K@ times, then fold the (non-empty) samples with a + -- total reducer — 'Shikumi.Combinator.majorityVote' passes 'modal' (the modal + -- value under 'Eq'); 'Shikumi.Combinator.majorityVoteBy' passes a custom + -- reducer. Each sample is run with its 'TempSchedule' temperature applied to + -- the wire (see 'TempSchedule'). The reducer is opaque to the parameter + -- traversal and to 'ProgramShape' (omitted, exactly like 'Ensemble'\'s), so a + -- @MajorityVote@ exposes the sub-program's 'Params' once. The @Eq o@ that + -- 'modal' needs now lives on the smart constructor, not the GADT. + MajorityVote :: Int -> TempSchedule -> (NonEmpty o -> o) -> Program i o -> Program i o -- | Run several programs on the same input, collect their (homogeneous) -- results, and fold them with a total reducer. Ensemble :: [Program i r] -> ([r] -> o) -> Program i o @@ -266,8 +278,8 @@ runProgram (Retry n p) i = retryWith runProgram (const True) n p i runProgram (RetryWhen ok n p) i = retryWith runProgram ok n p i runProgram (Validate v p) i = runProgram p i >>= acceptOrReject v -runProgram (MajorityVote k sched p) i = - modal <$> traverse (\mt -> withSampleTemp mt (runProgram p i)) (sampleTemps (max 1 k) sched) +runProgram (MajorityVote k sched reduce p) i = + reduce <$> traverse (\mt -> withSampleTemp mt (runProgram p i)) (sampleTemps k sched) runProgram (Ensemble ps reduce) i = reduce <$> traverse (\p -> runProgram p i) ps runProgram (Embed f) i = f i @@ -290,8 +302,8 @@ runProgramConc (Retry n p) i = retryWith runProgramConc (const True) n p i runProgramConc (RetryWhen ok n p) i = retryWith runProgramConc ok n p i runProgramConc (Validate v p) i = runProgramConc p i >>= acceptOrReject v -runProgramConc (MajorityVote k sched p) i = - modal <$> mapConcurrently (\mt -> withSampleTemp mt (runProgramConc p i)) (sampleTemps (max 1 k) sched) +runProgramConc (MajorityVote k sched reduce p) i = + reduce <$> mapConcurrently (\mt -> withSampleTemp mt (runProgramConc p i)) (sampleTemps k sched) runProgramConc (Ensemble ps reduce) i = reduce <$> mapConcurrently (\p -> runProgramConc p i) ps -- The body requires only @(LLM, Error ShikumiError)@, a subset of this row, so it -- runs unchanged; an embedded agent that wants concurrency uses 'runProgramConc' @@ -303,7 +315,7 @@ -- executors so the wire behaviour is defined once. runPredict :: forall i o es. - (FromModel i, FromModel o, ToSchema o, ToPrompt i, ToPrompt o) => + (FromModel i, FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) => (LLM :> es, Error ShikumiError :> es) => Signature i o -> Params -> @@ -316,7 +328,13 @@ -- Stamp the derived schema onto the metadata channel regardless of which -- adapter rendered the prompt; the router attaches a real @responseFormat@ -- from it for native-capable models and strips it otherwise. - opts = attachSchema (deriveSchema @o) opts0 + -- + -- Also stamp the native-format alternative (system prompt + JSON demos): the + -- prompt is rendered model-agnostically as the marker format, so the router + -- swaps in these native pieces once it knows the real model is native-capable + -- (and strips them for fallback models / un-routed runs). + (nativeSys, nativeDemos) = nativeRenderPieces @i @o sig' + opts = attachNativeRender nativeSys nativeDemos (attachSchema (deriveSchema @o) opts0) resp <- complete placeholderModel ctx opts either throwError pure (parseResponse sig' resp) @@ -324,9 +342,17 @@ -- a native model (whose @responseFormat@ the router enforced) replies with a JSON -- object, while a fallback model replies with @[[ ## field ## ]]@ sections. Because -- a model-agnostic 'runPredict' cannot know at render time which the real model is, --- we try the native JSON parse first and fall back to the section parser, reporting --- the fallback parser's error when both fail (so un-routed runs keep their exact --- prior error behaviour). +-- we detect the shape from the /body/: if it parses as JSON at all it is the native +-- wire shape, so we keep the native parser's precise, located error; otherwise it is +-- the marker shape and the fallback parser handles it exactly as before. +-- +-- This detection replaced an older "try native, silently fall back on any native +-- error" rule, which turned a genuine native decode failure (e.g. a JSON body of +-- the wrong shape) into a misleading @MissingField@ from the marker parser finding +-- no sections. One accepted edge: a body that is a bare JSON scalar (e.g. @42@) is +-- now the native shape and reports the native @SchemaMismatch@ ("expected object") +-- rather than a marker @MissingField@ — strictly more accurate. Un-routed runs, +-- whose stub replies are marker bodies, are unaffected. parseResponse :: forall i o. (FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) => @@ -334,27 +360,38 @@ Response -> Either ShikumiError o parseResponse sig' resp = - case parse (nativeAdapter @i @o) sig' resp of - Right o -> Right o + case assistantJSON resp of + -- The body is JSON: the native wire shape. Keep the native parser's error. + Right _ -> parse (nativeAdapter @i @o) sig' resp + -- Not JSON: the fallback / marker wire shape. Exact prior behaviour. Left _ -> parse (fallbackAdapter @i @o) sig' resp --- | The per-sample temperatures for a 'MajorityVote' of @k@ samples. 'Nothing' --- leaves the provider default in place; 'Just t' is stamped onto the sample's --- requests. The multiset is identical between 'runProgram' and 'runProgramConc'. -sampleTemps :: Int -> TempSchedule -> [Maybe Double] -sampleTemps k (TempFixed xs) - | null xs = replicate k Nothing - | otherwise = map Just (take k (cycle xs)) -sampleTemps k (TempSpread base spread) = map Just (spreadTemps k base spread) +-- | The per-sample temperatures for a 'MajorityVote' of @k@ samples (at least +-- one — @k@ is clamped up to 1 here so the executors need not). 'Nothing' leaves +-- the provider default in place; 'Just t' is stamped onto the sample's requests. +-- The multiset is identical between 'runProgram' and 'runProgramConc'. +sampleTemps :: Int -> TempSchedule -> NonEmpty (Maybe Double) +sampleTemps k sched = case sched of + TempFixed xs + | null xs -> NE.fromList (replicate k' Nothing) + | otherwise -> NE.fromList (map Just (take k' (cycle xs))) + TempSpread base spread -> NE.map Just (spreadTemps k' base spread) + where + k' = max 1 k --- | @k@ temperatures fanned evenly across @[base-spread, base+spread]@; a single --- sample sits exactly on @base@. -spreadTemps :: Int -> Double -> Double -> [Double] +-- | @k@ temperatures (@k >= 1@) fanned evenly across @[base-spread, base+spread]@; +-- a single sample sits exactly on @base@. Every derived value is clamped to +-- @[0, 2]@ — the widest range a mainstream provider accepts — so a wide spread +-- never sends a negative (or absurdly high) temperature to the wire. Note this +-- clamps only the /derived/ 'TempSpread' fan-out; 'TempFixed' values are the user's +-- explicit choice and pass through 'sampleTemps' unclamped. +spreadTemps :: Int -> Double -> Double -> NonEmpty Double spreadTemps k base spread - | k <= 1 = [base] - | otherwise = [base - spread + fromIntegral i * step | i <- [0 .. k - 1]] + | k <= 1 = clampTemp base :| [] + | otherwise = NE.fromList [clampTemp (base - spread + fromIntegral i * step) | i <- [0 .. k - 1]] where step = (2 * spread) / fromIntegral (k - 1) + clampTemp t = max 0 (min 2 t) -- | Run an action with one sample's temperature stamped onto every outgoing -- 'Complete' (via the private metadata channel the router realizes). 'Nothing' runs @@ -393,16 +430,19 @@ run p i `catchError` \_cs e -> if ok e && left > 1 then go (left - 1) else throwError e --- | The modal value of a non-empty list: most frequent under 'Eq', ties broken --- by first appearance. Tallies in first-seen order, then keeps the first entry --- whose count is strictly greatest. -modal :: (Eq o) => [o] -> o -modal = pickBest . foldl' tally [] +-- | The modal value of a non-empty collection of samples: most frequent under +-- 'Eq', ties broken by first appearance. Tallies in first-seen order, then keeps +-- the first entry whose count is strictly greatest. Total: the 'NonEmpty' input +-- guarantees a winner, so there is no empty-list crash. +modal :: (Eq o) => NonEmpty o -> o +modal xs = pickBest (foldl' tally [] (NE.toList xs)) where tally acc x = case break ((== x) . fst) acc of (pre, (y, c) : post) -> pre ++ (y, c + 1) : post (pre, []) -> pre ++ [(x, 1 :: Int)] - pickBest [] = error "Shikumi.Program.modal: empty sample list" + -- The tally of a non-empty input is non-empty, so the @[]@ case is + -- unreachable; it returns the first sample to stay total. + pickBest [] = NE.head xs pickBest (z : zs) = fst (foldl' (\best cur -> if snd cur > snd best then cur else best) z zs) @@ -410,6 +450,10 @@ -- override (when present) and decode the JSON demos into the signature's typed -- demo channel. A demo whose JSON does not decode is reported as the located -- 'ShikumiError' from 'fromModel'. +-- +-- Exported as an execution internal: "Shikumi.Stream".@streamPredict@ reuses it +-- (with 'parseResponse') so the streamed and blocking paths overlay 'Params' and +-- decode the reply through one definition, not two divergent copies. effectiveSignature :: (FromModel i, FromModel o, Error ShikumiError :> es) => Signature i o -> @@ -440,7 +484,7 @@ paramsTraversal h (Retry n p) = Retry n <$> paramsTraversal h p paramsTraversal h (RetryWhen ok n p) = RetryWhen ok n <$> paramsTraversal h p paramsTraversal h (Validate v p) = Validate v <$> paramsTraversal h p -paramsTraversal h (MajorityVote k sched p) = MajorityVote k sched <$> paramsTraversal h p +paramsTraversal h (MajorityVote k sched reduce p) = MajorityVote k sched reduce <$> paramsTraversal h p paramsTraversal h (Ensemble ps reduce) = Ensemble <$> traverse (paramsTraversal h) ps <*> pure reduce -- 'Embed' carries no 'Params' (its body is an opaque closure, like 'FMap'\'s -- function), so it is a traversal leaf — preserved untouched. @@ -478,7 +522,7 @@ go (Retry _ p) = go p go (RetryWhen _ _ p) = go p go (Validate _ p) = go p - go (MajorityVote _ _ p) = go p + go (MajorityVote _ _ _ p) = go p go (Ensemble ps _) = concatMap go ps go (Embed _) = [] @@ -501,7 +545,7 @@ go (Retry _ p) = go p go (RetryWhen _ _ p) = go p go (Validate _ p) = go p - go (MajorityVote _ _ p) = go p + go (MajorityVote _ _ _ p) = go p go (Ensemble ps _) = concatMap go ps go (Embed _) = [] @@ -541,9 +585,9 @@ go idx (Validate v p) = let (p', idx') = go idx p in (Validate v p', idx') - go idx (MajorityVote k sched p) = + go idx (MajorityVote k sched reduce p) = let (p', idx') = go idx p - in (MajorityVote k sched p', idx') + in (MajorityVote k sched reduce p', idx') go idx (Ensemble ps reduce) = let (ps', idx') = goList idx ps in (Ensemble ps' reduce, idx') @@ -610,7 +654,7 @@ programShape (Retry n p) = ShapeRetry n (programShape p) programShape (RetryWhen _ n p) = ShapeRetryWhen n (programShape p) programShape (Validate _ p) = ShapeValidate (programShape p) -programShape (MajorityVote k sched p) = ShapeMajorityVote k sched (programShape p) +programShape (MajorityVote k sched _ p) = ShapeMajorityVote k sched (programShape p) programShape (Ensemble ps _) = ShapeEnsemble (map programShape ps) programShape (Embed _) = ShapeEmbed @@ -662,9 +706,9 @@ go qs (Validate v p) = let (p', qs') = go qs p in (Validate v p', qs') - go qs (MajorityVote k sched p) = + go qs (MajorityVote k sched reduce p) = let (p', qs') = go qs p - in (MajorityVote k sched p', qs') + in (MajorityVote k sched reduce p', qs') go qs (Ensemble ms reduce) = let (ms', qs') = goList qs ms in (Ensemble ms' reduce, qs') diff --git a/src/Shikumi/Refine.hs b/src/Shikumi/Refine.hs --- a/src/Shikumi/Refine.hs +++ b/src/Shikumi/Refine.hs @@ -54,6 +54,7 @@ import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KM import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -140,7 +141,7 @@ Program i o -> Program i o bestOfNWith n failCount sched threshold reward inner = embed $ \i -> - let temps = sampleTemps (max 1 n) sched + let temps = NE.toList (sampleTemps n sched) go [] best lastErr _ = finish best lastErr go (t : ts) best lastErr budget = do res <- tryShikumi (withSampleTemp t (runProgram inner i)) @@ -213,6 +214,11 @@ refine n = refineWith n (max 1 n) -- | 'refine' with an explicit @failCount@ budget. +-- +-- The advice-generation call between attempts is auxiliary: if it fails, the loop +-- keeps the previous advice (if any) and continues the remaining attempts without +-- consuming the @failCount@ budget, so a failed advice call never discards a valid +-- best-so-far output. @failCount@ guards /inner-program/ failures only. refineWith :: -- | @N@ attempts (clamped to @>= 1@) Int -> @@ -244,8 +250,13 @@ if k == cnt - 1 then finish best' lastErr else do - adv <- generateAdvice r threshold - go (k + 1) best' lastErr (Just adv) budget + -- The advice call is auxiliary: if it fails, keep the + -- previous advice (if any) and continue — never discard + -- a valid best-so-far, and do not consume the failCount + -- error budget (it guards inner-program failures only). + advE <- tryShikumi (generateAdvice r threshold) + let mAdvice' = either (const mAdvice) Just advE + go (k + 1) best' lastErr mAdvice' budget finish (Just (o, _)) _ = pure o finish Nothing (Just e) = throwError e finish Nothing Nothing = throwError (ProviderFailure "Shikumi.Refine.refine: no attempt produced an output") @@ -374,7 +385,7 @@ Signature (MultiChainInput i o) o2 -> Program i o2 multiChainComparison m reasoner synthSig = embed $ \i -> do - let temps = sampleTemps (max 1 m) defaultSpread + let temps = NE.toList (sampleTemps m defaultSpread) results <- traverse (\t -> tryShikumi (withSampleTemp t (runProgram reasoner i))) temps let oks = [o | Right o <- results] errs = [e | Left e <- results] diff --git a/src/Shikumi/Routing.hs b/src/Shikumi/Routing.hs --- a/src/Shikumi/Routing.hs +++ b/src/Shikumi/Routing.hs @@ -11,13 +11,16 @@ -- effect — exactly the seam @cachedLLM@ ("Shikumi.Cache") and @tracedLLM@ -- ("Shikumi.Trace") already use. 'runProgram' renders each 'Predict' node -- model-agnostically against the inert placeholder model and stamps its intentions --- (the derived JSON schema, and any per-sample temperature) onto the private --- request-metadata channel ('Shikumi.Adapter.attachSchema' / --- 'Shikumi.Adapter.stampTemperature'). 'routeLLM' then reads the /ambient/ model --- supplied by 'runRouting', overwrites the placeholder with it, translates the --- stamped metadata into @Options.responseFormat@ (for native-capable models only) --- and @Options.temperature@, strips the private keys, and forwards the call to the --- real @LLM@ interpreter beneath it. +-- (the derived JSON schema, any per-sample temperature, and the native-format render +-- alternative — system prompt + JSON demos) onto the private request-metadata +-- channel ('Shikumi.Adapter.attachSchema' / 'Shikumi.Adapter.stampTemperature' / +-- 'Shikumi.Adapter.attachNativeRender'). 'routeLLM' then reads the /ambient/ model +-- supplied by 'runRouting', overwrites the placeholder with it, and calls +-- 'translateForWire', which for a native-capable model sets +-- @Options.responseFormat@ from the stamped schema and swaps the marker @Context@ +-- (system prompt + demo assistant turns) for the stamped native-format alternative; +-- sets @Options.temperature@ when stamped; and in all cases strips the private keys +-- before forwarding the call to the real @LLM@ interpreter beneath it. -- -- Install order (mirroring @runTrace . runKeyedLLM . tracedLLM@): 'runRouting' is -- /outer/ of the real @LLM@ interpreter, which is /outer/ of 'routeLLM' (the @@ -42,20 +45,24 @@ ) where -import Baikai (Model, Options, ResponseFormat (..)) +import Baikai (Context, Message (..), Model, Options, ResponseFormat (..), assistant) import Control.Lens ((&), (.~), (^.)) -import Data.Aeson (Result (..), Value, fromJSON) +import Data.Aeson (FromJSON, Result (..), Value, fromJSON) import Data.Generics.Labels () import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Vector qualified as V import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) -import Effectful.Dispatch.Dynamic (interpose, interpret, passthrough, send) +import Effectful.Dispatch.Dynamic (interpose, interpret, send) import Shikumi.Adapter ( ModelCapability (..), capabilityFor, + metaNativeDemosKey, + metaNativePromptKey, metaResponseSchemaKey, metaTemperatureKey, ) -import Shikumi.LLM (LLM (..), complete) +import Shikumi.LLM (LLM (..), complete, stream) -- | The ambient model-routing effect. Its single operation reads the model every -- 'Predict' node should dispatch against. It is supplied by an interpreter at the @@ -75,39 +82,96 @@ runRouting :: Model -> Eff (Routing : es) a -> Eff es a runRouting m = interpret (\_ CurrentModel -> pure m) --- | The router. Re-interpret the @LLM@ effect so each outgoing 'Complete' is --- dispatched against the ambient model (overwriting the placeholder model the --- model-agnostic 'Shikumi.Program.runProgram' passes), with the private metadata --- channel translated to real wire options and stripped. 'Stream' is forwarded --- unchanged ('runProgram' never streams). +-- | The router. Re-interpret the @LLM@ effect so each outgoing call — /both/ +-- 'Complete' and 'Stream' — is dispatched against the ambient model (overwriting +-- the placeholder model the model-agnostic 'Shikumi.Program.runProgram' / +-- 'Shikumi.Stream.streamProgram' passes), with the private metadata channel +-- translated to real wire options (and the marker 'Context' swapped for the native +-- one for native-capable models) and stripped. The two operations are rewritten +-- identically through the single 'translateForWire', so a streamed call gets the +-- same real model id and wire options a blocking call does. routeLLM :: (Routing :> es, LLM :> es) => Eff es a -> Eff es a -routeLLM = interpose $ \env -> \case +routeLLM = interpose $ \_ -> \case Complete _placeholder ctx opts -> do m <- currentModel - complete m ctx (translateForWire m opts) - other -> passthrough env other + let (ctx', opts') = translateForWire m ctx opts + complete m ctx' opts' + Stream _placeholder ctx opts -> do + m <- currentModel + let (ctx', opts') = translateForWire m ctx opts + stream m ctx' opts' --- | Realize the private request-metadata channel against the real model: attach a --- native @responseFormat@ when the schema was stamped /and/ the model is --- native-capable; set @temperature@ when one was stamped; then strip both private --- keys so nothing private reaches the transport. -translateForWire :: Model -> Options -> Options -translateForWire m opts = +-- | Realize the private request-metadata channel against the real model. For a +-- native-capable model: attach the native @responseFormat@ from the stamped +-- schema, and swap the marker-format 'Context' (system prompt + demo assistant +-- turns) for the stamped native-format alternative. In all cases: set +-- @temperature@ when one was stamped, and strip every private @shikumi.*@ key so +-- nothing private reaches the transport. Fallback-capability models keep the +-- marker 'Context' unchanged; non-'Predict' @Complete@ calls (no stamps) are never +-- rewritten. +translateForWire :: Model -> Context -> Options -> (Context, Options) +translateForWire m ctx opts = let md = opts ^. #metadata mSchema = Map.lookup metaResponseSchemaKey md mTemp = Map.lookup metaTemperatureKey md >>= valueToDouble - stripped = Map.delete metaResponseSchemaKey (Map.delete metaTemperatureKey md) - withSchema o = case (mSchema, capabilityFor m) of - (Just s, NativeSchema) -> - o & #responseFormat .~ Just (JsonSchema {name = "output", schema = s, strict = True}) - _ -> o + mNativeSys = Map.lookup metaNativePromptKey md >>= fromJSONMaybe + mNativeDemos = Map.lookup metaNativeDemosKey md >>= fromJSONMaybe + stripped = + foldr + Map.delete + md + [metaResponseSchemaKey, metaTemperatureKey, metaNativePromptKey, metaNativeDemosKey] + isNative = case capabilityFor m of NativeSchema -> True; PromptFallback -> False + withSchema o + | isNative, + Just s <- mSchema = + o & #responseFormat .~ Just (JsonSchema {name = "output", schema = s, strict = True}) + | otherwise = o withTemp o = case mTemp of Just t -> o & #temperature .~ Just t Nothing -> o - in withTemp (withSchema (opts & #metadata .~ stripped)) + opts' = withTemp (withSchema (opts & #metadata .~ stripped)) + ctx' = case (isNative, mNativeSys, mNativeDemos) of + (True, Just sys, Just demos) -> rewriteNativeContext sys demos ctx + _ -> ctx + in (ctx', opts') +-- | Install the native-format system prompt and demo assistant turns into a +-- 'Context'. The assistant turns of a 'Predict'-rendered context are exactly the +-- demo outputs, in order; each is replaced (via baikai's deterministic 'assistant' +-- constructor) with the corresponding stamped native text. Defensive: if the count +-- of assistant turns differs from the stamped list length the messages are left +-- untouched (only the system prompt is swapped), so a hand-built or unexpected +-- context is never corrupted. +rewriteNativeContext :: Text -> [Text] -> Context -> Context +rewriteNativeContext sys demos ctx = + let msgs = V.toList (ctx ^. #messages) + assistantCount = length [() | AssistantMessage _ <- msgs] + msgs' + | assistantCount == length demos = replaceAssistants demos msgs + | otherwise = msgs + in ctx & #systemPrompt .~ Just sys & #messages .~ V.fromList msgs' + +-- | Replace each assistant message's text with the next demo text, in order, +-- preserving all user/tool messages. Total: if the demo list runs out, remaining +-- assistant messages are kept as-is. +replaceAssistants :: [Text] -> [Message] -> [Message] +replaceAssistants _ [] = [] +replaceAssistants ds (m : rest) = case m of + AssistantMessage _ -> case ds of + (d : ds') -> assistant d : replaceAssistants ds' rest + [] -> m : replaceAssistants ds rest + _ -> m : replaceAssistants ds rest + -- | Read a JSON number back into a 'Double' (the per-sample temperature). valueToDouble :: Value -> Maybe Double valueToDouble v = case fromJSON v of Success d -> Just d + Error _ -> Nothing + +-- | Read a stamped JSON value back into a decodable Haskell value (the native +-- prompt 'Text' and the demo @[Text]@), returning 'Nothing' on any mismatch. +fromJSONMaybe :: (FromJSON a) => Value -> Maybe a +fromJSONMaybe v = case fromJSON v of + Success a -> Just a Error _ -> Nothing diff --git a/src/Shikumi/Schema.hs b/src/Shikumi/Schema.hs --- a/src/Shikumi/Schema.hs +++ b/src/Shikumi/Schema.hs @@ -122,8 +122,16 @@ in ([(nm, sch)], [nm | req]) -- | Per-field schema and whether the field is required. The general --- (overlappable) case is "required, no description"; 'Maybe' is optional/nullable; --- 'Field' attaches the description and preserves the inner required-ness. +-- (overlappable) case is "required, no description"; 'Maybe' is +-- required-but-nullable (see below); 'Field' attaches the description and +-- preserves the inner required-ness. +-- +-- A 'Maybe' field is /required/ in the JSON Schema and expresses its optionality +-- as nullability (a nullable schema). OpenAI strict mode (@strict: true@, which +-- the router always requests) requires every property to appear in @required@; +-- omitting a property is rejected. The decode side is unaffected — +-- @FromField (Maybe a)@ accepts a missing key, an explicit @null@, or a value — +-- so a fallback-model reply that omits the field still decodes. class FieldSchema t where fieldSchema :: Proxy t -> (Value, Bool) @@ -131,7 +139,7 @@ fieldSchema _ = (toSchema (Proxy @a), True) instance (ToSchema a) => FieldSchema (Maybe a) where - fieldSchema _ = (nullableSchema (toSchema (Proxy @a)), False) + fieldSchema _ = (nullableSchema (toSchema (Proxy @a)), True) instance (KnownSymbol d, FieldSchema a) => FieldSchema (Field d a) where fieldSchema _ = @@ -307,15 +315,23 @@ -- Validation hook -- --------------------------------------------------------------------------- --- | A domain rule applied after a successful decode. Defaults to "always valid"; --- override per output type to enforce rules (e.g. "bullets has 3-5 elements"). +-- | A domain rule applied after a successful decode, enforced by the decode path +-- in every program runner (@runProgram@, @runProgramConc@, @streamProgram@, and +-- the derived modules). Override per output type to enforce rules (e.g. +-- "bullets has 3-5 elements"); a violation surfaces as a +-- 'Shikumi.Error.ValidationFailure'. +-- +-- Instances are opt-in: there is no catch-all. Every type used as a @Predict@ +-- output (or a tool input) must declare an instance. A type with no rules +-- declares an empty instance — @instance Validatable Foo@ (no body; the default +-- @validate = Right@ applies) — or adds @Validatable@ to a @deriving anyclass@ +-- list (@DeriveAnyClass@ is a default extension in every package). Making the +-- no-rules case explicit is deliberate: it prevents a forgotten constraint from +-- silently regressing to "always valid". class Validatable a where validate :: a -> Either Text a validate = Right --- | Default "always valid" for any type without an explicit rule. -instance {-# OVERLAPPABLE #-} Validatable a - -- --------------------------------------------------------------------------- -- Declarative field constraints (EP-26) -- --------------------------------------------------------------------------- @@ -351,16 +367,20 @@ | otherwise = checkConstraints (Proxy @cs) t instance forall s cs a. (KnownSymbol s, ToScientificLeaf a, ReflectConstraints cs a) => ReflectConstraints ('MinVal s ': cs) a where - constraintSchema _ = constraintSchema @cs @a Proxy . withMinimum (parseBound (Proxy @s)) - checkConstraints _ x - | toScientificLeaf x < parseBound (Proxy @s) = Left ("minimum " <> T.pack (symbolVal (Proxy @s)) <> " violated") - | otherwise = checkConstraints (Proxy @cs) x + constraintSchema _ = constraintSchema @cs @a Proxy . maybe id withMinimum (parseBound (Proxy @s)) + checkConstraints _ x = case parseBound (Proxy @s) of + Nothing -> Left ("invalid numeric bound symbol: " <> T.pack (symbolVal (Proxy @s))) + Just b + | toScientificLeaf x < b -> Left ("minimum " <> T.pack (symbolVal (Proxy @s)) <> " violated") + | otherwise -> checkConstraints (Proxy @cs) x instance forall s cs a. (KnownSymbol s, ToScientificLeaf a, ReflectConstraints cs a) => ReflectConstraints ('MaxVal s ': cs) a where - constraintSchema _ = constraintSchema @cs @a Proxy . withMaximum (parseBound (Proxy @s)) - checkConstraints _ x - | toScientificLeaf x > parseBound (Proxy @s) = Left ("maximum " <> T.pack (symbolVal (Proxy @s)) <> " violated") - | otherwise = checkConstraints (Proxy @cs) x + constraintSchema _ = constraintSchema @cs @a Proxy . maybe id withMaximum (parseBound (Proxy @s)) + checkConstraints _ x = case parseBound (Proxy @s) of + Nothing -> Left ("invalid numeric bound symbol: " <> T.pack (symbolVal (Proxy @s))) + Just b + | toScientificLeaf x > b -> Left ("maximum " <> T.pack (symbolVal (Proxy @s)) <> " violated") + | otherwise -> checkConstraints (Proxy @cs) x instance (KnownSymbols ss, ReflectConstraints cs Text) => ReflectConstraints ('EnumOneOf ss ': cs) Text where constraintSchema _ = constraintSchema @cs @Text Proxy . withEnum (symbolTexts (Proxy @ss)) @@ -388,11 +408,14 @@ instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where symbolTexts _ = T.pack (symbolVal (Proxy @s)) : symbolTexts (Proxy @ss) --- | Parse a numeric-bound 'Symbol' (e.g. @"100"@, @"-3.5"@) to a 'Sci.Scientific'. -parseBound :: forall s. (KnownSymbol s) => Proxy s -> Sci.Scientific -parseBound _ = case readMaybe (symbolVal (Proxy @s)) of - Just v -> v - Nothing -> error ("Shikumi.Schema: invalid numeric bound symbol " <> symbolVal (Proxy @s)) +-- | Parse a numeric-bound 'Symbol' (e.g. @"100"@, @"-3.5"@) to a 'Sci.Scientific', +-- or 'Nothing' when the symbol is not a number. Total — a malformed bound (e.g. +-- @MinVal "abc"@) no longer crashes the process at schema-derivation time; instead +-- the schema keyword is silently omitted and every decode of the field fails with a +-- located 'ValidationFailure' naming the bad symbol (see the @MinVal@/@MaxVal@ +-- 'ReflectConstraints' instances). +parseBound :: forall s. (KnownSymbol s) => Proxy s -> Maybe Sci.Scientific +parseBound _ = readMaybe (symbolVal (Proxy @s)) tshow :: (Show a) => a -> Text tshow = T.pack . show diff --git a/src/Shikumi/Schema/Types.hs b/src/Shikumi/Schema/Types.hs --- a/src/Shikumi/Schema/Types.hs +++ b/src/Shikumi/Schema/Types.hs @@ -151,9 +151,11 @@ arraySchema :: Value -> Value arraySchema items = object ["type" .= ("array" :: Text), "items" .= items] --- | @{"enum":[...]}@ for an enum-like sum of nullary constructors. +-- | @{"type":"string","enum":[...]}@ for an enum-like sum of nullary +-- constructors. OpenAI strict mode requires every schema node to carry an explicit +-- type; the enum values are the constructor names, so the type is @"string"@. enumSchema :: [Text] -> Value -enumSchema names = object ["enum" .= names] +enumSchema names = object ["type" .= ("string" :: Text), "enum" .= names] -- | Permit JSON @null@ in addition to the wrapped schema. The @anyOf@ form is -- used (more portable across providers than @"type":["T","null"]@). diff --git a/src/Shikumi/Stream.hs b/src/Shikumi/Stream.hs --- a/src/Shikumi/Stream.hs +++ b/src/Shikumi/Stream.hs @@ -62,21 +62,21 @@ import Effectful (Eff, (:>)) import Effectful.Error.Static (Error, throwError) import GHC.Generics (Generic) -import Shikumi.Adapter (Adapter (..), ToPrompt, adapterFor) +import Shikumi.Adapter (Adapter (..), ToPrompt, adapterFor, attachNativeRender, attachSchema, nativeRenderPieces) import Shikumi.Error (ShikumiError) import Shikumi.LLM (LLM, stream) import Shikumi.Program - ( Demo (..), - Params (..), + ( Params, Program (Compose, Embed, FMap, MajorityVote, Map, Parallel, Predict, Retry, RetryWhen, Validate), acceptOrReject, + effectiveSignature, + parseResponse, retryWith, runProgram, ) -import Shikumi.Schema (FromModel, ToSchema, fromModel) +import Shikumi.Schema (FromModel, ToSchema, Validatable, deriveSchema) import Shikumi.Schema.Types qualified as ST -import Shikumi.Signature (Signature, getInstruction, outputFields, setDemos, setInstruction) -import Shikumi.Signature qualified as Sig +import Shikumi.Signature (Signature, outputFields) -- --------------------------------------------------------------------------- -- Event types @@ -173,10 +173,14 @@ firstTextEnd evs = listToMaybe [c | TextEnd (BlockEndPayload _ c) <- evs] -- | Reassemble a 'Response' from the stream's terminal event (its payload's --- fully-assembled assistant message). 'EventError' surfaces the assembled --- (possibly-partial) response just like the blocking path, so the caller's 'parse' --- fails on a bad response identically. Falls back to a response synthesized from +-- fully-assembled assistant message). Falls back to a response synthesized from -- the @TextEnd@ content if no terminal assistant message is present. +-- +-- The 'EventError' branch is retained for robustness against third-party @LLM@ +-- interpreters, but is /unreachable through shikumi's own interpreters/: they now +-- convert a terminal 'EventError' to an out-of-band 'ShikumiError' before the event +-- list ever reaches here (see 'Shikumi.LLM' — @raiseStreamError@), so a streamed +-- program fails with the real transport error, not a decode of a partial body. reassemble :: [AssistantMessageEvent] -> Response reassemble evs = case terminalPayloads of (p : _) -> _Response & #message .~ p @@ -227,17 +231,27 @@ -- chunks where per-field streaming is ambiguous or the body is opaque). Map _ _ -> blockingNode prog i cb Parallel _ _ -> blockingNode prog i cb - MajorityVote _ _ _ -> blockingNode prog i cb + MajorityVote _ _ _ _ -> blockingNode prog i cb Embed _ -> blockingNode prog i cb _ -> blockingNode prog i cb --- | Stream a single 'Predict': overlay its 'Params', render via the (fallback) --- adapter, stream the first output field's chunks bracketed by @LmStart@/@LmEnd@, --- then run the identical 'parse' on the reassembled response so the typed result --- equals 'runProgram'\'s. +-- | Stream a single 'Predict', mirroring 'Shikumi.Program.runPredict' exactly so +-- the streamed and blocking paths share one wire + decode definition. It overlays +-- 'Params' via the exported 'effectiveSignature', renders model-agnostically, stamps +-- the derived schema and the native render alternative onto the metadata channel +-- (so the router can attach a native @responseFormat@ and swap the native prompt for +-- native-capable models), streams the first output field's chunks bracketed by +-- @LmStart@/@LmEnd@, and decodes the reassembled response through the shared +-- 'Shikumi.Program.parseResponse' (dual-format: JSON body → native parser keeping +-- its located error, marker body → fallback parser). +-- +-- Chunk-attribution caveat (unchanged): field chunks are honest only for the +-- marker/raw-text wire shape; a routed native (JSON) stream still delivers chunks of +-- the raw JSON text, though the /final typed value/ now decodes correctly via +-- 'parseResponse'. streamPredict :: forall i o es. - (FromModel i, FromModel o, ToSchema o, ToPrompt i, ToPrompt o) => + (FromModel i, FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) => (LLM :> es, Error ShikumiError :> es) => Signature i o -> Params -> @@ -245,16 +259,18 @@ (StreamEvent -> Eff es ()) -> Eff es o streamPredict sig ps i cb = do - sig' <- effectiveSig sig ps + sig' <- effectiveSignature sig ps let adapter = adapterFor _Model - (ctx, opts) = render adapter sig' i + (ctx, opts0) = render adapter sig' i + (nativeSys, nativeDemos) = nativeRenderPieces @i @o sig' + opts = attachNativeRender nativeSys nativeDemos (attachSchema (deriveSchema @o) opts0) fieldNm = case map ST.fieldName (outputFields sig') of (x : _) -> x [] -> "" cb (StreamStatus (Status LmStart "LM call started")) resp <- streamComplete fieldNm _Model ctx opts cb cb (StreamStatus (Status LmEnd "LM call finished")) - either throwError pure (parse adapter sig' resp) + either throwError pure (parseResponse sig' resp) -- | Bracket an action with @NodeStart@/@NodeEnd@ status messages. bracketNode :: (StreamEvent -> Eff es ()) -> Eff es a -> Eff es a @@ -272,17 +288,3 @@ (StreamEvent -> Eff es ()) -> Eff es o blockingNode prog i cb = bracketNode cb (runProgram prog i) - --- | Overlay a node's 'Params' onto its signature (effective instruction + decoded --- demos), replicating 'Shikumi.Program.runProgram'\'s internal @effectiveSignature@ --- so a streamed 'Predict' renders byte-for-byte as the blocking one would. -effectiveSig :: - (FromModel i, FromModel o, Error ShikumiError :> es) => - Signature i o -> - Params -> - Eff es (Signature i o) -effectiveSig sig (Params {instructionOverride = ovr, demos = ds}) = do - typed <- either throwError pure (traverse decodeDemo ds) - pure (setDemos typed (setInstruction (fromMaybe (getInstruction sig) ovr) sig)) - where - decodeDemo (Demo inJ outJ) = Sig.Demo <$> fromModel inJ <*> fromModel outJ diff --git a/test/CombinatorSpec.hs b/test/CombinatorSpec.hs --- a/test/CombinatorSpec.hs +++ b/test/CombinatorSpec.hs @@ -10,6 +10,7 @@ import Control.Lens ((&), (.~)) import Data.Generics.Labels () import Data.IORef (newIORef, readIORef) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import Data.Text qualified as T import Effectful (runEff) @@ -171,7 +172,7 @@ r <- runSeq pipe [outlineResponse, draftResponse] (Topic "haskell") r @?= Right (Draft "A fine essay about the outline."), testCase "chain composes n same-type stages, returning the last stage's output" $ do - let pipe = chain [cellP, cellP, cellP] + let pipe = chain (cellP :| [cellP, cellP]) r <- runSeq pipe [cellResp "a", cellResp "b", cellResp "c"] (Cell "in") r @?= Right (Cell "c") ] @@ -268,7 +269,11 @@ testCase "majorityVoteBy applies the custom reducer" $ do let prog = majorityVoteBy 3 sched1 concatCells cellP r <- runSeq prog [cellResp "x", cellResp "y", cellResp "z"] (Cell "in") - r @?= Right (Cell "xyz") + r @?= Right (Cell "xyz"), + testCase "majorityVoteBy exposes the sub-program's params once, not K times" $ + -- EP-35: it is a single node sampled K times (reducer carried on + -- MajorityVote), not K distinct Ensemble members. + length (foldParams (majorityVoteBy 3 sched1 concatCells cellP)) @?= 1 ] ensembleTests :: TestTree @@ -289,9 +294,9 @@ deepProg :: Program Cell Cell deepProg = chain - [ retry 2 (majorityVote 3 sched1 cellP), - validate (const True) "always ok" cellP - ] + ( retry 2 (majorityVote 3 sched1 cellP) + :| [validate (const True) "always ok" cellP] + ) crossCuttingTests :: TestTree crossCuttingTests = diff --git a/test/ConstraintSpec.hs b/test/ConstraintSpec.hs --- a/test/ConstraintSpec.hs +++ b/test/ConstraintSpec.hs @@ -11,6 +11,7 @@ import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KM import Data.Text (Text) +import Data.Text qualified as T import GHC.Generics (Generic) import Shikumi.Error (ShikumiError (..)) import Shikumi.Schema (FromModel, ToSchema, Validatable, deriveSchema, fromModel) @@ -45,6 +46,18 @@ instance Validatable BioUnchecked +-- A record with a /malformed/ numeric bound symbol (EP-35): @"abc"@ is not a +-- number. Deriving its schema must not crash, and decoding must fail cleanly. +newtype BadBound = BadBound + {n :: Constrained '[ 'MinVal "abc"] Int} + deriving stock (Generic, Show, Eq) + +instance ToSchema BadBound + +instance FromModel BadBound + +instance Validatable BadBound + -- | Drill into @properties.@ of a record schema 'Value'. propOf :: Text -> Value -> Maybe Value propOf name (Object o) = do @@ -78,7 +91,13 @@ @?= Left (ValidationFailure "score: maximum 100 violated"), testCase "contrast: the unconstrained record accepts the short value" $ fromModel @BioUnchecked (obj "short" 50) - @?= Right (BioUnchecked {tagline = "short", score = 50}) + @?= Right (BioUnchecked {tagline = "short", score = 50}), + testCase "EP-35: a malformed numeric bound omits the schema keyword (no crash)" $ + (propOf "n" (deriveSchema @BadBound) >>= keyword "minimum") @?= Nothing, + testCase "EP-35: a malformed numeric bound fails decode with a ValidationFailure naming it" $ + case fromModel @BadBound (Object (KM.fromList [("n", Number 5)])) of + Left (ValidationFailure m) | "abc" `T.isInfixOf` m -> pure () + other -> assertFailure ("expected ValidationFailure mentioning abc, got " <> show other) ] where obj t s = diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -43,4 +43,5 @@ isTransient (InvalidJSON "") @?= False isTransient (MissingField "") @?= False isTransient (ValidationFailure "") @?= False + isTransient (CodeExecFailed "") @?= False ] diff --git a/test/LiveSpec.hs b/test/LiveSpec.hs --- a/test/LiveSpec.hs +++ b/test/LiveSpec.hs @@ -6,7 +6,7 @@ -- default test run remains hermetic. module LiveSpec (tests) where -import Baikai hiding (complete) +import Baikai hiding (complete, flattenAssistantText) import Baikai.Models.Generated (openai_gpt_4o_mini) import Baikai.Prelude import Baikai.Provider.OpenAI.Api qualified as OpenAI diff --git a/test/ModuleSpec.hs b/test/ModuleSpec.hs --- a/test/ModuleSpec.hs +++ b/test/ModuleSpec.hs @@ -16,8 +16,9 @@ mkResponse, runScriptedLLM, topicToOutline, + topicToVerdict, ) -import Shikumi.Error (ShikumiError) +import Shikumi.Error (ShikumiError (..)) import Shikumi.Module (WithReasoning (..), chainOfThought, chainOfThoughtRaw, predict) import Shikumi.Program (emptyParams, foldParams, mapParamsAt, runProgram) import Test.Tasty (TestTree, testGroup) @@ -59,6 +60,20 @@ runEff . runErrorNoCallStack @ShikumiError . runScriptedLLM ref $ runProgram (chainOfThought topicToOutline) (Topic "haskell") out @?= Right (Outline {points = ["x", "y"]}), + testCase "EP-32: a failing Validatable rule surfaces through chainOfThought" $ do + ref <- + newIORef + [ mkResponse + ( markerBody + [ ("reasoning", "thinking"), + ("value", "{\"score\": 99}") + ] + ) + ] + out <- + runEff . runErrorNoCallStack @ShikumiError . runScriptedLLM ref $ + runProgram (chainOfThought topicToVerdict) (Topic "haskell") + out @?= Left (ValidationFailure "score: must be at most 10"), testCase "the chain-of-thought node's params are reachable via mapParamsAt 0" $ foldParams (mapParamsAt 0 (\p -> p & #instructionOverride .~ Just "cot") (chainOfThought topicToOutline)) @?= [emptyParams & #instructionOverride .~ Just "cot"] diff --git a/test/ProgramFixtures.hs b/test/ProgramFixtures.hs --- a/test/ProgramFixtures.hs +++ b/test/ProgramFixtures.hs @@ -10,17 +10,20 @@ Outline (..), Draft (..), Cell (..), + Verdict (..), -- * Signatures topicToOutline, outlineToDraft, cellSig, + topicToVerdict, -- * Canned responses mkResponse, outlineResponse, draftResponse, cellResponse, + badVerdictResponse, markerBody, -- * Fake LLM interpreters @@ -48,7 +51,7 @@ import GHC.Generics (Generic) import Shikumi.Adapter (ToPrompt) import Shikumi.LLM (LLM (..)) -import Shikumi.Schema (FromModel, ToSchema, Validatable) +import Shikumi.Schema (FromModel, ToSchema, Validatable (..)) import Shikumi.Signature (Signature, mkSignature) -- --------------------------------------------------------------------------- @@ -101,6 +104,22 @@ instance Validatable Cell +-- | A record with a real validation rule, for the EP-32 dispatch tests. +newtype Verdict = Verdict {score :: Int} + deriving stock (Generic, Show, Eq) + +instance ToSchema Verdict + +instance FromModel Verdict + +instance ToPrompt Verdict + +-- | Domain rule: a score is at most 10. +instance Validatable Verdict where + validate v + | score v > 10 = Left "score: must be at most 10" + | otherwise = Right v + -- --------------------------------------------------------------------------- -- Signatures -- --------------------------------------------------------------------------- @@ -114,6 +133,9 @@ cellSig :: Signature Cell Cell cellSig = mkSignature "Echo the cell" +topicToVerdict :: Signature Topic Verdict +topicToVerdict = mkSignature "Score the topic" + -- --------------------------------------------------------------------------- -- Canned responses (rendered as the fallback adapter's [[ ## field ## ]] sections) -- --------------------------------------------------------------------------- @@ -139,6 +161,10 @@ -- | Echo a fixed cell value (used by the @Cell -> Cell@ pipelines). cellResponse :: Response cellResponse = mkResponse (markerBody [("cell", "echoed")]) + +-- | A reply whose score violates the 'Verdict' rule. +badVerdictResponse :: Response +badVerdictResponse = mkResponse (markerBody [("score", "99")]) -- --------------------------------------------------------------------------- -- Fake LLM interpreters diff --git a/test/ProgramSpec.hs b/test/ProgramSpec.hs --- a/test/ProgramSpec.hs +++ b/test/ProgramSpec.hs @@ -6,25 +6,31 @@ import Data.Generics.Labels () import Data.IORef (newIORef) import Data.List (foldl1') +import Data.List.NonEmpty qualified as NE import Data.Text (Text) import Data.Text qualified as T import Effectful (runEff) +import Effectful.Concurrent (runConcurrent) import Effectful.Error.Static (runErrorNoCallStack) import ProgramFixtures ( Cell (..), Draft, Outline (..), Topic (..), + badVerdictResponse, cellSig, + mkResponse, outlineResponse, outlineToDraft, runScriptedLLM, topicToOutline, + topicToVerdict, ) -import Shikumi.Error (ShikumiError) +import Shikumi.Error (ShikumiError (..)) import Shikumi.Program ( Params, Program (Compose, Predict), + TempSchedule (..), emptyParams, foldParams, mapParams, @@ -32,9 +38,11 @@ nodeInstructionsIndexed, pipeline, runProgram, + runProgramConc, + sampleTemps, ) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) import Test.Tasty.QuickCheck (NonNegative (..), Positive (..), testProperty, (===)) -- A two-stage program reused across the param tests. @@ -63,6 +71,33 @@ runEff . runErrorNoCallStack @ShikumiError . runScriptedLLM ref $ runProgram (Predict topicToOutline emptyParams) (Topic "haskell") out @?= Right (Outline {points = ["intro", "body", "end"]}), + testCase "EP-32: a failing Validatable rule surfaces as ValidationFailure through runProgram" $ do + ref <- newIORef [badVerdictResponse] + out <- + runEff . runErrorNoCallStack @ShikumiError . runScriptedLLM ref $ + runProgram (Predict topicToVerdict emptyParams) (Topic "haskell") + out @?= Left (ValidationFailure "score: must be at most 10"), + testCase "EP-32: a failing Validatable rule surfaces through runProgramConc" $ do + ref <- newIORef [badVerdictResponse] + out <- + runEff . runErrorNoCallStack @ShikumiError . runConcurrent . runScriptedLLM ref $ + runProgramConc (Predict topicToVerdict emptyParams) (Topic "haskell") + out @?= Left (ValidationFailure "score: must be at most 10"), + testCase "EP-33: a native JSON body of the wrong shape keeps the located native error" $ do + -- {"points": 42} parses as JSON, so it is the native wire shape; the + -- native decode reports the precise SchemaMismatch instead of the marker + -- parser's misleading MissingField. + ref <- newIORef [mkResponse "{\"points\": 42}"] + out <- + runEff . runErrorNoCallStack @ShikumiError . runScriptedLLM ref $ + runProgram (Predict topicToOutline emptyParams) (Topic "haskell") + out @?= Left (SchemaMismatch "points: expected array, got number"), + testCase "EP-35: TempSpread temperatures are clamped to [0, 2]" $ do + -- Before the clamp, TempSpread 0.1 0.5 fans to [-0.4, 0.1, 0.6]; the -0.4 + -- would be sent to a provider that rejects it. + let ts = [t | Just t <- NE.toList (sampleTemps 3 (TempSpread 0.1 0.5))] + length ts @?= 3 + assertBool ("all temperatures in [0, 2], got " <> show ts) (all (\t -> t >= 0 && t <= 2) ts), testCase "M2: foldParams returns nodes in stage order" $ foldParams twoStage @?= [emptyParams, emptyParams], testCase "M5: nodeInstructionsIndexed returns signature instructions in node order" $ diff --git a/test/RefineSpec.hs b/test/RefineSpec.hs --- a/test/RefineSpec.hs +++ b/test/RefineSpec.hs @@ -21,6 +21,7 @@ ( Answer (..), Sentence (..), classifyProg, + decideAdviceFailure, decideMCC, decideRefine, decideTemp, @@ -58,6 +59,7 @@ bestOfNShortCircuits, bestOfNExhaustsFailCount, refineClimbsViaAdvice, + refineSurvivesAdviceFailure, multiChainSynthesizes, moduleComposes, moduleIsTransparent, @@ -186,6 +188,16 @@ assertBool "feedback strictly improves the reward" (rewardOf goodReward wrapped > rewardOf goodReward single) + +refineSurvivesAdviceFailure :: TestTree +refineSurvivesAdviceFailure = + testCase "refine returns best-so-far when the advice call fails (EP-35)" $ do + -- Every classify answers "bad" (sub-threshold); the advice call between + -- attempts fails to decode. Before EP-35 that error aborted the whole refine; + -- now it is non-fatal and the best-so-far output is returned. + let reward = mkReward goodReward + (wrapped, _) <- runCounted decideAdviceFailure (refine 2 1.0 reward classifyProg) (Sentence "x") + wrapped @?= Right (Answer "bad") -- --------------------------------------------------------------------------- -- M3 — multiChainComparison diff --git a/test/RefineStub.hs b/test/RefineStub.hs --- a/test/RefineStub.hs +++ b/test/RefineStub.hs @@ -39,6 +39,7 @@ decideTemp, decideRefine, decideMCC, + decideAdviceFailure, -- * Stub interpreters runStub, @@ -56,6 +57,7 @@ import Control.Lens ((^.)) import Data.Generics.Labels () import Data.IORef (IORef, atomicModifyIORef', modifyIORef') +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -173,6 +175,15 @@ | hasField "Hint from a previous attempt" ctx = markerBody [("answer", "good")] | otherwise = markerBody [("answer", "bad")] +-- | EP-35 rule: the advice call replies with a body that has no @advice@ field, so +-- @generateAdvice@'s decode fails; every classify call answers @bad@ (always +-- sub-threshold). Exercises 'Shikumi.Refine.refine' surviving an advice-call +-- failure and returning its best-so-far instead of aborting. +decideAdviceFailure :: Context -> Options -> Text +decideAdviceFailure ctx _ + | hasField "advice" ctx = markerBody [("notadvice", "unusable")] + | otherwise = markerBody [("answer", "bad")] + -- | M3 multi-chain rule: a reasoning call answers a temperature-chosen candidate; a -- synthesis call returns the modal candidate it was shown. decideMCC :: Context -> Options -> Text @@ -197,7 +208,7 @@ modalCandidate :: Text -> Text modalCandidate t = case extractAnswers t of [] -> "" - xs -> modal xs + xs -> modal (NE.fromList xs) -- | Pull each attempt's answer out of the rendered 'MultiChainInput' prompt. extractAnswers :: Text -> [Text] diff --git a/test/ResilienceSpec.hs b/test/ResilienceSpec.hs --- a/test/ResilienceSpec.hs +++ b/test/ResilienceSpec.hs @@ -4,7 +4,7 @@ -- rate limit caps in-flight calls. module ResilienceSpec (tests) where -import Baikai (flattenAssistantBlocks) +import Baikai (AssistantMessageEvent (..), flattenAssistantBlocks) import Control.Concurrent (forkIO) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.STM (newTVarIO, readTVarIO) @@ -12,6 +12,7 @@ import Data.Ratio ((%)) import Effectful (runEff) import Effectful.Concurrent (runConcurrent) +import Effectful.Concurrent.Async (mapConcurrently) import Effectful.Error.Static (runErrorNoCallStack) import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM @@ -21,11 +22,15 @@ defaultLLMConfig, newRateLimiter, runLLMResilient, + stream, ) -import Shikumi.LLM.Budget (newBudget) +import Shikumi.LLM.Budget (newBudget, spentUSD) import StubProvider - ( concurrencyStubRegistry, + ( budgetBarrierStubRegistry, + concurrencyStubRegistry, costStubRegistry, + failingStreamCostStubRegistry, + failingStreamStubRegistry, failingStubRegistry, flattenAssistantText, invalidStubRegistry, @@ -78,6 +83,27 @@ case res2 of Left (BudgetExceeded _) -> pure () other -> assertFailure ("expected Left (BudgetExceeded ...), got " <> show other), + testCase "EP-35: budget admission is optimistic — N concurrent calls overshoot the ceiling" $ do + -- The barrier stub keeps all four calls in flight (each already past + -- admitCall) until none has recorded its cost, pinning the documented + -- overshoot: admission is not reservation. + arrived <- newTVarIO 0 + reg <- budgetBarrierStubRegistry arrived 4 (1 % 100) "ok" + b <- newBudget (Just (1 % 100)) -- ceiling = a single call's cost + let cfg = (defaultLLMConfig reg) {budget = Just b} + results <- + runEff . runConcurrent . runErrorNoCallStack @ShikumiError . runLLMResilient cfg $ + mapConcurrently (const (complete stubModel stubContext stubOptions)) [1 .. 4 :: Int] + case results of + Right rs -> length rs @?= 4 -- all four admitted together (overshoot) + other -> assertFailure ("expected all four concurrent calls to succeed, got " <> show other) + spent <- spentUSD b + assertBool "total overshot the ceiling" (spent > (1 % 100)) + -- the ceiling is now consumed; a subsequent call is refused + res5 <- runText cfg + case res5 of + Left (BudgetExceeded _) -> pure () + other -> assertFailure ("expected Left (BudgetExceeded ...) once the ceiling is consumed, got " <> show other), testCase "rate limit caps concurrency at 1" $ do cur <- newTVarIO 0 mx <- newTVarIO 0 @@ -93,10 +119,51 @@ r1 @?= Right "ok" r2 @?= Right "ok" observedMax <- readTVarIO mx - assertBool ("observed max concurrency " <> show observedMax <> " should be <= 1") (observedMax <= 1) + assertBool ("observed max concurrency " <> show observedMax <> " should be <= 1") (observedMax <= 1), + testCase "EP-34: stream retry recovers after 2 failures" $ do + -- A stream that fails twice (terminal EventError) then succeeds. The + -- interpreter now raises the in-band error out-of-band, so retrying fires. + ref <- newIORef 0 + reg <- failingStreamStubRegistry ref 2 "ok" + let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5} + res <- runStream cfg + case res of + Right evs -> assertBool "successful stream ends with EventDone" (any isEventDone evs) + other -> assertFailure ("expected Right events, got " <> show other) + n <- readIORef ref + n @?= 3, + testCase "EP-34: a permanently failing stream surfaces a transient ProviderFailure" $ do + ref <- newIORef 0 + reg <- failingStreamStubRegistry ref 5 "ok" -- more failures than attempts + let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5} + res <- runStream cfg + case res of + Left (ProviderFailure _) -> pure () + other -> assertFailure ("expected Left (ProviderFailure ...), got " <> show other) + n <- readIORef ref + n @?= 3, -- retried up to maxAttempts + testCase "EP-34: a failed stream still charges the budget (charge precedes the throw)" $ do + -- First call: budget gate passes, stream fails after charging its cost, so + -- the failure surfaces AND the cost is recorded. Second call: the gate now + -- refuses because the first (failed) call already consumed the ceiling. + reg <- failingStreamCostStubRegistry (1 % 100) + b <- newBudget (Just (1 % 100)) + let cfg = (defaultLLMConfig reg) {budget = Just b, retryPolicy = RetryPolicy 1 1 5} + res1 <- runStream cfg + case res1 of + Left (ProviderFailure _) -> pure () + other -> assertFailure ("expected Left (ProviderFailure ...), got " <> show other) + res2 <- runStream cfg + case res2 of + Left (BudgetExceeded _) -> pure () + other -> assertFailure ("expected Left (BudgetExceeded ...) after the failed call charged, got " <> show other) ] where runText cfg = runEff . runConcurrent . runErrorNoCallStack @ShikumiError . runLLMResilient cfg $ do r <- complete stubModel stubContext stubOptions pure (flattenAssistantText (flattenAssistantBlocks r)) + runStream cfg = + runEff . runConcurrent . runErrorNoCallStack @ShikumiError . runLLMResilient cfg $ + stream stubModel stubContext stubOptions + isEventDone = \case EventDone _ -> True; _ -> False diff --git a/test/RoutingSpec.hs b/test/RoutingSpec.hs --- a/test/RoutingSpec.hs +++ b/test/RoutingSpec.hs @@ -9,27 +9,54 @@ -- identical temperatures). module RoutingSpec (tests) where -import Baikai (Model, Options, ResponseFormat (..), _Model) +import Baikai + ( AssistantContent (..), + AssistantMessageEvent (..), + Context, + Message (..), + Model, + Options, + ResponseFormat (..), + StopReason (..), + TextContent (..), + doneTerminal, + _Model, + ) import Baikai.Models.Generated (openai_gpt_4o_mini) import Control.Lens ((^.)) +import Data.Aeson (Value (..), eitherDecodeStrict, object, (.=)) +import Data.Aeson.KeyMap qualified as KM import Data.Generics.Labels () -import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import Data.List (nub, sort) +import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding (encodeUtf8) +import Data.Vector qualified as V import Effectful (Eff, IOE, liftIO, runEff, type (:>)) import Effectful.Concurrent (runConcurrent) import Effectful.Dispatch.Dynamic (interpret) import Effectful.Error.Static (runErrorNoCallStack) import ProgramFixtures (Outline, Topic (..), outlineResponse, topicToOutline) -import Shikumi.Adapter (metaResponseSchemaKey, metaTemperatureKey) -import Shikumi.Combinator (majorityVote) +import Shikumi.Adapter (metaNativeDemosKey, metaNativePromptKey, metaResponseSchemaKey, metaTemperatureKey) +import Shikumi.Combinator (majorityVote, majorityVoteBy) import Shikumi.Error (ShikumiError) import Shikumi.LLM (LLM (..), Response) import Shikumi.Module (predict) -import Shikumi.Program (Program, TempSchedule (..), runProgram, runProgramConc) +import Shikumi.Program + ( Demo (..), + Params (..), + Program (Predict), + TempSchedule (..), + runProgram, + runProgramConc, + ) import Shikumi.Routing (routeLLM, runRouting) import Shikumi.Schema (deriveSchema) +import Shikumi.Stream (streamProgram) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) @@ -40,7 +67,12 @@ [ routesModelId, nativeAttachesSchema, fallbackLeavesSchemaUnset, + nativeReceivesNativeGuide, + nativeReceivesJsonDemos, + fallbackPromptUnchangedAndStampsStripped, + routesStreamModelAndStripsMetadata, spreadSetsDistinctTemps, + majorityVoteBySetsDistinctTemps, fixedSetsExactTemps, concurrentAgreesOnTemps ] @@ -49,23 +81,28 @@ -- Capturing stub + run helpers -- --------------------------------------------------------------------------- --- | A base @LLM@ interpreter that records every request's @(Model, Options)@ and --- returns a fixed response. +-- | A base @LLM@ interpreter that records every request's @(Model, Context, +-- Options)@ (the 'Context' so a test can assert the prompt and demo turns that +-- reached the wire) and returns a fixed response. runCapturingLLM :: (IOE :> es) => - IORef [(Model, Options)] -> + IORef [(Model, Context, Options)] -> Response -> Eff (LLM : es) a -> Eff es a runCapturingLLM ref resp = interpret $ \_ -> \case - Complete m _ o -> do - liftIO (modifyIORef' ref (++ [(m, o)])) + Complete m ctx o -> do + liftIO (atomicModifyIORef' ref (\xs -> (xs ++ [(m, ctx, o)], ()))) pure resp - Stream _ _ _ -> pure [] + Stream m ctx o -> do + liftIO (atomicModifyIORef' ref (\xs -> (xs ++ [(m, ctx, o)], ()))) + -- A minimal successful stream whose terminal reassembles to @resp@, so a + -- routed 'streamProgram' decodes exactly as the blocking path would. + pure [EventDone (doneTerminal Nothing Stop (AssistantMessage (resp ^. #message)))] -- | Run a program sequentially under @routeLLM . runRouting model@ over a capturing -- stub and return the captured requests. -captureRouted :: Model -> Program Topic Outline -> Topic -> IO [(Model, Options)] +captureRouted :: Model -> Program Topic Outline -> Topic -> IO [(Model, Context, Options)] captureRouted model prog input = do ref <- newIORef [] res <- @@ -79,7 +116,7 @@ readIORef ref -- | As 'captureRouted' but under the concurrent executor. -captureRoutedConc :: Model -> Program Topic Outline -> Topic -> IO [(Model, Options)] +captureRoutedConc :: Model -> Program Topic Outline -> Topic -> IO [(Model, Context, Options)] captureRoutedConc model prog input = do ref <- newIORef [] res <- @@ -96,6 +133,14 @@ isRight :: Either a b -> Bool isRight = either (const False) (const True) +-- | The assistant-turn texts of a captured 'Context', in order. +assistantTexts :: Context -> [Text] +assistantTexts ctx = + [ t + | AssistantMessage p <- V.toList (ctx ^. #messages), + AssistantText (TextContent t) <- V.toList (p ^. #content) + ] + -- --------------------------------------------------------------------------- -- M1 — the ambient model id reaches the wire -- --------------------------------------------------------------------------- @@ -104,7 +149,7 @@ routesModelId = testCase "routes the ambient model id onto the wire" $ do captured <- captureRouted openai_gpt_4o_mini (predict topicToOutline) (Topic "cats") - map (^. #modelId) (map fst captured) @?= [openai_gpt_4o_mini ^. #modelId] + map (\(m, _, _) -> m ^. #modelId) captured @?= [openai_gpt_4o_mini ^. #modelId] -- --------------------------------------------------------------------------- -- M2 — native responseFormat on the wire; fallback leaves it unset @@ -115,7 +160,7 @@ testCase "native model attaches responseFormat with the derived schema" $ do captured <- captureRouted openai_gpt_4o_mini (predict topicToOutline) (Topic "cats") case captured of - [(_, o)] -> do + [(_, _, o)] -> do o ^. #responseFormat @?= Just (JsonSchema {name = "output", schema = deriveSchema @Outline, strict = True}) assertBool @@ -128,7 +173,7 @@ testCase "fallback model leaves responseFormat unset" $ do captured <- captureRouted _Model (predict topicToOutline) (Topic "cats") case captured of - [(_, o)] -> do + [(_, _, o)] -> do o ^. #responseFormat @?= Nothing assertBool "private schema key stripped before transport" @@ -136,11 +181,102 @@ other -> assertBool ("expected exactly one request, got " <> show (length other)) False -- --------------------------------------------------------------------------- +-- EP-33 — native render channel: the native prompt and JSON demos reach the wire +-- for native-capable models; fallback models keep the marker prompt; stamps stripped +-- --------------------------------------------------------------------------- + +nativeReceivesNativeGuide :: TestTree +nativeReceivesNativeGuide = + testCase "native model receives the native output guide, not the marker guide" $ do + captured <- captureRouted openai_gpt_4o_mini (predict topicToOutline) (Topic "cats") + case captured of + [(_, ctx, _)] -> do + let sys = maybe "" id (ctx ^. #systemPrompt) + assertBool + "system prompt contains the native JSON guide" + ("Reply with a JSON object containing these fields:" `T.isInfixOf` sys) + assertBool + "system prompt carries no marker sections" + (not ("[[ ##" `T.isInfixOf` sys)) + other -> assertBool ("expected exactly one request, got " <> show (length other)) False + +nativeReceivesJsonDemos :: TestTree +nativeReceivesJsonDemos = + testCase "native model receives demo assistant turns as JSON objects" $ do + -- Demos must be supplied through the node's Params channel — 'effectiveSignature' + -- overwrites any signature-level demos with the Params ones. Stored as JSON and + -- decoded back into typed Topic/Outline demos before rendering. + let demo = + Demo + (object ["subject" .= ("dogs" :: Text)]) + (object ["points" .= (["one", "two"] :: [Text])]) + node = Predict topicToOutline (Params Nothing [demo]) + captured <- captureRouted openai_gpt_4o_mini node (Topic "cats") + case captured of + [(_, ctx, _)] -> case assistantTexts ctx of + (demoText : _) -> do + assertBool + "demo turn carries no marker sections" + (not ("[[ ##" `T.isInfixOf` demoText)) + case eitherDecodeStrict (encodeUtf8 demoText) of + Right (Object o) -> + assertBool "demo JSON object carries the points field" (KM.member "points" o) + other -> assertBool ("demo turn is not a JSON object: " <> show other) False + [] -> assertBool "expected a demo assistant turn on the wire" False + other -> assertBool ("expected exactly one request, got " <> show (length other)) False + +fallbackPromptUnchangedAndStampsStripped :: TestTree +fallbackPromptUnchangedAndStampsStripped = + testCase "fallback model keeps the marker prompt and native stamps are stripped" $ do + captured <- captureRouted _Model (predict topicToOutline) (Topic "cats") + case captured of + [(_, ctx, o)] -> do + let sys = maybe "" id (ctx ^. #systemPrompt) + assertBool + "system prompt keeps the marker guide" + ("Reply using these sections" `T.isInfixOf` sys) + o ^. #responseFormat @?= Nothing + assertBool + "native prompt key stripped before transport" + (Map.notMember metaNativePromptKey (o ^. #metadata)) + assertBool + "native demos key stripped before transport" + (Map.notMember metaNativeDemosKey (o ^. #metadata)) + other -> assertBool ("expected exactly one request, got " <> show (length other)) False + +-- --------------------------------------------------------------------------- +-- EP-34 — the Stream operation is routed exactly like Complete +-- --------------------------------------------------------------------------- + +routesStreamModelAndStripsMetadata :: TestTree +routesStreamModelAndStripsMetadata = + testCase "routes the ambient model and strips metadata on Stream" $ do + ref <- newIORef [] + res <- + runEff + . runErrorNoCallStack @ShikumiError + . runRouting openai_gpt_4o_mini + . runCapturingLLM ref outlineResponse + . routeLLM + $ streamProgram (predict topicToOutline) (Topic "cats") (\_ -> pure ()) + assertBool "routed streaming program decodes without error" (isRight res) + captured <- readIORef ref + case captured of + [(m, _, o)] -> do + m ^. #modelId @?= openai_gpt_4o_mini ^. #modelId + o ^. #responseFormat + @?= Just (JsonSchema {name = "output", schema = deriveSchema @Outline, strict = True}) + assertBool + "private schema key stripped before transport" + (Map.notMember metaResponseSchemaKey (o ^. #metadata)) + other -> assertBool ("expected exactly one Stream request, got " <> show (length other)) False + +-- --------------------------------------------------------------------------- -- M3 — per-sample temperature from MajorityVote's TempSchedule -- --------------------------------------------------------------------------- -capturedTemps :: [(Model, Options)] -> [Double] -capturedTemps = mapMaybe (\(_, o) -> o ^. #temperature) +capturedTemps :: [(Model, Context, Options)] -> [Double] +capturedTemps = mapMaybe (\(_, _, o) -> o ^. #temperature) spreadSetsDistinctTemps :: TestTree spreadSetsDistinctTemps = @@ -153,7 +289,23 @@ map round3 (sort temps) @?= [0.1, 0.5, 0.9] assertBool "private temperature key stripped before transport" - (all (\(_, o) -> Map.notMember metaTemperatureKey (o ^. #metadata)) captured) + (all (\(_, _, o) -> Map.notMember metaTemperatureKey (o ^. #metadata)) captured) + +majorityVoteBySetsDistinctTemps :: TestTree +majorityVoteBySetsDistinctTemps = + testCase "majorityVoteBy applies its TempSchedule per sample (EP-35)" $ do + -- Before EP-35 majorityVoteBy ignored its schedule (defined via Ensemble), so + -- zero temperatures reached the wire. The reducer is irrelevant here (we assert + -- on captured temperatures); pickFirst is any total [o] -> o. + let pickFirst = NE.head . NE.fromList + captured <- + captureRouted + openai_gpt_4o_mini + (majorityVoteBy 3 (TempSpread 0.5 0.4) pickFirst (predict topicToOutline)) + (Topic "cats") + let temps = capturedTemps captured + length temps @?= 3 + map round3 (sort temps) @?= [0.1, 0.5, 0.9] fixedSetsExactTemps :: TestTree fixedSetsExactTemps = diff --git a/test/SchemaSpec.hs b/test/SchemaSpec.hs --- a/test/SchemaSpec.hs +++ b/test/SchemaSpec.hs @@ -15,6 +15,12 @@ import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) -- | The schema we expect @deriveSchema \@Summary@ to produce. +-- +-- Pinned to the OpenAI strict-mode shape (EP-33): the @sentiment@ enum carries an +-- explicit @"type": "string"@, and the nullable @note@ appears in @required@ +-- (strict mode expresses optionality as required-but-nullable, not by omission). +-- The pre-EP-33 golden pinned the strict-mode-violating shape; this update is +-- deliberate, not a regression. expectedSummarySchema :: Value expectedSummarySchema = object @@ -37,10 +43,10 @@ "required" .= ["name" :: Text], "additionalProperties" .= False ], - "sentiment" .= object ["enum" .= (["Positive", "Neutral", "Negative"] :: [Text])], + "sentiment" .= object ["type" .= s "string", "enum" .= (["Positive", "Neutral", "Negative"] :: [Text])], "note" .= object ["anyOf" .= [object ["type" .= s "string"], object ["type" .= s "null"]]] ], - "required" .= (["headline", "bullets", "author", "sentiment"] :: [Text]), + "required" .= (["headline", "bullets", "author", "sentiment", "note"] :: [Text]), "additionalProperties" .= False ] where diff --git a/test/StreamSpec.hs b/test/StreamSpec.hs --- a/test/StreamSpec.hs +++ b/test/StreamSpec.hs @@ -36,10 +36,10 @@ import Effectful.Dispatch.Dynamic (interpret) import Effectful.Error.Static (runErrorNoCallStack) import GHC.Generics (Generic) -import ProgramFixtures (Draft (..), Topic (..), markerBody, outlineToDraft, topicToOutline) +import ProgramFixtures (Draft (..), Topic (..), markerBody, outlineToDraft, topicToOutline, topicToVerdict) import Shikumi.Adapter (ToPrompt, responseText) import Shikumi.Combinator ((>>>)) -import Shikumi.Error (ShikumiError) +import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (LLM (..)) import Shikumi.Module (predict) import Shikumi.Program (Program, runProgram) @@ -117,12 +117,12 @@ -- the value streaming incrementally, the terminal carries the whole structured reply. streamEventsFor :: [Text] -> Text -> [AssistantMessageEvent] streamEventsFor deltas terminalText = - [ EventStart (StartPayload (AssistantMessage (_Response ^. #message))), + [ EventStart (StartPayload (AssistantMessage (_Response ^. #message)) Nothing), TextStart (IndexPayload 0) ] ++ [TextDelta (DeltaPayload 0 d) | d <- deltas] ++ [ TextEnd (BlockEndPayload 0 (T.concat deltas)), - EventDone (doneTerminal Stop (AssistantMessage (payloadWith terminalText))) + EventDone (doneTerminal Nothing Stop (AssistantMessage (payloadWith terminalText))) ] where payloadWith t = (_Response ^. #message) & #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) @@ -167,6 +167,32 @@ out @?= Right (Answer "Hello"), testCase "M2: streamProgram returns the same value as runProgram" $ do let script = [streamEventsFor ["Hel", "lo"] (markerBody [("answer", "Hello")])] + ref1 <- newIORef script + streamed <- + runEff . runErrorNoCallStack @ShikumiError . runStreamingLLM ref1 $ + streamProgram (predict qToAnswer) (Question "q?") (\_ -> pure ()) + ref2 <- newIORef script + blocking <- + runEff . runErrorNoCallStack @ShikumiError . runStreamingLLM ref2 $ + runProgram (predict qToAnswer) (Question "q?") + streamed @?= blocking, + testCase "EP-32: a failing Validatable rule surfaces through streamProgram" $ do + ref <- newIORef [streamEventsFor ["99"] (markerBody [("score", "99")])] + out <- + runEff . runErrorNoCallStack @ShikumiError . runStreamingLLM ref $ + streamProgram (predict topicToVerdict) (Topic "haskell") (\_ -> pure ()) + out @?= Left (ValidationFailure "score: must be at most 10"), + testCase "EP-34: streamPredict decodes a native-shaped (JSON) terminal via parseResponse" $ do + -- The terminal body is a JSON object (the native wire shape). Before the + -- shared parseResponse, the fallback-only parser found no markers and + -- reported MissingField; now the JSON body decodes correctly. + ref <- newIORef [streamEventsFor ["{\"ans"] "{\"answer\": \"Hello\"}"] + out <- + runEff . runErrorNoCallStack @ShikumiError . runStreamingLLM ref $ + streamProgram (predict qToAnswer) (Question "q?") (\_ -> pure ()) + out @?= Right (Answer "Hello"), + testCase "EP-34: streamProgram equals runProgram on a JSON-shaped script" $ do + let script = [streamEventsFor ["{\"ans"] "{\"answer\": \"Hello\"}"] ref1 <- newIORef script streamed <- runEff . runErrorNoCallStack @ShikumiError . runStreamingLLM ref1 $ diff --git a/test/StubProvider.hs b/test/StubProvider.hs --- a/test/StubProvider.hs +++ b/test/StubProvider.hs @@ -13,13 +13,16 @@ flattenAssistantText, stubRegistry, costStubRegistry, + budgetBarrierStubRegistry, failingStubRegistry, + failingStreamStubRegistry, + failingStreamCostStubRegistry, invalidStubRegistry, concurrencyStubRegistry, ) where -import Baikai +import Baikai hiding (flattenAssistantText) import Baikai.Prelude import Control.Concurrent (threadDelay) import Control.Concurrent.STM @@ -27,6 +30,7 @@ atomically, modifyTVar', readTVar, + retry, ) import Control.Exception (bracket_, throwIO) import Data.Generics.Labels () @@ -36,8 +40,9 @@ import Streamly.Data.Stream qualified as Stream -- | Concatenate the text of every 'AssistantText' block, ignoring thinking and --- tool-call blocks. baikai has no library equivalent (its own smoke tests define --- this same helper locally). +-- tool-call blocks. baikai 0.3 exports its own 'flattenAssistantText'; this stub +-- keeps a local copy (hidden from the @Baikai@ import) so the fixture's behavior +-- is pinned regardless of the library's. flattenAssistantText :: V.Vector AssistantContent -> Text flattenAssistantText = T.concat . V.toList . V.mapMaybe textOf where @@ -92,11 +97,11 @@ -- | A deterministic, valid event sequence for the given text. stubEvents :: Text -> [AssistantMessageEvent] stubEvents t = - [ EventStart StartPayload {partial = AssistantMessage (_Response ^. #message)}, + [ EventStart StartPayload {partial = AssistantMessage (_Response ^. #message), responseId = Nothing}, TextStart IndexPayload {contentIndex = 0}, TextDelta DeltaPayload {contentIndex = 0, delta = t}, TextEnd BlockEndPayload {contentIndex = 0, content = t}, - EventDone (doneTerminal Stop (AssistantMessage (stubPayloadWith t))) + EventDone (doneTerminal Nothing Stop (AssistantMessage (stubPayloadWith t))) ] -- | Build an isolated registry from a @complete@ implementation, reusing the @@ -123,6 +128,20 @@ costStubRegistry c t = mkRegistry t (\_ _ _ -> pure (stubResponse t & #message . #usage . #cost . #usd .~ c)) +-- | A registry whose @complete@ blocks until @n@ calls have all arrived (a shared +-- 'TVar' barrier), then returns a cost-carrying response. Guarantees that @n@ +-- concurrent calls are all in flight — each already past the budget's optimistic +-- @admitCall@ gate — before any of them records its cost, so a test can pin the +-- documented budget overshoot under concurrency. +budgetBarrierStubRegistry :: TVar Int -> Int -> Rational -> Text -> IO ProviderRegistry +budgetBarrierStubRegistry arrived n cost t = + mkRegistry t $ \_ _ _ -> do + atomically (modifyTVar' arrived (+ 1)) + atomically $ do + a <- readTVar arrived + if a >= n then pure () else retry + pure (stubResponse t & #message . #usage . #cost . #usd .~ cost) + -- | A registry whose @complete@ throws 'providerError' (a transient failure) the -- first @failTimes@ calls, then returns the given text. The 'IORef' records the -- total number of attempts (used by the retry tests). @@ -133,6 +152,61 @@ if n <= failTimes then throwIO (providerError ("stub transient failure #" <> T.pack (show n))) else pure (stubResponse t) + +-- | A terminal-failing event sequence: an 'EventError' whose assembled message +-- carries @errorMessage@ (and optionally a dollar cost). Shikumi's @LLM@ +-- interpreters map this to a transient 'Shikumi.Error.ProviderFailure'. +streamErrorEvents :: Rational -> Text -> [AssistantMessageEvent] +streamErrorEvents cost msg = + [ EventStart StartPayload {partial = AssistantMessage (_Response ^. #message), responseId = Nothing}, + EventError (doneTerminal Nothing ErrorReason (AssistantMessage errPayload)) + ] + where + errPayload = + (_Response ^. #message) + & #errorMessage + .~ Just msg + & #usage + . #cost + . #usd + .~ cost + +-- | A registry whose /stream/ fails (a terminal 'EventError') the first +-- @failTimes@ calls, then streams success. @complete@ is irrelevant (stream-only +-- tests). The 'IORef' records the total number of stream attempts, so a retry test +-- can assert the loop fired. +failingStreamStubRegistry :: IORef Int -> Int -> Text -> IO ProviderRegistry +failingStreamStubRegistry ref failTimes t = do + reg <- newProviderRegistry + registerApiProviderWith + reg + ApiProvider + { apiTag = stubApi, + complete = \_ _ _ -> pure (stubResponse t), + stream = \_ _ _ -> Stream.concatEffect $ do + n <- atomicModifyIORef' ref (\k -> (k + 1, k + 1)) + pure $ + Stream.fromList $ + if n <= failTimes + then streamErrorEvents 0 ("stub stream failure #" <> T.pack (show n)) + else stubEvents t + } + pure reg + +-- | A registry whose /stream/ always fails with a terminal 'EventError' carrying +-- the given dollar cost, so a test can assert the budget is charged even though the +-- stream failed. +failingStreamCostStubRegistry :: Rational -> IO ProviderRegistry +failingStreamCostStubRegistry cost = do + reg <- newProviderRegistry + registerApiProviderWith + reg + ApiProvider + { apiTag = stubApi, + complete = \_ _ _ -> pure (stubResponse ""), + stream = \_ _ _ -> Stream.fromList (streamErrorEvents cost "stub stream failure") + } + pure reg -- | A registry whose @complete@ always throws 'invalidRequest' (a non-transient -- failure that maps to 'Shikumi.Error.SchemaMismatch'). The 'IORef' records the