shikumi 0.3.0.3 → 0.4.0.0

raw patch · 27 files changed

+1504/−160 lines, 27 filesdep ~baikaidep ~baikai-claudedep ~baikai-effectfulPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: baikai, baikai-claude, baikai-effectful, baikai-openai, shikumi

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• shikumi.cabal +29/−22
• src/Shikumi/Adapter.hs +29/−34
• src/Shikumi/Adapter/Xml.hs +233/−0
• src/Shikumi/Error.hs +31/−14
• src/Shikumi/LLM.hs +102/−52
• src/Shikumi/LLM/Continuation.hs +115/−0
• src/Shikumi/LLM/Defaults.hs +65/−0
• src/Shikumi/LLM/Observation.hs +180/−0
• src/Shikumi/Module.hs +20/−3
• src/Shikumi/Program.hs +23/−0
• src/Shikumi/Routing.hs +11/−4
• src/Shikumi/Stream.hs +2/−1
• test/AdapterSpec.hs +2/−0
• test/ContinuationSpec.hs +93/−0
• test/ErrorSpec.hs +30/−5
• test/LLMSpec.hs +3/−3
• test/Main.hs +7/−1
• test/ModuleSpec.hs +15/−3
• test/ProgramFixtures.hs +14/−0
• test/RequestDefaultsSpec.hs +108/−0
• test/ResilienceSpec.hs +87/−4
• test/ResponsesSpec.hs +45/−0
• test/RoutingSpec.hs +12/−2
• test/StubProvider.hs +59/−2
• test/TwoStepSpec.hs +15/−2
• test/XmlAdapterSpec.hs +158/−8

@@ -2,6 +2,22 @@  ## Unreleased +## 0.4.0.0 — 2026-09-08++- Add per-attempt observers to bare/resilient runtimes and a bounded, thread-safe billing collector with exact cost persistence and explicit unknown usage. Observer exceptions propagate without retry; no additional budget charge occurs. `LLMConfig.observer` is a public record addition requiring a PVP major review.++- Add `Shikumi.LLM.Defaults`: invocation-scoped thinking, speed, token and evidence defaults with fill-only precedence for blocking and streaming calls. Zero default ceilings raise `ValidationFailure`. Additive public API requires a PVP minor release; existing unreleased major changes still govern the next release.++- Add continuation origin/prefix guards shared by routing and transport. `routeLLM` now requires `Error ShikumiError`; this public constraint change requires a PVP major review at release.++- Preserve structured transport failures in `ProviderError BaikaiError` and expose `renderShikumiError`. Blocking and streaming calls retry only typed rate limits/transient failures; refusals, auth, unavailable-provider, process and unknown failures are terminal. Legacy `ProviderFailure` and malformed stream terminals retain retry behavior. The added public sum constructor requires a PVP major bump at release; exhaustive downstream matches must handle it.++- Upgrade the dependency on `mori://shinzui/baikai/packages/baikai` to `>=0.7.0.0 && <0.8`. Require the Claude and OpenAI providers at `0.7.0.0` and Effectful at `0.4.0.1`; recognize OpenAI Responses as native structured-output capable.++- Decode nested XML records and arrays with bounded, balanced parsing. Add `nestedXmlAdapter` with `ToJSON` output demonstrations and schema guides; preserve legacy XML rendering and JSON-in-tag container decoding. XML required strings now retain literal `null`.++- Add `CaptureCodec`, `PredictCaptured`, and `predictCaptured` for opt-in typed node capture. Ordinary prediction constraints and parameter serialization are unchanged. Public GADT matches must handle the new constructor; all core traversals preserve codecs.+ ## 0.3.0.3 — 2026-08-29  ### Changed

@@ -1,6 +1,6 @@ cabal-version:   3.4 name:            shikumi-version:         0.3.0.3+version:         0.4.0.0 synopsis:        Typed, structured, evaluable LM programs over baikai category:        AI description:@@ -39,6 +39,9 @@     Shikumi.Error     Shikumi.LLM     Shikumi.LLM.Budget+    Shikumi.LLM.Continuation+    Shikumi.LLM.Defaults+    Shikumi.LLM.Observation     Shikumi.Module     Shikumi.Multimodal     Shikumi.Prelude@@ -51,25 +54,26 @@     Shikumi.Signature     Shikumi.Stream +  other-modules:   Shikumi.Adapter.Xml   build-depends:-    , aeson              >=2.2  && <2.3-    , baikai             >=0.6  && <0.7-    , baikai-claude      >=0.6  && <0.7-    , baikai-effectful   >=0.4  && <0.5-    , baikai-openai      >=0.6  && <0.7-    , base               >=4.20 && <5-    , base64-bytestring  >=1.2  && <1.3-    , bytestring         >=0.11 && <0.13-    , containers         >=0.6  && <0.9-    , effectful          >=2.5  && <2.7-    , filepath           >=1.4  && <1.6-    , generic-lens       >=2.2  && <2.4+    , aeson              >=2.2     && <2.3+    , baikai             >=0.7.0.0 && <0.8+    , baikai-claude      >=0.7.0.0 && <0.8+    , baikai-effectful   >=0.4.0.1 && <0.5+    , baikai-openai      >=0.7.0.0 && <0.8+    , base               >=4.20    && <5+    , base64-bytestring  >=1.2     && <1.3+    , bytestring         >=0.11    && <0.13+    , containers         >=0.6     && <0.9+    , effectful          >=2.5     && <2.7+    , filepath           >=1.4     && <1.6+    , generic-lens       >=2.2     && <2.4     , lens               ^>=5.3-    , scientific         >=0.3  && <0.4-    , stm                >=2.5  && <2.6+    , scientific         >=0.3     && <0.4+    , stm                >=2.5     && <2.6     , text               ^>=2.1-    , time               >=1.12 && <1.17-    , vector             >=0.13 && <0.14+    , time               >=1.12    && <1.17+    , vector             >=0.13    && <0.14  test-suite shikumi-test   import:         common-options@@ -81,6 +85,7 @@     AdapterSpec     CombinatorSpec     ConstraintSpec+    ContinuationSpec     EndToEndSpec     ErrorSpec     Fixtures@@ -95,7 +100,9 @@     ProgramSpec     RefineSpec     RefineStub+    RequestDefaultsSpec     ResilienceSpec+    ResponsesSpec     RoutingSpec     SchemaSpec     SerializeSpec@@ -109,10 +116,10 @@    build-depends:     , aeson-    , baikai             >=0.6      && <0.7-    , baikai-claude      >=0.6      && <0.7-    , baikai-effectful   >=0.4      && <0.5-    , baikai-openai      >=0.6      && <0.7+    , baikai             >=0.7.0.0  && <0.8+    , baikai-claude      >=0.7.0.0  && <0.8+    , baikai-effectful   >=0.4.0.1  && <0.5+    , baikai-openai      >=0.7.0.0  && <0.8     , base     , base64-bytestring     , bytestring@@ -122,7 +129,7 @@     , generic-lens     , lens     , QuickCheck-    , shikumi            ^>=0.3.0.0+    , shikumi            ^>=0.4.0.0     , stm     , streamly-core     , tasty

@@ -8,10 +8,10 @@ -- @render@ builds a baikai @Context@+@Options@; @parse@ decodes a baikai -- @Response@ into the typed output via "Shikumi.Schema". ----- Two adapters ship. The native-schema adapter is the reliable path (the provider--- enforces the JSON schema); the prompt-based fallback renders @[[ ## field ## ]]@--- sections and re-parses them, for models without native structured output.--- 'capabilityFor' selects per model.+-- The native-schema adapter uses provider-enforced JSON; the prompt-based fallback+-- renders @[[ ## field ## ]]@ sections for models without native structured output.+-- 'capabilityFor' selects between them per model. Two opt-in XML adapters share+-- bounded nested decoding and offer legacy or structured demonstration rendering. -- -- Native structured output is wired through a private /metadata channel/ (EP-14). -- Because a 'Program' renders before the ambient model is known (the model is@@ -44,6 +44,7 @@     nativeAdapter,     fallbackAdapter,     xmlAdapter,+    nestedXmlAdapter,     adapterFor,     attachSchema,     responseText,@@ -92,6 +93,7 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Vector qualified as V import GHC.Generics+import Shikumi.Adapter.Xml (decodeXmlFields, renderXmlFields, xmlSchemaGuide) import Shikumi.Error (ShikumiError (..)) import Shikumi.Multimodal (GImageFieldNames (..), GImageFields (..), Image, imageToContent) import Shikumi.Schema (FromModel, ToSchema, Validatable, deriveSchema, fromModelChecked)@@ -188,6 +190,7 @@ capabilityFor :: Model -> ModelCapability capabilityFor m = case (m ^. #provider, m ^. #api) of   ("openai", OpenAIChatCompletions) -> NativeSchema+  ("openai", OpenAIResponses) -> NativeSchema   ("anthropic", AnthropicMessages) -> NativeSchema   _ -> PromptFallback @@ -307,9 +310,9 @@ -- | The XML adapter (EP-26). A third wire format on the same typed seam: @render@ -- asks the model to wrap each output field in @\<field\>…\</field\>@ tags, and -- @parse@ reads those tags back. Some models follow an XML shape more reliably than--- JSON or the @[[ ## … ## ]]@ markers. Reuses the same 'sectionsToObject' +--- 'fromModelChecked' decode path as 'fallbackAdapter', so nested records and lists--- in tags coerce the same way.+-- JSON or the @[[ ## … ## ]]@ markers. Both XML adapters decode nested elements+-- and legacy JSON-in-tag containers through 'fromModelChecked'. This adapter+-- retains its historical flattened demonstration rendering. -- -- Reachability: 'xmlAdapter' is /not/ selectable by the runtime router. The router -- ("Shikumi.Routing".@routeLLM@) picks between the native and fallback wire shapes@@ -330,11 +333,26 @@         let sys = systemHeader sig <> xmlOutputGuide sig             ctx = buildContext sys (xmlDemoMessages sig ++ [userTurn i])          in (ctx, emptyOptions),-      parse = \sig resp ->+      parse = \_sig resp -> decodeXmlFields (deriveSchema @o) (responseText resp) >>= fromModelChecked+    }++-- | Nested XML guides and faithful structured demonstrations (EP-55). Requires+-- 'Aeson.ToJSON' for outputs; inputs still use 'ToPrompt'. Supports generated+-- records, arrays, scalars and nullable schemas; other schema forms render an+-- escaped JSON fallback. Parsing is shared with 'xmlAdapter'. Opt-in only.+nestedXmlAdapter ::+  forall i o.+  (ToSchema o, FromModel o, Validatable o, ToPrompt i, Aeson.ToJSON o) =>+  Adapter i o+nestedXmlAdapter =+  Adapter+    { render = \sig i ->         let names = map fieldName (outputFields sig)-            sections = parseXmlTags names (responseText resp)-            obj = sectionsToObject (deriveSchema @o) sections-         in fromModelChecked obj+            schema = deriveSchema @o+            sys = systemHeader sig <> xmlSchemaGuide names schema+            demos = concat [[userTurn di, assistant (renderXmlFields names schema (toJSON o))] | Demo di o <- getDemos sig]+         in (buildContext sys (demos ++ [userTurn i]), emptyOptions),+      parse = \_sig resp -> decodeXmlFields (deriveSchema @o) (responseText resp) >>= fromModelChecked     }  -- ---------------------------------------------------------------------------@@ -484,29 +502,6 @@     flush (Just (name, buf)) acc       | name == "completed" = acc       | otherwise = Map.insert name (T.strip (T.unlines buf)) acc---- | Extract @\<name\>…\</name\>@ sections into a name->text map. Only names that--- appear as output fields are kept (so stray tags are ignored, DSPy parity), and--- the first match per name wins. The content is whatever lies between the first--- @\<name\>@ and its next @\</name\>@ — a non-greedy match, the same as DSPy's--- @\<(?P\<name\>\\w+)\>(?P\<content\>.*?)\</\\1\>@ with DOTALL.-parseXmlTags :: [Text] -> Text -> Map Text Text-parseXmlTags names body =-  Map.fromList [(nm, inner) | nm <- names, Just inner <- [extractTag nm body]]---- | The text between the first @\<name\>@ and its next @\</name\>@, trimmed;--- 'Nothing' if either tag is absent.-extractTag :: Text -> Text -> Maybe Text-extractTag nm body =-  let open = openTag nm-      close = closeTag nm-      (_, afterOpen) = T.breakOn open body-   in if T.null afterOpen-        then Nothing-        else-          let rest = T.drop (T.length open) afterOpen-              (inner, afterClose) = T.breakOn close rest-           in if T.null afterClose then Nothing else Just (T.strip inner)  -- | Recognize a @[[ ## name ## ]]@ marker line. markerName :: Text -> Maybe Text

@@ -0,0 +1,233 @@+-- | Bounded model-output XML fragments, not a general XML processor.+module Shikumi.Adapter.Xml (decodeXmlFields, renderXmlFields, xmlSchemaGuide) where++import Data.Aeson (Object, Value (..), eitherDecodeStrict, encode)+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Lazy qualified as LBS+import Data.Char (chr, isAlpha, isAlphaNum, ord)+import Data.List (sortOn)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Vector qualified as V+import Shikumi.Error (ShikumiError (..))++-- Offsets count Unicode code points, starting at zero. CDATA provenance matters+-- for the nullable literal string "null".+data Node = Element !Int !Text [Node] | Content !Bool !Text++data Cursor = Cursor !Int !Text++failure :: Int -> Text -> Either ShikumiError a+failure pos msg = Left (SchemaMismatch ("XML: offset " <> T.pack (show pos) <> ": " <> msg))++advance :: Text -> Cursor -> Cursor+advance consumed (Cursor pos rest) = Cursor (pos + T.length consumed) (T.drop (T.length consumed) rest)++xmlSpace :: Char -> Bool+xmlSpace c = c `elem` [' ', '\t', '\r', '\n']++validChar :: Char -> Bool+validChar c = let n = ord c in n == 9 || n == 10 || n == 13 || (n >= 32 && n <= 0xD7FF) || (n >= 0xE000 && n <= 0xFFFD) || (n >= 0x10000 && n <= 0x10FFFF)++-- Siblings accumulate tail-recursively; only element nesting consumes depth.+fragment :: Int -> Maybe Text -> Cursor -> Either ShikumiError ([Node], Cursor)+fragment depth closing = go []+  where+    go acc cur@(Cursor pos rest)+      | T.null rest = case closing of+          Nothing -> Right (reverse acc, cur)+          Just name -> failure pos ("unterminated element " <> name)+      | "<!--" `T.isPrefixOf` rest = do+          (body, next) <- delimited "<!--" "-->" cur+          if "--" `T.isInfixOf` body || "-" `T.isSuffixOf` body then failure pos "invalid comment" else go acc next+      | "<![CDATA[" `T.isPrefixOf` rest = do+          (body, next) <- delimited "<![CDATA[" "]]>" cur+          go (Content True body : acc) next+      | "</" `T.isPrefixOf` rest = do+          (name, selfClosing, next) <- tag True cur+          if closing == Just name && not selfClosing+            then Right (reverse acc, next)+            else failure pos ("unexpected closing tag " <> name)+      | "<!" `T.isPrefixOf` rest || "<?" `T.isPrefixOf` rest = failure pos "unsupported declaration or processing instruction"+      | "<" `T.isPrefixOf` rest = do+          if depth >= 64 then failure pos "depth limit 64 exceeded" else Right ()+          (name, selfClosing, next) <- tag False cur+          (children, after) <- if selfClosing then Right ([], next) else fragment (depth + 1) (Just name) next+          go (Element pos name children : acc) after+      | otherwise = do+          let (raw, _) = T.breakOn "<" rest+          if "]]>" `T.isInfixOf` raw then failure pos "CDATA terminator outside CDATA" else Right ()+          decoded <- if closing == Nothing then Right raw else entities pos raw+          go (Content False decoded : acc) (advance raw cur)++    delimited start end cur@(Cursor pos rest) =+      let (body, suffix) = T.breakOn end (T.drop (T.length start) rest)+       in if T.null suffix+            then failure pos ("unterminated " <> start)+            else Right (body, advance (start <> body <> end) cur)++tag :: Bool -> Cursor -> Either ShikumiError (Text, Bool, Cursor)+tag closing cur@(Cursor pos rest) =+  let prefix = if closing then "</" else "<"+      (name, suffix) = T.span (\c -> isAlphaNum c || c `elem` ['_', '-', '.']) (T.drop (T.length prefix) rest)+      spaces = T.takeWhile xmlSpace suffix+      end = T.dropWhile xmlSpace suffix+      finish token self = Right (name, self, advance (prefix <> name <> spaces <> token) cur)+   in case T.uncons name of+        Just (c, _)+          | isAlpha c || c == '_' ->+              if ">" `T.isPrefixOf` end+                then finish ">" False+                else+                  if not closing && "/>" `T.isPrefixOf` end+                    then finish "/>" True+                    else failure pos "attributes, namespaces, or malformed tag are unsupported"+        _ -> failure pos "invalid element name"++entities :: Int -> Text -> Either ShikumiError Text+entities = go []+  where+    go acc pos raw =+      let (plain, suffix) = T.breakOn "&" raw+          at = pos + T.length plain+       in if T.null suffix+            then Right (T.concat (reverse (plain : acc)))+            else+              let (ref, end) = T.breakOn ";" (T.drop 1 suffix)+               in if T.null end+                    then failure at "unterminated entity"+                    else do+                      value <- case ref of+                        "amp" -> Right "&"+                        "lt" -> Right "<"+                        "gt" -> Right ">"+                        "quot" -> Right "\""+                        "apos" -> Right "'"+                        _+                          | Just digits <- T.stripPrefix "#x" ref -> numeric at 16 digits+                          | Just digits <- T.stripPrefix "#" ref -> numeric at 10 digits+                          | otherwise -> failure at "unknown entity"+                      go (value : plain : acc) (at + T.length ref + 2) (T.drop 1 end)+    numeric pos base digits =+      let digit c+            | c >= '0' && c <= '9' = ord c - ord '0'+            | c >= 'a' && c <= 'f' = 10 + ord c - ord 'a'+            | c >= 'A' && c <= 'F' = 10 + ord c - ord 'A'+            | otherwise = base+          step n c = if n > 0x10FFFF || digit c >= base then 0x110000 else n * base + digit c+          value = T.foldl' step 0 digits+       in if T.null digits || value > 0x10FFFF || not (validChar (chr value))+            then failure pos "invalid Unicode character reference"+            else Right (T.singleton (chr value))++property :: Key.Key -> Value -> Value+property key (Object obj) = maybe Null id (KM.lookup key obj)+property _ _ = Null++properties :: Value -> Object+properties schema = case property "properties" schema of Object p -> p; _ -> KM.empty++nonNull :: Value -> Value+nonNull schema = case property "anyOf" schema of+  Array alts -> case V.toList alts of+    [a, b]+      | property "type" a == String "null" -> nonNull b+      | property "type" b == String "null" -> nonNull a+    _ -> schema+  _ -> schema++nullable :: Value -> Bool+nullable schema =+  property "type" schema == String "null" || case property "anyOf" schema of+    Array alts -> any nullable alts+    _ -> False++jsonText :: Text -> Value+jsonText raw = either (const (String raw)) id (eitherDecodeStrict (encodeUtf8 raw))++-- | Parse the entire fragment before selecting known top-level properties.+decodeXmlFields :: Value -> Text -> Either ShikumiError Value+decodeXmlFields schema body+  | T.length body > 1048576 = failure 0 "input length limit 1048576 exceeded"+  | Just pos <- T.findIndex (not . validChar) body = failure pos "invalid XML character"+  | otherwise = do+      (nodes, _) <- fragment 0 Nothing (Cursor 0 body)+      objectFields schema nodes++objectFields :: Value -> [Node] -> Either ShikumiError Value+objectFields schema nodes = Object . KM.fromList <$> traverse convert selected+  where+    present = KM.fromListWith (\_ first -> first) [(Key.fromText name, node) | node@(Element _ name _) <- nodes]+    selected = [(key, s, node) | (key, s) <- KM.toList (properties schema), Just node <- [KM.lookup key present]]+    convert (key, s, node) = (key,) <$> elementValue s node++elementValue :: Value -> Node -> Either ShikumiError Value+elementValue schema (Element pos _ nodes)+  | null children && nullable schema && raw == "null" && not cdata = Right Null+  | null children = Right $ case kind of+      String "string" -> String raw+      String "object" | T.null raw -> Object KM.empty+      String "array" | T.null raw -> Array V.empty+      _ -> jsonText raw+  | not (T.null raw) = failure pos "non-whitespace text mixed with child elements"+  | kind == String "object" = objectFields inner children+  | kind == String "array" = do+      values <- traverse item children+      Right (Array (V.fromList values))+  | otherwise = failure pos "scalar field contains child elements"+  where+    inner = nonNull schema+    kind = property "type" inner+    children = [node | node@Element {} <- nodes]+    raw = T.strip (T.concat [t | Content _ t <- nodes])+    cdata = or [flag | Content flag _ <- nodes]+    item node@(Element p name _)+      | name == "item" = elementValue (property "items" inner) node+      | otherwise = failure p "array children must be item elements"+    item _ = failure pos "invalid array content"+elementValue _ _ = failure 0 "expected element"++escape :: Text -> Text+escape = T.replace ">" "&gt;" . T.replace "<" "&lt;" . T.replace "&" "&amp;"++json :: Value -> Text+json = decodeUtf8 . LBS.toStrict . encode++wrap :: Text -> Text -> Text+wrap name body = "<" <> name <> ">" <> body <> "</" <> name <> ">"++-- | Signature order at the root, lexical property order within records.+renderXmlFields :: [Text] -> Value -> Value -> Text+renderXmlFields names schema value = T.unlines [renderElement name (property (Key.fromText name) (Object (properties schema))) v | name <- names, Just v <- [lookupValue name value]]+  where+    lookupValue name (Object obj) = KM.lookup (Key.fromText name) obj+    lookupValue _ _ = Nothing++renderElement :: Text -> Value -> Value -> Text+renderElement name schema value = wrap name body+  where+    inner = nonNull schema+    body = case (property "type" inner, value) of+      (_, Null) -> "null"+      (String "object", Object obj) -> T.concat [renderElement (Key.toText k) (property k (Object (properties inner))) v | (k, v) <- sortOn fst (KM.toList obj)]+      (String "array", Array values) -> T.concat [renderElement "item" (property "items" inner) v | v <- V.toList values]+      (String "string", String t)+        | nullable schema && T.strip t == "null" -> "<![CDATA[" <> T.replace "]]>" "]]]]><![CDATA[>" t <> "]]>"+        | otherwise -> escape t+      _ -> escape (json value)++-- | Guide for generated record/array/scalar/nullable schemas. Other hand-written+-- schema forms use escaped JSON values and are checked by the typed decoder.+xmlSchemaGuide :: [Text] -> Value -> Text+xmlSchemaGuide names schema =+  "Reply with these XML fields (no attributes or namespaces). Escape &, < and > in text.\n"+    <> "Arrays use repeated <item> elements; empty containers may self-close. Nullable fields may be omitted or contain null; use <![CDATA[null]]> for a nullable literal string.\n"+    <> T.unlines [guide name (property (Key.fromText name) (Object (properties schema))) | name <- names]+  where+    guide name s = wrap name $ case property "type" (nonNull s) of+      String "object" -> T.concat [guide (Key.toText k) v | (k, v) <- sortOn fst (KM.toList (properties (nonNull s)))]+      String "array" -> guide "item" (property "items" (nonNull s)) <> guide "item" (property "items" (nonNull s))+      String t -> "[" <> t <> "]"+      _ -> "[escaped JSON value]"

@@ -8,10 +8,11 @@   ( ShikumiError (..),     fromBaikaiError,     isTransient,+    renderShikumiError,   ) where -import Baikai.Error (BaikaiError (..), ErrorCategory (..))+import Baikai.Error (BaikaiError (..), ErrorCategory (..), isRetryable) import Data.Text (Text) import Data.Text qualified as T @@ -28,13 +29,15 @@     SchemaMismatch !Text   | -- | a typed value failed a user/program validation rule     ValidationFailure !Text-  | -- | the provider/transport failed (mapped from baikai)+  | -- | Legacy unclassified failure supplied by callers or scripted interpreters.     ProviderFailure !Text+  | -- | Structured transport failure, including verbatim refusal metadata.+    ProviderError !BaikaiError   | -- | the prompt exceeded the model's context window     ContextWindowExceeded !Text   | -- | the call exceeded its time budget     Timeout !Text-  | -- | the running cost ceiling was reached; the call was refused+  | -- | a configured resource allowance was exhausted (cost, calls or session size)     BudgetExceeded !Text   | -- | generated code failed after exhausting correction attempts     CodeExecFailed !Text@@ -50,20 +53,34 @@   DecodeFailure -> InvalidJSON (message e)   InvalidRequest -> SchemaMismatch ("invalid request: " <> message e)   ContextOverflow -> ContextWindowExceeded (message e)-  ProcessFailure ->-    ProviderFailure $-      case exitCode e of-        Just n -> "process exited " <> T.pack (show n) <> ": " <> message e-        Nothing -> message e-  _ -> ProviderFailure (message e)+  _ -> ProviderError e --- | Which errors are worth retrying. Provider/transport failures and timeouts are--- 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).+-- | Human-readable detail without dumping the transport record. Baikai's+-- message is its safe-to-log description; opaque request/response data is absent.+renderShikumiError :: ShikumiError -> Text+renderShikumiError = \case+  ProviderError e ->+    "provider "+      <> T.pack (show (category e))+      <> maybe "" (\n -> " (exit " <> T.pack (show n) <> ")") (exitCode e)+      <> ": "+      <> message e+  InvalidJSON t -> t+  MissingField t -> "missing field " <> t+  SchemaMismatch t -> t+  ValidationFailure t -> t+  ProviderFailure t -> t+  ContextWindowExceeded t -> t+  Timeout t -> t+  BudgetExceeded t -> t+  CodeExecFailed t -> t++-- | Retry only typed rate limits and transient failures, using Baikai's+-- classification. Legacy text failures and timeouts retain their retry policy.+-- Unknown/process errors and refusals are terminal; never infer from prose. isTransient :: ShikumiError -> Bool isTransient = \case+  ProviderError e -> isRetryable e   ProviderFailure {} -> True   Timeout {} -> True   _ -> False

@@ -7,7 +7,7 @@ -- -- The effect exposes two operations ('Complete', 'Stream'). The bare interpreters -- 'runLLM' / 'runLLMWith' map baikai's 'BaikaiError' into 'ShikumiError' and do--- nothing else. The resilient interpreter 'runLLMResilient' adds the production+-- validate continuation compatibility before transport. The resilient interpreter 'runLLMResilient' adds the production -- features baikai deliberately omits: retries with exponential backoff, an -- in-flight rate limit, and a US-dollar budget ceiling. --@@ -26,6 +26,7 @@     -- * Bare interpreters     runLLM,     runLLMWith,+    runLLMWithObserver,      -- * Resilience     RetryPolicy (..),@@ -59,6 +60,7 @@ import Baikai.Effectful qualified as BE import Baikai.Error (BaikaiError) import Baikai.Provider.Registry (ProviderRegistry)+import Baikai.Usage qualified as U import Control.Concurrent.STM   ( TVar,     modifyTVar',@@ -71,6 +73,8 @@ import Data.Generics.Labels () import Data.Maybe (fromMaybe, mapMaybe) import Data.Text qualified as T+import Data.Time.Clock (getCurrentTime)+import Data.Unique (hashUnique, newUnique) import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, IOE, liftIO, (:>)) import Effectful.Concurrent (Concurrent, threadDelay) import Effectful.Concurrent.STM (atomically)@@ -79,6 +83,8 @@ import Effectful.Exception (bracket_, try) import Shikumi.Error (ShikumiError (..), fromBaikaiError, isTransient) import Shikumi.LLM.Budget (Budget, admitCall, recordCost)+import Shikumi.LLM.Continuation+import Shikumi.LLM.Observation qualified as O  -- | The provider-neutral LM effect. 'Complete' is a blocking completion; -- 'Stream' returns the assembled list of typed events so callers that need@@ -116,7 +122,7 @@   (IOE :> es, Error ShikumiError :> es) =>   Eff (LLM : es) a ->   Eff es a-runLLM = reinterpret_ runBaikai bareHandler+runLLM = reinterpret_ runBaikai (bareHandler O.noObservation)  -- | Bare interpreter over an explicit registry. runLLMWith ::@@ -124,8 +130,12 @@   ProviderRegistry ->   Eff (LLM : es) a ->   Eff es a-runLLMWith reg = reinterpret_ (runBaikaiWith reg) bareHandler+runLLMWith reg = runLLMWithObserver reg O.noObservation +-- | Observe bare transport calls. Callback exceptions propagate without retries.+runLLMWithObserver :: (IOE :> es, Error ShikumiError :> es) => ProviderRegistry -> O.LLMObserver -> Eff (LLM : es) a -> Eff es a+runLLMWithObserver reg observer = reinterpret_ (runBaikaiWith reg) (bareHandler observer)+ -- | 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 routes baikai's@@ -136,15 +146,77 @@ -- '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 ->-  Eff es a-bareHandler = \case+  (IOE :> es, Baikai :> es, Error ShikumiError :> es) =>+  O.LLMObserver -> LLM (Eff localEs) a -> Eff es a+bareHandler observer op = do+  cid <- liftIO freshCallId+  transportAttempt observer Nothing cid 1 op++freshCallId :: IO T.Text+freshCallId = (T.pack . ("call-" <>) . show . hashUnique) <$> newUnique++-- The callback sits outside the typed transport try; its exceptions cannot+-- become retryable provider errors, even if the callback throws BaikaiError.+transportAttempt ::+  (IOE :> es, Baikai :> es, Error ShikumiError :> es) =>+  O.LLMObserver -> Maybe Budget -> T.Text -> Int -> LLM (Eff localEs) a -> Eff es a+transportAttempt observer mb cid ordinal op = case op of   Complete m c o -> do-    res <- try @BaikaiError (BE.complete m c o)-    either (throwError . fromBaikaiError) raiseResponseError res-  Stream m c o -> BE.streamCollect m c o >>= raiseStreamError+    either throwError pure (validateRequestContinuation m c o)+    start <- liftIO getCurrentTime+    res <- try @BaikaiError (BE.complete m c (stripContinuationMetadata o))+    case res of+      Left be -> do+        emit m O.CompletionCall start (Just (fromBaikaiError be)) Nothing Nothing+        throwError (fromBaikaiError be)+      Right resp -> do+        liftIO (chargeBudget mb resp)+        emit+          m+          O.CompletionCall+          start+          (fromBaikaiError <$> responseError resp)+          (availableUsage (resp ^. #message . #usage))+          (O.observedModelOf (resp ^. #evidence))+        raiseResponseError resp+  Stream m c o -> do+    either throwError pure (validateRequestContinuation m c o)+    start <- liftIO getCurrentTime+    res <- try @BaikaiError (BE.streamCollect m c (stripContinuationMetadata o))+    case res of+      Left be -> do+        emit m O.StreamCall start (Just (fromBaikaiError be)) Nothing Nothing+        throwError (fromBaikaiError be)+      Right evs -> do+        liftIO (chargeBudgetFromEvents mb evs)+        let terminals = [tp | ev <- evs, tp <- case ev of EventDone t -> [t]; EventError t -> [t]; _ -> []]+            terminal = case terminals of t : _ -> Just t; [] -> Nothing+            usage = terminal >>= \t -> case t ^. #message of AssistantMessage p -> availableUsage (p ^. #usage); _ -> Nothing+            err = case [streamTerminalError t | EventError t <- evs] of e : _ -> Just e; [] -> Nothing+        emit m O.StreamCall start err usage (terminal >>= O.observedModelOf . (^. #evidence))+        raiseStreamError evs+  where+    emit m kind start err usage observed = liftIO $ do+      end <- getCurrentTime+      observer+        ( O.LLMObservation+            cid+            ordinal+            kind+            (m ^. #modelId)+            (m ^. #provider)+            observed+            (O.errorClass <$> err)+            (O.UsageRecord <$> usage)+            start+            end+        ) +-- Baikai represents thrown transport errors with the additive zero. It carries+-- no observation; a reported zero has availability/basis and is retained.+availableUsage :: U.Usage -> Maybe U.Usage+availableUsage u = if u == U.zeroUsage then Nothing else Just u+ -- --------------------------------------------------------------------------- -- Resilience: retries, rate limiting, budget -- ---------------------------------------------------------------------------@@ -182,7 +254,9 @@     -- | 'Nothing' = unbounded concurrency     rateLimit :: !(Maybe RateLimiter),     -- | which baikai registry to dispatch against-    registry :: !ProviderRegistry+    registry :: !ProviderRegistry,+    -- | Optional per-attempt accounting; never charges budgets itself.+    observer :: !(Maybe O.LLMObserver)   }  -- | A config with default retries, no budget, and no rate limit, dispatching@@ -193,40 +267,23 @@     { retryPolicy = defaultRetryPolicy,       budget = Nothing,       rateLimit = Nothing,-      registry = reg+      registry = reg,+      observer = Nothing     }  -- | The resilient interpreter. Each operation is wrapped, outermost to -- innermost, by: budget check → rate-limit acquire → retry loop → the @Baikai@--- transport call. The budget is reserved once before the attempts and charged--- once after success; retries re-run only the transport call.+-- transport call. Budget admission happens once before the attempts; each+-- response or stream terminal is charged before success or failure is raised. runLLMResilient ::   (IOE :> es, Concurrent :> es, Error ShikumiError :> es) =>   LLMConfig ->   Eff (LLM : es) a ->   Eff es a-runLLMResilient cfg = reinterpret_ (runBaikaiWith (registry cfg)) $ \case-  Complete m c o ->-    withBudget mb . withRateLimit mr . retrying rp $ do-      res <- try @BaikaiError (BE.complete m c o)-      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)-          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)-      raiseStreamError evs-  where-    mb = budget cfg-    mr = rateLimit cfg-    rp = retryPolicy cfg+runLLMResilient cfg = reinterpret_ (runBaikaiWith (registry cfg)) $ \op -> do+  cid <- liftIO freshCallId+  withBudget (budget cfg) . withRateLimit (rateLimit cfg) $+    retrying (retryPolicy cfg) (\ordinal -> transportAttempt (fromMaybe O.noObservation (observer cfg)) (budget cfg) cid ordinal op)  -- | Optimistic pre-call budget gate (admission, not reservation). Refuses the -- call with 'BudgetExceeded' when the recorded running total has already reached@@ -264,12 +321,12 @@ retrying ::   (Concurrent :> es, Error ShikumiError :> es) =>   RetryPolicy ->-  Eff es a ->+  (Int -> Eff es a) ->   Eff es a retrying pol act = go 1   where     go attempt =-      act `catchError` \_cs e ->+      act attempt `catchError` \_cs e ->         if isTransient e && attempt < maxAttempts pol           then do             threadDelay (backoffMicros pol attempt)@@ -292,18 +349,9 @@ 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'.+-- | Raise structured terminal failures through the same mapping as blocking+-- calls. Only malformed third-party terminals without errorInfo use the legacy+-- text fallback. Successful event lists pass through unchanged. raiseStreamError ::   (Error ShikumiError :> es) => [AssistantMessageEvent] -> Eff es [AssistantMessageEvent] raiseStreamError evs = case [tp | EventError tp <- evs] of@@ -316,7 +364,7 @@ -- '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+-- failures (a classified error thrown /inside/ the retry loop). A success -- passes through unchanged. raiseResponseError ::   (Error ShikumiError :> es) => Response -> Eff es Response@@ -326,7 +374,9 @@  -- | Map a terminal 'EventError' payload to a 'ShikumiError'. streamTerminalError :: TerminalPayload -> ShikumiError-streamTerminalError tp = ProviderFailure ("stream failed: " <> detail)+streamTerminalError tp = case tp ^. #errorInfo of+  Just err -> fromBaikaiError err+  Nothing -> ProviderFailure ("stream failed: " <> detail)   where     detail = case tp ^. #message of       AssistantMessage p -> fromMaybe (T.pack (show (tp ^. #reason))) (p ^. #errorMessage)

@@ -0,0 +1,115 @@+-- | Pure continuation checks shared by routing, memoization and transport.+-- Request identity is not provider attestation. No credentials are persisted.+module Shikumi.LLM.Continuation+  ( RequestOrigin,+    requestOrigin,+    originModel,+    opaqueThinking,+    hasOpaqueContinuation,+    contextIdentity,+    stampContinuation,+    validateRequestContinuation,+    stripContinuationMetadata,+    validateReplayOrigin,+  )+where++import Baikai qualified as B+import Control.Lens ((&), (.~), (^.))+import Control.Monad (unless)+import Data.Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.Aeson.Types (parseEither)+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import GHC.Generics (Generic)+import Shikumi.Error (ShikumiError (ValidationFailure))++data RequestOrigin = RequestOrigin+  { provider :: !Text,+    api :: !B.Api,+    model :: !Text,+    endpoint :: !Text+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (ToJSON, FromJSON)++-- | Endpoints containing query strings or userinfo may contain credentials.+-- Refuse to persist them; callers can restart with a credential-free endpoint.+requestOrigin :: B.Model -> Maybe RequestOrigin+requestOrigin m+  | any T.null [m ^. #provider, m ^. #modelId, m ^. #baseUrl] = Nothing+  | m ^. #api == B.Custom "" = Nothing+  | T.any (`elem` ("?@#" :: String)) (m ^. #baseUrl) = Nothing+  | otherwise = Just (RequestOrigin (m ^. #provider) (m ^. #api) (m ^. #modelId) (m ^. #baseUrl))++-- | Minimal explicit request identity. Credentials and compatibility settings+-- must be supplied by the caller's runtime/router, never by a checkpoint.+originModel :: RequestOrigin -> B.Model+originModel (RequestOrigin p a m e) = B.mkModel a m e & #provider .~ p++opaqueThinking :: B.ThinkingContent -> Bool+opaqueThinking t = isJust (t ^. #signature) || t ^. #redacted || isJust (t ^. #replayState)++hasOpaqueContinuation :: [B.Message] -> Bool+hasOpaqueContinuation = any (\case B.AssistantMessage p -> any block (p ^. #content); _ -> False)+  where+    block (B.AssistantThinking t) = opaqueThinking t+    block _ = False++-- | Exact ordered request projection; only message construction timestamps go.+contextIdentity :: B.Context -> Value+contextIdentity c = object ["system" .= (c ^. #systemPrompt), "tools" .= (c ^. #tools), "messages" .= map messageIdentity (V.toList (c ^. #messages))]+  where+    messageIdentity m = case toJSON m of+      Object fields -> Object (case KM.lookup "contents" fields of Just v -> KM.insert "contents" (dropTimestamp v) fields; Nothing -> fields)+      v -> v+    dropTimestamp (Object fields) = Object (KM.delete "timestamp" fields)+    dropTimestamp v = v++continuationKey :: Text+continuationKey = "shikumi.continuation.v1"++stampContinuation :: Maybe RequestOrigin -> Maybe Value -> B.Options -> B.Options+stampContinuation origin prefix o = o & #metadata .~ Map.insert continuationKey (object ["origin" .= origin, "prefix" .= prefix]) (o ^. #metadata)++stripContinuationMetadata :: B.Options -> B.Options+stripContinuationMetadata o = o & #metadata .~ Map.delete continuationKey (o ^. #metadata)++failure :: Text -> Either ShikumiError a+failure t = Left (ValidationFailure ("ReAct continuation: " <> t <> "; explicitly restart from a caller-approved summary"))++-- | Also check returned Responses replay before tools can execute. Aliases are+-- compared to replay scope, never to optional observed-provider model evidence.+validateReplayOrigin :: B.Model -> [B.Message] -> Either ShikumiError ()+validateReplayOrigin m msgs = mapM_ check [r | B.AssistantMessage p <- msgs, B.AssistantThinking t <- V.toList (p ^. #content), Just r <- [t ^. #replayState]]+  where+    check r = unless (r ^. #replayApi == m ^. #api && r ^. #replayModel == m ^. #modelId) (failure "replay API/model differs from resolved request")++validateRequestContinuation :: B.Model -> B.Context -> B.Options -> Either ShikumiError ()+validateRequestContinuation m c o = do+  let opaque = hasOpaqueContinuation (V.toList (c ^. #messages))+  case Map.lookup continuationKey (o ^. #metadata) of+    Nothing -> unless (not opaque) (failure "opaque history has no origin expectation")+    Just value -> case parseEither (withObject "continuation" (\v -> (,) <$> v .: "origin" <*> v .: "prefix")) value of+      Left _ -> failure "malformed expectation"+      Right (origin, prefix) -> do+        case origin of+          Just expected -> unless (requestOrigin m == Just expected) (failure "provider/API/model/endpoint changed or unresolved")+          Nothing -> unless (not opaque) (failure "opaque history has unknown request origin")+        case prefix of+          Nothing -> unless (not opaque) (failure "opaque history has no protected prefix")+          Just protected -> unless (prefixMatches protected (contextIdentity c)) (failure "protected system/tools/message prefix changed")+  validateReplayOrigin m (V.toList (c ^. #messages))+  where+    prefixMatches (Object old) (Object new) =+      KM.lookup "system" old == KM.lookup "system" new+        && KM.lookup "tools" old == KM.lookup "tools" new+        && case (KM.lookup "messages" old, KM.lookup "messages" new) of+          (Just (Array before), Just (Array after)) -> V.length before <= V.length after && before == V.take (V.length before) after+          _ -> False+    prefixMatches _ _ = False

@@ -0,0 +1,65 @@+-- | Invocation-scoped, fill-only defaults for every LLM operation.+-- Compose the base interpreter with cache/trace, then 'withRequestDefaults',+-- then routing. The rightmost wrapper sees the originating call first.+module Shikumi.LLM.Defaults+  ( RequestDefaults (..),+    emptyRequestDefaults,+    applyRequestDefaults,+    withRequestDefaults,+  )+where++import Baikai (Options)+import Baikai.Evidence (EvidenceRequest)+import Baikai.Speed (Speed)+import Baikai.ThinkingLevel (ThinkingLevel)+import Control.Applicative ((<|>))+import Control.Lens ((&), (.~), (^.))+import Control.Monad (when)+import Data.Generics.Labels ()+import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (interpose)+import Effectful.Error.Static (Error, throwError)+import Numeric.Natural (Natural)+import Shikumi.Error (ShikumiError (ValidationFailure))+import Shikumi.LLM (LLM (..), complete, stream)++-- | Only request preferences belong here. Models, schemas, tools, credentials,+-- temperatures and private continuation metadata remain owned by their callers.+-- Evidence is replaced as a whole; requested settings are not provider evidence.+data RequestDefaults = RequestDefaults+  { defaultThinking :: !(Maybe ThinkingLevel),+    defaultSpeed :: !(Maybe Speed),+    defaultMaxTokens :: !(Maybe Natural),+    defaultEvidence :: !(Maybe EvidenceRequest)+  }+  deriving stock (Eq, Show)++-- | No implicit reasoning, fast mode, token ceiling or evidence collection.+emptyRequestDefaults :: RequestDefaults+emptyRequestDefaults = RequestDefaults Nothing Nothing Nothing Nothing++-- | Fill absent options only. This pure merge does not validate token ceilings;+-- use 'withRequestDefaults' to reject a zero configured default before execution.+applyRequestDefaults :: RequestDefaults -> Options -> Options+applyRequestDefaults defaults opts =+  opts+    & #thinking .~ (opts ^. #thinking <|> defaultThinking defaults)+    & #speed .~ (opts ^. #speed <|> defaultSpeed defaults)+    & #maxTokens .~ (opts ^. #maxTokens <|> defaultMaxTokens defaults)+    & #evidence .~ (opts ^. #evidence <|> defaultEvidence defaults)++-- | Apply the same merge to blocking and streaming calls. Per-call values win;+-- the innermost default scope fills first and therefore wins over outer scopes.+-- A zero default ceiling is invalid even when a call supplies its own ceiling.+-- No mutable state is shared between invocations.+withRequestDefaults :: (LLM :> es, Error ShikumiError :> es) => RequestDefaults -> Eff es a -> Eff es a+withRequestDefaults defaults action = do+  when (defaultMaxTokens defaults == Just 0) $+    throwError (ValidationFailure "request defaults: defaultMaxTokens must be positive")+  interpose+    ( \_ -> \case+        Complete model ctx opts -> complete model ctx (applyRequestDefaults defaults opts)+        Stream model ctx opts -> stream model ctx (applyRequestDefaults defaults opts)+    )+    action

@@ -0,0 +1,180 @@+-- | Run-local transport billing. Observations contain identity and accounting,+-- never prompts, outputs, credentials, or provider error messages. Observer IO+-- exceptions propagate outside provider retry classification. Cancellation emits+-- no synthetic terminal. Create a separate collector for each run.+module Shikumi.LLM.Observation+  ( LLMObservation (..),+    CallKind (..),+    LLMObserver,+    noObservation,+    BillingSummary (..),+    emptyBillingSummary,+    newBillingCollector,+    newBillingCollectorWithLimit,+    renderBillingSummary,+    usageUnknown,+    observedModelOf,+    errorClass,+    UsageRecord (..),+  )+where++import Baikai.Cost qualified as C+import Baikai.Error qualified as BE+import Baikai.Evidence qualified as E+import Baikai.Usage qualified as U+import Data.Aeson+import Data.Aeson.Types (Parser)+import Data.ByteString.Lazy qualified as BL+import Data.IORef+import Data.Maybe (isNothing)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Time (UTCTime)+import GHC.Generics (Generic)+import Shikumi.Error (ShikumiError (..))++-- | A local wrapper avoids adding competing orphan decoders. The exact rational+-- cost is encoded separately from the canonical provider usage JSON.+newtype UsageRecord = UsageRecord {getUsage :: U.Usage}+  deriving stock (Eq, Show)++instance ToJSON UsageRecord where+  toJSON (UsageRecord u) = object ["usage" .= u, "exactCost" .= exactCost (U.cost u)]+    where+      exactCost c = let b = C.breakdown c in [C.usd c, C.inputUsd b, C.outputUsd b, C.cachedInputUsd b, C.cachedWriteUsd b]++instance FromJSON UsageRecord where+  parseJSON = withObject "UsageRecord" $ \o -> do+    v <- o .: "usage"+    ns <- o .: "exactCost" :: Parser [Rational]+    c <- case ns of+      [a, b, c, d, e] -> pure (C.Cost a (C.CostBreakdown b c d e) mempty)+      _ -> fail "exactCost must contain five rational amounts"+    withObject+      "Usage"+      ( \u -> do+          cv <- u .: "cost"+          basis <- withObject "Cost" (\x -> x .:? "basis" .!= mempty) cv+          UsageRecord+            <$> ( U.Usage+                    <$> u .: "input_tokens"+                    <*> u .: "output_tokens"+                    <*> u .: "cache_read_tokens"+                    <*> u .: "cache_write_tokens"+                    <*> u .:? "reasoning_tokens"+                    <*> u .: "total_tokens"+                    <*> u .:? "availability"+                    <*> pure c {C.basis = basis}+                )+      )+      v++data CallKind = CompletionCall | StreamCall+  deriving stock (Eq, Show, Generic)+  deriving anyclass (ToJSON, FromJSON)++-- | callId identifies a logical invocation within this process; attempt is+-- one-based within it. No structural node attribution is implied.+data LLMObservation = LLMObservation+  { callId :: !Text,+    attempt :: !Int,+    callKind :: !CallKind,+    requestedModel :: !Text,+    requestedProvider :: !Text,+    observedModel :: !(Maybe Text),+    terminalError :: !(Maybe Text),+    usage :: !(Maybe UsageRecord),+    startedAt :: !UTCTime,+    endedAt :: !UTCTime+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (ToJSON, FromJSON)++type LLMObserver = LLMObservation -> IO ()++noObservation :: LLMObserver+noObservation _ = pure ()++observedModelOf :: Maybe E.ModelCallEvidence -> Maybe Text+observedModelOf e = e >>= E.observedValue . E.observedModel++-- | Stable classification only: raw messages can include provider output.+errorClass :: ShikumiError -> Text+errorClass = \case+  ProviderError e -> T.pack (show (BE.category e))+  ProviderFailure _ -> "ProviderFailure"+  InvalidJSON _ -> "InvalidJSON"+  MissingField _ -> "MissingField"+  SchemaMismatch _ -> "SchemaMismatch"+  ValidationFailure _ -> "ValidationFailure"+  ContextWindowExceeded _ -> "ContextWindowExceeded"+  Timeout _ -> "Timeout"+  BudgetExceeded _ -> "BudgetExceeded"+  CodeExecFailed _ -> "CodeExecFailed"++-- | Unknown includes absent/legacy quality metadata and partially missing or+-- inconsistent counters. Available numeric components still contribute to sums.+usageUnknown :: Maybe UsageRecord -> Bool+usageUnknown Nothing = True+usageUnknown (Just (UsageRecord u)) = case U.availability u of+  Nothing -> True+  Just a -> not (Set.null (U.missingCategories a)) || U.inconsistent a++data BillingSummary = BillingSummary+  { completedAttempts :: !Int,+    failedAttempts :: !Int,+    unknownUsageAttempts :: !Int,+    observedUsage :: !UsageRecord,+    retainedAttempts :: ![LLMObservation],+    detailTruncated :: !Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (ToJSON, FromJSON)++emptyBillingSummary :: BillingSummary+emptyBillingSummary = BillingSummary 0 0 0 (UsageRecord mempty) [] False++-- | Aggregate only by default. Opt in to bounded detail with the other constructor.+newBillingCollector :: IO (LLMObserver, IO BillingSummary)+newBillingCollector = newBillingCollectorWithLimit 0++-- | Negative limits are treated as zero. Counts and sums continue after the+-- detail limit, using an atomic strict update safe for concurrent evaluations.+newBillingCollectorWithLimit :: Int -> IO (LLMObserver, IO BillingSummary)+newBillingCollectorWithLimit limit = do+  ref <- newIORef emptyBillingSummary+  let observe o = atomicModifyIORef' ref $ \s ->+        let n = completedAttempts s + failedAttempts s+            ok = isNothing (terminalError o)+            u = maybe mempty getUsage (usage o)+            totalUsage = getUsage (observedUsage s) <> u+            next =+              BillingSummary+                (completedAttempts s + if ok then 1 else 0)+                (failedAttempts s + if ok then 0 else 1)+                (unknownUsageAttempts s + if usageUnknown (usage o) then 1 else 0)+                (UsageRecord totalUsage)+                (if n < max 0 limit then o : retainedAttempts s else retainedAttempts s)+                (detailTruncated s || n >= max 0 limit)+         in next `seq` (next, ())+  pure (observe, (\s -> s {retainedAttempts = reverse (retainedAttempts s)}) <$> readIORef ref)++renderBillingSummary :: BillingSummary -> Text+renderBillingSummary s =+  "transport billing: completed="+    <> t (completedAttempts s)+    <> " failed="+    <> t (failedAttempts s)+    <> " unknown-usage="+    <> t (unknownUsageAttempts s)+    <> " observed-usd="+    <> t (C.usd (U.cost (getUsage (observedUsage s))))+    <> " detail-truncated="+    <> t (detailTruncated s)+    <> "\ntransport quality: "+    <> TE.decodeUtf8 (BL.toStrict (encode (observedUsage s)))+  where+    t :: (Show a) => a -> Text; t = T.pack . show

@@ -21,6 +21,7 @@ -- lives here. See the plan's Decision Log. module Shikumi.Module   ( predict,+    predictCaptured,     chainOfThought,     chainOfThoughtRaw,     twoStep,@@ -30,7 +31,7 @@  import Baikai (emptyContext, emptyModel, emptyOptions, user) import Control.Lens ((&), (.~))-import Data.Aeson (Object, Value (Object))+import Data.Aeson (Object, ToJSON (..), Value (Object)) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KM import Data.Generics.Labels ()@@ -43,8 +44,8 @@ import Shikumi.Adapter (Adapter (..), ToPrompt (..), fallbackAdapter, responseText) import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (complete)-import Shikumi.Program (Program (FMap, Predict), embed, emptyParams)-import Shikumi.Schema (FromModel (..), ToSchema (..), Validatable (..))+import Shikumi.Program (CaptureCodec (..), Program (FMap, Predict, PredictCaptured), embed, emptyParams)+import Shikumi.Schema (FromModel (..), ToSchema (..), Validatable (..), deriveSchema) import Shikumi.Schema.Types   ( FieldMeta (..),     FieldPath,@@ -64,6 +65,22 @@   Signature i o ->   Program i o predict sig = Predict sig emptyParams++-- | Opt in to typed observation and node-local demonstration recovery.+predictCaptured ::+  forall i o.+  ( FromModel i,+    FromModel o,+    ToSchema i,+    ToSchema o,+    ToJSON i,+    ToJSON o,+    Validatable o,+    ToPrompt i,+    ToPrompt o+  ) =>+  Signature i o -> Program i o+predictCaptured sig = PredictCaptured (CaptureCodec toJSON toJSON (deriveSchema @i) (deriveSchema @o)) sig emptyParams  -- --------------------------------------------------------------------------- -- Chain of thought

@@ -31,6 +31,7 @@   ( -- * The representation     Program       ( Predict,+        PredictCaptured,         Compose,         FMap,         Map,@@ -42,6 +43,7 @@         Ensemble,         Embed       ),+    CaptureCodec (..),     Params (..),     Demo (..),     emptyParams,@@ -186,7 +188,19 @@ -- 'Predict' captures the adapter/decode dictionaries existentially so that -- 'runProgram' can recover them by pattern-matching — this is what lets a program -- be rewritten as data while staying type-checked.+-- | Explicit wire encoders and schema evidence. Functions stay in the template;+-- parameter artifacts never serialize them.+data CaptureCodec i o = CaptureCodec+  { encodeCaptureInput :: i -> Value,+    encodeCaptureOutput :: o -> Value,+    captureInputSchema :: Value,+    captureOutputSchema :: Value+  }+ data Program i o where+  PredictCaptured ::+    (FromModel i, FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) =>+    CaptureCodec i o -> Signature i o -> Params -> Program i o   Predict ::     (FromModel i, FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) =>     Signature i o ->@@ -271,6 +285,7 @@   i ->   Eff es o runProgram (Predict sig ps) i = runPredict sig ps i+runProgram (PredictCaptured _ sig ps) i = runPredict sig ps i runProgram (Compose f g) i = runProgram f i >>= runProgram g runProgram (FMap k p) i = k <$> runProgram p i runProgram (Map _ p) xs = traverse (runProgram p) xs@@ -295,6 +310,7 @@   i ->   Eff es o runProgramConc (Predict sig ps) i = runPredict sig ps i+runProgramConc (PredictCaptured _ sig ps) i = runPredict sig ps i runProgramConc (Compose f g) i = runProgramConc f i >>= runProgramConc g runProgramConc (FMap k p) i = k <$> runProgramConc p i runProgramConc (Map w p) xs = pooledMapConcurrentlyN (max 1 w) (runProgramConc p) xs@@ -477,6 +493,7 @@ -- @lens@ @Traversal'@ laws; use it directly with @toListOf@/@over@/@set@. paramsTraversal :: (Applicative f) => (Params -> f Params) -> Program i o -> f (Program i o) paramsTraversal h (Predict sig ps) = Predict sig <$> h ps+paramsTraversal h (PredictCaptured codec sig ps) = PredictCaptured codec sig <$> h ps paramsTraversal h (Compose f g) = Compose <$> paramsTraversal h f <*> paramsTraversal h g paramsTraversal h (FMap k p) = FMap k <$> paramsTraversal h p paramsTraversal h (Map w p) = Map w <$> paramsTraversal h p@@ -513,6 +530,7 @@ nodeFieldsIndexed = go   where     go :: forall x y. Program x y -> [NodeFields]+    go (PredictCaptured _ sig ps) = go (Predict sig ps)     go (Predict sig _) =       [NodeFields (map fieldName (inputFields sig)) (map fieldName (outputFields sig))]     go (Compose a b) = go a ++ go b@@ -538,6 +556,7 @@   where     go :: forall x y. Program x y -> [Text]     go (Predict sig _) = [getInstruction sig]+    go (PredictCaptured _ sig _) = [getInstruction sig]     go (Compose a b) = go a ++ go b     go (FMap _ p) = go p     go (Map _ p) = go p@@ -562,6 +581,7 @@   where     go :: forall x y. Int -> Program x y -> (Program x y, Int)     go idx (Predict sig ps) = (Predict sig (if idx == n then f ps else ps), idx + 1)+    go idx (PredictCaptured codec sig ps) = (PredictCaptured codec sig (if idx == n then f ps else ps), idx + 1)     go idx (Compose a b) =       let (a', idx') = go idx a           (b', idx'') = go idx' b@@ -647,6 +667,7 @@ -- changes (parameters do not affect shape). programShape :: Program i o -> ProgramShape programShape (Predict sig _) = ShapePredict (sigLabel sig)+programShape (PredictCaptured _ sig _) = ShapePredict (sigLabel sig) programShape (Compose a b) = ShapeCompose (programShape a) (programShape b) programShape (FMap _ p) = ShapeFMap (programShape p) programShape (Map w p) = ShapeMap w (programShape p)@@ -682,7 +703,9 @@     n = length (foldParams prog)     go :: forall x y. [Params] -> Program x y -> (Program x y, [Params])     go (q : qs) (Predict sig _) = (Predict sig q, qs)+    go (q : qs) (PredictCaptured codec sig _) = (PredictCaptured codec sig q, qs)     go qs (Predict sig old) = (Predict sig old, qs) -- unreachable after the length guard+    go qs (PredictCaptured codec sig old) = (PredictCaptured codec sig old, qs) -- unreachable after the length guard     go qs (Compose a b) =       let (a', qs') = go qs a           (b', qs'') = go qs' b

@@ -20,7 +20,9 @@ -- @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.+-- before forwarding the call to the real @LLM@ interpreter beneath it. Continuation+-- expectations survive routing and are validated here, then again before cache+-- lookup and final transport; only the transport boundary removes them. -- -- Install order (mirroring @runTrace . runKeyedLLM . tracedLLM@): 'runRouting' is -- /outer/ of the real @LLM@ interpreter, which is /outer/ of 'routeLLM' (the@@ -54,6 +56,7 @@ import Data.Vector qualified as V import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (interpose, interpret, send)+import Effectful.Error.Static (Error, throwError) import Shikumi.Adapter   ( ModelCapability (..),     capabilityFor,@@ -62,7 +65,9 @@     metaResponseSchemaKey,     metaTemperatureKey,   )+import Shikumi.Error (ShikumiError) import Shikumi.LLM (LLM (..), complete, stream)+import Shikumi.LLM.Continuation (validateRequestContinuation)  -- | 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@@ -90,23 +95,25 @@ -- 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 :: (Routing :> es, LLM :> es, Error ShikumiError :> es) => Eff es a -> Eff es a routeLLM = interpose $ \_ -> \case   Complete _placeholder ctx opts -> do     m <- currentModel     let (ctx', opts') = translateForWire m ctx opts+    either throwError pure (validateRequestContinuation m ctx' opts')     complete m ctx' opts'   Stream _placeholder ctx opts -> do     m <- currentModel     let (ctx', opts') = translateForWire m ctx opts+    either throwError pure (validateRequestContinuation m ctx' opts')     stream m ctx' 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+-- @temperature@ when one was stamped, and strip the four rendering keys.+-- Continuation expectations remain available for later boundary checks. Fallback-capability models keep the -- marker 'Context' unchanged; non-'Predict' @Complete@ calls (no stamps) are never -- rewritten. translateForWire :: Model -> Context -> Options -> (Context, Options)

@@ -67,7 +67,7 @@ import Shikumi.LLM (LLM, stream) import Shikumi.Program   ( Params,-    Program (Compose, Embed, FMap, MajorityVote, Map, Parallel, Predict, Retry, RetryWhen, Validate),+    Program (Compose, Embed, FMap, MajorityVote, Map, Parallel, Predict, PredictCaptured, Retry, RetryWhen, Validate),     acceptOrReject,     effectiveSignature,     parseResponse,@@ -219,6 +219,7 @@   (StreamEvent -> Eff es ()) ->   Eff es o streamProgram prog i cb = case prog of+  PredictCaptured _ sig ps -> streamPredict sig ps i cb   Predict sig ps -> streamPredict sig ps i cb   Compose f g -> bracketNode cb $ do     b <- streamProgram f i cb

@@ -98,6 +98,8 @@     "AdapterSpec"     [ testCase "capabilityFor: Anthropic messages -> NativeSchema" $         capabilityFor anthropicModel @?= NativeSchema,+      testCase "capabilityFor: OpenAI Responses -> NativeSchema" $+        capabilityFor (emptyModel & #provider .~ "openai" & #api .~ OpenAIResponses) @?= NativeSchema,       testCase "capabilityFor: Custom (ollama) host -> PromptFallback" $         capabilityFor ollamaModel @?= PromptFallback,       testCase "fallback render: system prompt has the instruction and field markers" $ do

@@ -0,0 +1,93 @@+module ContinuationSpec (tests) where++import Baikai qualified as B+import Control.Lens ((&), (.~), (^.))+import Data.Aeson (Value (..))+import Data.Generics.Labels ()+import Data.IORef+import Data.Map.Strict qualified as Map+import Data.Vector qualified as V+import Effectful (runEff)+import Effectful.Concurrent (runConcurrent)+import Effectful.Error.Static (runErrorNoCallStack)+import Shikumi.Error (ShikumiError (..))+import Shikumi.LLM+import Shikumi.LLM.Continuation+import Shikumi.Routing (routeLLM, runRouting)+import Streamly.Data.Stream qualified as Stream+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit++model :: B.Model+model = B.mkModel (B.Custom "continuation-test") "model" "https://provider.example"++context :: B.Context+context = B.emptyContext & #systemPrompt .~ Just "system" & #messages .~ V.fromList [B.user "input", B.AssistantMessage (B.emptyResponse ^. #message & #content .~ V.singleton (B.AssistantThinking (B.ThinkingContent "" (Just "signature") False Nothing)))]++options :: B.Options+options = stampContinuation (requestOrigin model) (Just (contextIdentity context)) B.emptyOptions++tests :: TestTree+tests =+  testGroup+    "Continuation"+    [ testCase "ordered prefix permits only append and construction timestamp changes" $ do+        validateRequestContinuation model context options @?= Right ()+        let appended = context & #messages .~ (context ^. #messages <> V.singleton (B.user "next"))+        validateRequestContinuation model appended options @?= Right ()+        let timestamped = context & #messages .~ V.map (\case B.AssistantMessage p -> B.AssistantMessage (p & #timestamp .~ Just (read "2026-09-08 00:00:00 UTC")); x -> x) (context ^. #messages)+        validateRequestContinuation model timestamped options @?= Right ()+        mapM_+          (\c -> assertRejected (validateRequestContinuation model c options))+          [context & #systemPrompt .~ Just "different", context & #messages .~ V.reverse (context ^. #messages), context & #tools .~ V.singleton B.emptyTool],+      testCase "unknown and malformed expectations reject opaque history" $ do+        assertRejected (validateRequestContinuation model context B.emptyOptions)+        assertRejected (validateRequestContinuation model context (stampContinuation Nothing Nothing B.emptyOptions))+        assertRejected (validateRequestContinuation model context (B.emptyOptions & #metadata .~ Map.singleton "shikumi.continuation.v1" (String "bad"))),+      testCase "bare, resilient and routed calls reject changed targets before transport" $ do+        (reg, seen) <- recordingRegistry+        let changed = [model & #modelId .~ "other", model & #api .~ B.OpenAIResponses, model & #provider .~ "other", model & #baseUrl .~ "https://other.example"]+        mapM_+          ( \m -> do+              runEff (runErrorNoCallStack @ShikumiError (runLLMWith reg (complete m context options))) >>= assertRejected+              runEff (runErrorNoCallStack @ShikumiError (runLLMWith reg (stream m context options))) >>= assertRejected+              runEff (runErrorNoCallStack @ShikumiError (runConcurrent (runLLMResilient (defaultLLMConfig reg) (complete m context options)))) >>= assertRejected+              runEff (runErrorNoCallStack @ShikumiError (runConcurrent (runLLMResilient (defaultLLMConfig reg) (stream m context options)))) >>= assertRejected+              runEff (runErrorNoCallStack @ShikumiError (runRouting m (runLLMWith reg (routeLLM (complete B.emptyModel context options))))) >>= assertRejected+          )+          changed+        readIORef seen >>= (@?= []),+      testCase "compatible route preserves payload and strips only private continuation metadata" $ do+        (reg, seen) <- recordingRegistry+        let opts = options & #metadata .~ Map.insert "public" (String "value") (options ^. #metadata)+        result <- runEff . runErrorNoCallStack @ShikumiError . runRouting model . runLLMWith reg . routeLLM $ complete B.emptyModel context opts+        case result of Left e -> assertFailure (show e); Right _ -> pure ()+        readIORef seen >>= (@?= [(context, stripContinuationMetadata opts)]),+      testCase "Responses replay scope is cross-checked independently of expectation" $ do+        let replay = B.ThinkingReplay B.OpenAIResponses "other" V.empty+            msg = B.AssistantMessage (B.emptyResponse ^. #message & #content .~ V.singleton (B.AssistantThinking (B.ThinkingContent "" Nothing False (Just replay))))+        assertRejected (validateReplayOrigin model [msg]),+      testCase "credentials never enter request-origin records" $ do+        requestOrigin (model & #baseUrl .~ "https://user:secret@provider.example") @?= Nothing+        requestOrigin (model & #baseUrl .~ "https://provider.example?key=secret") @?= Nothing+    ]++assertRejected :: Either ShikumiError a -> Assertion+assertRejected (Left (ValidationFailure _)) = pure ()+assertRejected _ = assertFailure "expected local continuation validation failure"++recordingRegistry :: IO (B.ProviderRegistry, IORef [(B.Context, B.Options)])+recordingRegistry = do+  seen <- newIORef []+  reg <- B.newProviderRegistry+  B.registerApiProviderWith+    reg+    ( ( B.apiProviderWith+          (model ^. #api)+          (\_ c o -> Stream.concatEffect $ modifyIORef' seen (<> [(c, o)]) >> pure (Stream.fromList []))+          (\m c o -> modifyIORef' seen (<> [(c, o)]) >> pure (B.emptyResponse & #model .~ m))+      )+        { B.describeThinking = \_ _ -> B.noThinkingRequested+        }+    )+  pure (reg, seen)

@@ -8,6 +8,7 @@   ( ShikumiError (..),     fromBaikaiError,     isTransient,+    renderShikumiError,   ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=))@@ -16,14 +17,14 @@ tests =   testGroup     "ErrorSpec"-    [ testCase "maps providerError -> ProviderFailure" $-        fromBaikaiError (providerError "x") @?= ProviderFailure "x",+    [ testCase "maps providerError -> ProviderError" $+        fromBaikaiError (providerError "x") @?= ProviderError (providerError "x"),       testCase "maps decodeError -> InvalidJSON" $         fromBaikaiError (decodeError "y") @?= InvalidJSON "y",       testCase "maps invalidRequest -> SchemaMismatch" $         fromBaikaiError (invalidRequest "z") @?= SchemaMismatch "invalid request: z",-      testCase "maps processError -> ProviderFailure" $-        fromBaikaiError (processError 2 "boom") @?= ProviderFailure "process exited 2: boom",+      testCase "maps processError -> ProviderError" $+        fromBaikaiError (processError 2 "boom") @?= ProviderError (processError 2 "boom"),       testCase "maps ContextOverflow -> ContextWindowExceeded" $         fromBaikaiError           BaikaiError@@ -31,6 +32,7 @@               message = "context length exceeded",               httpStatus = Just 400,               retryAfterSeconds = Nothing,+              refusalCategory = Nothing,               exitCode = Nothing             }           @?= ContextWindowExceeded "context length exceeded",@@ -43,5 +45,28 @@         isTransient (InvalidJSON "") @?= False         isTransient (MissingField "") @?= False         isTransient (ValidationFailure "") @?= False-        isTransient (CodeExecFailed "") @?= False+        isTransient (CodeExecFailed "") @?= False,+      testGroup+        "released categories"+        [ testCase (show cat) $ do+            let e = (providerError "detail") {category = cat, httpStatus = Just 403, retryAfterSeconds = Just 7, exitCode = Just 2, refusalCategory = Just "future_policy"}+                expected = case cat of+                  DecodeFailure -> InvalidJSON "detail"+                  InvalidRequest -> SchemaMismatch "invalid request: detail"+                  ContextOverflow -> ContextWindowExceeded "detail"+                  _ -> ProviderError e+            fromBaikaiError e @?= expected+            isTransient expected @?= (cat `elem` [RateLimited, TransientError])+        | cat <- [AuthError, RateLimited, ContextOverflow, InvalidRequest, ContentFiltered, TransientError, DecodeFailure, ProcessFailure, ProviderUnavailable, OtherError]+        ],+      testGroup+        "refusal categories retained verbatim"+        [ testCase (show rc) $ do+            let e = (providerError "refused") {category = ContentFiltered, refusalCategory = rc}+            fromBaikaiError e @?= ProviderError e+        | rc <- [Nothing, Just "policy_example", Just "future_category"]+        ],+      testCase "readable structured error" $ do+        renderShikumiError (ProviderError (processError 2 "boom")) @?= "provider ProcessFailure (exit 2): boom"+        renderShikumiError (ProviderFailure "legacy") @?= "legacy"     ]

@@ -30,13 +30,13 @@             r <- complete stubModel stubContext stubOptions             pure (flattenAssistantText (flattenAssistantBlocks r))         res @?= Right "hello from stub",-      testCase "unregistered tag -> ProviderFailure" $ do+      testCase "unregistered tag -> ProviderError" $ do         reg <- newProviderRegistry -- empty registry: no handler for the stub tag         res <-           runEff . runErrorNoCallStack @ShikumiError . runLLMWith reg $ do             r <- complete stubModel stubContext stubOptions             pure (flattenAssistantText (flattenAssistantBlocks r))         case res of-          Left (ProviderFailure _) -> pure ()-          other -> assertFailure ("expected Left (ProviderFailure ...), got " <> show other)+          Left (ProviderError _) -> pure ()+          other -> assertFailure ("expected Left (ProviderError ...), got " <> show other)     ]

@@ -5,6 +5,7 @@ import AdapterSpec qualified import CombinatorSpec qualified import ConstraintSpec qualified+import ContinuationSpec qualified import EndToEndSpec qualified import ErrorSpec qualified import LLMSpec qualified@@ -16,7 +17,9 @@ import ProgramAcceptanceSpec qualified import ProgramSpec qualified import RefineSpec qualified+import RequestDefaultsSpec qualified import ResilienceSpec qualified+import ResponsesSpec qualified import RoutingSpec qualified import SchemaSpec qualified import SerializeSpec qualified@@ -32,7 +35,10 @@   defaultMain $     testGroup       "shikumi"-      [ ErrorSpec.tests,+      [ ResponsesSpec.tests,+        RequestDefaultsSpec.tests,+        ContinuationSpec.tests,+        ErrorSpec.tests,         SchemaSpec.tests,         SignatureSpec.tests,         AdapterSpec.tests,

@@ -6,7 +6,7 @@  import Control.Lens ((&), (.~)) import Data.Generics.Labels ()-import Data.IORef (newIORef)+import Data.IORef (newIORef, readIORef) import Effectful (runEff) import Effectful.Error.Static (runErrorNoCallStack) import ProgramFixtures@@ -14,12 +14,14 @@     Topic (..),     markerBody,     mkResponse,+    outlineResponse,+    runFullRecordingLLM,     runScriptedLLM,     topicToOutline,     topicToVerdict,   ) import Shikumi.Error (ShikumiError (..))-import Shikumi.Module (WithReasoning (..), chainOfThought, chainOfThoughtRaw, predict)+import Shikumi.Module (WithReasoning (..), chainOfThought, chainOfThoughtRaw, predict, predictCaptured) import Shikumi.Program (emptyParams, foldParams, mapParamsAt, runProgram) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=))@@ -28,7 +30,17 @@ tests =   testGroup     "ModuleSpec"-    [ testCase "predict builds a single default-parameter node" $+    [ testCase "captured prediction preserves requests and decoded output" $ do+        let run p = do+              replies <- newIORef [outlineResponse]+              requests <- newIORef []+              result <- runEff . runErrorNoCallStack @ShikumiError . runFullRecordingLLM requests replies $ runProgram p (Topic "haskell")+              sent <- readIORef requests+              pure (result, sent)+        ordinary <- run (predict topicToOutline)+        captured <- run (predictCaptured topicToOutline)+        captured @?= ordinary,+      testCase "predict builds a single default-parameter node" $         foldParams (predict topicToOutline) @?= [emptyParams],       testCase "chainOfThoughtRaw yields a WithReasoning value through the stub" $ do         ref <-

@@ -29,6 +29,7 @@     -- * Fake LLM interpreters     runScriptedLLM,     runRecordingLLM,+    runFullRecordingLLM,   ) where @@ -40,6 +41,7 @@     emptyTextContent,   ) import Control.Lens ((&), (.~), (^.))+import Data.Aeson (ToJSON) import Data.Generics.Labels () import Data.IORef (IORef, atomicModifyIORef', modifyIORef') import Data.Maybe (fromMaybe)@@ -61,6 +63,8 @@ newtype Topic = Topic {subject :: Text}   deriving stock (Generic, Show, Eq) +instance ToJSON Topic+ instance ToSchema Topic  instance FromModel Topic@@ -72,6 +76,8 @@ newtype Outline = Outline {points :: [Text]}   deriving stock (Generic, Show, Eq) +instance ToJSON Outline+ instance ToSchema Outline  instance FromModel Outline@@ -188,6 +194,14 @@ runRecordingLLM capture ref = interpret $ \_ -> \case   Complete _ ctx _ -> do     liftIO (modifyIORef' capture (++ [renderedPrompt ctx]))+    liftIO (pop ref)+  Stream _ _ _ -> pure []++-- | Capture every request component, including demos and routing metadata.+runFullRecordingLLM :: (IOE :> es) => IORef [Text] -> IORef [Response] -> Eff (LLM : es) a -> Eff es a+runFullRecordingLLM capture ref = interpret $ \_ -> \case+  Complete model ctx opts -> do+    liftIO (modifyIORef' capture (++ [T.pack (show (model, ctx, opts))]))     liftIO (pop ref)   Stream _ _ _ -> pure [] 

@@ -0,0 +1,108 @@+module RequestDefaultsSpec (tests) where++import Baikai (ToolChoice (..), emptyContext, emptyModel, emptyOptions, emptyResponse)+import Baikai.Evidence qualified as E+import Baikai.Speed (Speed (..))+import Baikai.ThinkingLevel (ThinkingLevel (..))+import Control.Concurrent (forkFinally, newEmptyMVar, putMVar, takeMVar)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson (Value (..))+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Map.Strict qualified as Map+import Effectful (liftIO, runEff)+import Effectful.Dispatch.Dynamic (interpret)+import Effectful.Error.Static (runErrorNoCallStack)+import Shikumi.Error (ShikumiError (..), isTransient)+import Shikumi.LLM (LLM (..), complete, stream)+import Shikumi.LLM.Defaults+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit++defaults :: RequestDefaults+defaults = RequestDefaults (Just ThinkingHigh) (Just SpeedFast) (Just 4096) (Just (E.evidenceRequest "default"))++tests :: TestTree+tests =+  testGroup+    "Request defaults"+    [ testCase "empty is identity and unrelated policy and metadata survive" $ do+        let opts =+              emptyOptions+                & #temperature .~ Just 0.7+                & #toolChoice .~ Just ToolChoiceAuto+                & #metadata .~ Map.fromList [("shikumi.continuation.v1", String "protected"), ("schema", Bool True)]+        applyRequestDefaults emptyRequestDefaults opts @?= opts+        let merged = applyRequestDefaults defaults opts+        merged ^. #temperature @?= opts ^. #temperature+        merged ^. #toolChoice @?= opts ^. #toolChoice+        merged ^. #metadata @?= opts ^. #metadata+        merged @?= (opts & #thinking .~ Just ThinkingHigh & #speed .~ Just SpeedFast & #maxTokens .~ Just 4096 & #evidence .~ defaultEvidence defaults),+      testCase "explicit fields and whole evidence object override every default" $ do+        let evidence = (E.evidenceRequest "explicit") {E.strictness = E.EvidenceRequired E.EvidenceFullyObserved, E.attempt = 3, E.supersedes = Just "previous"}+            opts = emptyOptions & #thinking .~ Just ThinkingLow & #speed .~ Just SpeedStandard & #maxTokens .~ Just 12 & #evidence .~ Just evidence+        applyRequestDefaults defaults opts @?= opts+        applyRequestDefaults defaults (applyRequestDefaults defaults emptyOptions) @?= applyRequestDefaults defaults emptyOptions,+      testCase "blocking and streaming use nearest scope and preserve explicit values" $ do+        ref <- newIORef []+        result <- runEff+          . runErrorNoCallStack @ShikumiError+          . interpret+            ( \_ -> \case+                Complete _ _ o -> liftIO (modifyIORef' ref (++ [o])) >> pure emptyResponse+                Stream _ _ o -> liftIO (modifyIORef' ref (++ [o])) >> pure []+            )+          . withRequestDefaults defaults+          $ do+            _ <- complete emptyModel emptyContext emptyOptions+            withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just SpeedStandard}) $ do+              _ <- stream emptyModel emptyContext emptyOptions+              _ <- complete emptyModel emptyContext (emptyOptions & #speed .~ Just SpeedFast)+              pure ()+        result @?= Right ()+        captured <- readIORef ref+        map (^. #speed) captured @?= [Just SpeedFast, Just SpeedStandard, Just SpeedFast]+        map (^. #thinking) captured @?= replicate 3 (Just ThinkingHigh)+        map (^. #evidence) captured @?= replicate 3 (defaultEvidence defaults),+      testCase "zero default ceiling rejects before either dispatch or action" $ do+        ref <- newIORef (0 :: Int)+        result <- runEff+          . runErrorNoCallStack @ShikumiError+          . interpret+            ( \_ -> \case+                Complete {} -> liftIO (modifyIORef' ref (+ 1)) >> pure emptyResponse+                Stream {} -> liftIO (modifyIORef' ref (+ 1)) >> pure []+            )+          . withRequestDefaults (defaults {defaultMaxTokens = Just 0})+          $ do+            liftIO (modifyIORef' ref (+ 1))+            _ <- complete emptyModel emptyContext (emptyOptions & #maxTokens .~ Just 12)+            pure ()+        result @?= Left (ValidationFailure "request defaults: defaultMaxTokens must be positive")+        readIORef ref >>= (@?= 0)+        isTransient (ValidationFailure "invalid configuration") @?= False,+      testCase "concurrent invocations retain independent settings" $ do+        let run :: Speed -> IO [Maybe Speed]+            run speed = do+              ref <- newIORef []+              r <- runEff+                . runErrorNoCallStack @ShikumiError+                . interpret+                  ( \_ -> \case+                      Complete _ _ o -> liftIO (modifyIORef' ref (++ [o ^. #speed])) >> pure emptyResponse+                      Stream _ _ o -> liftIO (modifyIORef' ref (++ [o ^. #speed])) >> pure []+                  )+                . withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just speed})+                $ do+                  _ <- complete emptyModel emptyContext emptyOptions+                  _ <- stream emptyModel emptyContext emptyOptions+                  pure ()+              r @?= Right ()+              readIORef ref+        a <- newEmptyMVar+        b <- newEmptyMVar+        _ <- forkFinally (run SpeedFast) (putMVar a)+        _ <- forkFinally (run SpeedStandard) (putMVar b)+        takeMVar a >>= either (assertFailure . show) (@?= replicate 2 (Just SpeedFast))+        takeMVar b >>= either (assertFailure . show) (@?= replicate 2 (Just SpeedStandard))+    ]

@@ -5,16 +5,20 @@ module ResilienceSpec (tests) where  import Baikai (AssistantMessageEvent (..), flattenAssistantBlocks)+import Baikai.Error (BaikaiError (..), ErrorCategory (..), providerError) import Control.Concurrent (forkIO) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.STM (newTVarIO, readTVarIO)+import Control.Exception (AsyncException (ThreadKilled), throwIO, try)+import Control.Lens ((^.))+import Data.Aeson (eitherDecode, encode) import Data.IORef (newIORef, readIORef) 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.Error (ShikumiError (..), fromBaikaiError) import Shikumi.LLM   ( LLMConfig (..),     RetryPolicy (..),@@ -25,15 +29,19 @@     stream,   ) import Shikumi.LLM.Budget (newBudget, spentUSD)+import Shikumi.LLM.Observation qualified as O import StubProvider   ( budgetBarrierStubRegistry,+    classifiedStubRegistry,     concurrencyStubRegistry,     costStubRegistry,+    exceptionStubRegistry,     failingStreamCostStubRegistry,     failingStreamStubRegistry,     failingStubRegistry,     flattenAssistantText,     invalidStubRegistry,+    retryStreamCostStubRegistry,     stubContext,     stubModel,     stubOptions,@@ -45,8 +53,61 @@ tests =   testGroup     "ResilienceSpec"-    [ testCase "retry recovers after 2 failures" $ do+    [ testCase "EP-61: retry emits two correlated attempts and retains failure cost" $ do+        (observe, snapshot) <- O.newBillingCollectorWithLimit 10         ref <- newIORef 0+        reg <- retryStreamCostStubRegistry ref 1 (1 % 3) "ok"+        let cfg = (defaultLLMConfig reg) {observer = Just observe, retryPolicy = RetryPolicy 2 0 0}+        result <-+          runEff . runConcurrent . runErrorNoCallStack @ShikumiError . runLLMResilient cfg $+            stream stubModel stubContext stubOptions+        assertBool "retry succeeded" (either (const False) (const True) result)+        summary <- snapshot+        O.completedAttempts summary @?= 1+        O.failedAttempts summary @?= 1+        (O.getUsage (O.observedUsage summary) ^. #cost . #usd) @?= (1 % 3)+        map O.attempt (O.retainedAttempts summary) @?= [1, 2]+        case O.retainedAttempts summary of+          [a, b] -> O.callId a @?= O.callId b+          _ -> assertFailure "expected two attempts"+        eitherDecode (encode summary) @?= Right summary,+      testCase "EP-61: thrown transport failure has no invented usage" $ do+        ref <- newIORef 0+        reg <- failingStubRegistry ref 1 "ok"+        (observe, snapshot) <- O.newBillingCollectorWithLimit 2+        _ <- runText ((defaultLLMConfig reg) {observer = Just observe, retryPolicy = RetryPolicy 2 0 0})+        summary <- snapshot+        case O.retainedAttempts summary of+          first : _ -> O.usage first @?= Nothing+          [] -> assertFailure "no attempt observed",+      testCase "EP-61: bounded collector keeps exact totals after detail truncation" $ do+        (observe, snapshot) <- O.newBillingCollectorWithLimit 1+        reg <- costStubRegistry (1 % 3) "ok"+        let cfg = (defaultLLMConfig reg) {observer = Just observe}+        _ <- runText cfg+        _ <- runText cfg+        summary <- snapshot+        O.completedAttempts summary @?= 2+        O.unknownUsageAttempts summary @?= 2+        length (O.retainedAttempts summary) @?= 1+        O.detailTruncated summary @?= True+        (O.getUsage (O.observedUsage summary) ^. #cost . #usd) @?= (2 % 3),+      testCase "EP-61: callback BaikaiError propagates without another transport attempt" $ do+        ref <- newIORef 0+        reg <- failingStubRegistry ref 0 "ok"+        let err = (providerError "observer failed") {category = TransientError}+            cfg = (defaultLLMConfig reg) {observer = Just (\_ -> throwIO err)}+        result <- try @BaikaiError (runText cfg)+        result @?= Left err+        readIORef ref >>= (@?= 1),+      testCase "EP-61: cancellation emits no synthetic success" $ do+        (observe, snapshot) <- O.newBillingCollector+        reg <- exceptionStubRegistry (throwIO ThreadKilled)+        result <- try @AsyncException (runText ((defaultLLMConfig reg) {observer = Just observe}))+        result @?= Left ThreadKilled+        snapshot >>= (@?= O.emptyBillingSummary),+      testCase "retry recovers after 2 failures" $ do+        ref <- newIORef 0         reg <- failingStubRegistry ref 2 "ok"         let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5}         res <- runText cfg@@ -59,7 +120,7 @@         let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 2 1 5}         res <- runText cfg         case res of-          Left (ProviderFailure _) -> pure ()+          Left (ProviderError _) -> pure ()           other -> assertFailure ("expected Left (ProviderFailure ...), got " <> show other)         n <- readIORef ref         n @?= 2,@@ -156,7 +217,29 @@         res2 <- runStream cfg         case res2 of           Left (BudgetExceeded _) -> pure ()-          other -> assertFailure ("expected Left (BudgetExceeded ...) after the failed call charged, got " <> show other)+          other -> assertFailure ("expected Left (BudgetExceeded ...) after the failed call charged, got " <> show other),+      testGroup+        "classified attempts across APIs"+        [ testCase (show (cat, streaming, thrown)) $ do+            ref <- newIORef 0+            let err = (providerError "refused") {category = cat, refusalCategory = Just "policy_example"}+                retryable = cat `elem` [RateLimited, TransientError]+                cost = 1 % 100+            reg <- classifiedStubRegistry ref 1 err thrown cost+            b <- newBudget Nothing+            let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5, budget = Just b}+            result <- if streaming then fmap (fmap (const "ok")) (runStream cfg) else runText cfg+            result @?= if retryable then Right "ok" else Left (fromBaikaiError err)+            readIORef ref >>= (@?= if retryable then 2 else 1)+            spentUSD b >>= (@?= if thrown then 0 else cost)+        | cat <- [AuthError, RateLimited, ContentFiltered, TransientError, ProviderUnavailable, ProcessFailure, OtherError, InvalidRequest, ContextOverflow, DecodeFailure],+          (streaming, thrown) <- [(False, False), (False, True), (True, False)]+        ],+      testCase "cancellation escapes without retry" $ do+        reg <- exceptionStubRegistry (throwIO ThreadKilled)+        let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5}+        result <- try @AsyncException (runText cfg)+        result @?= Left ThreadKilled     ]   where     runText cfg =

@@ -0,0 +1,45 @@+module ResponsesSpec (tests) where++import Baikai qualified as B+import Control.Lens ((&), (.~), (^.))+import Data.Aeson (Value (..), object, (.=))+import Data.Generics.Labels ()+import Data.IORef+import Effectful (liftIO, runEff)+import Effectful.Dispatch.Dynamic (interpret)+import Effectful.Error.Static (runErrorNoCallStack)+import Shikumi.Adapter (ModelCapability (..), attachSchema, capabilityFor)+import Shikumi.Error (ShikumiError)+import Shikumi.LLM qualified as L+import Shikumi.Routing (routeLLM, runRouting)+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests = testCase "Responses routes strict native schemas for both operations" $ do+  let model = B.mkModel B.OpenAIResponses "fixture" "https://example.invalid" & #provider .~ "openai"+      schema = object ["type" .= String "object", "properties" .= object []]+  case capabilityFor model of NativeSchema -> pure (); _ -> assertFailure "Responses must be native"+  seen <- newIORef []+  result <- runEff+    . runErrorNoCallStack @ShikumiError+    . runRouting model+    . interpret+      ( \_ -> \case+          L.Complete m _ o -> liftIO (modifyIORef' seen (<> [(m, o)])) >> pure B.emptyResponse+          L.Stream m _ o -> liftIO (modifyIORef' seen (<> [(m, o)])) >> pure []+      )+    . routeLLM+    $ do+      _ <- L.complete B.emptyModel B.emptyContext (attachSchema schema B.emptyOptions)+      _ <- L.stream B.emptyModel B.emptyContext (attachSchema schema B.emptyOptions)+      pure ()+  result @?= Right ()+  recorded <- readIORef seen+  length recorded @?= 2+  mapM_+    ( \(m, o) -> do+        m ^. #api @?= B.OpenAIResponses+        o ^. #responseFormat @?= Just (B.JsonSchema (B.jsonSchemaFormat "output" schema & #strict .~ True))+    )+    recorded

@@ -25,6 +25,7 @@     jsonSchemaFormat,   ) import Baikai.Models.Generated (openai_gpt_4o_mini)+import Baikai.Speed (Speed (..)) import Control.Lens ((^.)) import Data.Aeson (Value (..), eitherDecodeStrict, object, (.=)) import Data.Aeson.KeyMap qualified as KM@@ -47,6 +48,7 @@ import Shikumi.Combinator (majorityVote, majorityVoteBy) import Shikumi.Error (ShikumiError) import Shikumi.LLM (LLM (..), Response)+import Shikumi.LLM.Defaults import Shikumi.Module (predict) import Shikumi.Program   ( Demo (..),@@ -112,10 +114,13 @@       . runErrorNoCallStack @ShikumiError       . runRouting model       . runCapturingLLM ref outlineResponse+      . withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just SpeedFast})       . routeLLM       $ runProgram prog input   assertBool "routed program decodes without error" (isRight res)-  readIORef ref+  captured <- readIORef ref+  map (\(_, _, o) -> o ^. #speed) captured @?= replicate (length captured) (Just SpeedFast)+  pure captured  -- | As 'captureRouted' but under the concurrent executor. captureRoutedConc :: Model -> Program Topic Outline -> Topic -> IO [(Model, Context, Options)]@@ -127,10 +132,13 @@       . runConcurrent       . runRouting model       . runCapturingLLM ref outlineResponse+      . withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just SpeedFast})       . routeLLM       $ runProgramConc prog input   assertBool "routed program decodes without error" (isRight res)-  readIORef ref+  captured <- readIORef ref+  map (\(_, _, o) -> o ^. #speed) captured @?= replicate (length captured) (Just SpeedFast)+  pure captured  isRight :: Either a b -> Bool isRight = either (const False) (const True)@@ -259,12 +267,14 @@         . runErrorNoCallStack @ShikumiError         . runRouting openai_gpt_4o_mini         . runCapturingLLM ref outlineResponse+        . withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just SpeedFast})         . 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+        o ^. #speed @?= Just SpeedFast         m ^. #modelId @?= openai_gpt_4o_mini ^. #modelId         o ^. #responseFormat           @?= Just (JsonSchema ((jsonSchemaFormat "output" (deriveSchema @Outline)) {strict = True}))

@@ -17,8 +17,11 @@     failingStubRegistry,     failingStreamStubRegistry,     failingStreamCostStubRegistry,+    retryStreamCostStubRegistry,     invalidStubRegistry,     concurrencyStubRegistry,+    classifiedStubRegistry,+    exceptionStubRegistry,   ) where @@ -152,7 +155,7 @@       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+-- | A registry whose @complete@ throws a typed transient failure the -- first @failTimes@ calls, then returns the given text. The 'IORef' records the -- total number of attempts (used by the retry tests). failingStubRegistry :: IORef Int -> Int -> Text -> IO ProviderRegistry@@ -160,7 +163,7 @@   mkRegistry t $ \_ _ _ -> do     n <- atomicModifyIORef' ref (\k -> (k + 1, k + 1))     if n <= failTimes-      then throwIO (providerError ("stub transient failure #" <> T.pack (show n)))+      then throwIO ((providerError ("stub transient failure #" <> T.pack (show n))) {category = TransientError})       else pure (stubResponse t)  -- | A terminal-failing event sequence: an 'EventError' whose assembled message@@ -206,6 +209,27 @@       }   pure reg +retryStreamCostStubRegistry :: IORef Int -> Int -> Rational -> Text -> IO ProviderRegistry+retryStreamCostStubRegistry ref failTimes cost t = do+  reg <- newProviderRegistry+  registerApiProviderWith+    reg+    ( apiProviderWith+        stubApi+        ( \_ _ _ -> Stream.concatEffect $ do+            n <- atomicModifyIORef' ref (\k -> (k + 1, k + 1))+            pure $+              Stream.fromList $+                if n <= failTimes+                  then streamErrorEvents cost ("stub stream failure #" <> T.pack (show n))+                  else stubEvents t+        )+        (\_ _ _ -> pure (stubResponse t))+    )+      { describeThinking = stubDescribeThinking+      }+  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.@@ -245,3 +269,36 @@       c <- readTVar cur       modifyTVar' mx (max c)     leave = atomically (modifyTVar' cur (subtract 1))++-- | Exercise in-band, thrown, and streamed classified failures with attempt costs.+classifiedStubRegistry :: IORef Int -> Int -> BaikaiError -> Bool -> Rational -> IO ProviderRegistry+classifiedStubRegistry ref failTimes err thrown cost = do+  let next = atomicModifyIORef' ref (\n -> (n + 1, n < failTimes))+      payload = stubPayloadWith "partial" & #usage . #cost . #usd .~ cost & #errorMessage .~ Just "legacy text disagrees" & #stopReason .~ ErrorReason+      response = stubResponse "partial" & #message .~ payload & #errorInfo .~ Just err+  reg <- newProviderRegistry+  registerApiProviderWith+    reg+    ( apiProviderWith+        stubApi+        ( \_ _ _ -> Stream.concatEffect $ do+            failed <- next+            pure+              ( Stream.fromList+                  ( if failed+                      then [EventStart (StartPayload (AssistantMessage (stubPayloadWith "")) Nothing), EventError (errorTerminal Nothing Nothing ErrorReason (AssistantMessage payload) err)]+                      else stubEvents "ok"+                  )+              )+        )+        ( \_ _ _ -> do+            failed <- next+            if failed then if thrown then throwIO err else pure response else pure (stubResponse "ok")+        )+    )+      { describeThinking = stubDescribeThinking+      }+  pure reg++exceptionStubRegistry :: IO Response -> IO ProviderRegistry+exceptionStubRegistry action = mkRegistry "" (\_ _ _ -> action)

@@ -11,6 +11,7 @@     emptyResponse,     emptyTextContent,   )+import Baikai.Error (contentFiltered) import Control.Lens ((&), (.~)) import Data.Generics.Labels () import Data.IORef (newIORef, readIORef)@@ -18,14 +19,18 @@ import Data.Text qualified as T import Data.Vector qualified as V import Effectful (runEff)+import Effectful.Concurrent (runConcurrent) import Effectful.Error.Static (runErrorNoCallStack) import Fixtures (Article, Author (..), Sentiment (..), Summary (..), sampleArticle, sampleSummary) import ProgramFixtures (runScriptedLLM)-import Shikumi.Error (ShikumiError)+import Shikumi.Error (ShikumiError (..))+import Shikumi.LLM (LLMConfig (..), RetryPolicy (..), defaultLLMConfig, runLLMResilient) import Shikumi.Module (twoStep) import Shikumi.Program (Program, runProgram)+import Shikumi.Routing (routeLLM, runRouting) import Shikumi.Schema.Types (field) import Shikumi.Signature (Demo (..), Signature, mkSignature, setDemos)+import StubProvider (classifiedStubRegistry, stubModel) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -93,5 +98,13 @@           runEff . runErrorNoCallStack @ShikumiError . runScriptedLLM ref $             runProgram prog sampleArticle         remaining <- readIORef ref-        length remaining @?= 0+        length remaining @?= 0,+      testCase "refusal prevents the extraction call" $ do+        ref <- newIORef 0+        let err = contentFiltered "refused"+        reg <- classifiedStubRegistry ref 1 err False 0+        let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5}+        out <- runEff . runConcurrent . runErrorNoCallStack @ShikumiError . runRouting stubModel . runLLMResilient cfg . routeLLM $ runProgram prog sampleArticle+        out @?= Left (ProviderError err)+        readIORef ref >>= (@?= 1)     ]

@@ -1,28 +1,32 @@--- | EP-26 M1: 'Shikumi.Adapter.xmlAdapter'. A third wire format on the typed seam.--- @render@ asks for @<field>…</field>@ tags; @parse@ reads them back into the--- typed output via the same 'sectionsToObject' + decode path the fallback adapter--- uses, so a missing tag yields the same located 'MissingField'.+{-# LANGUAGE DataKinds #-}+ module XmlAdapterSpec (tests) where  import Baikai   ( AssistantContent (..),+    Context,+    Message (..),     Response,+    TextContent (..),     emptyResponse,     emptyTextContent,   ) import Control.Lens ((&), (.~), (^.))+import Data.Aeson (ToJSON, object, (.=)) import Data.Generics.Labels () import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Vector qualified as V import Fixtures (Article, Author (..), Sentiment (..), Summary (..), sampleArticle, sampleSummary)-import Shikumi.Adapter (Adapter (..), xmlAdapter)+import GHC.Generics (Generic)+import Shikumi.Adapter (Adapter (..), ToPrompt, nestedXmlAdapter, xmlAdapter) import Shikumi.Error (ShikumiError (..))-import Shikumi.Schema.Types (field)+import Shikumi.Schema (FromModel, ToSchema (..), Validatable)+import Shikumi.Schema.Types (Constrained, Constraint (..), field) import Shikumi.Signature (Demo (..), Signature, mkSignature, setDemos) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))  sig :: Signature Article Summary sig = setDemos [Demo sampleArticle sampleSummary] (mkSignature "Summarize the article")@@ -90,7 +94,8 @@ tests =   testGroup     "XmlAdapterSpec"-    [ testCase "xml render: system prompt has the instruction and an XML tag" $ do+    [ nestedTests,+      testCase "xml render: system prompt has the instruction and an XML tag" $ do         T.isInfixOf "Summarize the article" (sysOf xmlAdapter) @?= True         T.isInfixOf "<headline>" (sysOf xmlAdapter) @?= True,       testCase "xml parse: tagged body decodes to the expected Summary" $@@ -98,3 +103,148 @@       testCase "xml parse: a missing tag -> MissingField (located)" $         parse xmlAdapter sig (mkResponse xmlBodyNoBullets) @?= Left (MissingField "bullets")     ]++-- Separate fixtures keep the richer codec independent of ToPrompt flattening.+data Person = Person {label :: Text, count :: Int}+  deriving stock (Generic, Show, Eq)+  deriving anyclass (ToJSON, ToSchema, FromModel)++newtype Meta = Meta {optional :: Maybe Text}+  deriving stock (Generic, Show, Eq)+  deriving anyclass (ToJSON, ToSchema, FromModel)++data Envelope = Envelope+  { people :: [Person],+    matrix :: [[Int]],+    metadata :: Meta,+    literal :: Text,+    maybeText :: Maybe Text,+    flag :: Bool,+    ratio :: Double+  }+  deriving stock (Generic, Show, Eq)+  deriving anyclass (ToJSON, ToSchema, FromModel, Validatable)++newtype Limited = Limited {value :: Constrained '[ 'MinLen 3] Text}+  deriving stock (Generic, Show, Eq)+  deriving anyclass (ToPrompt, ToSchema, FromModel, Validatable)++-- A hand-written union is outside the generated-schema subset and uses JSON.+newtype Manual = Manual {manual :: Text}+  deriving stock (Generic, Show, Eq)+  deriving anyclass (ToJSON, FromModel, Validatable)++instance ToSchema Manual where+  toSchema _ = object ["type" .= ("object" :: Text), "properties" .= object ["manual" .= object ["anyOf" .= [object ["type" .= ("string" :: Text)], object ["type" .= ("integer" :: Text)]]]]]++envelopeSig :: Signature Article Envelope+envelopeSig = mkSignature "Encode all nested fields"++example :: Envelope+example = Envelope [Person "Ada & </author>" 2, Person "Lin" 3] [[1, 2], [], [3]] (Meta Nothing) "null" (Just "null") True 1.25++assistantBodies :: Context -> [Text]+assistantBodies ctx = [T.concat [t | AssistantText (TextContent t) <- V.toList (p ^. #content)] | AssistantMessage p <- V.toList (ctx ^. #messages)]++rendered :: Envelope -> [Text]+rendered value = assistantBodies (fst (render nestedXmlAdapter (setDemos [Demo sampleArticle value] envelopeSig) sampleArticle))++decodeEnvelope :: Text -> Either ShikumiError Envelope+decodeEnvelope = parse nestedXmlAdapter envelopeSig . mkResponse++nestedBody :: Text+nestedBody = T.replace "{\"name\": \"Ada\"}" "<name>Ada</name>" $ T.replace "[\"records in\", \"records out\", \"errors are typed\"]" "<item>records in</item><item>records out</item><item>errors are typed</item>" xmlBody++nestedTests :: TestTree+nestedTests =+  testGroup+    "nested codec"+    [ testCase "nested record and list agree with legacy JSON containers" $+        parse xmlAdapter sig (mkResponse nestedBody) @?= Right expectedSummary,+      testCase "same-name nesting balances and unknown properties are ignored" $+        parse xmlAdapter sig (mkResponse (T.replace "<author>" "<author><author/>" nestedBody)) @?= Right expectedSummary,+      testCase "first complete duplicate wins, unknown top-level ignored, prose allowed" $+        parse xmlAdapter sig (mkResponse ("Here is the answer & details. <unknown/>" <> nestedBody <> "<headline>wrong</headline>")) @?= Right expectedSummary,+      testCase "nested occurrence cannot satisfy missing outer field" $+        parse xmlAdapter sig (mkResponse (T.replace "<author>" "<author><bullets/>" (T.replace "{\"name\": \"Ada\"}" "<name>Ada</name>" xmlBodyNoBullets))) @?= Left (MissingField "bullets"),+      testCase "missing nested field retains path" $+        parse xmlAdapter sig (mkResponse (T.replace "<name>Ada</name>" "" nestedBody)) @?= Left (MissingField "author.name"),+      testCase "record validation still executes" $+        parse xmlAdapter sig (mkResponse (T.replace "<item>records in</item>" "" nestedBody)) @?= Left (ValidationFailure "bullets: must have 3 to 5 items"),+      testCase "declared field constraints execute" $+        parse xmlAdapter (mkSignature "Validate" :: Signature Article Limited) (mkResponse "<value>x</value>") @?= Left (ValidationFailure "value: minLength 3 violated"),+      testCase "nested demos round-trip records, matrices, null strings and numeric/boolean scalars" $+        mapM_+          ( \v -> case rendered v of+              [body] -> decodeEnvelope body @?= Right v+              bodies -> assertFailure (show bodies)+          )+          [example, example {people = [], matrix = [], literal = "", maybeText = Nothing, flag = False, ratio = -2.5}, example {literal = "a ]]> b & <tag>  c\nd", maybeText = Just ""}],+      testCase "manual union schemas use escaped JSON fallback" $ do+        let manualSig = setDemos [Demo sampleArticle (Manual "a < b")] (mkSignature "Manual")+            ctx = fst (render nestedXmlAdapter manualSig sampleArticle)+        assistantBodies ctx @?= ["<manual>\"a &lt; b\"</manual>\n"]+        map (parse nestedXmlAdapter manualSig . mkResponse) (assistantBodies ctx) @?= [Right (Manual "a < b")],+      testCase "renderer preserves top-level order and distinguishes null spellings" $+        case rendered example of+          [body] -> do+            T.isPrefixOf "<people>" body @?= True+            T.isInfixOf "<literal>null</literal>" body @?= True+            T.isInfixOf "<maybeText><![CDATA[null]]></maybeText>" body @?= True+            T.isInfixOf "<item><count>2</count><label>" body @?= True+          bodies -> assertFailure (show bodies),+      testCase "guide contains nested fields and repeated items" $ do+        let guide = fromMaybe "" (fst (render nestedXmlAdapter envelopeSig sampleArticle) ^. #systemPrompt)+        T.isInfixOf "<people><item><count>" guide @?= True+        T.isInfixOf "<![CDATA[null]]>" guide @?= True,+      testCase "nullable omission, self-closing empty object, comments and entities" $+        decodeEnvelope "<people/><matrix/><metadata/><!-- ok --><literal>&amp;&lt;&gt;&quot;&apos;&#65;&#x1F600;</literal><flag>false</flag><ratio>2</ratio>"+          @?= Right (Envelope [] [] (Meta Nothing) "&<>\"'A😀" Nothing False 2),+      testCase "CDATA stays literal and preserves inner whitespace" $+        decodeEnvelope "<people/><matrix/><metadata/><literal><![CDATA[a < b  & c]]></literal><maybeText><![CDATA[null]]></maybeText><flag>true</flag><ratio>1</ratio>"+          @?= Right (Envelope [] [] (Meta Nothing) "a < b  & c" (Just "null") True 1),+      testCase "nested scalar errors carry record and array indices" $ do+        let prefix = "<people><item><label>Ada</label><count>wrong</count></item></people>"+        decodeEnvelope prefix @?= Left (SchemaMismatch "people.[0].count: expected integer, got string")+        decodeEnvelope "<people/><matrix><item><item>1</item><item>wrong</item></item></matrix>" @?= Left (SchemaMismatch "matrix.[0].[1]: expected integer, got string"),+      testCase "depth 64 accepted; 65 rejected" $ do+        parse xmlAdapter sig (mkResponse (T.replicate 64 "<x>" <> T.replicate 64 "</x>" <> nestedBody)) @?= Right expectedSummary+        xmlFailure "depth limit 64" (T.replicate 65 "<x>" <> T.replicate 65 "</x>"),+      testCase "size limit counts Unicode code points" $ do+        let body = nestedBody <> T.replicate (1048576 - T.length nestedBody) "😀"+        parse xmlAdapter sig (mkResponse body) @?= Right expectedSummary+        xmlFailure "input length limit 1048576" (body <> "😀"),+      testGroup+        "malformed fragments fail with located XML errors"+        [ testCase (T.unpack bad) (xmlFailure "" bad)+        | bad <-+            [ "<author><name>Ada</author></name>",+              "<headline>unfinished",+              "<x/",+              "</x>",+              "<!DOCTYPE x>",+              "<?xml version='1.0'?>",+              "<x a='b'/>",+              "<ns:x/>",+              "<x>&bogus;</x>",+              "<x>&amp</x>",+              "<x>&#xD800;</x>",+              "<x>&#0;</x>",+              "<x>&#x110000;</x>",+              "<x>&#9999999999999999999999;</x>",+              "<x>&#;</x>",+              "<!-- unclosed",+              "<!-- bad -- comment -->",+              "<x><![CDATA[unfinished</x>",+              "<x>]]></x>",+              "<author>mixed<name>Ada</name></author>",+              "<bullets><wrong/></bullets>"+            ]+        ]+    ]+  where+    xmlFailure expected body = case parse xmlAdapter sig (mkResponse body) of+      Left (SchemaMismatch msg) -> do+        T.isPrefixOf "XML: offset " msg @?= True+        T.isInfixOf expected msg @?= True+      result -> assertFailure (show result)