diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,14 @@ # Changelog -## Unreleased +## 0.4.1.0 — 2026-09-30 + +- Route subscription-CLI models through the native schema adapter. `capabilityFor` now starts from Baikai's `declaredStructuredOutput` for the model's `api`: `AnthropicMessagesCli` (`claude -p --json-schema`) and `OpenAICompletionsCli` (`codex exec --output-schema`) are `NativeSchema`, so their requests carry the strict derived schema and a list-of-records output decodes. First-party HTTP routing is unchanged; third-party hosts over a first-party wire format (`deepseek`, `openrouter` over Chat Completions) and `Custom` hosts stay `PromptFallback`. Previously cached CLI responses miss once, because the request now carries a `responseFormat` and the native prompt. Implements `mori://shinzui/shikumi/okf/improvement-requests/concepts/IR-4`. + +- Show the JSON shape of every object or array output field in the fallback guide: a `JSON shape:` line under the field's marker lists nested keys (in `required` order) and closed enum values. Scalar-only fallback prompts are byte-for-byte unchanged. + +- Raise the dependencies on `mori://shinzui/baikai/packages/baikai` to `>=0.7.2.0 && <0.8`, and on `mori://shinzui/baikai/packages/baikai-claude` and `mori://shinzui/baikai/packages/baikai-openai` to `>=0.7.1.0 && <0.8`. Older provider packages ignore `responseFormat` on the CLI transports, which would drop the marker fallback without gaining enforcement. + +- Move the dependency on `mori://shinzui/baikai/packages/baikai` to `>=0.7.1.0 && <0.8` and on `mori://shinzui/baikai/packages/baikai-effectful` to `>=0.4.0.1 && <0.5`, and widen the `effectful` bound to `>=2.6 && <2.8`. Both effectful 2.6 and 2.7 are supported: `baikai-effectful` 0.4.0.1 requires `effectful-core` 2.6 and 0.4.0.2 requires 2.7, so the solver pairs them. Bounds only; no source changed. ## 0.4.0.0 — 2026-09-08 diff --git a/shikumi.cabal b/shikumi.cabal --- a/shikumi.cabal +++ b/shikumi.cabal @@ -1,27 +1,33 @@ -cabal-version: 3.4 -name: shikumi -version: 0.4.0.0 -synopsis: Typed, structured, evaluable LM programs over baikai -category: AI +cabal-version: 3.4 +name: shikumi +version: 0.4.1.0 +synopsis: Typed, structured, evaluable LM programs over baikai +category: AI description: Shikumi is a Haskell-native framework for building typed language-model programs. This package provides the runtime substrate: the LLM effect over baikai, the shikumi error type, and resilience (retries, rate limiting, budget control). -license: BSD-3-Clause -author: Nadeem Bitar -maintainer: nadeem@gmail.com -build-type: Simple +license: BSD-3-Clause +author: Nadeem Bitar +maintainer: nadeem@gmail.com +build-type: Simple extra-doc-files: CHANGELOG.md common common-options ghc-options: - -Wall -Wcompat -Widentities -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wredundant-constraints - -fhide-source-paths -Wmissing-export-lists -Wpartial-fields + -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wmissing-export-lists + -Wpartial-fields -Wmissing-deriving-strategies - default-language: GHC2024 + default-language: GHC2024 default-extensions: DeriveAnyClass DuplicateRecordFields @@ -29,8 +35,8 @@ OverloadedStrings library - import: common-options - hs-source-dirs: src + import: common-options + hs-source-dirs: src exposed-modules: Shikumi.Adapter Shikumi.Combinator @@ -54,43 +60,48 @@ Shikumi.Signature Shikumi.Stream - other-modules: Shikumi.Adapter.Xml + other-modules: Shikumi.Adapter.Xml build-depends: - , aeson >=2.2 && <2.3 - , baikai >=0.7.0.0 && <0.8 - , baikai-claude >=0.7.0.0 && <0.8 - , baikai-effectful >=0.4.0.1 && <0.5 - , baikai-openai >=0.7.0.0 && <0.8 - , base >=4.20 && <5 - , base64-bytestring >=1.2 && <1.3 - , bytestring >=0.11 && <0.13 - , containers >=0.6 && <0.9 - , effectful >=2.5 && <2.7 - , filepath >=1.4 && <1.6 - , generic-lens >=2.2 && <2.4 - , lens ^>=5.3 - , scientific >=0.3 && <0.4 - , stm >=2.5 && <2.6 - , text ^>=2.1 - , time >=1.12 && <1.17 - , vector >=0.13 && <0.14 + aeson >=2.2 && <2.3, + baikai >=0.7.2.0 && <0.8, + baikai-claude >=0.7.1.0 && <0.8, + baikai-effectful >=0.4.0.1 && <0.5, + baikai-openai >=0.7.1.0 && <0.8, + base >=4.20 && <5, + base64-bytestring >=1.2 && <1.3, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.9, + effectful >=2.6 && <2.8, + filepath >=1.4 && <1.6, + generic-lens >=2.2 && <2.4, + lens ^>=5.3, + scientific >=0.3 && <0.4, + stm >=2.5 && <2.6, + text ^>=2.1, + time >=1.12 && <1.17, + vector >=0.13 && <0.14, test-suite shikumi-test - import: common-options - type: exitcode-stdio-1.0 + import: common-options + type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Main.hs - ghc-options: -threaded -with-rtsopts=-N + main-is: Main.hs + ghc-options: + -threaded + -with-rtsopts=-N + other-modules: AdapterSpec + CliSchemaSpec CombinatorSpec ConstraintSpec ContinuationSpec EndToEndSpec ErrorSpec + FallbackGuideSpec Fixtures - LiveSpec LLMSpec + LiveSpec ModuleSpec MultimodalAdapterSpec MultimodalEndToEndSpec @@ -115,25 +126,25 @@ XmlAdapterSpec build-depends: - , aeson - , baikai >=0.7.0.0 && <0.8 - , baikai-claude >=0.7.0.0 && <0.8 - , baikai-effectful >=0.4.0.1 && <0.5 - , baikai-openai >=0.7.0.0 && <0.8 - , base - , base64-bytestring - , bytestring - , containers - , directory - , effectful - , generic-lens - , lens - , QuickCheck - , shikumi ^>=0.4.0.0 - , stm - , streamly-core - , tasty - , tasty-hunit - , tasty-quickcheck - , text - , vector + QuickCheck, + aeson, + baikai >=0.7.2.0 && <0.8, + baikai-claude >=0.7.1.0 && <0.8, + baikai-effectful >=0.4.0.1 && <0.5, + baikai-openai >=0.7.1.0 && <0.8, + base, + base64-bytestring, + bytestring, + containers, + directory, + effectful, + generic-lens, + lens, + shikumi ^>=0.4.1.0, + stm, + streamly-core, + tasty, + tasty-hunit, + tasty-quickcheck, + text, + vector, diff --git a/src/Shikumi/Adapter.hs b/src/Shikumi/Adapter.hs --- a/src/Shikumi/Adapter.hs +++ b/src/Shikumi/Adapter.hs @@ -10,7 +10,9 @@ -- -- The native-schema adapter uses provider-enforced JSON; the prompt-based fallback -- renders @[[ ## field ## ]]@ sections for models without native structured output. --- 'capabilityFor' selects between them per model. Two opt-in XML adapters share +-- 'capabilityFor' selects between them per model from baikai's declared +-- structured-output support: first-party HTTP hosts and the subscription CLIs +-- (@claude@, @codex@) are native; third-party and @Custom@ hosts fall back. Two opt-in XML adapters share -- bounded nested decoding and offer legacy or structured demonstration rendering. -- -- Native structured output is wired through a private /metadata channel/ (EP-14). @@ -70,8 +72,10 @@ Model, Options, Response, + StructuredOutputSupport (..), TextContent (..), assistant, + declaredStructuredOutput, emptyContext, emptyOptions, flattenAssistantBlocks, @@ -86,8 +90,10 @@ import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Kind (Type) +import Data.List (sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) @@ -184,15 +190,43 @@ data ModelCapability = NativeSchema | PromptFallback deriving stock (Eq, Show) --- | A pure capability check over a baikai 'Model'. OpenAI/Anthropic on their --- non-CLI APIs are native-capable; CLI APIs and unknown @Custom@ hosts use the --- fallback. Refine as more models gain native support. +-- | A pure capability check over a baikai 'Model', derived from baikai's +-- per-transport declaration ('declaredStructuredOutput'). +-- +-- A model is 'NativeSchema' when baikai declares 'NativeJsonSchema' for its +-- @api@ and either: +-- +-- * the @api@ is a subscription CLI tag ('AnthropicMessagesCli' for @claude -p +-- --json-schema@, 'OpenAICompletionsCli' for @codex exec --output-schema@) — +-- such a tag is always served by baikai's own CLI provider, so baikai's +-- declaration is authoritative; or +-- * the @(provider, api)@ pair is a first-party HTTP host: @openai@ over Chat +-- Completions or Responses, or @anthropic@ over Messages. +-- +-- Third-party hosts speaking a first-party wire format (for example @deepseek@ +-- or @openrouter@ over 'OpenAIChatCompletions') stay 'PromptFallback': baikai +-- forwards the schema, but cannot know whether such a host enforces it. +-- @Custom@ transports are 'NoStructuredOutput' in baikai's table and therefore +-- always 'PromptFallback'. +-- +-- This answers schema enforcement only. Provider-native /tool calling/ is a +-- separate capability (baikai's CLI providers enforce schemas but drop tools); +-- see "Shikumi.Agent.ReAct". capabilityFor :: Model -> ModelCapability -capabilityFor m = case (m ^. #provider, m ^. #api) of - ("openai", OpenAIChatCompletions) -> NativeSchema - ("openai", OpenAIResponses) -> NativeSchema - ("anthropic", AnthropicMessages) -> NativeSchema - _ -> PromptFallback +capabilityFor m = case declaredStructuredOutput api of + NoStructuredOutput -> PromptFallback + NativeJsonSchema + | cliTransport || firstPartyApi -> NativeSchema + | otherwise -> PromptFallback + where + api = m ^. #api + cliTransport = api `elem` [AnthropicMessagesCli, OpenAICompletionsCli] + firstPartyApi = + (m ^. #provider, api) + `elem` [ ("openai", OpenAIChatCompletions), + ("openai", OpenAIResponses), + ("anthropic", AnthropicMessages) + ] -- | Select the adapter for a model from its capability. adapterFor :: @@ -393,11 +427,77 @@ -- | A fallback-output guide: ask for one @[[ ## field ## ]]@ section per output -- field, then a final @[[ ## completed ## ]]@ marker (DSPy's convention). -fallbackOutputGuide :: Signature i o -> Text +-- +-- A field whose derived schema (ignoring nullability) is an object or an array +-- gets one further @JSON shape: …@ line ('renderShape'), so a model without +-- schema enforcement still sees nested keys and closed enum values. Scalar +-- fields, including top-level enums, render exactly as before. +fallbackOutputGuide :: forall i o. (ToSchema o) => Signature i o -> Text fallbackOutputGuide sig = "Reply using these sections, each marker on its own line:\n" - <> T.unlines [marker (fieldName f) <> describeSuffix f | f <- outputFields sig] + <> T.unlines (concat [fieldLines f | f <- outputFields sig]) <> marker "completed" + where + schema = deriveSchema @o + fieldLines f = + (marker (fieldName f) <> describeSuffix f) + : [ "JSON shape: " <> renderShape s + | Just s <- [propertySchema (fieldName f) schema], + isStructured s + ] + isStructured s = case KM.lookup "type" =<< objectOf (stripNullable s) of + Just (String t) -> t == "object" || t == "array" + _ -> False + +-- | The schema of one top-level property of a derived object schema. +propertySchema :: Text -> Value -> Maybe Value +propertySchema name schema = + KM.lookup (Key.fromText name) =<< objectOf =<< KM.lookup "properties" =<< objectOf schema + +objectOf :: Value -> Maybe Object +objectOf (Object o) = Just o +objectOf _ = Nothing + +-- | Strip a nullable @anyOf [s, {"type":"null"}]@ wrapper, if present. +stripNullable :: Value -> Value +stripNullable v = fromMaybe v (nullableInner v) + +-- | The inner schema of a nullable @anyOf [s, {"type":"null"}]@ wrapper. +nullableInner :: Value -> Maybe Value +nullableInner (Object o) + | Just (Array alts) <- KM.lookup "anyOf" o, + [s, Object n] <- V.toList alts, + KM.lookup "type" n == Just (String "null") = + Just s +nullableInner _ = Nothing + +-- | A compact, JSON-like rendering of a derived schema for the fallback guide: +-- scalars by type name, string enums as their quoted values joined by @|@, +-- arrays as @[, ...]@, objects as @{"k": , …}@ (keys in @required@ +-- order, any others sorted after), and nullable values as @ | null@. +renderShape :: Value -> Text +renderShape v = case nullableInner v of + Just s -> renderShape s <> " | null" + Nothing -> case objectOf v of + Nothing -> anyValue + Just o -> case KM.lookup "enum" o of + Just (Array vs) | not (V.null vs) -> T.intercalate " | " (map jsonText (V.toList vs)) + _ -> case KM.lookup "type" o of + Just (String "array") -> "[" <> maybe anyValue renderShape (KM.lookup "items" o) <> ", ...]" + Just (String "object") -> renderObject o + Just (String t) | t `elem` ["string", "integer", "number", "boolean"] -> t + _ -> anyValue + where + anyValue = "any JSON value" + jsonText x = decodeUtf8 (LBS.toStrict (Aeson.encode x)) + renderObject o = + let props = fromMaybe KM.empty (objectOf =<< KM.lookup "properties" o) + required = case KM.lookup "required" o of + Just (Array rs) -> [k | String r <- V.toList rs, let k = Key.fromText r, KM.member k props] + _ -> [] + others = sortOn Key.toText [k | k <- KM.keys props, k `notElem` required] + entry k = jsonText (String (Key.toText k)) <> ": " <> maybe anyValue renderShape (KM.lookup k props) + in "{" <> T.intercalate ", " (map entry (required <> others)) <> "}" describeField :: FieldMeta -> Text describeField f = "- " <> fieldName f <> maybe "" (": " <>) (fieldDesc f) diff --git a/test/AdapterSpec.hs b/test/AdapterSpec.hs --- a/test/AdapterSpec.hs +++ b/test/AdapterSpec.hs @@ -102,6 +102,16 @@ capabilityFor (emptyModel & #provider .~ "openai" & #api .~ OpenAIResponses) @?= NativeSchema, testCase "capabilityFor: Custom (ollama) host -> PromptFallback" $ capabilityFor ollamaModel @?= PromptFallback, + testCase "capabilityFor: claude CLI -> NativeSchema" $ + capabilityFor (emptyModel & #provider .~ "claude-cli" & #api .~ AnthropicMessagesCli) @?= NativeSchema, + testCase "capabilityFor: codex CLI -> NativeSchema" $ + capabilityFor (emptyModel & #provider .~ "codex-cli" & #api .~ OpenAICompletionsCli) @?= NativeSchema, + testCase "capabilityFor: deepseek over Chat Completions -> PromptFallback" $ + capabilityFor (emptyModel & #provider .~ "deepseek" & #api .~ OpenAIChatCompletions) @?= PromptFallback, + testCase "capabilityFor: openrouter over Chat Completions -> PromptFallback" $ + capabilityFor (emptyModel & #provider .~ "openrouter" & #api .~ OpenAIChatCompletions) @?= PromptFallback, + testCase "capabilityFor: OpenAI Chat Completions -> NativeSchema" $ + capabilityFor (emptyModel & #provider .~ "openai" & #api .~ OpenAIChatCompletions) @?= NativeSchema, testCase "fallback render: system prompt has the instruction and field markers" $ do T.isInfixOf "Summarize the article" (sysOf fallbackAdapter) @?= True T.isInfixOf "[[ ## headline ## ]]" (sysOf fallbackAdapter) @?= True, diff --git a/test/CliSchemaSpec.hs b/test/CliSchemaSpec.hs new file mode 100644 --- /dev/null +++ b/test/CliSchemaSpec.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE DataKinds #-} + +-- | EP-67: a typed program whose output is a list of records decodes through a +-- subscription-CLI provider that enforces the derived schema, and fails the way +-- Mina's @codex-cli@ judges did when the same provider sits under a fallback tag. +-- +-- The scripted provider stands in for baikai's CLI providers: it returns +-- schema-conforming JSON only when the request carries a 'B.JsonSchema' +-- @responseFormat@ (what @claude -p --json-schema@ / @codex exec --output-schema@ +-- enforce), and otherwise replies like an unconstrained model — marker sections +-- whose list-of-records field holds bare strings. Registering the identical +-- provider under a @Custom@ tag is the control: only the routing decision differs. +module CliSchemaSpec + ( tests, + Severity (..), + Concern (..), + Assessment (..), + Proposal (..), + ) +where + +import Baikai qualified as B +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (Value) +import Data.Generics.Labels () +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Effectful (runEff) +import Effectful.Error.Static (runErrorNoCallStack) +import GHC.Generics (Generic) +import Shikumi.Adapter (ToPrompt) +import Shikumi.Error (ShikumiError, renderShikumiError) +import Shikumi.LLM (runLLMWith) +import Shikumi.Program (Program (Predict), emptyParams, runProgram) +import Shikumi.Routing (routeLLM, runRouting) +import Shikumi.Schema (FromModel, ToSchema, Validatable, deriveSchema) +import Shikumi.Schema.Types (Field (..), field) +import Shikumi.Signature (Signature, mkSignature) +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +data Severity = Blocker | Major | Minor + deriving stock (Generic, Show, Eq) + +instance ToSchema Severity + +instance FromModel Severity + +data Concern = Concern + { statement :: !(Field "What is wrong" Text), + severity :: !Severity + } + deriving stock (Generic, Show, Eq) + +instance ToSchema Concern + +instance FromModel Concern + +data Assessment = Assessment + { concerns :: !(Field "Readiness concerns" [Concern]), + verdict :: !(Field "Overall verdict" Text) + } + deriving stock (Generic, Show, Eq) + +instance ToSchema Assessment + +instance FromModel Assessment + +instance ToPrompt Assessment + +instance Validatable Assessment + +newtype Proposal = Proposal {plan :: Field "The release plan to assess" Text} + deriving stock (Generic, Show, Eq) + +instance ToSchema Proposal + +instance FromModel Proposal + +instance ToPrompt Proposal + +instance Validatable Proposal + +assessSig :: Signature Proposal Assessment +assessSig = mkSignature "Assess whether the release plan is ready." + +proposal :: Proposal +proposal = Proposal {plan = field "Ship on Friday."} + +expectedAssessment :: Assessment +expectedAssessment = + Assessment + { concerns = field [Concern {statement = field "No rollback path", severity = Blocker}], + verdict = field "not ready" + } + +-- | The reply a schema-enforcing CLI returns. +conformingJson :: Text +conformingJson = + "{\"concerns\":[{\"statement\":\"No rollback path\",\"severity\":\"Blocker\"}],\"verdict\":\"not ready\"}" + +-- | The reply an unconstrained model wrote in Mina: strings where records belong. +unconstrainedMarkers :: Text +unconstrainedMarkers = + T.intercalate + "\n" + [ "[[ ## concerns ## ]]", + "[\"No rollback path\"]", + "[[ ## verdict ## ]]", + "not ready", + "[[ ## completed ## ]]" + ] + +textResponse :: B.Model -> Text -> B.Response +textResponse m t = + B.emptyResponse + & #message + . #content + .~ V.singleton (B.AssistantText (B.emptyTextContent & #text .~ t)) + & #model + .~ m + +-- | A registry whose single provider serves @api@ and enforces the schema only +-- when one is requested, recording every 'B.Options' it receives. +cliRegistry :: B.Api -> IO (B.ProviderRegistry, IORef [B.Options]) +cliRegistry api = do + seen <- newIORef [] + reg <- B.newProviderRegistry + let reply m o = case o ^. #responseFormat of + Just (B.JsonSchema _) -> textResponse m conformingJson + _ -> textResponse m unconstrainedMarkers + B.registerApiProviderWith + reg + ( B.apiProviderWith + api + (\_ _ _ -> Stream.nil) + (\m _ o -> modifyIORef' seen (<> [o]) >> pure (reply m o)) + ) + { B.describeThinking = \_ _ -> B.noThinkingRequested + } + pure (reg, seen) + +runOn :: B.Model -> B.ProviderRegistry -> IO (Either ShikumiError Assessment) +runOn model reg = + runEff + . runErrorNoCallStack @ShikumiError + . runRouting model + . runLLMWith reg + . routeLLM + $ runProgram (Predict assessSig emptyParams) proposal + +schemaOf :: B.Options -> Maybe Value +schemaOf o = case o ^. #responseFormat of + Just (B.JsonSchema fmt) -> Just (fmt ^. #schema) + _ -> Nothing + +tests :: TestTree +tests = + testGroup + "CliSchema" + [ testCase "claude CLI model: routed with the strict derived schema and decodes a list of records" $ do + let model = B.mkModel B.AnthropicMessagesCli "fixture" "https://example.invalid" + (reg, seen) <- cliRegistry B.AnthropicMessagesCli + result <- runOn model reg + result @?= Right expectedAssessment + recorded <- readIORef seen + map (^. #responseFormat) recorded + @?= [Just (B.JsonSchema (B.jsonSchemaFormat "output" (deriveSchema @Assessment) & #strict .~ True))] + map schemaOf recorded @?= [Just (deriveSchema @Assessment)] + -- Private shikumi metadata never reaches the transport. + map (Map.keys . (^. #metadata)) recorded @?= [[]], + testCase "codex CLI model: routed with the derived schema" $ do + let model = B.mkModel B.OpenAICompletionsCli "fixture" "https://example.invalid" + (reg, seen) <- cliRegistry B.OpenAICompletionsCli + result <- runOn model reg + result @?= Right expectedAssessment + readIORef seen >>= (@?= [Just (deriveSchema @Assessment)]) . map schemaOf, + testCase "same provider under a fallback tag: no schema, strings where records belong" $ do + let api = B.Custom "no-schema" + model = B.mkModel api "fixture" "https://example.invalid" + (reg, seen) <- cliRegistry api + result <- runOn model reg + readIORef seen >>= (@?= [Nothing]) . map schemaOf + case result of + Left e + | "expected object, got string" `T.isInfixOf` renderShikumiError e -> pure () + | otherwise -> assertFailure ("unexpected error: " <> T.unpack (renderShikumiError e)) + Right a -> assertFailure ("expected a decode failure, got " <> show a) + ] diff --git a/test/FallbackGuideSpec.hs b/test/FallbackGuideSpec.hs new file mode 100644 --- /dev/null +++ b/test/FallbackGuideSpec.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} + +-- | EP-67 M3: the fallback adapter's output guide shows the JSON shape of every +-- structured (object or array) output field, while a scalar-only guide stays +-- byte-for-byte what it was before shapes were added. Each case pins the full +-- system prompt 'fallbackAdapter' renders. +module FallbackGuideSpec (tests) where + +import Baikai (Context) +import CliSchemaSpec (Assessment, Proposal (..), Severity) +import Control.Lens ((^.)) +import Data.Generics.Labels () +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Fixtures (Article, Summary, sampleArticle) +import GHC.Generics (Generic) +import Shikumi.Adapter (Adapter (..), ToPrompt, fallbackAdapter) +import Shikumi.Schema (FromModel, ToSchema, Validatable) +import Shikumi.Schema.Types (Field (..), field) +import Shikumi.Signature (Signature, mkSignature) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +-- | A scalar-only output: two text fields (one described) and an enum. +data Triage = Triage + { label :: !(Field "Short label" Text), + reason :: !Text, + level :: !Severity + } + deriving stock (Generic, Show, Eq) + +instance ToSchema Triage + +instance FromModel Triage + +instance ToPrompt Triage + +instance Validatable Triage + +systemOf :: Context -> Text +systemOf ctx = fromMaybe "" (ctx ^. #systemPrompt) + +proposal :: Proposal +proposal = Proposal {plan = field "Ship on Friday."} + +assessSystem :: Text +assessSystem = + systemOf . fst $ + render + fallbackAdapter + (mkSignature "Assess whether the release plan is ready." :: Signature Proposal Assessment) + proposal + +triageSystem :: Text +triageSystem = + systemOf . fst $ + render fallbackAdapter (mkSignature "Triage the plan." :: Signature Proposal Triage) proposal + +summarySystem :: Text +summarySystem = + systemOf . fst $ + render fallbackAdapter (mkSignature "Summarize the article" :: Signature Article Summary) sampleArticle + +-- | Written by hand from the pre-EP-67 'fallbackOutputGuide' before it changed. +expectedTriage :: Text +expectedTriage = + "Triage the plan.\n\n\ + \Reply using these sections, each marker on its own line:\n\ + \[[ ## label ## ]] -- Short label\n\ + \[[ ## reason ## ]]\n\ + \[[ ## level ## ]]\n\ + \[[ ## completed ## ]]" + +expectedAssessment :: Text +expectedAssessment = + "Assess whether the release plan is ready.\n\n\ + \Reply using these sections, each marker on its own line:\n\ + \[[ ## concerns ## ]] -- Readiness concerns\n\ + \JSON shape: [{\"statement\": string, \"severity\": \"Blocker\" | \"Major\" | \"Minor\"}, ...]\n\ + \[[ ## verdict ## ]] -- Overall verdict\n\ + \[[ ## completed ## ]]" + +tests :: TestTree +tests = + testGroup + "FallbackGuide" + [ testCase "scalar-only guide is unchanged" $ + triageSystem @?= expectedTriage, + testCase "a list of records shows its nested keys and enum values" $ + assessSystem @?= expectedAssessment, + testCase "Summary gains shape lines for bullets and author only" $ + filter ("JSON shape:" `T.isPrefixOf`) (T.lines summarySystem) + @?= [ "JSON shape: [string, ...]", + "JSON shape: {\"name\": string}" + ] + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,11 +3,13 @@ module Main (main) where import AdapterSpec qualified +import CliSchemaSpec qualified import CombinatorSpec qualified import ConstraintSpec qualified import ContinuationSpec qualified import EndToEndSpec qualified import ErrorSpec qualified +import FallbackGuideSpec qualified import LLMSpec qualified import LiveSpec qualified import ModuleSpec qualified @@ -42,6 +44,8 @@ SchemaSpec.tests, SignatureSpec.tests, AdapterSpec.tests, + CliSchemaSpec.tests, + FallbackGuideSpec.tests, EndToEndSpec.tests, LLMSpec.tests, ResilienceSpec.tests,