diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,24 @@ ## Unreleased +## 0.3.0.3 — 2026-08-29 + +### Changed + +- Every library dependency now carries a PVP upper bound: `aeson`, + `base64-bytestring`, `bytestring`, `containers`, `effectful`, `filepath`, + `generic-lens`, `scientific`, `stm`, `time`, `vector`. `cabal check` reported + these under `missing-upper-bounds`. Without one, a future breaking release of + a dependency enters a consumer's build plan unchecked — which is the failure + the bound exists to prevent. + + Each bound admits the version this package is built and tested against and + stops below the next major. + + `aeson` stops at `<2.3` rather than `<2.4`: baikai-openai 0.5 constrains it to + `^>=2.2`, so aeson 2.3 is not reachable for this cohort and a wider bound + would assert compatibility that cannot be exercised here. + ## 0.3.0.2 — 2026-08-07 ### Changed diff --git a/shikumi.cabal b/shikumi.cabal --- a/shikumi.cabal +++ b/shikumi.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: shikumi -version: 0.3.0.2 +version: 0.3.0.3 synopsis: Typed, structured, evaluable LM programs over baikai category: AI description: @@ -52,24 +52,24 @@ Shikumi.Stream build-depends: - , aeson - , baikai >=0.5 && <0.6 - , baikai-claude >=0.5 && <0.6 - , baikai-effectful >=0.3.0.3 && <0.4 - , baikai-openai >=0.5 && <0.6 - , base >=4.20 && <5 - , base64-bytestring - , bytestring - , containers - , effectful - , filepath - , generic-lens + , 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 , lens ^>=5.3 - , scientific - , stm + , scientific >=0.3 && <0.4 + , stm >=2.5 && <2.6 , text ^>=2.1 - , time - , vector + , time >=1.12 && <1.17 + , vector >=0.13 && <0.14 test-suite shikumi-test import: common-options @@ -109,10 +109,10 @@ build-depends: , aeson - , baikai >=0.5 && <0.6 - , baikai-claude >=0.5 && <0.6 - , baikai-effectful >=0.3.0.3 && <0.4 - , baikai-openai >=0.5 && <0.6 + , baikai >=0.6 && <0.7 + , baikai-claude >=0.6 && <0.7 + , baikai-effectful >=0.4 && <0.5 + , baikai-openai >=0.6 && <0.7 , base , base64-bytestring , bytestring diff --git a/src/Shikumi/Adapter.hs b/src/Shikumi/Adapter.hs --- a/src/Shikumi/Adapter.hs +++ b/src/Shikumi/Adapter.hs @@ -71,11 +71,11 @@ Response, TextContent (..), assistant, + emptyContext, + emptyOptions, flattenAssistantBlocks, user, userImage, - _Context, - _Options, ) import Control.Lens (at, (&), (.~), (?~), (^.)) import Data.Aeson (Object, Value (..), eitherDecodeStrict, toJSON) @@ -281,7 +281,7 @@ { render = \sig i -> let sys = systemHeader sig <> nativeOutputGuide sig ctx = buildContext sys (nativeDemoMessages sig ++ [userTurn i]) - opts = attachSchema (deriveSchema @o) _Options + opts = attachSchema (deriveSchema @o) emptyOptions in (ctx, opts), parse = \_sig resp -> assistantJSON resp >>= fromModelChecked } @@ -297,7 +297,7 @@ { render = \sig i -> let sys = systemHeader sig <> fallbackOutputGuide sig ctx = buildContext sys (demoMessages sig ++ [userTurn i]) - in (ctx, _Options), + in (ctx, emptyOptions), parse = \_sig resp -> let sections = parseMarkers (responseText resp) obj = sectionsToObject (deriveSchema @o) sections @@ -329,7 +329,7 @@ { render = \sig i -> let sys = systemHeader sig <> xmlOutputGuide sig ctx = buildContext sys (xmlDemoMessages sig ++ [userTurn i]) - in (ctx, _Options), + in (ctx, emptyOptions), parse = \sig resp -> let names = map fieldName (outputFields sig) sections = parseXmlTags names (responseText resp) @@ -343,7 +343,7 @@ buildContext :: Text -> [Message] -> Context buildContext sys msgs = - _Context & #systemPrompt .~ Just sys & #messages .~ V.fromList msgs + emptyContext & #systemPrompt .~ Just sys & #messages .~ V.fromList msgs -- | Build the final user turn for an input. If the input has an image field, it is -- lowered to a baikai 'userImage' block, with the remaining (text) fields rendered diff --git a/src/Shikumi/Compaction.hs b/src/Shikumi/Compaction.hs --- a/src/Shikumi/Compaction.hs +++ b/src/Shikumi/Compaction.hs @@ -17,10 +17,10 @@ Response, TextContent (..), Usage, + emptyContext, + emptyOptions, flattenAssistantBlocks, user, - _Context, - _Options, ) import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () @@ -94,7 +94,7 @@ summaryRequest :: Text -> (Context, Options) summaryRequest rendered = - ( _Context + ( emptyContext & #systemPrompt .~ Just ( T.unlines @@ -104,7 +104,7 @@ ] ) & #messages .~ V.singleton (user rendered), - _Options + emptyOptions ) renderItems :: (a -> Text) -> [a] -> Text diff --git a/src/Shikumi/Module.hs b/src/Shikumi/Module.hs --- a/src/Shikumi/Module.hs +++ b/src/Shikumi/Module.hs @@ -28,7 +28,7 @@ ) where -import Baikai (user, _Context, _Model, _Options) +import Baikai (emptyContext, emptyModel, emptyOptions, user) import Control.Lens ((&), (.~)) import Data.Aeson (Object, Value (Object)) import Data.Aeson.Key qualified as Key @@ -191,15 +191,15 @@ twoStep sig = embed $ \i -> do -- 1. Free-form call: plain prose, no structured shape requested. let ffCtx = - _Context + emptyContext & #systemPrompt .~ Just (freeFormSystem sig) & #messages .~ V.fromList [user (toPrompt i)] - ffResp <- complete _Model ffCtx _Options + ffResp <- complete emptyModel ffCtx emptyOptions -- 2. Extraction call: coerce the prose into the typed output via the marker -- fallback adapter (a robust extraction target that already round-trips). let exSig = extractSig sig (exCtx, exOpts) = render fallbackAdapter exSig (ExtractIn (responseText ffResp)) - exResp <- complete _Model exCtx exOpts + exResp <- complete emptyModel exCtx exOpts either throwError pure (parse fallbackAdapter exSig exResp) -- | The plain-prose system prompt for the free-form call (mirrors DSPy's diff --git a/src/Shikumi/Program.hs b/src/Shikumi/Program.hs --- a/src/Shikumi/Program.hs +++ b/src/Shikumi/Program.hs @@ -82,7 +82,7 @@ ) where -import Baikai (Model, _Model) +import Baikai (Model, emptyModel) import Data.Aeson (FromJSON, ToJSON, Value) import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) @@ -255,10 +255,10 @@ -- ambient model is supplied below the stack by "Shikumi.Routing".@runRouting@ and -- the router ("Shikumi.Routing".@routeLLM@) overwrites this placeholder with it on -- every outgoing call. With no router installed (the bare-stub test path) the call --- still carries '_Model', which 'adapterFor' maps to the prompt-fallback adapter — +-- still carries 'emptyModel', which 'adapterFor' maps to the prompt-fallback adapter — -- preserving EP-4's original behaviour for un-routed runs. placeholderModel :: Model -placeholderModel = _Model +placeholderModel = emptyModel -- | Interpret a program as a typed @Eff@ computation. A 'Predict' node overlays -- its 'Params' onto the signature (effective instruction + decoded demos), renders diff --git a/src/Shikumi/Routing.hs b/src/Shikumi/Routing.hs --- a/src/Shikumi/Routing.hs +++ b/src/Shikumi/Routing.hs @@ -45,7 +45,7 @@ ) where -import Baikai (Context, Message (..), Model, Options, ResponseFormat (..), assistant) +import Baikai (Context, JsonSchemaFormat (strict), Message (..), Model, Options, ResponseFormat (..), assistant, jsonSchemaFormat) import Control.Lens ((&), (.~), (^.)) import Data.Aeson (FromJSON, Result (..), Value, fromJSON) import Data.Generics.Labels () @@ -125,7 +125,7 @@ withSchema o | isNative, Just s <- mSchema = - o & #responseFormat .~ Just (JsonSchema {name = "output", schema = s, strict = True}) + o & #responseFormat .~ Just (JsonSchema ((jsonSchemaFormat "output" s) {strict = True})) | otherwise = o withTemp o = case mTemp of Just t -> o & #temperature .~ Just t diff --git a/src/Shikumi/Stream.hs b/src/Shikumi/Stream.hs --- a/src/Shikumi/Stream.hs +++ b/src/Shikumi/Stream.hs @@ -50,9 +50,9 @@ Options, Response, TerminalPayload (..), - _Model, - _Response, - _TextContent, + emptyModel, + emptyResponse, + emptyTextContent, ) import Control.Lens ((&), (.~)) import Data.Generics.Labels () @@ -183,7 +183,7 @@ -- program fails with the real transport error, not a decode of a partial body. reassemble :: [AssistantMessageEvent] -> Response reassemble evs = case terminalPayloads of - (p : _) -> _Response & #message .~ p + (p : _) -> emptyResponse & #message .~ p [] -> synthResponse (fromMaybe "" (firstTextEnd evs)) where terminalPayloads = @@ -193,7 +193,7 @@ -- | A response carrying @t@ as its single assistant text block. synthResponse :: Text -> Response synthResponse t = - _Response & #message . #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + emptyResponse & #message . #content .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) -- --------------------------------------------------------------------------- -- M2/M3: streaming a whole program @@ -260,7 +260,7 @@ Eff es o streamPredict sig ps i cb = do sig' <- effectiveSignature sig ps - let adapter = adapterFor _Model + let adapter = adapterFor emptyModel (ctx, opts0) = render adapter sig' i (nativeSys, nativeDemos) = nativeRenderPieces @i @o sig' opts = attachNativeRender nativeSys nativeDemos (attachSchema (deriveSchema @o) opts0) @@ -268,7 +268,7 @@ (x : _) -> x [] -> "" cb (StreamStatus (Status LmStart "LM call started")) - resp <- streamComplete fieldNm _Model ctx opts cb + resp <- streamComplete fieldNm emptyModel ctx opts cb cb (StreamStatus (Status LmEnd "LM call finished")) either throwError pure (parseResponse sig' resp) diff --git a/test/AdapterSpec.hs b/test/AdapterSpec.hs --- a/test/AdapterSpec.hs +++ b/test/AdapterSpec.hs @@ -9,9 +9,9 @@ AssistantContent (..), Model, Response, - _Model, - _Response, - _TextContent, + emptyModel, + emptyResponse, + emptyTextContent, ) import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () @@ -34,10 +34,10 @@ import Test.Tasty.HUnit (testCase, (@?=)) anthropicModel :: Model -anthropicModel = _Model & #provider .~ "anthropic" & #api .~ AnthropicMessages +anthropicModel = emptyModel & #provider .~ "anthropic" & #api .~ AnthropicMessages ollamaModel :: Model -ollamaModel = _Model & #provider .~ "ollama" & #api .~ Custom "ollama" +ollamaModel = emptyModel & #provider .~ "ollama" & #api .~ Custom "ollama" sig :: Signature Article Summary sig = setDemos [Demo sampleArticle sampleSummary] (mkSignature "Summarize the article") @@ -45,7 +45,7 @@ -- | Build a response whose single assistant text block carries the given body. mkResponse :: Text -> Response mkResponse t = - _Response & #message . #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + emptyResponse & #message . #content .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) markerBody :: Text markerBody = diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs --- a/test/EndToEndSpec.hs +++ b/test/EndToEndSpec.hs @@ -8,9 +8,9 @@ ( AssistantContent (..), Model, Response, - _Model, - _Response, - _TextContent, + emptyModel, + emptyResponse, + emptyTextContent, ) import Control.Lens ((&), (.~)) import Data.Generics.Labels () @@ -39,12 +39,12 @@ runSig :: (LLM :> es) => Adapter i o -> Signature i o -> i -> Eff es (Either ShikumiError o) runSig adapter signature i = do let (ctx, opts) = render adapter signature i - resp <- complete (_Model :: Model) ctx opts + resp <- complete (emptyModel :: Model) ctx opts pure (parse adapter signature resp) mkResponse :: Text -> Response mkResponse t = - _Response & #message . #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + emptyResponse & #message . #content .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) sig :: Signature Article Summary sig = setDemos [Demo sampleArticle sampleSummary] (mkSignature "Summarize the article") diff --git a/test/LiveSpec.hs b/test/LiveSpec.hs --- a/test/LiveSpec.hs +++ b/test/LiveSpec.hs @@ -32,8 +32,8 @@ case live of Just "1" -> do OpenAI.register - let ctx = _Context & #messages .~ V.singleton (user "Reply with a single word.") - opts = _Options & #maxTokens .~ Just 16 + let ctx = emptyContext & #messages .~ V.singleton (user "Reply with a single word.") + opts = emptyOptions & #maxTokens .~ Just 16 cfg = defaultLLMConfig globalProviderRegistry out <- runEff . runConcurrent . runErrorNoCallStack @ShikumiError . runLLMResilient cfg $ do diff --git a/test/MultimodalEndToEndSpec.hs b/test/MultimodalEndToEndSpec.hs --- a/test/MultimodalEndToEndSpec.hs +++ b/test/MultimodalEndToEndSpec.hs @@ -17,9 +17,9 @@ Response, TextContent (..), UserContent (..), - _Model, - _Response, - _TextContent, + emptyModel, + emptyResponse, + emptyTextContent, ) import Control.Lens ((&), (.~), (^.)) import Data.ByteString qualified as BS @@ -69,12 +69,12 @@ runSig :: (LLM :> es) => Adapter i o -> Signature i o -> i -> Eff es (Either ShikumiError o) runSig adapter signature i = do let (ctx, opts) = render adapter signature i - resp <- complete (_Model :: Model) ctx opts + resp <- complete (emptyModel :: Model) ctx opts pure (parse adapter signature resp) mkResponse :: Text -> Response mkResponse t = - _Response & #message . #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + emptyResponse & #message . #content .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) cannedAnswer :: Response cannedAnswer = diff --git a/test/ProgramFixtures.hs b/test/ProgramFixtures.hs --- a/test/ProgramFixtures.hs +++ b/test/ProgramFixtures.hs @@ -36,8 +36,8 @@ ( AssistantContent (..), Context, Response, - _Response, - _TextContent, + emptyResponse, + emptyTextContent, ) import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () @@ -150,7 +150,7 @@ -- | An assistant 'Response' carrying @t@ as its single text block. mkResponse :: Text -> Response mkResponse t = - _Response & #message . #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + emptyResponse & #message . #content .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) outlineResponse :: Response outlineResponse = mkResponse (markerBody [("points", "[\"intro\", \"body\", \"end\"]")]) diff --git a/test/RefineSpec.hs b/test/RefineSpec.hs --- a/test/RefineSpec.hs +++ b/test/RefineSpec.hs @@ -4,13 +4,13 @@ -- ('Shikumi.Refine.bestOfN', 'Shikumi.Refine.refine', -- 'Shikumi.Refine.multiChainComparison'). -- --- Every test installs the production router (@routeLLM . runRouting _Model@) above a +-- Every test installs the production router (@routeLLM . runRouting emptyModel@) above a -- deterministic stub @LLM@ (see "RefineStub") so per-sample temperature reaches the -- wire exactly as in production — no network, no API key. The headline assertion -- (M4) shows a deliberately-weak program's score strictly improves once wrapped. module RefineSpec (tests) where -import Baikai (Context, Options, _Model) +import Baikai (Context, Options, emptyModel) import Data.IORef (newIORef, readIORef) import Data.Text (Text) import Data.Text qualified as T @@ -70,7 +70,7 @@ -- Run helpers — router over the stub, mirroring production install order -- --------------------------------------------------------------------------- --- | Run a program sequentially under @routeLLM . runRouting _Model@ over the +-- | Run a program sequentially under @routeLLM . runRouting emptyModel@ over the -- decision-rule stub; returns the result and the completion count. runCounted :: (Context -> Options -> Text) -> @@ -82,7 +82,7 @@ res <- runEff . runErrorNoCallStack @ShikumiError - . runRouting _Model + . runRouting emptyModel . runStub ref decide . routeLLM $ runProgram prog input @@ -100,7 +100,7 @@ runEff . runErrorNoCallStack @ShikumiError . runConcurrent - . runRouting _Model + . runRouting emptyModel . runStub ref decide . routeLLM $ runProgramConc prog input @@ -116,7 +116,7 @@ res <- runEff . runErrorNoCallStack @ShikumiError - . runRouting _Model + . runRouting emptyModel . runThrowingLLM ref . routeLLM $ runProgram prog input @@ -134,7 +134,7 @@ res <- runEff . runErrorNoCallStack @ShikumiError - . runRouting _Model + . runRouting emptyModel . runRecordingStub cap decide . routeLLM $ runProgram prog input diff --git a/test/RoutingSpec.hs b/test/RoutingSpec.hs --- a/test/RoutingSpec.hs +++ b/test/RoutingSpec.hs @@ -13,6 +13,7 @@ ( AssistantContent (..), AssistantMessageEvent (..), Context, + JsonSchemaFormat (strict), Message (..), Model, Options, @@ -20,7 +21,8 @@ StopReason (..), TextContent (..), doneTerminal, - _Model, + emptyModel, + jsonSchemaFormat, ) import Baikai.Models.Generated (openai_gpt_4o_mini) import Control.Lens ((^.)) @@ -162,7 +164,7 @@ case captured of [(_, _, o)] -> do o ^. #responseFormat - @?= Just (JsonSchema {name = "output", schema = deriveSchema @Outline, strict = True}) + @?= Just (JsonSchema ((jsonSchemaFormat "output" (deriveSchema @Outline)) {strict = True})) assertBool "private schema key stripped before transport" (Map.notMember metaResponseSchemaKey (o ^. #metadata)) @@ -171,7 +173,7 @@ fallbackLeavesSchemaUnset :: TestTree fallbackLeavesSchemaUnset = testCase "fallback model leaves responseFormat unset" $ do - captured <- captureRouted _Model (predict topicToOutline) (Topic "cats") + captured <- captureRouted emptyModel (predict topicToOutline) (Topic "cats") case captured of [(_, _, o)] -> do o ^. #responseFormat @?= Nothing @@ -228,7 +230,7 @@ fallbackPromptUnchangedAndStampsStripped :: TestTree fallbackPromptUnchangedAndStampsStripped = testCase "fallback model keeps the marker prompt and native stamps are stripped" $ do - captured <- captureRouted _Model (predict topicToOutline) (Topic "cats") + captured <- captureRouted emptyModel (predict topicToOutline) (Topic "cats") case captured of [(_, ctx, o)] -> do let sys = maybe "" id (ctx ^. #systemPrompt) @@ -265,7 +267,7 @@ [(m, _, o)] -> do m ^. #modelId @?= openai_gpt_4o_mini ^. #modelId o ^. #responseFormat - @?= Just (JsonSchema {name = "output", schema = deriveSchema @Outline, strict = True}) + @?= Just (JsonSchema ((jsonSchemaFormat "output" (deriveSchema @Outline)) {strict = True})) assertBool "private schema key stripped before transport" (Map.notMember metaResponseSchemaKey (o ^. #metadata)) diff --git a/test/StreamSpec.hs b/test/StreamSpec.hs --- a/test/StreamSpec.hs +++ b/test/StreamSpec.hs @@ -20,11 +20,11 @@ StopReason (..), TerminalPayload (..), doneTerminal, - _Context, - _Model, - _Options, - _Response, - _TextContent, + emptyContext, + emptyModel, + emptyOptions, + emptyResponse, + emptyTextContent, ) import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () @@ -102,13 +102,13 @@ -- | A response carrying @t@ as its single assistant text block. mkResponse :: Text -> Response mkResponse t = - _Response & #message . #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + emptyResponse & #message . #content .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) -- | The 'Response' assembled from a stream's terminal event. terminalResponse :: [AssistantMessageEvent] -> Response terminalResponse evs = case [p | EventDone TerminalPayload {message = AssistantMessage p} <- evs] of - (p : _) -> _Response & #message .~ p + (p : _) -> emptyResponse & #message .~ p [] -> mkResponse "" -- | A valid event sequence: @deltas@ stream as text chunks, and the terminal event @@ -117,7 +117,7 @@ -- the value streaming incrementally, the terminal carries the whole structured reply. streamEventsFor :: [Text] -> Text -> [AssistantMessageEvent] streamEventsFor deltas terminalText = - [ EventStart (StartPayload (AssistantMessage (_Response ^. #message)) Nothing), + [ EventStart (StartPayload (AssistantMessage (emptyResponse ^. #message)) Nothing), TextStart (IndexPayload 0) ] ++ [TextDelta (DeltaPayload 0 d) | d <- deltas] @@ -125,7 +125,7 @@ EventDone (doneTerminal Nothing Nothing Stop (AssistantMessage (payloadWith terminalText))) ] where - payloadWith t = (_Response ^. #message) & #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + payloadWith t = (emptyResponse ^. #message) & #content .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) -- | A recording callback: append each event to the IORef in order. recorder :: (IOE :> es) => IORef [StreamEvent] -> StreamEvent -> Eff es () @@ -144,7 +144,7 @@ rec <- newIORef [] resp <- runEff . runStreamingLLM ref $ - streamComplete "answer" _Model _Context _Options (recorder rec) + streamComplete "answer" emptyModel emptyContext emptyOptions (recorder rec) evs <- readIORef rec evs @?= [ StreamFieldChunk (FieldChunk "answer" "Hel" False), diff --git a/test/StubProvider.hs b/test/StubProvider.hs --- a/test/StubProvider.hs +++ b/test/StubProvider.hs @@ -64,7 +64,7 @@ -- | A hand-built 'Model' whose 'api' routes to the stub provider. stubModel :: Model stubModel = - _Model + emptyModel & #api .~ stubApi & #modelId @@ -76,23 +76,23 @@ -- | A minimal request context (one user turn). stubContext :: Context -stubContext = _Context & #messages .~ V.singleton (user "ping") +stubContext = emptyContext & #messages .~ V.singleton (user "ping") -- | Default request options. stubOptions :: Options -stubOptions = _Options +stubOptions = emptyOptions -- | An assistant payload carrying the given text as its single text block. stubPayloadWith :: Text -> AssistantPayload stubPayloadWith t = - (_Response ^. #message) + (emptyResponse ^. #message) & #content - .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) -- | A fixed assistant response carrying the given text as its single text block. stubResponse :: Text -> Response stubResponse t = - _Response + emptyResponse & #message .~ stubPayloadWith t & #model @@ -105,7 +105,7 @@ -- | A deterministic, valid event sequence for the given text. stubEvents :: Text -> [AssistantMessageEvent] stubEvents t = - [ EventStart StartPayload {partial = AssistantMessage (_Response ^. #message), responseId = Nothing}, + [ EventStart StartPayload {partial = AssistantMessage (emptyResponse ^. #message), responseId = Nothing}, TextStart IndexPayload {contentIndex = 0}, TextDelta DeltaPayload {contentIndex = 0, delta = t}, TextEnd BlockEndPayload {contentIndex = 0, content = t}, @@ -119,11 +119,12 @@ reg <- newProviderRegistry registerApiProviderWith reg - ApiProvider - { apiTag = stubApi, - complete = completeFn, - stream = \_ _ _ -> Stream.fromList (stubEvents streamText), - describeThinking = stubDescribeThinking + ( apiProviderWith + stubApi + (\_ _ _ -> Stream.fromList (stubEvents streamText)) + completeFn + ) + { describeThinking = stubDescribeThinking } pure reg @@ -167,12 +168,12 @@ -- interpreters map this to a transient 'Shikumi.Error.ProviderFailure'. streamErrorEvents :: Rational -> Text -> [AssistantMessageEvent] streamErrorEvents cost msg = - [ EventStart StartPayload {partial = AssistantMessage (_Response ^. #message), responseId = Nothing}, + [ EventStart StartPayload {partial = AssistantMessage (emptyResponse ^. #message), responseId = Nothing}, EventError (doneTerminal Nothing Nothing ErrorReason (AssistantMessage errPayload)) ] where errPayload = - (_Response ^. #message) + (emptyResponse ^. #message) & #errorMessage .~ Just msg & #usage @@ -189,17 +190,19 @@ reg <- newProviderRegistry registerApiProviderWith reg - ApiProvider - { apiTag = stubApi, - complete = \_ _ _ -> pure (stubResponse t), - stream = \_ _ _ -> Stream.concatEffect $ do - n <- atomicModifyIORef' ref (\k -> (k + 1, k + 1)) - pure $ - Stream.fromList $ - if n <= failTimes - then streamErrorEvents 0 ("stub stream failure #" <> T.pack (show n)) - else stubEvents t, - describeThinking = stubDescribeThinking + ( apiProviderWith + stubApi + ( \_ _ _ -> Stream.concatEffect $ do + n <- atomicModifyIORef' ref (\k -> (k + 1, k + 1)) + pure $ + Stream.fromList $ + if n <= failTimes + then streamErrorEvents 0 ("stub stream failure #" <> T.pack (show n)) + else stubEvents t + ) + (\_ _ _ -> pure (stubResponse t)) + ) + { describeThinking = stubDescribeThinking } pure reg @@ -211,11 +214,12 @@ reg <- newProviderRegistry registerApiProviderWith reg - ApiProvider - { apiTag = stubApi, - complete = \_ _ _ -> pure (stubResponse ""), - stream = \_ _ _ -> Stream.fromList (streamErrorEvents cost "stub stream failure"), - describeThinking = stubDescribeThinking + ( apiProviderWith + stubApi + (\_ _ _ -> Stream.fromList (streamErrorEvents cost "stub stream failure")) + (\_ _ _ -> pure (stubResponse "")) + ) + { describeThinking = stubDescribeThinking } pure reg diff --git a/test/TwoStepSpec.hs b/test/TwoStepSpec.hs --- a/test/TwoStepSpec.hs +++ b/test/TwoStepSpec.hs @@ -8,8 +8,8 @@ import Baikai ( AssistantContent (..), Response, - _Response, - _TextContent, + emptyResponse, + emptyTextContent, ) import Control.Lens ((&), (.~)) import Data.Generics.Labels () @@ -38,7 +38,7 @@ -- | Build a response whose single assistant text block carries the given body. mkResponse :: Text -> Response mkResponse t = - _Response & #message . #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + emptyResponse & #message . #content .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) -- | The first scripted call's reply: free-form prose (no structure requested). freeFormResponse :: Response diff --git a/test/XmlAdapterSpec.hs b/test/XmlAdapterSpec.hs --- a/test/XmlAdapterSpec.hs +++ b/test/XmlAdapterSpec.hs @@ -7,8 +7,8 @@ import Baikai ( AssistantContent (..), Response, - _Response, - _TextContent, + emptyResponse, + emptyTextContent, ) import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () @@ -30,7 +30,7 @@ -- | Build a response whose single assistant text block carries the given body. mkResponse :: Text -> Response mkResponse t = - _Response & #message . #content .~ V.singleton (AssistantText (_TextContent & #text .~ t)) + emptyResponse & #message . #content .~ V.singleton (AssistantText (emptyTextContent & #text .~ t)) -- | A hand-written XML reply wrapping each 'Summary' field in tags. xmlBody :: Text