diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,91 @@ ## [Unreleased] +## [baikai 0.9.0.0] - 2026-10-25 + +### Added + +- `Baikai.Judgment` compiles closed-set schemas into ordered questions, refuses + generation controls and validates neutral answers without normalizing provider + probabilities or deriving confidence and expected scores. +- `UserData`, `AssistantData`/`DataContent`, user-data message helpers, atomic + data events, and named full-response JSON codecs preserve structured answers. +- `TypeSafeSystemOne`, catalog-owned `OutputKind`/`isJudgmentOnly`, `InputData`, + and `typesafe_jev_latest`/`typesafe_jev_preview`. Legacy model JSON defaults to + generative output. Register the new `baikai-typesafe` provider explicitly. + +### Changed (breaking) + +- Public content/event sums and model, error, trace and log records gain fields + or constructors. Update exhaustive matches and record construction on upgrade. +- Terminal traces and both call-log paths preserve structured answer payloads. + Evidence schema 2.6 includes structured response commitments and typed request + problems; existing digest rules are unchanged. + +## [baikai-typesafe 0.1.0.0] - 2026-10-25 + +### Added + +- Initial explicitly registered TypeSafe System One provider using the released + `typesafe-hs ^>=0.1.0.0` wire client. Strict request and response validation, + atomic synthetic streaming, truthful call evidence, bounded HTTP calls and an + opt-in live test. No retry policy is embedded. +- Installation, schema, refusal and consumer migration guide, plus CAP-27. + +## [baikai-claude 0.7.2.0] - 2026-10-25 + +### Changed + +- Require `baikai ^>=0.9.0`, encode user data as canonical JSON text, and refuse + structured assistant history before dispatch with a typed field path. + +### Fixed + +- The offline cancellation fixture waits until the response reader is active + before cancelling, eliminating a fixed-startup-delay race under build load. + +## [baikai-openai 0.7.2.0] - 2026-10-25 + +### Changed + +- Require `baikai ^>=0.9.0`, encode user data as canonical JSON text, and refuse + structured assistant history before dispatch with a typed field path across + Chat Completions, Responses and batch CLI calls. + +### Fixed + +- The offline cancellation fixture waits until the response reader is active + before cancelling, eliminating a fixed-startup-delay race under build load. + +## [baikai-trace-otel 0.4.1.0] - 2026-10-25 + +### Added + +- Export structured answer data as canonical JSON under + `baikai.response.structured_data`, on success and failure terminals. + +### Changed + +- Require `baikai ^>=0.9.0` for the expanded trace protocol. + +## [baikai-effectful 0.4.0.4] - 2026-10-25 + +### Changed + +- Require `baikai ^>=0.9.0`. Dependency-only update; no package API change. + +## [baikai-kit 0.4.0.2] - 2026-10-25 + +### Changed + +- Require `baikai ^>=0.9.0`. Dependency-only update; no package API change. + +## [baikai-agent 0.2.0.3] - 2026-10-25 + +### Changed + +- Require `baikai ^>=0.9.0`. Dependency-only update; no package API change. + ## [baikai 0.8.0.0] - 2026-10-10 ### Added diff --git a/baikai.cabal b/baikai.cabal --- a/baikai.cabal +++ b/baikai.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: baikai -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Unified Haskell interface for multiple AI providers description: baikai provides a unified, provider-agnostic Haskell interface for working @@ -82,6 +82,7 @@ Baikai.Header Baikai.Http Baikai.Interactive + Baikai.Judgment Baikai.Message Baikai.Model Baikai.Models.Generated @@ -94,6 +95,7 @@ Baikai.Provider.Registry Baikai.Provider.Transport.Classify Baikai.Response + Baikai.Response.JSON Baikai.ResponseFormat Baikai.Speed Baikai.StopReason @@ -112,7 +114,11 @@ -- it so an evidence record can name the build that produced it, -- centrally rather than through a literal in each of the five -- packages that construct evidence. - other-modules: Paths_baikai + other-modules: + Baikai.Internal.Data + Baikai.Internal.JSON + Paths_baikai + autogen-modules: Paths_baikai build-depends: aeson ^>=2.2, @@ -210,6 +216,7 @@ CliProcessSpec ContextSpec CostSpec + DataContentSpec EmbeddingSpec ErrorInfoSpec ErrorSpec @@ -220,6 +227,7 @@ GenModelsSpec HelpersSpec InteractiveSpec + JudgmentSpec PricingPolicySpec PublicSurfaceSpec StreamSpec diff --git a/data/models/typesafe.json b/data/models/typesafe.json new file mode 100644 --- /dev/null +++ b/data/models/typesafe.json @@ -0,0 +1,46 @@ +{ + "provider": "typesafe", + "baseUrl": "https://api.typesafe.ai", + "api": "typesafe-system-one", + "compat": "auto", + "models": [ + { + "id": "jev-latest", + "name": "jev-latest", + "reasoning": false, + "input": [ + "text", + "data" + ], + "outputKind": "judgment", + "cost": { + "input": 0, + "output": 0, + "cacheRead": 0, + "cacheWrite": 0 + }, + "contextWindow": 0, + "maxOutputTokens": 0, + "enabled": true + }, + { + "id": "jev-preview", + "name": "jev-preview", + "reasoning": false, + "input": [ + "text", + "data" + ], + "outputKind": "judgment", + "cost": { + "input": 0, + "output": 0, + "cacheRead": 0, + "cacheWrite": 0 + }, + "contextWindow": 0, + "maxOutputTokens": 0, + "enabled": true + } + ] +} diff --git a/fetch/FetchModelsCore.hs b/fetch/FetchModelsCore.hs --- a/fetch/FetchModelsCore.hs +++ b/fetch/FetchModelsCore.hs @@ -222,6 +222,7 @@ name :: !Text, reasoning :: !Bool, input :: ![InputModality], + outputKind :: !Model.OutputKind, cost :: !CatalogCost, fastModeCost :: !(Maybe CatalogCost), pricingPolicy :: !(Maybe Model.PricingPolicy), @@ -463,6 +464,7 @@ { modelId = m ^. #modelId, name = normalizeName (fromMaybe (m ^. #modelId) (m ^. #name)), reasoning = m ^. #reasoning, + outputKind = Model.GenerativeOutput, input = if "image" `elem` (m ^. #inputModalities) then [InputText, InputImage] @@ -658,6 +660,7 @@ " \"contextWindow\": " <> Text.pack (show (m ^. #contextWindow)) <> ",", " \"maxOutputTokens\": " <> Text.pack (show (m ^. #maxOutputTokens)) <> "," ] + ++ [" \"outputKind\": \"judgment\"," | m ^. #outputKind == Model.JudgmentOutput] ++ maybe [] (\a -> [" \"api\": " <> jsonString a <> ","]) (m ^. #apiOverride) ++ maybe [] (\r -> [" \"fastModeCost\": " <> renderFastCost r <> ","]) (m ^. #fastModeCost) ++ maybe [] (\p -> [" \"pricingPolicy\": " <> renderPricingPolicy p <> ","]) (m ^. #pricingPolicy) @@ -756,6 +759,7 @@ where one InputText = "\"text\"" one InputImage = "\"image\"" + one InputData = "\"data\"" jsonBool :: Bool -> Text jsonBool True = "true" diff --git a/gen/GenModelsCore.hs b/gen/GenModelsCore.hs --- a/gen/GenModelsCore.hs +++ b/gen/GenModelsCore.hs @@ -242,6 +242,7 @@ entryName :: !Text, entryReasoning :: !Bool, entryInput :: ![InputModality], + entryOutputKind :: !Model.OutputKind, entryCost :: !CostEntry, entryFastModeCost :: !(Maybe CostEntry), entryPricingPolicy :: !(Maybe Model.PricingPolicy), @@ -259,6 +260,7 @@ <*> o .: "name" <*> o .:? "reasoning" .!= False <*> (o .: "input" >>= traverse parseInputModality) + <*> o .:? "outputKind" .!= Model.GenerativeOutput <*> o .: "cost" <*> o .:? "fastModeCost" <*> (o .:? "pricingPolicy" >>= traverse parsePricingPolicy) @@ -272,6 +274,7 @@ parseInputModality = \case "text" -> pure InputText "image" -> pure InputImage + "data" -> pure InputData t -> fail $ "unknown input modality: " <> Text.unpack t -- | Per-million-token cost rates. Parsed as 'Scientific' so the @@ -329,6 +332,7 @@ baseUrl :: !Text, reasoning :: !Bool, input :: ![InputModality], + outputKind :: !Model.OutputKind, cost :: !CostEntry, fastModeCost :: !(Maybe CostEntry), pricingPolicy :: !(Maybe Model.PricingPolicy), @@ -353,6 +357,7 @@ baseUrl = c.baseUrl, reasoning = entryReasoning m, input = entryInput m, + outputKind = entryOutputKind m, cost = entryCost m, fastModeCost = entryFastModeCost m, pricingPolicy = entryPricingPolicy m, @@ -498,6 +503,7 @@ " InputPriceTier (..),", " Model,", " ModelCost (..),", + " OutputKind (..),", " PricingPolicy (..),", " api,", " baseUrl,", @@ -511,6 +517,7 @@ " maxOutputTokens,", " modelId,", " name,", + " outputKind,", " pricingPolicy,", " provider,", " reasoning,", @@ -552,6 +559,7 @@ " baseUrl = " <> renderText g.baseUrl <> ",", " reasoning = " <> renderBool g.reasoning <> ",", " input = " <> renderInputList g.input <> ",", + " outputKind = " <> (if g.outputKind == Model.JudgmentOutput then "JudgmentOutput" else "GenerativeOutput") <> ",", " cost =", renderCost g.cost <> ",", renderFastCost g.fastModeCost, @@ -581,6 +589,7 @@ where renderInput InputText = "InputText" renderInput InputImage = "InputImage" + renderInput InputData = "InputData" renderApiCtor :: Api -> Text renderApiCtor = \case @@ -589,6 +598,7 @@ AnthropicMessages -> "AnthropicMessages" OpenAICompletionsCli -> "OpenAICompletionsCli" AnthropicMessagesCli -> "AnthropicMessagesCli" + TypeSafeSystemOne -> "TypeSafeSystemOne" Custom t -> "Custom " <> renderText t renderCost :: CostEntry -> Text diff --git a/src/Baikai.hs b/src/Baikai.hs --- a/src/Baikai.hs +++ b/src/Baikai.hs @@ -48,6 +48,8 @@ -- * Streaming module Baikai.Stream, module Baikai.Stream.Event, + module Baikai.Response.JSON, + module Baikai.Judgment, ) where @@ -64,11 +66,13 @@ import Baikai.Evidence.Build import Baikai.Header import Baikai.Interactive +import Baikai.Judgment import Baikai.Message import Baikai.Model import Baikai.Options import Baikai.Provider import Baikai.Response +import Baikai.Response.JSON import Baikai.ResponseFormat import Baikai.Speed import Baikai.StopReason diff --git a/src/Baikai/Api.hs b/src/Baikai/Api.hs --- a/src/Baikai/Api.hs +++ b/src/Baikai/Api.hs @@ -32,6 +32,7 @@ | AnthropicMessages | OpenAICompletionsCli | AnthropicMessagesCli + | TypeSafeSystemOne | Custom !Text deriving stock (Eq, Ord, Show, Generic) @@ -43,6 +44,7 @@ AnthropicMessages -> "anthropic-messages" OpenAICompletionsCli -> "openai-completions-cli" AnthropicMessagesCli -> "anthropic-messages-cli" + TypeSafeSystemOne -> "typesafe-system-one" Custom t -> t -- | Parse a wire string into an 'Api' tag. Unknown strings become @@ -54,6 +56,7 @@ "anthropic-messages" -> AnthropicMessages "openai-completions-cli" -> OpenAICompletionsCli "anthropic-messages-cli" -> AnthropicMessagesCli + "typesafe-system-one" -> TypeSafeSystemOne t -> Custom t -- | Collapse a 'Custom' tag that spells a built-in API onto that diff --git a/src/Baikai/Auth.hs b/src/Baikai/Auth.hs --- a/src/Baikai/Auth.hs +++ b/src/Baikai/Auth.hs @@ -69,6 +69,7 @@ match host where match host + | hostMatchesSuffix host "api.typesafe.ai" = Just "TYPESAFE_API_KEY" | hostMatchesSuffix host "api.openai.com" = Just "OPENAI_API_KEY" | hostMatchesSuffix host "api.deepseek.com" = Just "DEEPSEEK_API_KEY" | hostMatchesSuffix host "openrouter.ai" = Just "OPENROUTER_API_KEY" diff --git a/src/Baikai/Content.hs b/src/Baikai/Content.hs --- a/src/Baikai/Content.hs +++ b/src/Baikai/Content.hs @@ -4,9 +4,9 @@ -- -- A message no longer carries a single opaque blob of text. Instead it -- holds a vector of typed blocks. For user input the blocks can be text --- or an inline base64-encoded image. For assistant output a block can be +-- or an inline base64-encoded image, or structured JSON. Assistant output can be -- text, a thinking trace (for reasoning-capable models), or a tool --- invocation. For tool-result messages (a caller-supplied reply to a +-- invocation or structured data with answer evidence. For tool-result messages (a caller-supplied reply to a -- model-issued tool call) blocks can be text or image. -- -- Image content is restricted to @@ -17,6 +17,8 @@ module Baikai.Content ( -- * Block primitives TextContent (..), + DataContent (..), + canonicalDataText, ThinkingContent (..), ThinkingReplay (..), ToolCall (..), @@ -40,6 +42,7 @@ where import Baikai.Api (Api) +import Baikai.Evidence (canonicalEncode) import Data.Aeson ( FromJSON (parseJSON), Options (..), @@ -60,6 +63,8 @@ import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Base64 qualified as Base64 +import Data.Map.Strict (Map) +import Data.Scientific qualified as Scientific import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text @@ -73,6 +78,35 @@ deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) +-- | Structured output and optional provider-reported answer evidence. +-- Probabilities need not sum to one. Confidence is never derived locally. +data DataContent = DataContent + { value :: !Value, + probabilities :: !(Maybe (Map Text (Map Text Double))), + confidence :: !(Maybe (Map Text Double)), + method :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON DataContent where + toJSON d = + object $ + ["value" .= value d] + <> maybe [] (\x -> ["probabilities" .= x]) (probabilities d) + <> maybe [] (\x -> ["confidence" .= x]) (confidence d) + <> maybe [] (\x -> ["method" .= x]) (method d) + +instance FromJSON DataContent where + parseJSON = withObject "DataContent" $ \o -> do + v <- o .: "value" + ps <- o .:? "probabilities" + cs <- o .:? "confidence" + m <- o .:? "method" + let check n + | n < 0 || n > (1 :: Scientific.Scientific) = fail "expected a probability in [0,1]" + | otherwise = pure (Scientific.toRealFloat n :: Double) + DataContent v <$> traverse (traverse (traverse check)) ps <*> traverse (traverse check) cs <*> pure m + -- | A reasoning trace block produced by thinking-capable models. The -- @signature@ field is an opaque continuation token returned by the -- provider; it must be threaded back into the next request unchanged for @@ -169,6 +203,7 @@ data UserContent = UserText !TextContent | UserImage !ImageContent + | UserData !Value deriving stock (Eq, Show, Generic) -- | What a provider can put into a 'Baikai.Message.AssistantMessage'. @@ -176,6 +211,7 @@ = AssistantText !TextContent | AssistantThinking !ThinkingContent | AssistantToolCall !ToolCall + | AssistantData !DataContent deriving stock (Eq, Show, Generic) -- | What a caller can put into a 'Baikai.Message.ToolResultMessage'. @@ -283,3 +319,7 @@ instance ToJSON ToolResultContent where toJSON = genericToJSON contentSumOptions + +-- | Deterministic UTF-8 JSON text for a structured input block. +canonicalDataText :: Value -> Text +canonicalDataText = Text.decodeUtf8 . canonicalEncode diff --git a/src/Baikai/Context.hs b/src/Baikai/Context.hs --- a/src/Baikai/Context.hs +++ b/src/Baikai/Context.hs @@ -19,6 +19,7 @@ messages, tools, emptyContext, + refuseAssistantDataHistory, contextOf, systemUser, addUser, @@ -30,6 +31,7 @@ where import Baikai.Content (AssistantContent (..), ToolCall (..), isCutOffToolCall) +import Baikai.Error (BaikaiError, unsupportedFeature) import Baikai.Message (Message (..), ToolResult, toolResultErrorText, toolResultFromCallNow, toolResultText, user) import Baikai.Response (Response (..), responseError, responseMessage) import Baikai.Tool (Tool) @@ -38,6 +40,7 @@ import Data.Aeson (ToJSON) import Data.Generics.Labels () import Data.Text (Text) +import Data.Text qualified as Text import Data.Vector (Vector) import Data.Vector qualified as V import GHC.Generics (Generic) @@ -169,3 +172,12 @@ IO Context appendToolResultText ctx resp dispatcher = appendToolResult ctx resp (fmap toolResultText . dispatcher) + +-- | Generative transports cannot replay structured answer evidence losslessly. +refuseAssistantDataHistory :: Context -> Either BaikaiError () +refuseAssistantDataHistory ctx = case [ "messages[" <> Text.pack (show i) <> "].content[" <> Text.pack (show j) <> "]" + | (i, AssistantMessage p) <- zip [0 :: Int ..] (V.toList (messages ctx)), + (j, AssistantData _) <- zip [0 :: Int ..] (V.toList (p ^. #content)) + ] of + [] -> Right () + path : _ -> Left (unsupportedFeature path "This transport cannot replay AssistantData evidence") diff --git a/src/Baikai/Cost/Log.hs b/src/Baikai/Cost/Log.hs --- a/src/Baikai/Cost/Log.hs +++ b/src/Baikai/Cost/Log.hs @@ -40,7 +40,8 @@ ) where -import Baikai.Content (TextContent (..), UserContent (..)) +import Baikai.Content (DataContent, TextContent (..), UserContent (..)) +import Baikai.Content qualified as Content import Baikai.Context (Context) import Baikai.Cost (CostBasis, usdAsScientific) import Baikai.Cost qualified as Cost @@ -55,7 +56,7 @@ completeRequestWith, globalProviderRegistry, ) -import Baikai.Response (Response) +import Baikai.Response (Response, flattenAssistantData) import Baikai.Usage (Usage) import Baikai.Usage qualified as Usage import Control.Concurrent (forkIO) @@ -68,6 +69,7 @@ import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Data.Aeson (FromJSON, ToJSON) import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM import Data.ByteString.Lazy qualified as BSL import Data.Foldable (find) import Data.Function ((&)) @@ -113,11 +115,18 @@ reasoningTokens :: !(Maybe Natural), usd :: !(Maybe Scientific), latencyMs :: !Int, - promptSummary :: !Text + promptSummary :: !Text, + structuredData :: !(Maybe (Vector.Vector DataContent)) } deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) +instance FromJSON CallLogEntry where parseJSON = Aeson.genericParseJSON Aeson.defaultOptions + +instance ToJSON CallLogEntry where + toJSON e = case Aeson.genericToJSON Aeson.defaultOptions e of + Aeson.Object o | Nothing <- structuredData e -> Aeson.Object (KM.delete "structuredData" o) + v -> v + -- | Opaque handle for an open call log. data CallLogHandle = CallLogHandle { chan :: !(Chan (Maybe CallLogEntry)), @@ -230,6 +239,7 @@ -- which entry point produced it. usd = Just (usdAsScientific (Usage.cost u)), latencyMs = resp ^. #latencyMs, + structuredData = nonEmptyData (flattenAssistantData ((resp ^. #message) ^. #content)), promptSummary = summarizeContext ctx } appendEntry h entry @@ -283,4 +293,8 @@ concatUserText = Text.concat . Vector.toList . Vector.mapMaybe pickText where pickText (UserText (TextContent t)) = Just t + pickText (UserData v) = Just (Content.canonicalDataText v) pickText _ = Nothing + +nonEmptyData :: Vector.Vector a -> Maybe (Vector.Vector a) +nonEmptyData v = if Vector.null v then Nothing else Just v diff --git a/src/Baikai/Error.hs b/src/Baikai/Error.hs --- a/src/Baikai/Error.hs +++ b/src/Baikai/Error.hs @@ -1,6 +1,9 @@ module Baikai.Error ( BaikaiError (..), ErrorCategory (..), + RequestProblem (..), + unsupportedFeature, + unsupportedModel, -- * Smart constructors providerError, @@ -37,6 +40,8 @@ genericParseJSON, genericToJSON, ) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM import Data.Maybe (listToMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as Text @@ -93,6 +98,28 @@ genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_'} +-- | A machine-readable request refusal, with its offending field or model. +data RequestProblem = UnsupportedFeature Text | UnsupportedModel Text + deriving stock (Eq, Show, Generic) + +instance ToJSON RequestProblem where + toJSON (UnsupportedFeature path) = Aeson.object ["kind" Aeson..= ("unsupported_feature" :: Text), "field" Aeson..= path] + toJSON (UnsupportedModel model) = Aeson.object ["kind" Aeson..= ("unsupported_model" :: Text), "model" Aeson..= model] + +instance FromJSON RequestProblem where + parseJSON = Aeson.withObject "RequestProblem" $ \o -> do + k <- o Aeson..: "kind" + case k :: Text of + "unsupported_feature" -> UnsupportedFeature <$> o Aeson..: "field" + "unsupported_model" -> UnsupportedModel <$> o Aeson..: "model" + _ -> fail "unknown request problem kind" + +unsupportedFeature :: Text -> Text -> BaikaiError +unsupportedFeature path msg = (invalidRequest msg) {requestProblem = Just (UnsupportedFeature path)} + +unsupportedModel :: Text -> Text -> BaikaiError +unsupportedModel model msg = (invalidRequest msg) {requestProblem = Just (UnsupportedModel model)} + -- | A failed baikai call. The 'category' drives caller policy; the -- remaining fields carry optional structured hints. No record-field -- prefixes (project convention): fields are plain names. @@ -109,15 +136,16 @@ exitCode :: !(Maybe Int), -- | Provider-reported refusal category, an open vocabulary. Present only -- when a content refusal names one; never inferred from message text. - refusalCategory :: !(Maybe Text) + refusalCategory :: !(Maybe Text), + requestProblem :: !(Maybe RequestProblem) } deriving stock (Eq, Show, Generic) -- | Fields serialize as snake_case (e.g. @http_status@, @retry_after_seconds@). instance ToJSON BaikaiError where - toJSON = - genericToJSON - defaultOptions {fieldLabelModifier = camelTo2 '_'} + toJSON e = case genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'} e of + Aeson.Object o | Nothing <- requestProblem e -> Aeson.Object (KM.delete "request_problem" o) + v -> v instance FromJSON BaikaiError where parseJSON = @@ -137,7 +165,8 @@ httpStatus = Nothing, retryAfterSeconds = Nothing, exitCode = Nothing, - refusalCategory = Nothing + refusalCategory = Nothing, + requestProblem = Nothing } -- Smart constructors. These keep call sites close to the old API: an diff --git a/src/Baikai/Evidence.hs b/src/Baikai/Evidence.hs --- a/src/Baikai/Evidence.hs +++ b/src/Baikai/Evidence.hs @@ -788,6 +788,7 @@ OpenAIResponses -> EvidenceModelObserved AnthropicMessagesCli -> EvidenceModelObserved OpenAICompletionsCli -> EvidenceCorrelated + TypeSafeSystemOne -> EvidenceModelObserved Custom _ -> EvidenceRequestedOnly -- ============================================================ @@ -916,7 +917,9 @@ -- thinking_summary_unavailable diagnostic; existing digest rules are unchanged. -- Version 2.5 adds error_info.refusal_category, an optional provider fact. -- Older error objects decode with Nothing; digest inputs are unchanged. -evidenceSchemaVersion = "baikai.model-call-evidence/2.5" +-- Version 2.6 adds structured response content and optional request_problem. +-- The canonical encoding and data-free commitment fixtures are unchanged. +evidenceSchemaVersion = "baikai.model-call-evidence/2.6" -- | Everything Baikai can say about one completed provider call. -- diff --git a/src/Baikai/Internal/Data.hs b/src/Baikai/Internal/Data.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Internal/Data.hs @@ -0,0 +1,34 @@ +-- | Recover atomic data omitted by a failure terminal, without duplicating +-- blocks when event indices have gaps and terminal content is compacted. +module Baikai.Internal.Data (recoverDataBlocks) where + +import Baikai.Content (AssistantContent (..), DataContent, TextContent (..)) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.List (mapAccumL) +import Data.Vector (Vector) +import Data.Vector qualified as V + +recoverDataBlocks :: IntMap AssistantContent -> Vector AssistantContent -> Vector AssistantContent +recoverDataBlocks closed terminal + | not (IntMap.null closed), V.all blankText terminal = V.fromList (IntMap.elems closed) + | otherwise = foldl insert terminal missing + where + blankText (AssistantText (TextContent "")) = True + blankText _ = False + terminalData = [d | AssistantData d <- V.toList terminal] + (_, candidates) = mapAccumL consume terminalData (zip [0 ..] (IntMap.elems closed)) + missing = [entry | Just entry <- candidates] + consume remaining (ordinal, AssistantData d) = case removeOne d remaining of + Just rest -> (rest, Nothing) + Nothing -> (remaining, Just (ordinal, AssistantData d)) + consume remaining _ = (remaining, Nothing) + insert blocks (ordinal, block) = + let position = min ordinal (V.length blocks) + in V.take position blocks <> V.singleton block <> V.drop position blocks + +removeOne :: DataContent -> [DataContent] -> Maybe [DataContent] +removeOne _ [] = Nothing +removeOne wanted (d : ds) + | wanted == d = Just ds + | otherwise = (d :) <$> removeOne wanted ds diff --git a/src/Baikai/Internal/JSON.hs b/src/Baikai/Internal/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Internal/JSON.hs @@ -0,0 +1,112 @@ +-- | Local persistence parsers. These deliberately introduce no orphan instances. +module Baikai.Internal.JSON (parseAssistant, parseMessage, parseUsage, parseEvidence) where + +import Baikai.Cost qualified as C +import Baikai.Evidence qualified as E +import Baikai.Message qualified as M +import Baikai.Usage qualified as U +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Scientific (Scientific) +import Data.Text (Text) + +parseAssistant :: Value -> Parser M.AssistantPayload +parseAssistant = withObject "AssistantPayload" $ \o -> + M.AssistantPayload + <$> o .: "content" + <*> (o .: "usage" >>= parseUsage) + <*> o .: "stopReason" + <*> o .:? "errorMessage" + <*> o .:? "timestamp" + +parseMessage :: Value -> Parser M.Message +parseMessage = withObject "Message" $ \o -> do + tag <- o .: "tag" + v <- o .: "contents" + case tag :: Text of + "AssistantMessage" -> M.AssistantMessage <$> parseAssistant v + "UserMessage" -> withObject "UserPayload" (\d -> M.UserMessage <$> (M.UserPayload <$> d .: "content" <*> d .:? "timestamp")) v + "ToolResultMessage" -> withObject "ToolResultPayload" (\d -> M.ToolResultMessage <$> (M.ToolResultPayload <$> d .: "toolCallId" <*> d .: "toolName" <*> d .: "content" <*> d .: "isError" <*> d .:? "timestamp")) v + _ -> fail "unknown message tag" + +parseUsage :: Value -> Parser U.Usage +parseUsage = withObject "Usage" $ \o -> + U.Usage + <$> o .: "input_tokens" + <*> o .: "output_tokens" + <*> o .: "cache_read_tokens" + <*> o .: "cache_write_tokens" + <*> o .:? "reasoning_tokens" + <*> o .: "total_tokens" + <*> o .:? "availability" + <*> (o .: "cost" >>= parseCost) + +parseCost :: Value -> Parser C.Cost +parseCost = withObject "Cost" $ \o -> + C.Cost + <$> (toRational <$> (o .: "usd" :: Parser Scientific)) + <*> (o .: "breakdown" >>= parseBreakdown) + <*> o .:? "basis" .!= mempty + +parseBreakdown :: Value -> Parser C.CostBreakdown +parseBreakdown = withObject "CostBreakdown" $ \o -> + let rat k = toRational <$> (o .: k :: Parser Scientific) + in C.CostBreakdown <$> rat "input_usd" <*> rat "output_usd" <*> rat "cached_input_usd" <*> rat "cached_write_usd" + +parseEvidence :: Value -> Parser E.ModelCallEvidence +parseEvidence = withObject "ModelCallEvidence" $ \o -> + build + <$> o .: "schema_version" + <*> o .: "run_id" + <*> o .: "call_id" + <*> o .: "attempt" + <*> o .:? "supersedes" + <*> o .: "endpoint" + <*> o .: "requested_model" + <*> o .: "thinking" + <*> o .: "observed_model" + <*> o .: "observed_thinking" + <*> o .: "response_id" + <*> o .: "provider_request_id" + <*> o .:? "client_request_id" + <*> o .: "started_at" + <*> o .: "ended_at" + <*> o .: "latency_ms" + <*> o .: "status" + <*> o .:? "error_info" + <*> (o .: "usage" >>= parseObservedUsage) + <*> o .: "strength" + <*> o .: "request_commitment" + <*> o .: "request_configuration" + <*> o .: "response_commitment" + where + build v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16 v17 v18 v19 v20 v21 v22 = + (E.baseEvidence (E.evidenceRequest v1) v2 v5 v6 v7 v13 v14 v16 v20 v21) + { E.schemaVersion = v0, + E.runId = v1, + E.callId = v2, + E.attempt = v3, + E.supersedes = v4, + E.endpoint = v5, + E.requestedModel = v6, + E.thinking = v7, + E.observedModel = v8, + E.observedThinking = v9, + E.responseId = v10, + E.providerRequestId = v11, + E.clientRequestId = v12, + E.startedAt = v13, + E.endedAt = v14, + E.latencyMs = v15, + E.status = v16, + E.errorInfo = v17, + E.usage = v18, + E.strength = v19, + E.requestCommitment = v20, + E.requestConfiguration = v21, + E.responseCommitment = v22 + } + +parseObservedUsage :: Value -> Parser (E.Observed U.Usage) +parseObservedUsage (String "unobserved") = pure E.Unobserved +parseObservedUsage v = withObject "Observed Usage" (\o -> E.Observed <$> (o .: "observed" >>= parseUsage)) v diff --git a/src/Baikai/Judgment.hs b/src/Baikai/Judgment.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Judgment.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Provider-neutral closed-set questions and strict answer validation. +module Baikai.Judgment + ( JudgmentKind (..), + Judgment (..), + Judgments, + judgmentList, + lookupJudgment, + compileJudgments, + judgmentUserMessage, + refuseGenerationControls, + prepareJudgment, + JudgmentAnswer (..), + validateAnswers, + judgmentMethod, + ) +where + +import Baikai.CacheRetention (CacheRetention (..)) +import Baikai.Content (DataContent (..)) +import Baikai.Context (Context) +import Baikai.Error +import Baikai.Message (Message (..)) +import Baikai.Options (Options) +import Baikai.ResponseFormat (JsonSchemaFormat, ResponseFormat (..)) +import Control.Lens ((^.)) +import Control.Monad (forM, unless, when) +import Data.Aeson (Object, Value (..)) +import Data.Aeson qualified as A +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Generics.Labels () +import Data.List (sort, sortOn) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) +import Data.Scientific qualified as Sci +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector (Vector) +import Data.Vector qualified as V +import GHC.Generics (Generic) + +data JudgmentKind + = PredicateJudgment (Maybe (Value, Value)) + | ChoiceJudgment (Vector (Text, Maybe Value)) + | ScoreJudgment (Vector (Maybe Value)) + deriving stock (Eq, Show, Generic) + +data Judgment = Judgment {name :: !Text, instructions :: !Value, kind :: !JudgmentKind} + deriving stock (Eq, Show, Generic) + +data Judgments = Judgments !(Vector Judgment) !(Map Text Judgment) + deriving stock (Eq, Show) + +judgmentList :: Judgments -> Vector Judgment +judgmentList (Judgments js _) = js + +lookupJudgment :: Text -> Judgments -> Maybe Judgment +lookupJudgment n (Judgments _ ix) = Map.lookup n ix + +schemaPath :: Text +schemaPath = "Options.responseFormat.schema" + +refuse :: Text -> Text -> Either BaikaiError a +refuse p why = Left (unsupportedFeature p (p <> ": " <> why)) + +asObject :: Text -> Value -> Either BaikaiError Object +asObject _ (Object o) = Right o +asObject p _ = refuse p "expected an object" + +allowed :: Text -> [Text] -> Object -> Either BaikaiError () +allowed p keys o = case sort [K.toText k | k <- KM.keys o, K.toText k `notElem` keys] of + [] -> Right () + k : _ -> refuse (p <> "." <> k) "unsupported schema keyword" + +description :: Object -> Maybe Value +description o = case KM.lookup "description" o of Just Null -> Nothing; x -> x + +compileJudgments :: JsonSchemaFormat -> Either BaikaiError Judgments +compileJudgments format = do + o <- asObject schemaPath (format ^. #schema) + allowed schemaPath ["type", "properties", "required", "additionalProperties", "title", "description"] o + unless (KM.lookup "type" o == Just (String "object")) (refuse (schemaPath <> ".type") "expected object type") + props <- maybe (refuse (schemaPath <> ".properties") "properties required") (asObject (schemaPath <> ".properties")) (KM.lookup "properties" o) + when (KM.null props) (refuse (schemaPath <> ".properties") "questions must not be empty") + case KM.lookup "additionalProperties" o of + Nothing -> pure () + Just (Bool False) -> pure () + _ -> refuse (schemaPath <> ".additionalProperties") "only false is supported" + let names = sort (map K.toText (KM.keys props)) + required <- case KM.lookup "required" o of + Nothing -> pure [] + Just (Array xs) -> forM (V.toList xs) $ \case + String t | t `elem` names -> pure t + _ -> refuse (schemaPath <> ".required") "required must name declared properties" + _ -> refuse (schemaPath <> ".required") "expected an array" + let order = if sort required == names then required else names + js <- forM order $ \n -> do + let p = schemaPath <> ".properties." <> n + prop <- maybe (refuse p "property missing") (asObject p) (KM.lookup (K.fromText n) props) + k <- compileKind p prop + pure (Judgment n (maybe (String n) id (description prop)) k) + pure (Judgments (V.fromList js) (Map.fromList [(name j, j) | j <- js])) + +compileKind :: Text -> Object -> Either BaikaiError JudgmentKind +compileKind p o = do + allowed p ["type", "enum", "anyOf", "oneOf", "title", "description"] o + let alternatives = [v | key <- ["enum", "anyOf", "oneOf"], Just v <- [KM.lookup key o]] + case alternatives of + [] | KM.lookup "type" o == Just (String "boolean") -> pure (PredicateJudgment Nothing) + [v] -> do + let enum = KM.member "enum" o + xs <- case v of Array a | not (V.null a) -> pure (V.toList a); _ -> refuse p "expected nonempty alternatives" + entries <- + if enum + then pure [(x, Nothing) | x <- xs] + else forM xs $ \branch -> do + b <- asObject p branch + allowed p ["const", "description", "title"] b + val <- maybe (refuse p "const required on every branch") pure (KM.lookup "const" b) + pure (val, description b) + let values = map fst entries + ty = KM.lookup "type" o + typeAllowed allowedTypes = unless (maybe True (`elem` map String allowedTypes) ty) (refuse p "conflicting property type") + when (length values /= Set.size (Set.fromList values)) (refuse p "duplicate alternatives") + case values of + Bool _ : _ -> do + typeAllowed ["boolean"] + unless (sort values == [Bool False, Bool True]) (refuse p "predicate must declare true and false") + let get b = maybe Null id (lookup (Bool b) entries >>= id) + criteria = if any (isJust . snd) entries then Just (get True, get False) else Nothing + pure (PredicateJudgment criteria) + String _ : _ -> do + typeAllowed ["string"] + labels <- forM entries $ \case (String t, d) -> pure (t, d); _ -> refuse p "mixed alternatives" + when (length labels > 255) (refuse p "at most 255 labels") + pure (ChoiceJudgment (V.fromList labels)) + Number _ : _ -> do + typeAllowed ["integer"] + levels <- forM entries $ \case + (Number n, d) | Just i <- (Sci.toBoundedInteger n :: Maybe Int) -> pure (i, d) + _ -> refuse p "levels must be integral numbers" + let ordered = sortOn fst levels; count = length ordered + unless (count >= 2 && count <= 10 && map fst ordered == [0 .. count - 1]) (refuse p "score levels must be 0 to N-1 with 2 to 10 levels") + pure (ScoreJudgment (V.fromList (map snd ordered))) + _ -> refuse p "unsupported alternatives" + _ -> refuse p "unsupported or conflicting validation keywords" + +judgmentUserMessage :: Context -> Either BaikaiError Message +judgmentUserMessage ctx = do + when (isJust (ctx ^. #systemPrompt)) (refuse "Context.systemPrompt" "judgments do not accept a system prompt") + unless (V.length (ctx ^. #messages) == 1) (refuse "Context.messages" "exactly one user message required") + msg <- case V.head (ctx ^. #messages) of + m@UserMessage {} -> Right m + _ -> refuse "Context.messages[0]" "expected a user message" + unless (V.null (ctx ^. #tools)) (refuse "Context.tools" "judgments do not accept tools") + pure msg + +refuseGenerationControls :: Options -> Either BaikaiError () +refuseGenerationControls o = + mapM_ + check + [ ("maxTokens", isJust (o ^. #maxTokens)), + ("temperature", isJust (o ^. #temperature)), + ("topP", isJust (o ^. #topP)), + ("stopSequences", not (null (o ^. #stopSequences))), + ("seed", isJust (o ^. #seed)), + ("frequencyPenalty", isJust (o ^. #frequencyPenalty)), + ("presencePenalty", isJust (o ^. #presencePenalty)), + ("thinking", isJust (o ^. #thinking)), + ("toolChoice", isJust (o ^. #toolChoice)), + ("cacheRetention", maybe False (/= CacheRetentionNone) (o ^. #cacheRetention)), + ("speed", isJust (o ^. #speed)) + ] + where + check (n, True) = refuse ("Options." <> n) "generation control is unsupported for judgments" + check (_, False) = pure () + +prepareJudgment :: Context -> Options -> Either BaikaiError (Message, Judgments) +prepareJudgment ctx opts = do + msg <- judgmentUserMessage ctx + refuseGenerationControls opts + fmt <- case opts ^. #responseFormat of + Just (JsonSchema f) -> pure f + _ -> refuse "Options.responseFormat" "closed-set JsonSchema required" + js <- compileJudgments fmt + pure (msg, js) + +data JudgmentAnswer + = PredicateAnswer Double + | ChoiceAnswer {selected :: Text, probabilities :: Map Text Double, confidence :: Maybe Double} + | ScoreAnswer {expected :: Maybe Double, probabilities :: Map Text Double, confidence :: Maybe Double} + | RefusedAnswer (Maybe Text) + deriving stock (Eq, Show, Generic) + +judgmentMethod :: Text +judgmentMethod = "provider_classification" + +validateAnswers :: Judgments -> Map Text JudgmentAnswer -> Either BaikaiError DataContent +validateAnswers js answers = do + let names = Set.fromList [name j | j <- V.toList (judgmentList js)] + actual = Map.keysSet answers + unless (actual == names) (Left (decodeError ("answer names differ: " <> T.intercalate "," (Set.toAscList ((names Set.\\ actual) <> (actual Set.\\ names)))))) + rows <- forM (V.toList (judgmentList js)) $ \j -> do + a <- maybe (Left (decodeError (name j <> ": missing answer"))) Right (Map.lookup (name j) answers) + let bad :: Text -> Either BaikaiError a + bad why = Left (decodeError (name j <> ": " <> why)) + unit x = unless (not (isNaN x || isInfinite x) && x >= 0 && x <= 1) (bad "expected finite probability/confidence in [0,1]") + distribution keys ps c = do + unless (Map.keysSet ps == Set.fromList keys) (bad "distribution keys differ") + mapM_ unit ps + mapM_ unit c + (v, ps, c) <- case (kind j, a) of + (_, RefusedAnswer category) -> Left ((contentFiltered (name j <> ": provider refused answer")) {refusalCategory = category}) + (PredicateJudgment _, PredicateAnswer p) -> do + unit p + pure (Bool (p >= 0.5), Map.fromList [("true", p), ("false", 1 - p)], Nothing) + (ChoiceJudgment choices, ChoiceAnswer chosen ps c) -> do + let labels = map fst (V.toList choices) + distribution labels ps c + unless (chosen `elem` labels) (bad "selected undeclared label") + pure (String chosen, ps, c) + (ScoreJudgment levels, ScoreAnswer expScore ps c) -> do + let indices = [0 .. V.length levels - 1]; keys = map (T.pack . show) indices + distribution keys ps c + mapM_ (\x -> unless (not (isNaN x || isInfinite x) && x >= 0 && x <= fromIntegral (V.length levels - 1)) (bad "expected score outside declared range")) expScore + let best = foldl (\best i -> if Map.findWithDefault 0 (T.pack (show i)) ps > Map.findWithDefault 0 (T.pack (show best)) ps then i else best) 0 indices + score = maybe (A.toJSON best) A.toJSON expScore + pure (score, ps, c) + _ -> bad "answer kind differs from question" + pure (name j, v, ps, c) + pure + ( DataContent + (Object (KM.fromList [(K.fromText n, v) | (n, v, _, _) <- rows])) + (Just (Map.fromList [(n, ps) | (n, _, ps, _) <- rows])) + (let cs = Map.fromList [(n, c) | (n, _, _, Just c) <- rows] in if Map.null cs then Nothing else Just cs) + (Just judgmentMethod) + ) diff --git a/src/Baikai/Message.hs b/src/Baikai/Message.hs --- a/src/Baikai/Message.hs +++ b/src/Baikai/Message.hs @@ -38,6 +38,9 @@ ToolResultPayload (..), ToolResult (..), user, + userData, + userDataAt, + userDataNow, userAt, userNow, userImage, @@ -72,7 +75,7 @@ ) import Baikai.StopReason (StopReason (..)) import Baikai.Usage (Usage, zeroUsage) -import Data.Aeson (ToJSON) +import Data.Aeson (ToJSON, Value) import Data.Text (Text) import Data.Time (UTCTime, getCurrentTime) import Data.Vector (Vector) @@ -194,6 +197,18 @@ userImageNow img mPrefix = do now <- getCurrentTime pure (userImageAt now img mPrefix) + +-- | Build one structured user block, without a timestamp. +userData :: Value -> Message +userData v = UserMessage (UserPayload (V.singleton (UserData v)) Nothing) + +-- | Build one structured user block at an explicit timestamp. +userDataAt :: UTCTime -> Value -> Message +userDataAt ts v = UserMessage (UserPayload (V.singleton (UserData v)) (Just ts)) + +-- | Build one structured user block using the current time. +userDataNow :: Value -> IO Message +userDataNow v = (\ts -> userDataAt ts v) <$> getCurrentTime -- | Build a one-text-block assistant message with zero usage, a @stop@ -- stop reason, and no recorded timestamp. diff --git a/src/Baikai/Model.hs b/src/Baikai/Model.hs --- a/src/Baikai/Model.hs +++ b/src/Baikai/Model.hs @@ -39,6 +39,9 @@ -- * Capabilities InputModality (..), + OutputKind (..), + outputKind, + isJudgmentOnly, -- * Compatibility shim Compat (..), @@ -71,6 +74,8 @@ (.:), (.:?), ) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM import Data.List (nub, sort) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -83,9 +88,27 @@ data InputModality = InputText | InputImage + | InputData deriving stock (Eq, Ord, Show, Generic) deriving anyclass (FromJSON, ToJSON) +-- | Catalog-owned output semantics. Legacy model JSON is generative. +data OutputKind = GenerativeOutput | JudgmentOutput + deriving stock (Eq, Show, Generic) + +instance ToJSON OutputKind where + toJSON GenerativeOutput = Aeson.String "generative" + toJSON JudgmentOutput = Aeson.String "judgment" + +instance FromJSON OutputKind where + parseJSON = Aeson.withText "OutputKind" $ \t -> case t of + "generative" -> pure GenerativeOutput + "judgment" -> pure JudgmentOutput + _ -> fail "unknown output kind" + +isJudgmentOnly :: Model -> Bool +isJudgmentOnly m = outputKind m == JudgmentOutput + -- | Per-million-token prices in USD as exact 'Rational' values. data ModelCost = ModelCost { inputCost :: !Rational, @@ -196,6 +219,7 @@ baseUrl :: !Text, reasoning :: !Bool, input :: ![InputModality], + outputKind :: !OutputKind, cost :: !ModelCost, -- | Optional premium speed rates, in USD per million tokens. fastModeCost :: !(Maybe ModelCost), @@ -215,8 +239,11 @@ compat :: !Compat } deriving stock (Eq, Generic) - deriving anyclass (FromJSON) +instance FromJSON Model where + parseJSON = Aeson.withObject "Model" $ \o -> + Aeson.genericParseJSON Aeson.defaultOptions (Aeson.Object (if KM.member "outputKind" o then o else KM.insert "outputKind" (Aeson.String "generative") o)) + -- | Rendered field by field rather than derived, so that the value of a -- credential-carrying header prints as 'Auth.redactedMarker'. A 'Model' -- is the record most likely to reach a log: it is embedded in every @@ -247,6 +274,7 @@ . next "baseUrl" (baseUrl m) . next "reasoning" (reasoning m) . next "input" (input m) + . next "outputKind" (outputKind m) . next "cost" (cost m) . next "fastModeCost" (fastModeCost m) . next "pricingPolicy" (pricingPolicy m) @@ -298,6 +326,7 @@ baseUrl = "", reasoning = False, input = [InputText], + outputKind = GenerativeOutput, cost = zeroModelCost, fastModeCost = Nothing, pricingPolicy = Nothing, diff --git a/src/Baikai/Models/Generated.hs b/src/Baikai/Models/Generated.hs --- a/src/Baikai/Models/Generated.hs +++ b/src/Baikai/Models/Generated.hs @@ -44,6 +44,7 @@ InputPriceTier (..), Model, ModelCost (..), + OutputKind (..), PricingPolicy (..), api, baseUrl, @@ -57,6 +58,7 @@ maxOutputTokens, modelId, name, + outputKind, pricingPolicy, provider, reasoning, @@ -75,6 +77,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 10 % 1, @@ -110,6 +113,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 10 % 1, @@ -145,6 +149,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 1 % 1, @@ -180,6 +185,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 1 % 10, @@ -215,6 +221,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 1, @@ -250,6 +257,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 1, @@ -285,6 +293,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 1, @@ -320,6 +329,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 1, @@ -363,6 +373,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 1, @@ -406,6 +417,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 4 % 1, @@ -449,6 +461,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 3 % 1, @@ -484,6 +497,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 3 % 1, @@ -519,6 +533,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 2 % 1, @@ -554,6 +569,7 @@ baseUrl = "https://api.anthropic.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 2 % 1, @@ -589,6 +605,7 @@ baseUrl = "https://api.deepseek.com", reasoning = False, input = [InputText], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 27 % 100, @@ -614,6 +631,7 @@ baseUrl = "https://api.deepseek.com", reasoning = True, input = [InputText], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 11 % 20, @@ -639,6 +657,7 @@ baseUrl = "https://api.openai.com", reasoning = False, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 2 % 1, @@ -664,6 +683,7 @@ baseUrl = "https://api.openai.com", reasoning = False, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 2 % 5, @@ -689,6 +709,7 @@ baseUrl = "https://api.openai.com", reasoning = False, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 1 % 10, @@ -714,6 +735,7 @@ baseUrl = "https://api.openai.com", reasoning = False, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 2, @@ -739,6 +761,7 @@ baseUrl = "https://api.openai.com", reasoning = False, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 3 % 20, @@ -764,6 +787,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 4, @@ -789,6 +813,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 4, @@ -814,6 +839,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 7 % 4, @@ -839,6 +865,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 2, @@ -864,6 +891,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 3 % 4, @@ -889,6 +917,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 1 % 5, @@ -914,6 +943,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 5 % 1, @@ -939,6 +969,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 4 % 1, @@ -964,6 +995,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 1 % 5, @@ -989,6 +1021,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 4 % 1, @@ -1014,6 +1047,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 2 % 1, @@ -1039,6 +1073,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 1 % 4, @@ -1064,6 +1099,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 1 % 20, @@ -1089,6 +1125,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 2 % 1, @@ -1121,6 +1158,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 10 % 1, @@ -1153,6 +1191,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 1 % 10, @@ -1185,6 +1224,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 2 % 1, @@ -1217,6 +1257,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 15 % 1, @@ -1242,6 +1283,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 2 % 1, @@ -1267,6 +1309,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 11 % 10, @@ -1292,6 +1335,7 @@ baseUrl = "https://api.openai.com", reasoning = True, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 11 % 10, @@ -1317,6 +1361,7 @@ baseUrl = "https://openrouter.ai/api", reasoning = False, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 3 % 1, @@ -1342,6 +1387,7 @@ baseUrl = "https://openrouter.ai/api", reasoning = False, input = [InputText, InputImage], + outputKind = GenerativeOutput, cost = ModelCost { inputCost = 3 % 20, @@ -1357,6 +1403,58 @@ compat = CompatNone } +typesafe_jev_latest :: Model +typesafe_jev_latest = + emptyModel + { modelId = "jev-latest", + name = "jev-latest", + api = TypeSafeSystemOne, + provider = "typesafe", + baseUrl = "https://api.typesafe.ai", + reasoning = False, + input = [InputText, InputData], + outputKind = JudgmentOutput, + cost = + ModelCost + { inputCost = 0 % 1, + outputCost = 0 % 1, + cacheReadCost = 0 % 1, + cacheWriteCost = 0 % 1 + }, + fastModeCost = Nothing, + pricingPolicy = Nothing, + contextWindow = 0, + maxOutputTokens = 0, + headers = Map.empty, + compat = CompatNone + } + +typesafe_jev_preview :: Model +typesafe_jev_preview = + emptyModel + { modelId = "jev-preview", + name = "jev-preview", + api = TypeSafeSystemOne, + provider = "typesafe", + baseUrl = "https://api.typesafe.ai", + reasoning = False, + input = [InputText, InputData], + outputKind = JudgmentOutput, + cost = + ModelCost + { inputCost = 0 % 1, + outputCost = 0 % 1, + cacheReadCost = 0 % 1, + cacheWriteCost = 0 % 1 + }, + fastModeCost = Nothing, + pricingPolicy = Nothing, + contextWindow = 0, + maxOutputTokens = 0, + headers = Map.empty, + compat = CompatNone + } + -- | Every model in the generated catalog, in declaration order. allModels :: [Model] allModels = @@ -1403,5 +1501,7 @@ openai_o3_mini, openai_o4_mini, openrouter_anthropic_claude_sonnet_4, - openrouter_openai_gpt_4o_mini + openrouter_openai_gpt_4o_mini, + typesafe_jev_latest, + typesafe_jev_preview ] diff --git a/src/Baikai/Provider/Cli/Internal.hs b/src/Baikai/Provider/Cli/Internal.hs --- a/src/Baikai/Provider/Cli/Internal.hs +++ b/src/Baikai/Provider/Cli/Internal.hs @@ -42,6 +42,7 @@ ToolResultContent (..), UserContent (..), ) +import Baikai.Content qualified as Content import Baikai.Context (Context) import Baikai.Cost (Cost (..), providerReportedBasis, zeroCost, zeroCostBreakdown) import Baikai.Error (BaikaiError (..), ErrorCategory (..), decodeError, processError) @@ -129,6 +130,7 @@ flattenUser = Text.concat . Vector.toList . Vector.mapMaybe pickU where pickU (UserText (TextContent t)) = Just t + pickU (UserData v) = Just (Content.canonicalDataText v) pickU _ = Nothing flattenAssistant :: Vector AssistantContent -> Text diff --git a/src/Baikai/Response.hs b/src/Baikai/Response.hs --- a/src/Baikai/Response.hs +++ b/src/Baikai/Response.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | The provider response envelope. -- -- A 'Response' wraps the model's assistant payload ('message') with @@ -16,13 +18,14 @@ responseMessage, flattenAssistantBlocks, flattenAssistantText, + flattenAssistantData, responseError, errorResponse, ) where import Baikai.Api (Api (..)) -import Baikai.Content (AssistantContent (..), TextContent (..)) +import Baikai.Content (AssistantContent (..), DataContent, TextContent (..)) import Baikai.Error (BaikaiError, providerError) import Baikai.Error qualified as Error import Baikai.Evidence (ModelCallEvidence) @@ -139,3 +142,7 @@ errorInfo = Just err, evidence = Nothing } + +-- | Structured output blocks in content order, independent of call evidence. +flattenAssistantData :: Vector AssistantContent -> Vector DataContent +flattenAssistantData = V.mapMaybe (\case AssistantData d -> Just d; _ -> Nothing) diff --git a/src/Baikai/Response/JSON.hs b/src/Baikai/Response/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Response/JSON.hs @@ -0,0 +1,34 @@ +-- | Named full-response persistence, without global response/usage instances. +-- Decimal costs use the existing encoder's precision; arbitrary rationals +-- are not promised to round-trip exactly. Optional evidence is preserved. +module Baikai.Response.JSON (responseToJSON, responseFromJSON) where + +import Baikai.Internal.JSON (parseAssistant, parseEvidence) +import Baikai.Response (Response (..)) +import Data.Aeson +import Data.Aeson.Types (Parser) + +responseToJSON :: Response -> Value +responseToJSON r = + object $ + [ "message" .= message r, + "model" .= model r, + "api" .= api r, + "provider" .= provider r, + "responseId" .= responseId r, + "latencyMs" .= latencyMs r, + "errorInfo" .= errorInfo r + ] + <> maybe [] (\e -> ["evidence" .= e]) (evidence r) + +responseFromJSON :: Value -> Parser Response +responseFromJSON = withObject "Response" $ \o -> + Response + <$> (o .: "message" >>= parseAssistant) + <*> o .: "model" + <*> o .: "api" + <*> o .: "provider" + <*> o .:? "responseId" + <*> o .: "latencyMs" + <*> o .:? "errorInfo" + <*> (o .:? "evidence" >>= traverse parseEvidence) diff --git a/src/Baikai/ResponseFormat.hs b/src/Baikai/ResponseFormat.hs --- a/src/Baikai/ResponseFormat.hs +++ b/src/Baikai/ResponseFormat.hs @@ -36,7 +36,8 @@ -- | A named JSON Schema to enforce. -- -- The 'schema' is a raw JSON Schema document (an aeson 'Value'), passed --- through verbatim; baikai never inspects or validates it. 'strict' +-- through verbatim by generative providers. Judgment providers accept only the +-- closed-set subset compiled by 'Baikai.Judgment.compileJudgments'. 'strict' -- requests the provider's strict schema-enforcement mode where available -- (OpenAI honours it; Anthropic structured outputs are always -- schema-enforcing and ignore it). @@ -136,4 +137,5 @@ OpenAIResponses -> NativeJsonSchema AnthropicMessagesCli -> NativeJsonSchema OpenAICompletionsCli -> NativeJsonSchema + TypeSafeSystemOne -> NativeJsonSchema Custom _ -> NoStructuredOutput diff --git a/src/Baikai/Stream.hs b/src/Baikai/Stream.hs --- a/src/Baikai/Stream.hs +++ b/src/Baikai/Stream.hs @@ -39,6 +39,7 @@ import Baikai.Evidence (ModelCallEvidence) import Baikai.Evidence qualified as Evidence import Baikai.Evidence.Build qualified as Build +import Baikai.Internal.Data (recoverDataBlocks) import Baikai.Message (AssistantPayload (..), Message (AssistantMessage)) import Baikai.Message qualified as Msg import Baikai.Model (Model) @@ -56,6 +57,7 @@ import Baikai.Stream.Event ( AssistantMessageEvent (..), BlockEndPayload (..), + DataEndPayload (..), DeltaPayload (..), IndexPayload (..), StartPayload (..), @@ -273,6 +275,9 @@ i (AssistantThinking tc) & #thinkBuf %~ IntMap.delete i + DataStart _ -> s + DataEnd DataEndPayload {contentIndex = i, content = d} -> + s & #blocks %~ IntMap.insert i (AssistantData d) ToolCallStart IndexPayload {contentIndex = i} -> s & #toolArgsBuf %~ IntMap.insert i Text.empty ToolCallDelta DeltaPayload {contentIndex = i, delta = d} -> @@ -325,7 +330,7 @@ finalContent | not sawTerminal = assembled | Vector.null terminalContent = assembled - | terminalFailed = terminalContent <> Vector.fromList (IntMap.elems dangling) + | terminalFailed = recoverDataBlocks (s ^. #blocks) terminalContent <> Vector.fromList (IntMap.elems dangling) | otherwise = terminalContent message' = overrideBlocksAndReason terminalReason terminalMsg finalContent now latency = case (s ^. #skeleton >>= messageTimestamp, assistantPayloadTimestamp message') of @@ -545,6 +550,7 @@ ThinkingDelta DeltaPayload {contentIndex = i, delta = t}, ThinkingEnd ThinkingEndPayload {contentIndex = i, content = th} ] + AssistantData d -> [DataStart (IndexPayload i), DataEnd (DataEndPayload i d)] AssistantToolCall tc -> let argsText = Text.decodeUtf8 (BSL.toStrict (Aeson.encode (Content.arguments tc))) diff --git a/src/Baikai/Stream/Event.hs b/src/Baikai/Stream/Event.hs --- a/src/Baikai/Stream/Event.hs +++ b/src/Baikai/Stream/Event.hs @@ -33,6 +33,7 @@ ( AssistantMessageEvent (..), StartPayload (..), IndexPayload (..), + DataEndPayload (..), DeltaPayload (..), BlockEndPayload (..), ThinkingEndPayload (..), @@ -44,12 +45,14 @@ ) where -import Baikai.Content (ThinkingContent, ToolCall) +import Baikai.Content (DataContent, ThinkingContent, ToolCall) import Baikai.Error (BaikaiError) import Baikai.Evidence (ModelCallEvidence) +import Baikai.Internal.JSON (parseEvidence, parseMessage) import Baikai.Message (Message) import Baikai.StopReason (StopReason) -import Data.Aeson (ToJSON) +import Data.Aeson +import Data.Aeson.Types (Parser) import Data.Text (Text) import GHC.Generics (Generic) @@ -92,6 +95,8 @@ -- carries the full 'ThinkingContent', including provider -- signature and redacted flag when available. ThinkingEnd ThinkingEndPayload + | DataStart IndexPayload + | DataEnd DataEndPayload | -- | A tool-call content block is about to receive argument-JSON -- chunks. The tool's @id_@ and @name@ become known on this event -- when the upstream API delivers them up front (Anthropic), or on @@ -172,6 +177,14 @@ deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) +-- | Atomic structured block; there are no incremental data deltas. +data DataEndPayload = DataEndPayload + { contentIndex :: !Int, + content :: !DataContent + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON) + -- | Payload of 'ToolCallEnd': the fully parsed 'toolCall'. data ToolCallEndPayload = ToolCallEndPayload { contentIndex :: !Int, @@ -257,3 +270,48 @@ EventDone {} -> True EventError {} -> True _ -> False + +instance FromJSON IndexPayload where parseJSON = genericParseJSON defaultOptions + +instance FromJSON DeltaPayload where parseJSON = genericParseJSON defaultOptions + +instance FromJSON BlockEndPayload where parseJSON = genericParseJSON defaultOptions + +instance FromJSON ThinkingEndPayload where parseJSON = genericParseJSON defaultOptions + +instance FromJSON ToolCallEndPayload where parseJSON = genericParseJSON defaultOptions + +instance FromJSON DataEndPayload where parseJSON = genericParseJSON defaultOptions + +instance FromJSON StartPayload where + parseJSON = withObject "StartPayload" $ \o -> StartPayload <$> (o .: "partial" >>= parseMessage) <*> o .:? "responseId" + +instance FromJSON TerminalPayload where + parseJSON = withObject "TerminalPayload" $ \o -> + TerminalPayload + <$> o .: "reason" + <*> (o .: "message" >>= parseMessage) + <*> o .:? "responseId" + <*> o .:? "errorInfo" + <*> (o .:? "evidence" >>= traverse parseEvidence) + +instance FromJSON AssistantMessageEvent where + parseJSON = withObject "AssistantMessageEvent" $ \o -> do + tag <- o .: "tag" :: Parser Text + v <- o .: "contents" + case tag of + "EventStart" -> EventStart <$> parseJSON v + "TextStart" -> TextStart <$> parseJSON v + "TextDelta" -> TextDelta <$> parseJSON v + "TextEnd" -> TextEnd <$> parseJSON v + "ThinkingStart" -> ThinkingStart <$> parseJSON v + "ThinkingDelta" -> ThinkingDelta <$> parseJSON v + "ThinkingEnd" -> ThinkingEnd <$> parseJSON v + "ToolCallStart" -> ToolCallStart <$> parseJSON v + "ToolCallDelta" -> ToolCallDelta <$> parseJSON v + "ToolCallEnd" -> ToolCallEnd <$> parseJSON v + "DataStart" -> DataStart <$> parseJSON v + "DataEnd" -> DataEnd <$> parseJSON v + "EventDone" -> EventDone <$> parseJSON v + "EventError" -> EventError <$> parseJSON v + _ -> fail "unknown assistant event tag" diff --git a/src/Baikai/Trace.hs b/src/Baikai/Trace.hs --- a/src/Baikai/Trace.hs +++ b/src/Baikai/Trace.hs @@ -70,22 +70,25 @@ -- does 'Baikai.Trace.Event.TraceEvent'. They mean different things and -- both belong in this module, so the status constructors stay behind -- the @Evidence.@ qualifier. + +import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Evidence ( ModelCallEvidence, newCallId, ) import Baikai.Evidence qualified as Evidence import Baikai.Evidence.Build qualified as Build +import Baikai.Internal.Data (recoverDataBlocks) import Baikai.Message (AssistantPayload (..), Message (..)) import Baikai.Model (Model) import Baikai.Options (Options) import Baikai.Prelude import Baikai.Provider.Registry (ProviderRegistry, globalProviderRegistry) import Baikai.Provider.Registry qualified as Registry -import Baikai.Response (Response) +import Baikai.Response (Response, flattenAssistantData) import Baikai.StopReason (StopReason (ErrorReason)) import Baikai.Stream (reassembleResponse, streamRequestWith) -import Baikai.Stream.Event (AssistantMessageEvent (..), TerminalPayload (..)) +import Baikai.Stream.Event (AssistantMessageEvent (..), BlockEndPayload (..), DataEndPayload (..), TerminalPayload (..), ThinkingEndPayload (..), ToolCallEndPayload (..)) import Baikai.Trace.Event (TraceEvent (..)) import Baikai.Trace.Sink (TraceSink (..)) import Baikai.Usage (Usage) @@ -97,8 +100,10 @@ import Control.Monad (forM_, unless, void) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.IntMap.Strict qualified as IntMap import Data.Maybe (fromMaybe, isJust) import Data.Time (UTCTime, diffUTCTime, getCurrentTime) +import Data.Vector qualified as V import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream @@ -218,6 +223,7 @@ closed :: !(IORef Bool), sinkError :: !(IORef (Maybe SomeException)), terminalSent :: !(IORef Bool), + dataBlocks :: !(IORef (IntMap.IntMap AssistantContent)), stableRoot :: !(IORef (Maybe (StablePtr TraceState))) } deriving stock (Generic) @@ -229,8 +235,9 @@ r <- newIORef False e <- newIORef Nothing t <- newIORef False + dat <- newIORef IntMap.empty root <- newIORef Nothing - let state = TraceState {chan = c, done = d, closed = r, sinkError = e, terminalSent = t, stableRoot = root} + let state = TraceState {chan = c, done = d, closed = r, sinkError = e, terminalSent = t, dataBlocks = dat, stableRoot = root} sp <- newStablePtr state writeIORef root (Just sp) pure state @@ -276,6 +283,7 @@ costBasis = Nothing, usageAvailability = Nothing, usd = Nothing, + structuredData = Nothing, errorMessage = abortText } -- The consumer stopped before the terminal event, so no adapter @@ -482,7 +490,25 @@ AssistantMessageEvent -> IO AssistantMessageEvent traceEvent reg state eid start m opts ev = do + let remember i block = atomicModifyIORef' (state ^. #dataBlocks) (\old -> (IntMap.insert i block old, ())) case ev of + DataEnd DataEndPayload {contentIndex = i, content = d} -> remember i (AssistantData d) + TextEnd BlockEndPayload {contentIndex = i, content = t} -> remember i (AssistantText (TextContent t)) + ThinkingEnd ThinkingEndPayload {contentIndex = i, content = t} -> remember i (AssistantThinking t) + ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = t} -> remember i (AssistantToolCall t) + _ -> pure () + closed <- readIORef (state ^. #dataBlocks) + let dataFor failed msg = case msg of + AssistantMessage p -> + let blocks = p ^. #content + recovered + | V.null blocks = V.fromList (IntMap.elems closed) + | failed = recoverDataBlocks closed blocks + | otherwise = blocks + ds = flattenAssistantData recovered + in if V.null ds then Nothing else Just ds + _ -> Nothing + case ev of EventDone TerminalPayload {message = msg, evidence = mev} -> do now <- getCurrentTime let latency = millisBetween start now @@ -513,6 +539,7 @@ -- common case rather than a corner. costBasis = mu >>= Cost.nonEmptyBasis . Usage.cost, usageAvailability = mu >>= Usage.availability, + structuredData = dataFor False msg, usd = fmap (usdAsScientific . Usage.cost) mu } -- Evidence goes out *before* the terminal, so a sink that keys @@ -549,6 +576,7 @@ totalTokens = fmap Usage.totalTokens mu, costBasis = mu >>= Cost.nonEmptyBasis . Usage.cost, usageAvailability = mu >>= Usage.availability, + structuredData = dataFor True msg, usd = fmap (usdAsScientific . Usage.cost) mu, errorMessage = errMsg } @@ -634,6 +662,7 @@ -- zero. usd = fmap (usdAsScientific . Usage.cost) mu, latencyMs = resp ^. #latencyMs, + structuredData = let ds = flattenAssistantData ((resp ^. #message) ^. #content) in if V.null ds then Nothing else Just ds, promptSummary = summarizeContext ctx } appendEntry h entry diff --git a/src/Baikai/Trace/Event.hs b/src/Baikai/Trace/Event.hs --- a/src/Baikai/Trace/Event.hs +++ b/src/Baikai/Trace/Event.hs @@ -15,6 +15,7 @@ ) where +import Baikai.Content (DataContent) import Baikai.Cost (CostBasis) import Baikai.Evidence (ModelCallEvidence) import Baikai.Usage (UsageAvailability) @@ -34,6 +35,7 @@ import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (UTCTime) +import Data.Vector (Vector) import GHC.Generics (Generic) import Numeric.Natural (Natural) @@ -87,7 +89,8 @@ totalTokens :: !(Maybe Natural), costBasis :: !(Maybe CostBasis), usageAvailability :: !(Maybe UsageAvailability), - usd :: !(Maybe Scientific) + usd :: !(Maybe Scientific), + structuredData :: !(Maybe (Vector DataContent)) } | CallFailed { eventId :: !Text, @@ -104,6 +107,7 @@ costBasis :: !(Maybe CostBasis), usageAvailability :: !(Maybe UsageAvailability), usd :: !(Maybe Scientific), + structuredData :: !(Maybe (Vector DataContent)), errorMessage :: !Text } | -- | The complete evidence record for one terminal provider call. @@ -198,6 +202,7 @@ <*> d .:? "costBasis" <*> d .:? "usageAvailability" <*> d .:? "usd" + <*> d .:? "structuredData" "call_failed" -> CallFailed <$> d .: "eventId" @@ -214,6 +219,7 @@ <*> d .:? "costBasis" <*> d .:? "usageAvailability" <*> d .:? "usd" + <*> d .:? "structuredData" <*> d .: "errorMessage" "call_evidence" -> fail diff --git a/test/CostSpec.hs b/test/CostSpec.hs --- a/test/CostSpec.hs +++ b/test/CostSpec.hs @@ -280,6 +280,7 @@ cacheWriteTokens = Nothing, costBasis = Nothing, usageAvailability = Nothing, + structuredData = Nothing, usd = Nothing, latencyMs = 0, promptSummary = "" diff --git a/test/DataContentSpec.hs b/test/DataContentSpec.hs new file mode 100644 --- /dev/null +++ b/test/DataContentSpec.hs @@ -0,0 +1,146 @@ +module DataContentSpec (tests) where + +import Baikai +import Baikai.Cost.Log qualified as Log +import Baikai.Evidence.Build qualified +import Baikai.Prelude +import Baikai.Trace (runRequestWithRegistry, withTraceWith) +import Baikai.Trace.Event qualified as T +import Baikai.Trace.Sink qualified as Sink +import Control.Monad (forM_) +import Data.Aeson qualified as A +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (parseEither) +import Data.ByteString.Lazy qualified as BL +import Data.Either (isLeft) +import Data.Map.Strict qualified as Map +import Data.Ratio ((%)) +import Data.Text qualified as Text +import Data.Vector qualified as V +import Streamly.Data.Stream qualified as S +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +sample :: DataContent +sample = + DataContent + (A.object ["urgent" A..= True, "category" A..= ("technical" :: Text.Text), "severity" A..= (2 :: Int)]) + (Just (Map.fromList [("urgent", Map.fromList [("true", 0.8), ("false", 0.2)]), ("category", Map.fromList [("billing", 0.2), ("technical", 0.7)]), ("severity", Map.fromList [("0", 0), ("1", 0.1), ("2", 1)])])) + (Just (Map.fromList [("category", 0.7), ("severity", 0.9)])) + (Just "provider_classification") + +payload :: AssistantPayload +payload = (emptyResponse ^. #message) & #content .~ V.fromList [AssistantText (TextContent "before"), AssistantData sample, AssistantText (TextContent "after")] + +modelFixture :: Model +modelFixture = emptyModel & #api .~ Custom "data-fixture" & #provider .~ "data-fixture" + +responseFixture :: Response +responseFixture = emptyResponse & #message . #usage . #cost .~ (zeroCost & #usd .~ (3 % 10) & #breakdown . #inputUsd .~ (3 % 10)) & #model .~ modelFixture & #api .~ Custom "data-fixture" & #message .~ (payload & #usage . #cost .~ (zeroCost & #usd .~ (3 % 10) & #breakdown . #inputUsd .~ (3 % 10))) + +-- Deliberately leave the error terminal empty to exercise closed-block recovery. +events :: Bool -> [AssistantMessageEvent] +events failed = + [ EventStart (StartPayload (assistant "") Nothing), + TextStart (IndexPayload 0), + TextEnd (BlockEndPayload 0 "before"), + DataStart (IndexPayload 1), + DataEnd (DataEndPayload 1 sample), + TextStart (IndexPayload 2), + TextEnd (BlockEndPayload 2 "after") + ] + <> [ if failed + then EventError (errorTerminal Nothing Nothing ErrorReason (assistant "") (providerError "failed")) + else EventDone (doneTerminal Nothing Nothing Stop (AssistantMessage payload)) + ] + +tests :: TestTree +tests = + testGroup + "structured content" + [ testCase "data, scalar inputs and typed refusals round-trip" $ do + A.eitherDecode (A.encode (AssistantData sample)) @?= Right (AssistantData sample) + forM_ [A.Null, A.Bool True, A.String "日本語", A.toJSON ([1, 2] :: [Int]), value sample] $ \v -> do + A.eitherDecode (A.encode (UserData v)) @?= Right (UserData v) + let ctx = contextOf [userData v] + Log.summarizeContext ctx @?= Text.take 200 (canonicalDataText v) + forM_ [unsupportedFeature "messages[0].content[1]" "cannot replay", unsupportedModel "unknown" "not supported"] $ \e -> do + A.eitherDecode (A.encode e) @?= Right e + isRetryable e @?= False, + testCase "invalid individual probabilities/confidences fail without normalizing totals" $ do + forM_ ["probabilities", "confidence"] $ \key -> + forM_ [A.toJSON (-0.1 :: Double), A.toJSON (1.1 :: Double), A.String "bad", A.Null, A.Number 1e10000] $ \bad -> do + let v = A.object ["value" A..= A.Null, key A..= if key == "probabilities" then A.object ["field" A..= A.object ["x" A..= bad]] else A.object ["field" A..= bad]] + assertBool "invalid numeric evidence rejected" (isLeft (parseEither A.parseJSON v :: Either String DataContent)) + A.eitherDecode (A.encode sample) @?= Right sample, + testCase "atomic events serialize and retain mixed blocks on success and failure" $ do + forM_ [False, True] $ \failed -> do + let es = events failed + A.eitherDecode (A.encode es) @?= Right es + r <- S.fold (reassembleResponse modelFixture) (S.fromList es) + (r ^. #message) ^. #content @?= payload ^. #content + r2 <- S.fold (reassembleResponse modelFixture) (S.fromList (es <> [EventDone (doneTerminal Nothing Nothing Stop (assistant "overwrite"))])) + r2 ^. #message @?= r ^. #message + r <- S.fold (reassembleResponse modelFixture) (S.fromList [DataStart (IndexPayload 0)]) + flattenAssistantData ((r ^. #message) ^. #content) @?= V.empty, + testCase "gapped data indices are not duplicated and partial failure terminals recover all data" $ do + let first = sample + second = sample & #method .~ Just "second" + finalOne = (emptyResponse ^. #message) & #content .~ V.singleton (AssistantData first) + terminal = EventError (errorTerminal Nothing Nothing ErrorReason (AssistantMessage finalOne) (providerError "partial terminal")) + es = [DataStart (IndexPayload 2), DataEnd (DataEndPayload 2 first)] + r <- S.fold (reassembleResponse modelFixture) (S.fromList (es <> [terminal])) + flattenAssistantData (r ^. #message . #content) @?= V.singleton first + let both = es <> [DataStart (IndexPayload 5), DataEnd (DataEndPayload 5 second), terminal] + r2 <- S.fold (reassembleResponse modelFixture) (S.fromList both) + flattenAssistantData (r2 ^. #message . #content) @?= V.fromList [first, second] + reg <- newProviderRegistry + let stream _ _ _ = S.fromList both + registerApiProviderWith reg (apiProviderWith (Custom "data-fixture") stream (streamingComplete stream)) + withSystemTempDirectory "baikai-gapped-data" $ \dir -> do + sink <- Sink.fileSink (dir "trace.jsonl") + _ <- withTraceWith reg sink modelFixture emptyContext emptyOptions + bytes <- BL.readFile (dir "trace.jsonl") + ts <- either assertFailure pure (traverse A.eitherDecode (filter (not . BL.null) (BL.split 10 bytes)) :: Either String [T.TraceEvent]) + [ds | T.CallFailed {T.structuredData = ds} <- ts] @?= [Just (V.fromList [first, second])], + testCase "named response bytes, optional evidence and response commitments" $ do + ev <- Baikai.Evidence.Build.minimalEvidence modelFixture (emptyOptions & #evidence .~ Just (evidenceRequest "data-test")) TransportHttpApi noThinkingRequested (A.object []) (read "2026-10-25 00:00:00 UTC") (read "2026-10-25 00:00:01 UTC") CallSucceeded Nothing + forM_ [responseFixture, responseFixture & #evidence .~ fmap (\e -> e & #usage .~ Observed (responseFixture ^. #message . #usage)) ev, responseFixture & #errorInfo .~ Just (unsupportedFeature "x" "refused") & #message . #stopReason .~ ErrorReason] $ \r -> do + let encoded = responseToJSON r + case parseEither responseFromJSON encoded of + Left e -> assertFailure e + Right decoded -> do + canonicalEncode (responseToJSON decoded) @?= canonicalEncode encoded + flattenAssistantData ((decoded ^. #message) ^. #content) @?= V.singleton sample + let cached = case encoded of A.Object o -> A.Object (KM.delete "evidence" o); v -> v + fmap (flattenAssistantData . (^. #content) . (^. #message)) (parseEither responseFromJSON cached) @?= Right (V.singleton sample) + let changed = sample {method = Just "another"} + assertBool "probability is committed" (commitmentDigest (A.toJSON sample) /= commitmentDigest (A.toJSON (sample & #probabilities .~ Just Map.empty))) + assertBool "method is committed" (commitmentDigest (A.toJSON sample) /= commitmentDigest (A.toJSON changed)), + testCase "file trace and both call-log entry points preserve data without evidence opt-in" $ + withSystemTempDirectory "baikai-data" $ \dir -> + forM_ [False, True] $ \failed -> do + reg <- newProviderRegistry + let stream _ _ _ = S.fromList (events failed) + registerApiProviderWith reg (apiProviderWith (Custom "data-fixture") stream (streamingComplete stream)) + let tracePath = dir (if failed then "failed-trace.jsonl" else "trace.jsonl") + logPath = dir (if failed then "failed-log.jsonl" else "log.jsonl") + sink <- Sink.fileSink tracePath + Log.withCallLog (Log.callLogConfig logPath) $ \h -> do + _ <- runRequestWithRegistry reg sink h modelFixture emptyContext emptyOptions + _ <- Log.runRequestWithLogWith reg h modelFixture emptyContext emptyOptions + pure () + traceBytes <- BL.readFile tracePath + let decodedTrace = traverse A.eitherDecode (filter (not . BL.null) (BL.split 10 traceBytes)) :: Either String [T.TraceEvent] + case decodedTrace of + Right ts -> case [ds | T.CallFinished {T.structuredData = ds} <- ts] <> [ds | T.CallFailed {T.structuredData = ds} <- ts] of + [ds] -> ds @?= Just (V.singleton sample) + _ -> assertFailure "expected one terminal" + Left e -> assertFailure e + logBytes <- BL.readFile logPath + case traverse A.eitherDecode (filter (not . BL.null) (BL.split 10 logBytes)) :: Either String [Log.CallLogEntry] of + Right entries -> map (\e -> e ^. #structuredData) entries @?= replicate 2 (Just (V.singleton sample)) + Left e -> assertFailure e + ] diff --git a/test/EvidenceSpec.hs b/test/EvidenceSpec.hs --- a/test/EvidenceSpec.hs +++ b/test/EvidenceSpec.hs @@ -271,7 +271,7 @@ testGroup "usage envelope" [ testCase "cost basis is serialized additively without changing provider commitments" $ do - evidenceSchemaVersion @?= "baikai.model-call-evidence/2.5" + evidenceSchemaVersion @?= "baikai.model-call-evidence/2.6" let estimated = zeroUsage {cost = estimateCost [CacheWriteUsageNotReported] zeroCost} usageEnvelope estimated @?= usageEnvelope zeroUsage assertBool "usage JSON retains the local calculation basis" (Aeson.toJSON estimated /= Aeson.toJSON zeroUsage), diff --git a/test/FetchModelsSpec.hs b/test/FetchModelsSpec.hs --- a/test/FetchModelsSpec.hs +++ b/test/FetchModelsSpec.hs @@ -6,6 +6,7 @@ import Baikai.Compat (AnthropicThinkingStyle (..), defaultOpenAIResponsesCompat) import Baikai.Model (InputModality (..)) +import Baikai.Model qualified import Baikai.Model qualified as Model import Baikai.Prelude import Control.Monad (forM_) @@ -59,6 +60,7 @@ name = "GPT-5 Nano", reasoning = True, input = [InputText, InputImage], + outputKind = Baikai.Model.GenerativeOutput, cost = CatalogCost 0.05 0.4 0 0, fastModeCost = Nothing, pricingPolicy = Nothing, @@ -72,6 +74,7 @@ name = "GPT-5.4", reasoning = True, input = [InputText, InputImage], + outputKind = Baikai.Model.GenerativeOutput, cost = CatalogCost 2.5 15 0.25 0, fastModeCost = Nothing, pricingPolicy = Nothing, @@ -98,6 +101,7 @@ name = "Claude Opus 4.5", reasoning = True, input = [InputText, InputImage], + outputKind = Baikai.Model.GenerativeOutput, cost = CatalogCost 5 25 1.5 6.25, fastModeCost = Nothing, pricingPolicy = Nothing, @@ -238,6 +242,7 @@ name = nameWithControls, reasoning = False, input = [InputText], + outputKind = Baikai.Model.GenerativeOutput, cost = CatalogCost 0 0 0 0, fastModeCost = Nothing, pricingPolicy = Nothing, diff --git a/test/GenModelsSpec.hs b/test/GenModelsSpec.hs --- a/test/GenModelsSpec.hs +++ b/test/GenModelsSpec.hs @@ -9,6 +9,7 @@ thinkingStyle, ) import Baikai.Model (InputModality (InputText)) +import Baikai.Model qualified import Control.Monad (forM_) import Data.Aeson qualified as Aeson import Data.Text (Text) @@ -127,6 +128,7 @@ entryName = mid, entryReasoning = False, entryInput = [InputText], + entryOutputKind = Baikai.Model.GenerativeOutput, entryCost = CostEntry { costInput = 0, diff --git a/test/JudgmentSpec.hs b/test/JudgmentSpec.hs new file mode 100644 --- /dev/null +++ b/test/JudgmentSpec.hs @@ -0,0 +1,151 @@ +module JudgmentSpec (tests) where + +import Baikai hiding (confidence, format, kind, name, probabilities) +import Baikai.Judgment qualified as J +import Baikai.Models.Generated qualified as Models +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (forM_) +import Data.Aeson qualified as A +import Data.Aeson.Key qualified +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as BL +import Data.Either (isLeft) +import Data.Generics.Labels () +import Data.Map.Strict qualified as M +import Data.Text (Text) +import Data.Text qualified +import Data.Vector qualified as V +import FetchModelsCore qualified as F +import GenModelsCore qualified as G +import Test.Tasty +import Test.Tasty.HUnit + +schemaFixture :: A.Value +schemaFixture = + A.object + [ "type" A..= ("object" :: Text), + "additionalProperties" A..= False, + "required" A..= (["urgent", "category", "severity"] :: [Text]), + "properties" + A..= A.object + [ "urgent" A..= A.object ["type" A..= ("boolean" :: Text), "description" A..= ("Is service blocked?" :: Text)], + "category" A..= branches [A.String "billing", A.String "technical"] [A.String "Payment issue", A.String "Product malfunction"] "Classify the issue.", + "severity" A..= branches (map A.toJSON [0 :: Int, 1, 2]) (map A.String ["Minor", "Disruptive", "Blocking"]) "Rate impact." + ] + ] + +branches :: [A.Value] -> [A.Value] -> Text -> A.Value +branches vs ds instr = A.object ["description" A..= instr, "anyOf" A..= [A.object ["const" A..= v, "description" A..= d] | (v, d) <- zip vs ds]] + +format :: A.Value -> JsonSchemaFormat +format = jsonSchemaFormat "judgments" + +opts :: Options +opts = emptyOptions & #responseFormat .~ Just (JsonSchema (format schemaFixture)) + +ctx :: Context +ctx = contextOf [userData (A.object ["ticket" A..= ("Checkout is unavailable." :: Text)])] + +answers :: M.Map Text JudgmentAnswer +answers = + M.fromList + [ ("urgent", PredicateAnswer 0.83), + ("category", ChoiceAnswer "technical" (M.fromList [("billing", 0.2), ("technical", 0.7)]) (Just 0.65)), + ("severity", ScoreAnswer (Just 1.5) (M.fromList [("0", 0.1), ("1", 0.3), ("2", 0.6)]) (Just 0.55)) + ] + +withProperty :: A.Value -> A.Value +withProperty v = A.object ["type" A..= ("object" :: Text), "properties" A..= A.object ["x" A..= v]] + +enum :: [A.Value] -> A.Value +enum vs = A.object ["enum" A..= vs] + +compiled :: IO Judgments +compiled = either (assertFailure . show) pure (compileJudgments (format schemaFixture)) + +assertPath :: Text -> Either BaikaiError a -> IO () +assertPath p r = case r of + Left e -> e ^. #requestProblem @?= Just (UnsupportedFeature p) + Right _ -> assertFailure "expected refusal" + +tests :: TestTree +tests = + testGroup + "neutral judgments" + [ testCase "fetch render preserves curated judgment output and data modality" $ do + let m = F.CatalogModel "jev-latest" "Jev" False [InputText, InputData] JudgmentOutput (F.CatalogCost 0 0 0 0) Nothing Nothing 0 0 Nothing Nothing + c = F.Catalog "typesafe" "https://api.typesafe.ai" "typesafe-system-one" [m] + case A.eitherDecode (BL.fromStrict (F.renderCatalog c)) :: Either String G.CatalogFile of + Left e -> assertFailure e + Right catalog -> case G.flattenEntries catalog of + [(_, g)] -> do G.outputKind g @?= JudgmentOutput; G.input g @?= [InputText, InputData] + _ -> assertFailure "one model required", + testCase "catalog facts and generative legacy default" $ do + forM_ [Models.typesafe_jev_latest, Models.typesafe_jev_preview] $ \m -> do + isJudgmentOnly m @?= True + m ^. #api @?= TypeSafeSystemOne + m ^. #input @?= [InputText, InputData] + A.eitherDecode (A.encode m) @?= Right m + forM_ Models.allModels $ \m -> isJudgmentOnly m @?= (m ^. #provider == "typesafe") + let old = case A.toJSON emptyModel of A.Object o -> A.Object (KM.delete "outputKind" o); v -> v + fmap (^. #outputKind) ((A.fromJSON old :: A.Result Model)) @?= A.Success GenerativeOutput, + testCase "ordered fixture with exact instructions and criteria; deterministic fallback" $ do + js <- compiled + V.toList (judgmentList js) + @?= [ Judgment "urgent" (A.String "Is service blocked?") (PredicateJudgment Nothing), + Judgment "category" (A.String "Classify the issue.") (ChoiceJudgment (V.fromList [("billing", Just (A.String "Payment issue")), ("technical", Just (A.String "Product malfunction"))])), + Judgment "severity" (A.String "Rate impact.") (ScoreJudgment (V.fromList (map (Just . A.String) ["Minor", "Disruptive", "Blocking"]))) + ] + let noRequired = case schemaFixture of A.Object o -> A.Object (KM.delete "required" o); v -> v + fallback <- either (assertFailure . show) pure (compileJudgments (format noRequired)) + map (^. #name) (V.toList (judgmentList fallback)) @?= ["category", "severity", "urgent"], + testCase "predicate criteria and neutral non-string content are preserved" $ do + forM_ [A.String "", A.Bool False, A.Number 0, A.object [], A.toJSON ([] :: [Int])] $ \d -> do + let p = A.object ["description" A..= d, "oneOf" A..= [A.object ["const" A..= False, "description" A..= ("no" :: Text)], A.object ["const" A..= True, "description" A..= ("yes" :: Text)]]] + js <- either (assertFailure . show) pure (compileJudgments (format (withProperty p))) + lookupJudgment "x" js @?= Just (Judgment "x" d (PredicateJudgment (Just (A.String "yes", A.String "no")))), + testCase "all unsupported schema shapes and boundary sizes" $ do + forM_ [A.object [], A.object ["type" A..= ("string" :: Text)], A.object ["type" A..= ("object" :: Text)], enum [], enum [A.String "x", A.String "x"], enum [A.Bool True, A.String "x"], enum (map A.toJSON [0 :: Int, 2]), enum (map A.toJSON [1 :: Int, 2, 3]), enum [A.Number 0], enum (map A.toJSON [0 :: Int .. 10]), enum [A.Number 0, A.Number 1.5], A.object ["allOf" A..= ([] :: [Int])], A.object ["anyOf" A..= [A.object []]], A.object ["type" A..= ("boolean" :: Text), "enum" A..= [A.String "x"]]] $ \p -> + assertBool (show p) (isLeft (compileJudgments (format (withProperty p)))) + forM_ [1, 255] $ \n -> assertBool "choice boundary accepted" (not (isLeft (compileJudgments (format (withProperty (enum [A.String (fromString (show i)) | i <- [1 .. n :: Int]])))))) + forM_ [2, 10] $ \n -> assertBool "score boundary accepted" (not (isLeft (compileJudgments (format (withProperty (enum (map A.toJSON [0 .. n - 1 :: Int]))))))) + assertPath "Options.responseFormat.schema.properties.x" (compileJudgments (format (withProperty (enum [A.String (fromString (show i)) | i <- [1 .. 256 :: Int]])))) + forM_ [("required", A.toJSON (["missing"] :: [Text])), ("additionalProperties", A.Bool True), ("$ref", A.String "#defs/x")] $ \(k, v) -> do + let s = case schemaFixture of A.Object o -> A.Object (KM.insert k v o); x -> x + assertPath ("Options.responseFormat.schema." <> fromString (showKey k)) (compileJudgments (format s)), + testCase "every explicit generation control is refused by path" $ do + let controls = [("maxTokens", opts & #maxTokens .~ Just 1), ("temperature", opts & #temperature .~ Just 0), ("topP", opts & #topP .~ Just 1), ("stopSequences", opts & #stopSequences .~ ["x"]), ("seed", opts & #seed .~ Just 1), ("frequencyPenalty", opts & #frequencyPenalty .~ Just 0), ("presencePenalty", opts & #presencePenalty .~ Just 0), ("thinking", opts & #thinking .~ Just ThinkingLow), ("cacheRetention", opts & #cacheRetention .~ Just CacheRetentionShort), ("speed", opts & #speed .~ Just SpeedStandard)] + forM_ controls $ \(field, o) -> assertPath ("Options." <> field) (prepareJudgment ctx o) + forM_ [ToolChoiceAuto, ToolChoiceNone, ToolChoiceRequired, ToolChoiceSpecific "x"] $ \choice -> assertPath "Options.toolChoice" (prepareJudgment ctx (opts & #toolChoice .~ Just choice)) + assertBool "explicit no caching accepted" (not (isLeft (prepareJudgment ctx (opts & #cacheRetention .~ Just CacheRetentionNone)))), + testCase "context checks precede option and schema checks" $ do + assertPath "Context.systemPrompt" (prepareJudgment (ctx & #systemPrompt .~ Just "") emptyOptions) + forM_ [contextOf [], contextOf [user "x", user "y"]] $ \c -> assertPath "Context.messages" (prepareJudgment c opts) + assertPath "Context.messages[0]" (prepareJudgment (contextOf [assistant "x"]) opts) + assertPath "Context.messages[0]" (prepareJudgment (contextOf [toolResult "call" "tool" "result" False]) opts) + assertPath "Context.tools" (prepareJudgment (ctx & #tools .~ V.singleton emptyTool) opts) + forM_ [emptyOptions, emptyOptions & #responseFormat .~ Just JsonObject] $ \o -> assertPath "Options.responseFormat" (prepareJudgment ctx o), + testCase "complete data preserves provider selection, expected score and non-normalized probabilities" $ do + js <- compiled + d <- either (assertFailure . show) pure (validateAnswers js answers) + d ^. #value @?= A.object ["urgent" A..= True, "category" A..= ("technical" :: Text), "severity" A..= (1.5 :: Double)] + d ^. #confidence @?= Just (M.fromList [("category", 0.65), ("severity", 0.55)]) + A.eitherDecode (A.encode d) @?= Right d + let other = M.insert "category" (ChoiceAnswer "billing" (M.fromList [("billing", 0.2), ("technical", 0.7)]) Nothing) answers + selected <- either (assertFailure . show) pure (validateAnswers js other) + case selected ^. #value of A.Object o -> KM.lookup "category" o @?= Just (A.String "billing"); _ -> assertFailure "object required" + tied <- either (assertFailure . show) pure (validateAnswers js (M.insert "severity" (ScoreAnswer Nothing (M.fromList [("0", 0.5), ("1", 0.5), ("2", 0)]) Nothing) answers)) + case tied ^. #value of A.Object o -> KM.lookup "severity" o @?= Just (A.Number 0); _ -> assertFailure "object required", + testCase "malformed answer names, kinds, distributions, selected labels and numeric evidence" $ do + js <- compiled + forM_ [M.delete "urgent" answers, M.insert "extra" (PredicateAnswer 0.5) answers, M.insert "category" (PredicateAnswer 0.5) answers, M.insert "category" (ChoiceAnswer "other" (M.fromList [("billing", 0.2), ("technical", 0.7)]) Nothing) answers, M.insert "category" (ChoiceAnswer "billing" M.empty Nothing) answers] $ \as -> + case validateAnswers js as of Left e -> e ^. #category @?= DecodeFailure; Right _ -> assertFailure "expected failure" + forM_ [-0.1, 1.1, 1 / 0, 0 / 0] $ \bad -> forM_ [M.insert "urgent" (PredicateAnswer bad) answers, M.insert "category" (ChoiceAnswer "billing" (M.fromList [("billing", 0.2), ("technical", 0.7)]) (Just bad)) answers] $ \as -> + case validateAnswers js as of Left e -> e ^. #category @?= DecodeFailure; Right _ -> assertFailure "expected numeric failure" + case validateAnswers js (M.insert "urgent" (RefusedAnswer (Just "policy")) answers) of + Left e -> do e ^. #category @?= ContentFiltered; e ^. #refusalCategory @?= Just "policy" + Right _ -> assertFailure "refusal required" + ] + where + fromString = Data.Text.pack + showKey = Data.Aeson.Key.toString diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -23,6 +23,7 @@ import Data.Proxy (Proxy (..)) import Data.Text qualified as Text import Data.Vector qualified as V +import DataContentSpec qualified import EmbeddingSpec qualified import ErrorInfoSpec qualified import ErrorSpec qualified @@ -32,6 +33,7 @@ import GenModelsSpec qualified import HelpersSpec qualified import InteractiveSpec qualified +import JudgmentSpec qualified import PricingPolicySpec qualified import PublicSurfaceSpec qualified import StreamSpec qualified @@ -112,6 +114,7 @@ CliInternalSpec.tests, CliProcessSpec.tests, ContextSpec.tests, + DataContentSpec.tests, CostSpec.tests, EmbeddingSpec.tests, ErrorInfoSpec.tests, @@ -121,6 +124,7 @@ GenModelsSpec.tests, HelpersSpec.tests, InteractiveSpec.tests, + JudgmentSpec.tests, PricingPolicySpec.tests, PublicSurfaceSpec.tests, StreamSpec.tests, diff --git a/test/TraceSpec.hs b/test/TraceSpec.hs --- a/test/TraceSpec.hs +++ b/test/TraceSpec.hs @@ -1240,6 +1240,7 @@ totalTokens = Just 26, costBasis = Nothing, usageAvailability = Nothing, + structuredData = Nothing, usd = Just 0 } @@ -1259,6 +1260,7 @@ totalTokens = Nothing, costBasis = Nothing, usageAvailability = Nothing, + structuredData = Nothing, usd = Nothing, errorMessage = "boom" }