diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,33 @@ ## Unreleased +## 0.5.0.0 — 2026-11-02 + +### Added + +- Add probability-backed `NoulWith`/`Noul`, `Choice` and `Score` outputs on + judgment-only and generative models, with closed evidence schemas, strict + decoding and shared local answer derivation. +- Add persistent per-field thresholds, score cuts and choice weights. Setting + changes reuse cached or replayed evidence without changing request identity. +- Add structured prompt and evidence rendering through `ToPrompt.toPromptJSON`, + `toEvidenceJSON` and `PromptValue` methods. + +### Changed + +- **Breaking:** `Params` gains a decision-settings field; use `emptyParams` + record updates instead of positional construction. Custom `ToPrompt` instances + without generic defaults must implement the new structured rendering methods. +- **Breaking:** `ModelCapability` gains `DecisionOnly`; update exhaustive matches. +- Route judgment-only models through typed structured state. Only evidence defaults + apply to these models; explicit generation controls retain typed refusals. +- Refuse decision streaming before dispatch. Nested decision containers, recursive + sessions and ReAct decision submissions remain unsupported. +- Require `mori://shinzui/baikai/packages/baikai` `>=0.10.0.0 && <0.11`, + `mori://shinzui/baikai/packages/baikai-claude` and + `mori://shinzui/baikai/packages/baikai-openai` `>=0.7.3.0 && <0.8`, and + `mori://shinzui/baikai/packages/baikai-effectful` `>=0.4.0.5 && <0.5`. + ## 0.4.1.1 — 2026-10-16 ### 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.4.1.1 +version: 0.5.0.0 synopsis: Typed, structured, evaluable LM programs over baikai category: AI description: @@ -13,6 +13,7 @@ maintainer: nadeem@gmail.com build-type: Simple extra-doc-files: CHANGELOG.md +extra-source-files: test/compile-fail/*.hs common common-options ghc-options: @@ -41,6 +42,9 @@ Shikumi.Adapter Shikumi.Combinator Shikumi.Compaction + Shikumi.Decision + Shikumi.Decision.Runtime + Shikumi.Decision.Setting Shikumi.Effect.Time Shikumi.Error Shikumi.LLM @@ -60,13 +64,16 @@ Shikumi.Signature Shikumi.Stream - other-modules: Shikumi.Adapter.Xml + other-modules: + Shikumi.Adapter.Prompt + Shikumi.Adapter.Xml + build-depends: aeson >=2.2 && <2.3, - baikai >=0.8.0.0 && <0.9, - baikai-claude >=0.7.1.1 && <0.8, - baikai-effectful >=0.4.0.3 && <0.5, - baikai-openai >=0.7.1.1 && <0.8, + baikai >=0.10.0.0 && <0.11, + baikai-claude >=0.7.3.0 && <0.8, + baikai-effectful >=0.4.0.5 && <0.5, + baikai-openai >=0.7.3.0 && <0.8, base >=4.20 && <5, base64-bytestring >=1.2 && <1.3, bytestring >=0.11 && <0.13, @@ -96,6 +103,7 @@ CombinatorSpec ConstraintSpec ContinuationSpec + DecisionDeriveSpec EndToEndSpec ErrorSpec FallbackGuideSpec @@ -128,10 +136,10 @@ build-depends: QuickCheck, aeson, - baikai >=0.8.0.0 && <0.9, - baikai-claude >=0.7.1.1 && <0.8, - baikai-effectful >=0.4.0.3 && <0.5, - baikai-openai >=0.7.1.1 && <0.8, + baikai >=0.10.0.0 && <0.11, + baikai-claude >=0.7.3.0 && <0.8, + baikai-effectful >=0.4.0.5 && <0.5, + baikai-openai >=0.7.3.0 && <0.8, base, base64-bytestring, bytestring, @@ -140,7 +148,7 @@ effectful, generic-lens, lens, - shikumi ^>=0.4.1.1, + shikumi ^>=0.5.0.0, stm, streamly-core, tasty, diff --git a/src/Shikumi/Adapter.hs b/src/Shikumi/Adapter.hs --- a/src/Shikumi/Adapter.hs +++ b/src/Shikumi/Adapter.hs @@ -38,6 +38,7 @@ module Shikumi.Adapter ( -- * Input rendering ToPrompt (..), + PromptValue (..), -- * The seam Adapter (..), @@ -58,6 +59,15 @@ metaTemperatureKey, metaNativePromptKey, metaNativeDemosKey, + metaDecisionStateKey, + metaDecisionSchemaKey, + metaDecisionEvidenceKey, + evidenceFields, + evidenceSchema, + renderEvidenceRequest, + responseValue, + attachDecisionState, + stripDecisionMarkers, attachNativeRender, nativeRenderPieces, renderOutputNative, @@ -82,6 +92,7 @@ user, userImage, ) +import Baikai.Model (isJudgmentOnly) import Control.Lens (at, (&), (.~), (?~), (^.)) import Data.Aeson (Object, Value (..), eitherDecodeStrict, toJSON) import Data.Aeson qualified as Aeson @@ -89,7 +100,6 @@ import Data.Aeson.KeyMap qualified as KM 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 @@ -98,13 +108,15 @@ import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Vector qualified as V -import GHC.Generics +import Shikumi.Adapter.Prompt import Shikumi.Adapter.Xml (decodeXmlFields, renderXmlFields, xmlSchemaGuide) +import Shikumi.Decision (Judgment (..), JudgmentKind (..), judgmentsInSchema, questionJSON) +import Shikumi.Decision.Setting (DecisionSetting) import Shikumi.Error (ShikumiError (..)) -import Shikumi.Multimodal (GImageFieldNames (..), GImageFields (..), Image, imageToContent) +import Shikumi.Multimodal (imageToContent) import Shikumi.Schema (FromModel, ToSchema, Validatable, deriveSchema, fromModelChecked) -import Shikumi.Schema.Types (Constrained (..), FieldMeta (..)) -import Shikumi.Signature (Demo (..), Signature, getDemos, getInstruction, outputFields) +import Shikumi.Schema.Types (FieldMeta (..)) +import Shikumi.Signature (Demo (..), Signature, getDemos, getInstruction, inputFields, outputFields) -- --------------------------------------------------------------------------- -- ToPrompt: render an input record (and demo outputs) as labeled text @@ -112,70 +124,6 @@ -- | Render a record as labeled text for the prompt. 'toPromptFields' yields the -- @(fieldName, valueText)@ pairs; 'toPrompt' joins them as @"name: value"@ lines. -class ToPrompt a where - toPromptFields :: a -> [(Text, Text)] - default toPromptFields :: (Generic a, GToPromptFields (Rep a)) => a -> [(Text, Text)] - toPromptFields = gToPromptFields . from - - toPrompt :: a -> Text - toPrompt = T.intercalate "\n" . map (\(k, v) -> k <> ": " <> v) . toPromptFields - - -- | The 'Image' values an /input/ record carries, in field order (EP-24). The - -- adapter lowers these to baikai @UserImage@ blocks in 'userTurn'. The generic - -- default walks the record, so any 'Generic' input gets it for free; a record - -- with no image field yields @[]@ and renders byte-for-byte as before. A - -- hand-written instance whose fields are polymorphic (e.g. - -- "Shikumi.Module".@WithReasoning@) cannot be walked generically and overrides - -- this to @[]@. - imageFields :: a -> [Image] - default imageFields :: (Generic a, GImageFields (Rep a)) => a -> [Image] - imageFields = gImageFields . from - - -- | The names of an input record's image fields, in field order (EP-24). The - -- text renderer in 'userTurn' drops these so an image is not also rendered as - -- prose. Same defaulting story as 'imageFields'. - imageFieldNames :: a -> [Text] - default imageFieldNames :: (Generic a, GImageFieldNames (Rep a)) => a -> [Text] - imageFieldNames = gImageFieldNames . from - -class GToPromptFields (f :: Type -> Type) where - gToPromptFields :: f p -> [(Text, Text)] - -instance (GToPromptFields cs) => GToPromptFields (D1 d cs) where - gToPromptFields (M1 x) = gToPromptFields x - -instance (GToPromptFields cs) => GToPromptFields (C1 c cs) where - gToPromptFields (M1 x) = gToPromptFields x - -instance (GToPromptFields a, GToPromptFields b) => GToPromptFields (a :*: b) where - gToPromptFields (a :*: b) = gToPromptFields a ++ gToPromptFields b - -instance (Selector s, PromptValue t) => GToPromptFields (S1 s (K1 R t)) where - gToPromptFields m@(M1 (K1 v)) = [(T.pack (selName m), promptValue v)] - --- | Render a leaf value to text. Text stays as-is; lists join with commas; --- 'Maybe' renders its contents or @""@; a 'Shikumi.Schema.Types.Field' unwraps; --- everything else falls back to 'Show'. -class PromptValue a where - promptValue :: a -> Text - -instance {-# OVERLAPPABLE #-} (Show a) => PromptValue a where - promptValue = T.pack . show - -instance PromptValue Text where - promptValue = id - -instance (PromptValue a) => PromptValue [a] where - promptValue = T.intercalate ", " . map promptValue - -instance (PromptValue a) => PromptValue (Maybe a) where - promptValue = maybe "" promptValue - --- | A t'Constrained' field renders as its inner value (the constraint is a --- compile-time/decode-time concern, not a prompt concern). EP-26. -instance (PromptValue a) => PromptValue (Constrained cs a) where - promptValue = promptValue . unConstrained - -- --------------------------------------------------------------------------- -- The seam -- --------------------------------------------------------------------------- @@ -187,7 +135,7 @@ } -- | Whether a model supports provider-native structured output. -data ModelCapability = NativeSchema | PromptFallback +data ModelCapability = NativeSchema | PromptFallback | DecisionOnly deriving stock (Eq, Show) -- | A pure capability check over a baikai t'Model', derived from baikai's @@ -213,6 +161,7 @@ -- separate capability (baikai's CLI providers enforce schemas but drop tools); -- see "Shikumi.Agent.ReAct". capabilityFor :: Model -> ModelCapability +capabilityFor m | isJudgmentOnly m = DecisionOnly capabilityFor m = case declaredStructuredOutput api of NoStructuredOutput -> PromptFallback NativeJsonSchema @@ -235,6 +184,7 @@ Model -> Adapter i o adapterFor m = case capabilityFor m of + DecisionOnly -> nativeAdapter NativeSchema -> nativeAdapter PromptFallback -> fallbackAdapter @@ -267,6 +217,20 @@ metaNativeDemosKey :: Text metaNativeDemosKey = "shikumi.native.demos" +-- | Reserved structured state for judgment routing. Stripped before transport. +metaDecisionStateKey :: Text +metaDecisionStateKey = "shikumi.decision.state" + +-- | Attach decision state without changing the native or marker prompt. +attachDecisionState :: Value -> Options -> Options +attachDecisionState state opts = opts & #metadata . at metaDecisionStateKey ?~ state + +-- | Remove private decoder metadata recursively before sending a schema. +stripDecisionMarkers :: Value -> Value +stripDecisionMarkers (Object o) = Object (fmap stripDecisionMarkers (KM.delete "x-shikumi-decision" o)) +stripDecisionMarkers (Array xs) = Array (fmap stripDecisionMarkers xs) +stripDecisionMarkers v = v + -- | Stamp the derived JSON schema onto a request's private metadata channel. This -- is no longer a no-op: it records the schema under 'metaResponseSchemaKey' so the -- router can attach a real @responseFormat@ once the ambient model is known. (The @@ -650,3 +614,67 @@ Just (Array alts) -> any isStringLike (V.toList alts) _ -> False isStringLike _ = False + +-- | Evidence mode and its original answer schema are independent of numeric +-- settings. The router chooses the answer schema for judgment-only models. +metaDecisionEvidenceKey, metaDecisionSchemaKey :: Text +metaDecisionEvidenceKey = "shikumi.decision.evidence" +metaDecisionSchemaKey = "shikumi.decision.schema" + +evidenceFields :: forall o. (ToSchema o) => Map Text DecisionSetting -> [Judgment] +evidenceFields settings = filter selected (fst (judgmentsInSchema schema)) + where + schema = deriveSchema @o + selected j = + Map.member (judgmentField j) settings || case propertySchema (judgmentField j) schema of + Just (Object p) -> KM.member "x-shikumi-decision" p + _ -> False + +-- | Replace selected answer properties with closed probability objects. +evidenceSchema :: Value -> [Judgment] -> Value +evidenceSchema (Object root) fields = case KM.lookup "properties" root of + Just (Object props) -> Object (KM.insert "properties" (Object (foldl replace props fields)) root) + _ -> Object root + where + probability = Aeson.object ["type" Aeson..= ("number" :: Text), "minimum" Aeson..= (0 :: Int), "maximum" Aeson..= (1 :: Int)] + closed props = Aeson.object ["type" Aeson..= ("object" :: Text), "properties" Aeson..= Object props, "required" Aeson..= map Key.toText (KM.keys props), "additionalProperties" Aeson..= False] + replace props j = + let keys = case judgmentKind j of JudgeBoolean {} -> []; JudgeChoice ls -> map fst ls; JudgeOrdered ls -> map (T.pack . show) [0 .. length ls - 1] + shape = case judgmentKind j of + JudgeBoolean {} -> closed (KM.singleton "noul" probability) + _ -> closed (KM.fromList [("probabilities", closed (KM.fromList [(Key.fromText k, probability) | k <- keys])), ("confidence", probability)]) + described = case shape of Object p -> Object (KM.insert "description" (String (jsonText (questionJSON j))) p); _ -> shape + in KM.insert (Key.fromText (judgmentField j)) described props +evidenceSchema v _ = v + +jsonText :: Value -> Text +jsonText = decodeUtf8 . LBS.toStrict . Aeson.encode + +-- | Render probability requests without demonstration turns. Task examples keep +-- labels or actual evidence and never invent probability distributions. +renderEvidenceRequest :: forall i o. (ToSchema o, ToPrompt i, ToPrompt o) => Map Text DecisionSetting -> Signature i o -> i -> (Context, Options) +renderEvidenceRequest settings sig input = + let fields = evidenceFields @o settings + original = deriveSchema @o + schema = evidenceSchema original fields + example (Demo i o) = case (toPromptJSON i, toEvidenceJSON o) of + (Object a, Object b) -> Object (KM.fromList [(k, v) | (k, v) <- KM.toList (KM.union b a), Key.toText k `elem` map fieldName (inputFields sig ++ outputFields sig)]) + _ -> Null + examples = if null (getDemos sig) then "" else "\n\nTask examples (labels or evidence):\n" <> jsonText (toJSON (map example (getDemos sig))) + header = getInstruction sig <> examples <> "\n\nEach probability and confidence must be between 0 and 1. Choice and Score probabilities should sum to one.\n" + describe f = case filter ((== fieldName f) . judgmentField) fields of + j : _ -> jsonText (questionJSON j) + [] -> fromMaybe "" (fieldDesc f) + native = header <> "Reply with a JSON object containing these fields:\n" <> T.unlines [fieldName f <> ": " <> describe f | f <- outputFields sig] + markerGuide = header <> "Reply using these sections, each marker on its own line:\n" <> T.unlines [marker (fieldName f) <> " -- " <> describe f <> maybe "" (\s -> "\nJSON shape: " <> renderShape s) (propertySchema (fieldName f) schema) | f <- outputFields sig] <> marker "completed" + opts = + attachNativeRender native [] (attachSchema schema emptyOptions) + & #metadata . at metaDecisionEvidenceKey ?~ toJSON [Aeson.object ["field" Aeson..= judgmentField j, "kind" Aeson..= (case judgmentKind j of JudgeBoolean {} -> "noul"; JudgeChoice {} -> "choice"; JudgeOrdered {} -> "score" :: Text)] | j <- fields] + & #metadata . at metaDecisionSchemaKey ?~ original + in (buildContext markerGuide [userTurn input], opts) + +-- | Read either JSON text or marker sections with schema-driven object coercion. +responseValue :: Value -> Response -> Either ShikumiError Value +responseValue schema response = case assistantJSON response of + Right value -> Right value + Left _ -> Right (sectionsToObject schema (parseMarkers (responseText response))) diff --git a/src/Shikumi/Adapter/Prompt.hs b/src/Shikumi/Adapter/Prompt.hs new file mode 100644 --- /dev/null +++ b/src/Shikumi/Adapter/Prompt.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Prompt records and typed leaves, shared by ordinary and decision rendering. +module Shikumi.Adapter.Prompt (ToPrompt (..), PromptValue (..)) where + +import Data.Aeson (Value (..), toJSON) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM +import Data.Kind (Type) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics +import Shikumi.Multimodal (GImageFieldNames (..), GImageFields (..), Image) +import Shikumi.Schema.Types (Constrained (..), Field (..)) + +class ToPrompt a where + toPromptFields :: a -> [(Text, Text)] + default toPromptFields :: (Generic a, GToPromptFields (Rep a)) => a -> [(Text, Text)] + toPromptFields = gToPromptFields . from + + toPrompt :: a -> Text + toPrompt = T.intercalate "\n" . map (\(k, v) -> k <> ": " <> v) . toPromptFields + + -- | Structured fields for decision state. Unlike prompt text, strings such as + -- @"null"@ or @"123"@ stay strings, and numbers, lists and optional values keep + -- their JSON types. Override for a custom input representation. + toPromptJSON :: a -> Value + default toPromptJSON :: (Generic a, GToPromptFields (Rep a)) => a -> Value + toPromptJSON = Object . KM.fromList . gToPromptJSON . from + + -- | Demonstration JSON retaining rich decision evidence when available. + toEvidenceJSON :: a -> Value + default toEvidenceJSON :: (Generic a, GToPromptFields (Rep a)) => a -> Value + toEvidenceJSON = Object . KM.fromList . gToEvidenceJSON . from + + -- | The 'Image' values an /input/ record carries, in field order (EP-24). The + -- adapter lowers these to baikai @UserImage@ blocks in @userTurn@. The generic + -- default walks the record, so any 'Generic' input gets it for free; a record + -- with no image field yields @[]@ and renders byte-for-byte as before. A + -- hand-written instance whose fields are polymorphic (e.g. + -- "Shikumi.Module".@WithReasoning@) cannot be walked generically and overrides + -- this to @[]@. + imageFields :: a -> [Image] + default imageFields :: (Generic a, GImageFields (Rep a)) => a -> [Image] + imageFields = gImageFields . from + + -- | The names of an input record's image fields, in field order (EP-24). The + -- text renderer in @userTurn@ drops these so an image is not also rendered as + -- prose. Same defaulting story as 'imageFields'. + imageFieldNames :: a -> [Text] + default imageFieldNames :: (Generic a, GImageFieldNames (Rep a)) => a -> [Text] + imageFieldNames = gImageFieldNames . from + +class GToPromptFields (f :: Type -> Type) where + gToPromptFields :: f p -> [(Text, Text)] + gToPromptJSON :: f p -> [(Key.Key, Value)] + gToEvidenceJSON :: f p -> [(Key.Key, Value)] + +instance (GToPromptFields cs) => GToPromptFields (D1 d cs) where + gToPromptFields (M1 x) = gToPromptFields x + gToPromptJSON (M1 x) = gToPromptJSON x + gToEvidenceJSON (M1 x) = gToEvidenceJSON x + +instance (GToPromptFields cs) => GToPromptFields (C1 c cs) where + gToPromptFields (M1 x) = gToPromptFields x + gToPromptJSON (M1 x) = gToPromptJSON x + gToEvidenceJSON (M1 x) = gToEvidenceJSON x + +instance (GToPromptFields a, GToPromptFields b) => GToPromptFields (a :*: b) where + gToPromptFields (a :*: b) = gToPromptFields a ++ gToPromptFields b + gToPromptJSON (a :*: b) = gToPromptJSON a ++ gToPromptJSON b + gToEvidenceJSON (a :*: b) = gToEvidenceJSON a ++ gToEvidenceJSON b + +instance (Selector s, PromptValue t) => GToPromptFields (S1 s (K1 R t)) where + gToPromptFields m@(M1 (K1 v)) = [(T.pack (selName m), promptValue v)] + gToPromptJSON m@(M1 (K1 v)) = [(Key.fromString (selName m), promptValueJSON v)] + gToEvidenceJSON m@(M1 (K1 v)) = [(Key.fromString (selName m), promptEvidenceJSON v)] + +-- | Render a leaf value to text. Text stays as-is; lists join with commas; +-- 'Maybe' renders its contents or @""@; a 'Shikumi.Schema.Types.Field' unwraps; +-- everything else falls back to 'Show'. +class PromptValue a where + promptValue :: a -> Text + + -- | JSON counterpart of the prompt leaf. Custom structured leaves should + -- override this instead of encoding JSON through 'Show'. + promptValueJSON :: a -> Value + promptValueJSON = String . promptValue + + -- | Full demonstration evidence; ordinary leaves keep their structured value. + promptEvidenceJSON :: a -> Value + promptEvidenceJSON = promptValueJSON + +instance {-# OVERLAPPABLE #-} (Show a) => PromptValue a where + promptValue = T.pack . show + +instance PromptValue Text where + promptValue = id + +instance PromptValue Bool where + promptValue = T.pack . show + promptValueJSON = toJSON + +instance PromptValue Int where + promptValue = T.pack . show + promptValueJSON = toJSON + +instance PromptValue Integer where + promptValue = T.pack . show + promptValueJSON = toJSON + +instance PromptValue Double where + promptValue = T.pack . show + promptValueJSON = toJSON + +instance (PromptValue a) => PromptValue [a] where + promptValue = T.intercalate ", " . map promptValue + promptValueJSON = toJSON . map promptValueJSON + +instance (PromptValue a) => PromptValue (Maybe a) where + promptValue = maybe "" promptValue + promptValueJSON = maybe Null promptValueJSON + +-- Preserve the existing textual representation of described fields. Decision +-- state uses the unwrapped JSON value without changing legacy prompts. +instance (Show a, PromptValue a) => PromptValue (Field d a) where + promptValue = T.pack . show + promptValueJSON = promptValueJSON . unField + promptEvidenceJSON = promptEvidenceJSON . unField + +-- | A t'Constrained' field renders as its inner value (the constraint is a +-- compile-time/decode-time concern, not a prompt concern). EP-26. +instance (PromptValue a) => PromptValue (Constrained cs a) where + promptValue = promptValue . unConstrained + promptValueJSON = promptValueJSON . unConstrained + promptEvidenceJSON = promptEvidenceJSON . unConstrained diff --git a/src/Shikumi/Decision.hs b/src/Shikumi/Decision.hs new file mode 100644 --- /dev/null +++ b/src/Shikumi/Decision.hs @@ -0,0 +1,507 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Closed decisions and their probability evidence. Answers are derived +-- locally; schemas describe judgments, while JSON decoding consumes evidence. +-- No provider transport or provider-specific response type lives here. +module Shikumi.Decision + ( NoulWith (..), + Noul, + Choice (..), + Score (..), + NoulEvidence (..), + ChoiceEvidence (..), + ScoreEvidence (..), + FieldEvidence (..), + ChoiceOptions (..), + IsDecision (..), + DecisionOutputs, + judgmentsOf, + Judgment (..), + JudgmentKind (..), + judgmentsInSchema, + questionJSON, + renderDecisionState, + deriveNoul, + deriveScore, + deriveChoice, + ) +where + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.:?), (.=)) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (Pair, Parser, parseEither) +import Data.Bifunctor (first) +import Data.Kind (Constraint, Type) +import Data.List (sort) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector (Vector) +import Data.Vector qualified as V +import GHC.Generics +import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Nat, Symbol, TypeError, symbolVal, type (+)) +import Shikumi.Adapter.Prompt (PromptValue (..), ToPrompt (..)) +import Shikumi.Error (ShikumiError (..)) +import Shikumi.Schema (FromModel (..), ToSchema (..), Validatable) +import Shikumi.Schema.Types (Field, FieldMeta (..), FieldPath, renderPath) +import Shikumi.Signature (Demo (..), Signature, getDemos, getInstruction, inputFields) + +-- Evidence JSON is shared by provider-backed and generative decisions. +newtype NoulEvidence = NoulEvidence {pTrue :: Double} + deriving stock (Eq, Show, Generic) + +data ChoiceEvidence = ChoiceEvidence + {probabilities :: !(Map Text Double), confidence :: !(Maybe Double)} + deriving stock (Eq, Show, Generic) + +data ScoreEvidence = ScoreEvidence + {levelProbabilities :: !(Vector Double), confidence :: !(Maybe Double)} + deriving stock (Eq, Show, Generic) + +data FieldEvidence = FieldNoul !NoulEvidence | FieldChoice !ChoiceEvidence | FieldScore !ScoreEvidence + deriving stock (Eq, Show, Generic) + +instance ToJSON NoulEvidence where + toJSON (NoulEvidence p) = object ["noul" .= p] + +instance FromJSON NoulEvidence where + parseJSON = withObject "NoulEvidence" $ \o -> NoulEvidence <$> (o .: "noul" >>= probabilityP) + +instance ToJSON ChoiceEvidence where + toJSON (ChoiceEvidence ps c) = object ["probabilities" .= ps, "confidence" .= c] + +instance FromJSON ChoiceEvidence where + parseJSON = withObject "ChoiceEvidence" $ \o -> do + ps <- o .: "probabilities" >>= traverse probabilityP + if Map.null ps then fail "empty probability distribution" else pure () + c <- o .:? "confidence" >>= traverse probabilityP + pure (ChoiceEvidence ps c) + +instance ToJSON ScoreEvidence where + toJSON (ScoreEvidence ps c) = object ["probabilities" .= indexedProbabilities ps, "confidence" .= c] + +instance FromJSON ScoreEvidence where + parseJSON = withObject "ScoreEvidence" $ \o -> do + ps <- o .: "probabilities" >>= traverse probabilityP + let n = Map.size ps + keys = map (T.pack . show) [0 .. n - 1] + if n < 2 || n > 10 || sort keys /= Map.keys ps + then fail "score probabilities must have contiguous indices 0..N-1, with 2 to 10 levels" + else pure () + c <- o .:? "confidence" >>= traverse probabilityP + pure (ScoreEvidence (V.fromList [ps Map.! k | k <- keys]) c) + +-- A wrapper needs a tag because numeric Choice labels and Score indices overlap. +instance ToJSON FieldEvidence where + toJSON e = case e of + FieldNoul x -> tagged "noul" (toJSON x) + FieldChoice x -> tagged "choice" (toJSON x) + FieldScore x -> tagged "score" (toJSON x) + where + tagged :: Text -> Value -> Value + tagged k v = object ["kind" .= k, "evidence" .= v] + +instance FromJSON FieldEvidence where + parseJSON = withObject "FieldEvidence" $ \o -> do + kind <- o .: "kind" :: Parser Text + case kind of + "noul" -> FieldNoul <$> o .: "evidence" + "choice" -> FieldChoice <$> o .: "evidence" + "score" -> FieldScore <$> o .: "evidence" + _ -> fail "unknown decision evidence kind" + +probabilityP :: Double -> Parser Double +probabilityP p + | finite p && p >= 0 && p <= 1 = pure p + | otherwise = fail "probability or confidence must be finite and in [0,1]" + +finite :: Double -> Bool +finite p = not (isNaN p || isInfinite p) + +indexedProbabilities :: Vector Double -> Map Text Double +indexedProbabilities ps = Map.fromList [(T.pack (show i), p) | (i, p) <- zip [0 :: Int ..] (V.toList ps)] + +data NoulWith (t :: Symbol) (f :: Symbol) = Noul + {value :: !Bool, probability :: !Double, confidence :: !Double} + deriving stock (Eq, Show, Generic) + +type Noul = NoulWith "" "" + +data Choice a = Choice + {value :: !a, probabilities :: !(Map Text Double), confidence :: !(Maybe Double)} + deriving stock (Eq, Show, Generic) + +-- The constructor carries the level-count constraint as well as the schema +-- instance, so an invalid Score cannot be constructed outside schema derivation. +data Score (levels :: [Symbol]) where + Score :: + (CheckLevels (Length levels)) => + {value :: !Double, level :: !Int, levelProbabilities :: !(Vector Double), confidence :: !(Maybe Double)} -> + Score levels + +deriving stock instance Eq (Score levels) + +deriving stock instance Show (Score levels) + +-- | Labels in declaration order, with optional criteria. Override the generic +-- nullary-enum default to use domain labels and descriptions. +class (Eq a) => ChoiceOptions a where + choiceOptions :: [(Text, a, Maybe Text)] + default choiceOptions :: (Generic a, GChoiceOptions (Rep a)) => [(Text, a, Maybe Text)] + choiceOptions = [(n, to v, Nothing) | (n, v) <- gChoiceOptions] + +class GChoiceOptions (f :: Type -> Type) where + gChoiceOptions :: [(Text, f p)] + +instance (GChoiceOptions f) => GChoiceOptions (D1 d f) where + gChoiceOptions = [(n, M1 v) | (n, v) <- gChoiceOptions @f] + +instance (GChoiceOptions a, GChoiceOptions b) => GChoiceOptions (a :+: b) where + gChoiceOptions = [(n, L1 v) | (n, v) <- gChoiceOptions @a] ++ [(n, R1 v) | (n, v) <- gChoiceOptions @b] + +instance (Constructor c) => GChoiceOptions (C1 c U1) where + gChoiceOptions = [(T.pack (conName (undefined :: C1 c U1 ())), M1 U1)] + +class KnownLevels (ss :: [Symbol]) where + levelNames :: Proxy ss -> [Text] + +instance KnownLevels '[] where levelNames _ = [] + +instance (KnownSymbol s, KnownLevels ss) => KnownLevels (s ': ss) where + levelNames _ = T.pack (symbolVal (Proxy @s)) : levelNames (Proxy @ss) + +type family Length (ss :: [Symbol]) :: Nat where + Length '[] = 0 + Length (s ': ss) = 1 + Length ss + +type family CheckLevels (n :: Nat) :: Constraint where + CheckLevels 0 = TypeError ('Text "Score requires 2 to 10 levels") + CheckLevels 1 = TypeError ('Text "Score requires 2 to 10 levels") + CheckLevels 2 = () + CheckLevels 3 = () + CheckLevels 4 = () + CheckLevels 5 = () + CheckLevels 6 = () + CheckLevels 7 = () + CheckLevels 8 = () + CheckLevels 9 = () + CheckLevels 10 = () + CheckLevels n = TypeError ('Text "Score requires 2 to 10 levels; got " ':<>: 'ShowType n) + +-- | Schema-independent metadata, also consumed by the generative evidence path. +data JudgmentKind + = JudgeBoolean !(Maybe Value) !(Maybe Value) + | JudgeChoice ![(Text, Maybe Value)] + | JudgeOrdered ![Value] + deriving stock (Eq, Show, Generic) + +data Judgment = Judgment + {judgmentField :: !Text, judgmentInstruction :: !(Maybe Text), judgmentKind :: !JudgmentKind} + deriving stock (Eq, Show, Generic) + +class IsDecision a where + decisionKind :: Proxy a -> JudgmentKind + decisionDescription :: Proxy a -> Maybe Text + decisionDescription _ = Nothing + +instance (KnownSymbol t, KnownSymbol f) => IsDecision (NoulWith t f) where + decisionKind _ = JudgeBoolean (criterion @t) (criterion @f) + +instance IsDecision Bool where decisionKind _ = JudgeBoolean Nothing Nothing + +instance (ChoiceOptions a) => IsDecision (Choice a) where + decisionKind _ = JudgeChoice [(n, String <$> d) | (n, _, d) <- choiceOptions @a] + +instance (KnownLevels ss, CheckLevels (Length ss)) => IsDecision (Score ss) where + decisionKind _ = JudgeOrdered (map String (levelNames (Proxy @ss))) + +instance (KnownSymbol d, IsDecision a) => IsDecision (Field d a) where + decisionKind _ = decisionKind (Proxy @a) + decisionDescription _ = Just (T.pack (symbolVal (Proxy @d))) + +criterion :: forall s. (KnownSymbol s) => Maybe Value +criterion = case T.pack (symbolVal (Proxy @s)) of + "" -> Nothing + t -> Just (String t) + +-- | Compile-time guarantee that every output is a supported decision leaf. +class DecisionOutputs o where + decisionJudgments :: Proxy o -> [Judgment] + default decisionJudgments :: (GDecisionOutputs (Rep o)) => Proxy o -> [Judgment] + decisionJudgments _ = gDecisionJudgments (Proxy @(Rep o)) + +judgmentsOf :: forall o. (DecisionOutputs o) => [Judgment] +judgmentsOf = decisionJudgments (Proxy @o) + +type family RequireDecision (name :: Symbol) a :: Constraint where + RequireDecision name (Field d a) = RequireDecision name a + RequireDecision name (NoulWith t f) = () + RequireDecision name (Choice a) = () + RequireDecision name (Score ss) = () + RequireDecision name Bool = () + RequireDecision name a = TypeError ('Text "Decision output field `" ':<>: 'Text name ':<>: 'Text "` has unsupported type " ':<>: 'ShowType a) + +class GDecisionOutputs (f :: Type -> Type) where + gDecisionJudgments :: Proxy f -> [Judgment] + +instance (GDecisionOutputs f) => GDecisionOutputs (D1 d f) where + gDecisionJudgments _ = gDecisionJudgments (Proxy @f) + +instance (GDecisionOutputs f) => GDecisionOutputs (C1 c f) where + gDecisionJudgments _ = gDecisionJudgments (Proxy @f) + +instance (GDecisionOutputs a, GDecisionOutputs b) => GDecisionOutputs (a :*: b) where + gDecisionJudgments _ = gDecisionJudgments (Proxy @a) ++ gDecisionJudgments (Proxy @b) + +instance (KnownSymbol name, RequireDecision name a, IsDecision a) => GDecisionOutputs (S1 ('MetaSel ('Just name) su ss ds) (K1 R a)) where + gDecisionJudgments _ = [Judgment (T.pack (symbolVal (Proxy @name))) (decisionDescription (Proxy @a)) (decisionKind (Proxy @a))] + +instance (KnownSymbol t, KnownSymbol f) => ToSchema (NoulWith t f) where + toSchema _ = case decisionKind (Proxy @(NoulWith t f)) of + JudgeBoolean Nothing Nothing -> marked "noul" ["type" .= ("boolean" :: Text)] + JudgeBoolean t f -> marked "noul" ["type" .= ("boolean" :: Text), "anyOf" .= [branch (Bool True) t, branch (Bool False) f]] + _ -> marked "noul" [] + +instance (ChoiceOptions a) => ToSchema (Choice a) where + toSchema _ = marked "choice" ["type" .= ("string" :: Text), "anyOf" .= [branch (String n) (String <$> d) | (n, _, d) <- choiceOptions @a]] + +instance (KnownLevels ss, CheckLevels (Length ss)) => ToSchema (Score ss) where + toSchema _ = marked "score" ["type" .= ("integer" :: Text), "anyOf" .= [branch (toJSON i) (Just (String d)) | (i, d) <- zip [0 :: Int ..] (levelNames (Proxy @ss))]] + +marked :: Text -> [Pair] -> Value +marked kind fields = object (fields ++ ["x-shikumi-decision" .= object ["kind" .= kind]]) + +branch :: Value -> Maybe Value -> Value +branch c d = object ["const" .= c, "description" .= d] + +-- | Read only the declared judgment grammar. Unsupported or malformed fields +-- are returned separately for a pre-dispatch refusal. Property order follows a +-- complete, unique required array, otherwise ascending property name. +judgmentsInSchema :: Value -> ([Judgment], [Text]) +judgmentsInSchema (Object schema) + | Just (Object props) <- KM.lookup "properties" schema = + foldMap (readField props) (propertyOrder schema props) + where + readField props name = case KM.lookup (Key.fromText name) props >>= readJudgment name of + Just j -> ([j], []) + Nothing -> ([], [name]) +judgmentsInSchema _ = ([], []) + +propertyOrder :: KM.KeyMap Value -> KM.KeyMap Value -> [Text] +propertyOrder schema props = + let names = map (Key.toText . fst) (KM.toAscList props) + in case KM.lookup "required" schema of + Just (Array xs) + | Just required <- traverse textOf (V.toList xs), sort required == names -> required + _ -> names + +readJudgment :: Text -> Value -> Maybe Judgment +readJudgment name (Object prop) = do + -- Ignoring an unfamiliar constraint would widen the caller's declared domain. + if all (`elem` ["type", "description", "title", "x-shikumi-decision", "anyOf", "oneOf", "enum"]) (KM.keys prop) + then pure () + else Nothing + instruction <- case KM.lookup "description" prop of + Nothing -> Just Nothing + Just Null -> Just Nothing + Just (String t) -> Just (Just t) + _ -> Nothing + kind <- booleanKind prop <|> choiceKind prop <|> scoreKind prop + pure (Judgment name instruction kind) +readJudgment _ _ = Nothing + +booleanKind :: KM.KeyMap Value -> Maybe JudgmentKind +booleanKind p + | KM.member "enum" p = Nothing + | KM.lookup "type" p == Just (String "boolean"), not (KM.member "anyOf" p || KM.member "oneOf" p) = Just (JudgeBoolean Nothing Nothing) + | allowedType "boolean" p = do + if KM.member "anyOf" p && KM.member "oneOf" p then Nothing else pure () + Array xs <- KM.lookup "anyOf" p <|> KM.lookup "oneOf" p + pairs <- traverse readBranch (V.toList xs) + if sort (map fst pairs) == [Bool False, Bool True] + then Just (JudgeBoolean (lookup (Bool True) pairs >>= id) (lookup (Bool False) pairs >>= id)) + else Nothing + | otherwise = Nothing + +choiceKind :: KM.KeyMap Value -> Maybe JudgmentKind +choiceKind p = do + if allowedType "string" p && not (KM.member "oneOf" p) then pure () else Nothing + labels <- case (KM.lookup "enum" p, KM.lookup "anyOf" p) of + (Just (Array xs), Nothing) -> traverse (\v -> (,Nothing) <$> textOf v) (V.toList xs) + (Nothing, Just (Array xs)) -> traverse (\v -> do (c, d) <- readBranch v; n <- textOf c; pure (n, d)) (V.toList xs) + _ -> Nothing + let names = map fst labels + if null names || length names > 255 || Map.size (Map.fromList labels) /= length names + then Nothing + else Just (JudgeChoice labels) + +scoreKind :: KM.KeyMap Value -> Maybe JudgmentKind +scoreKind p = do + if allowedType "integer" p && not (KM.member "enum" p || KM.member "oneOf" p) then pure () else Nothing + Array xs <- KM.lookup "anyOf" p + pairs <- traverse readBranch (V.toList xs) + let n = length pairs + if n >= 2 && n <= 10 && map fst pairs == map toJSON [0 :: Int .. n - 1] + then Just (JudgeOrdered (map (fromMaybe Null . snd) pairs)) + else Nothing + +allowedType :: Text -> KM.KeyMap Value -> Bool +allowedType t p = maybe True (== String t) (KM.lookup "type" p) + +readBranch :: Value -> Maybe (Value, Maybe Value) +readBranch (Object o) + | all (`elem` ["const", "description"]) (KM.keys o) = do + c <- KM.lookup "const" o + pure (c, case KM.lookup "description" o of Just Null -> Nothing; d -> d) +readBranch _ = Nothing + +textOf :: Value -> Maybe Text +textOf (String t) = Just t +textOf _ = Nothing + +-- | Render a provider-neutral judgment question; no private marker is needed. +questionJSON :: Judgment -> Value +questionJSON (Judgment name instruction kind) = + object + (["type" .= kindName, "instructions" .= fromMaybe name instruction] ++ criteria) + where + (kindName, criteria) = case kind of + JudgeBoolean Nothing Nothing -> ("noul" :: Text, []) + JudgeBoolean t f -> ("noul", ["criteria" .= object ["true" .= t, "false" .= f]]) + JudgeChoice xs -> ("choice", ["criteria" .= object [Key.fromText n .= d | (n, d) <- xs]]) + JudgeOrdered ds -> ("score", ["criteria" .= ds]) + +-- | A single JSON state, with flat input/output demos. Demo answers use their +-- derived values through 'PromptValue', rather than evidence or Haskell Show. +renderDecisionState :: (ToPrompt i, ToPrompt o) => Signature i o -> i -> Value +renderDecisionState sig i = + object + ( [ "instructions" .= getInstruction sig, + "input_fields" .= T.intercalate "\n" (zipWith describe [1 :: Int ..] (inputFields sig)), + "inputs" .= toPromptJSON i + ] + ++ ["demos" .= map demo (getDemos sig) | not (null (getDemos sig))] + ) + where + inputObject = case toPromptJSON i of Object o -> o; _ -> KM.empty + describe n (FieldMeta name description) = + T.pack (show n) <> ". `" <> name <> "` (" <> jsonType (KM.lookup (Key.fromText name) inputObject) <> "): " <> fromMaybe "" description + demo (Demo di o) = case (toPromptJSON di, toPromptJSON o) of + (Object ins, Object outs) -> Object (KM.union outs ins) + _ -> object [] + jsonType = \case + Just (String _) -> "str" + Just (Bool _) -> "bool" + Just (Number _) -> "number" + Just (Array _) -> "list" + Just (Object _) -> "dict" + _ -> "null" + +-- Pure derivation accepts explicit settings; defaults are selected by decoding. +deriveNoul :: Double -> NoulEvidence -> (Bool, Double) +deriveNoul threshold (NoulEvidence p) = (p >= threshold, if denominator == 0 then 0 else abs (p - threshold) / denominator) + where + denominator = max threshold (1 - threshold) + +deriveScore :: [Double] -> ScoreEvidence -> Either Text (Double, Int) +deriveScore cuts (ScoreEvidence ps _) = do + validateMass (V.toList ps) + let v = sum [fromIntegral n * p | (n, p) <- zip [0 :: Int ..] (V.toList ps)] / V.sum ps + pure (v, length (filter (<= v) cuts)) + +-- | Select from declared labels in order; ties prefer the raw winner, then +-- declaration order. A probability map alone cannot retain that order. +deriveChoice :: [Text] -> Map Text Double -> ChoiceEvidence -> Either Text Text +deriveChoice labels weights (ChoiceEvidence ps _) = do + if sort labels == Map.keys ps then pure () else Left "probability keys must match declared choice labels exactly" + validateMass (Map.elems ps) + let scored = [(label, ps Map.! label * Map.findWithDefault 1 label weights) | label <- labels] + if any (\(_, p) -> not (finite p) || p < 0) scored + then Left "weighted probabilities must be finite and non-negative" + else if all ((== 0) . snd) scored then Left "no remaining probability mass" else pure () + let winner pairs = case pairs of + [] -> Left "empty choice" + x : xs -> Right (fst (foldl (\best next -> if snd next > snd best then next else best) x xs)) + raw <- winner [(label, ps Map.! label) | label <- labels] + weighted <- winner scored + pure (if lookup raw scored == lookup weighted scored then raw else weighted) + +validateMass :: [Double] -> Either Text () +validateMass ps + | any (\p -> not (finite p) || p < 0 || p > 1) ps = Left "probabilities must be finite and in [0,1]" + | sum ps <= 0 = Left "no remaining probability mass" + | otherwise = Right () + +decodeEvidence :: (FromJSON a) => FieldPath -> Value -> Either ShikumiError a +decodeEvidence path = first (SchemaMismatch . ((renderPath path <> ": ") <>) . T.pack) . parseEither parseJSON + +-- Internal normalized decode values, supplied after local derivation. These +-- annotations are never accepted from a provider evidence object. +derivedAt :: (FromJSON a) => FieldPath -> Value -> a -> Either ShikumiError a +derivedAt path (Object o) fallback = maybe (Right fallback) (decodeEvidence path) (KM.lookup "x-shikumi-derived" o) +derivedAt _ _ fallback = Right fallback + +instance FromModel (NoulWith t f) where + fromModelP path v = do + e@(NoulEvidence p) <- decodeEvidence path v + let (answer, c) = deriveNoul 0.5 e + (answer', c') <- derivedAt path v (answer, c) + pure (Noul answer' p c') + +instance (ChoiceOptions a) => FromModel (Choice a) where + fromModelP path v = do + e@(ChoiceEvidence ps c) <- decodeEvidence path v + label <- first (SchemaMismatch . ((renderPath path <> ": ") <>)) (deriveChoice [n | (n, _, _) <- choiceOptions @a] Map.empty e) + label' <- derivedAt path v label + case [a | (n, a, _) <- choiceOptions @a, n == label'] of + a : _ -> pure (Choice a ps c) + [] -> Left (SchemaMismatch (renderPath path <> ": undeclared choice label")) + +instance (KnownLevels ss, CheckLevels (Length ss)) => FromModel (Score ss) where + fromModelP path v = do + e@(ScoreEvidence ps c) <- decodeEvidence path v + let n = length (levelNames (Proxy @ss)) + if V.length ps == n then pure () else Left (SchemaMismatch (renderPath path <> ": score level count does not match declaration")) + (answer, l) <- first (SchemaMismatch . ((renderPath path <> ": ") <>)) (deriveScore [fromIntegral k + 0.5 | k <- [0 .. n - 2]] e) + (answer', l') <- derivedAt path v (answer, l) + pure (Score answer' l' ps c) + +instance ToJSON (NoulWith t f) where toJSON (Noul _ p _) = toJSON (NoulEvidence p) + +instance ToJSON (Choice a) where toJSON (Choice _ ps c) = toJSON (ChoiceEvidence ps c) + +instance ToJSON (Score ss) where toJSON (Score _ _ ps c) = toJSON (ScoreEvidence ps c) + +instance Validatable (NoulWith t f) + +instance Validatable (Choice a) + +instance Validatable (Score ss) + +instance PromptValue (NoulWith t f) where + promptValue (Noul v _ _) = if v then "true" else "false" + promptValueJSON (Noul v _ _) = Bool v + promptEvidenceJSON n@(Noul v _ c) = case toJSON n of Object o -> Object (KM.insert "value" (Bool v) (KM.insert "confidence" (toJSON c) o)); x -> x + +instance (ChoiceOptions a) => PromptValue (Choice a) where + promptValue (Choice a _ _) = fromMaybe "" (lookup a [(v, n) | (n, v, _) <- choiceOptions @a]) + promptValueJSON = String . promptValue + promptEvidenceJSON c = case toJSON c of Object o -> Object (KM.insert "value" (String (promptValue c)) o); x -> x + +instance PromptValue (Score ss) where + promptValue (Score _ l _ _) = T.pack (show l) + promptValueJSON (Score _ l _ _) = toJSON l + promptEvidenceJSON s@(Score v l _ _) = case toJSON s of Object o -> Object (KM.insert "value" (toJSON v) (KM.insert "level" (toJSON l) o)); x -> x diff --git a/src/Shikumi/Decision/Runtime.hs b/src/Shikumi/Decision/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Shikumi/Decision/Runtime.hs @@ -0,0 +1,98 @@ +-- | Extraction of provider-neutral probability evidence. Provider selections are +-- deliberately ignored; the typed decoder derives every answer locally. +module Shikumi.Decision.Runtime (evidenceOf, evidenceObject, decodeDecisionEvidence) where + +import Baikai (AssistantContent (..), Response) +import Control.Lens ((^.)) +import Data.Aeson (Result (..), Value (..), fromJSON) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Generics.Labels () +import Data.List (sort) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Shikumi.Decision +import Shikumi.Decision.Setting (DecisionSetting, deriveField) +import Shikumi.Error (ShikumiError (..)) + +evidenceOf :: [Judgment] -> Response -> Maybe (Either ShikumiError (Map Text FieldEvidence)) +evidenceOf js response = case [d | AssistantData d <- V.toList (response ^. #message . #content)] of + [] -> Nothing + [d] -> Just $ do + ps <- maybe (Left (SchemaMismatch "decision response: missing probabilities")) Right (d ^. #probabilities) + let cs = maybe Map.empty id (d ^. #confidence) + get field key probs = maybe (Left (SchemaMismatch (field <> ": missing probability " <> key))) Right (Map.lookup key probs) + Map.fromList + <$> traverse + ( \j -> do + let name = judgmentField j + probs <- maybe (Left (MissingField name)) Right (Map.lookup name ps) + if all (\p -> not (isNaN p || isInfinite p) && p >= 0 && p <= 1) (Map.elems probs ++ maybe [] pure (Map.lookup name cs)) + then pure () + else Left (ValidationFailure (name <> ": probability/confidence must be finite and in [0,1]")) + ev <- case judgmentKind j of + JudgeBoolean {} -> FieldNoul . NoulEvidence <$> get name "true" probs + JudgeChoice labels -> do + if Map.keysSet probs == Map.keysSet (Map.fromList labels) then pure () else Left (SchemaMismatch (name <> ": probability keys differ from declared labels")) + pure (FieldChoice (ChoiceEvidence probs (Map.lookup name cs))) + JudgeOrdered levels -> do + let keys = map (T.pack . show) [0 .. length levels - 1] + if Map.keysSet probs == Map.keysSet (Map.fromList [(k, ()) | k <- keys]) then pure () else Left (SchemaMismatch (name <> ": probability keys differ from declared levels")) + values <- traverse (\k -> get name k probs) keys + pure (FieldScore (ScoreEvidence (V.fromList values) (Map.lookup name cs))) + pure (name, ev) + ) + js + _ -> Just (Left (SchemaMismatch "decision response: expected one structured data block")) + +-- | Rich fields decode evidence; native closed fields decode the derived scalar. +evidenceObject :: Value -> [Judgment] -> Map Text DecisionSetting -> Map Text FieldEvidence -> Either ShikumiError Value +evidenceObject schema js settings evidence = Object . KM.fromList <$> traverse field js + where + props = case schema of + Object o | Just (Object p) <- KM.lookup "properties" o -> p + _ -> KM.empty + field j = do + let name = judgmentField j + rich = case KM.lookup (K.fromText name) props of Just (Object p) -> KM.member "x-shikumi-decision" p; _ -> False + ev <- maybe (Left (MissingField name)) Right (Map.lookup name evidence) + derived <- deriveField j (Map.lookup name settings) ev + let native = case derived of + Object o | Just result <- KM.lookup "x-shikumi-derived" o -> case judgmentKind j of + JudgeBoolean {} -> case result of Array a -> maybe Null id (a V.!? 0); _ -> Null + JudgeOrdered {} -> case result of Array a -> maybe Null id (a V.!? 1); _ -> Null + JudgeChoice {} -> result + _ -> derived + pure (K.fromText name, if rich then derived else native) + +-- | Strict generative evidence grammar. Shape errors and range violations keep +-- the field path. No provider-supplied derived-answer annotation is accepted. +decodeDecisionEvidence :: Judgment -> Value -> Either ShikumiError FieldEvidence +decodeDecisionEvidence j value = do + fields <- case value of Object o -> Right o; _ -> shape "expected evidence object" + let expected = case judgmentKind j of JudgeBoolean {} -> ["noul"]; _ -> ["confidence", "probabilities"] + if sort (KM.keys fields) == sort expected then pure () else shape "missing or extra evidence keys" + case judgmentKind j of + JudgeBoolean {} -> FieldNoul . NoulEvidence <$> (get "noul" fields >>= number) + kind -> do + probs <- get "probabilities" fields >>= \case Object p -> Right p; _ -> shape "expected probabilities object" + let keys = case kind of JudgeChoice ls -> map (K.fromText . fst) ls; JudgeOrdered ls -> map (K.fromText . T.pack . show) [0 .. length ls - 1]; _ -> [] + if sort (KM.keys probs) == sort keys then pure () else shape "missing or extra probability keys" + ps <- traverse number probs + confidence <- get "confidence" fields >>= number + let mapping = Map.fromList [(K.toText key, p) | (key, p) <- KM.toList ps] + case kind of + JudgeChoice {} -> pure (FieldChoice (ChoiceEvidence mapping (Just confidence))) + JudgeOrdered {} -> pure (FieldScore (ScoreEvidence (V.fromList [mapping Map.! K.toText key | key <- keys]) (Just confidence))) + _ -> shape "unexpected judgment kind" + where + shape :: Text -> Either ShikumiError a + shape msg = Left (SchemaMismatch (judgmentField j <> ": " <> msg)) + get key fields = maybe (shape ("missing " <> K.toText key)) Right (KM.lookup key fields) + number (Number n) = case fromJSON (Number n) of + Success p | not (isNaN p || isInfinite p) && p >= 0 && p <= (1 :: Double) -> Right p + _ -> Left (ValidationFailure (judgmentField j <> ": probability/confidence must be finite and in [0,1]")) + number _ = shape "expected numeric probability/confidence" diff --git a/src/Shikumi/Decision/Setting.hs b/src/Shikumi/Decision/Setting.hs new file mode 100644 --- /dev/null +++ b/src/Shikumi/Decision/Setting.hs @@ -0,0 +1,85 @@ +-- | Pure per-field calibration settings and local derivation. These values never +-- enter provider requests or response-cache identity. +module Shikumi.Decision.Setting (DecisionSetting (..), defaultSetting, validateSetting, deriveField) where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, toJSON, withObject, (.:), (.=)) +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (Parser) +import Data.Bifunctor (first) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import GHC.Generics (Generic) +import Shikumi.Decision (Judgment (..), JudgmentKind (..)) +import Shikumi.Decision qualified as D +import Shikumi.Error (ShikumiError (..)) + +data DecisionSetting + = NoulSetting {threshold :: !Double} + | ScoreSetting {cuts :: ![Double]} + | ChoiceSetting {weights :: !(Map Text Double)} + deriving stock (Eq, Show, Generic) + +instance ToJSON DecisionSetting where + toJSON = \case + NoulSetting t -> object ["kind" .= ("noul" :: Text), "threshold" .= t] + ScoreSetting cs -> object ["kind" .= ("score" :: Text), "cuts" .= cs] + ChoiceSetting ws -> object ["kind" .= ("choice" :: Text), "weights" .= ws] + +instance FromJSON DecisionSetting where + parseJSON = withObject "DecisionSetting" $ \o -> do + kind <- o .: "kind" :: Parser Text + case kind of + "noul" -> NoulSetting <$> o .: "threshold" + "score" -> ScoreSetting <$> o .: "cuts" + "choice" -> ChoiceSetting <$> o .: "weights" + _ -> fail "unknown decision setting kind" + +defaultSetting :: Judgment -> DecisionSetting +defaultSetting j = case judgmentKind j of + JudgeBoolean {} -> NoulSetting 0.5 + JudgeOrdered levels -> ScoreSetting [fromIntegral k + 0.5 | k <- [0 .. length levels - 2]] + JudgeChoice {} -> ChoiceSetting Map.empty + +-- | Validate against the declared domain. Omitted Choice weights stay absent +-- and mean 1; zero weights are valid and disable the corresponding label. +validateSetting :: Judgment -> DecisionSetting -> Either Text DecisionSetting +validateSetting j setting = case (judgmentKind j, setting) of + (JudgeBoolean {}, NoulSetting t) + | not (finite t) || t < 0 || t > 1 -> bad "threshold must be finite and in [0,1]" + | otherwise -> Right setting + (JudgeOrdered levels, ScoreSetting cs) + | length cs /= length levels - 1 -> bad "cuts must have exactly N-1 entries" + | any (\c -> not (finite c) || c <= 0 || c >= fromIntegral (length levels - 1)) cs -> bad "cuts must be finite and in (0,N-1)" + | not (and (zipWith (<) cs (drop 1 cs))) -> bad "cuts must be strictly increasing" + | otherwise -> Right setting + (JudgeChoice options, ChoiceSetting ws) + | any (`notElem` map fst options) (Map.keys ws) -> bad "weights must name declared labels" + | any (\w -> not (finite w) || w < 0) (Map.elems ws) -> bad "weights must be finite and non-negative" + | otherwise -> Right setting + _ -> bad "setting kind does not match the decision field" + where + bad rule = Left (judgmentField j <> ": " <> rule) + finite x = not (isNaN x || isInfinite x) + +-- | Derive once, after validating settings and evidence. The private annotation +-- is consumed only by the rich FromModel leaves; it never enters request identity +-- or the public evidence codecs. Native fields receive an ordinary scalar. +deriveField :: Judgment -> Maybe DecisionSetting -> D.FieldEvidence -> Either ShikumiError Value +deriveField j stored ev = do + setting <- first ValidationFailure (validateSetting j (fromMaybe (defaultSetting j) stored)) + case (judgmentKind j, setting, ev) of + (JudgeBoolean {}, NoulSetting t, D.FieldNoul e@(D.NoulEvidence _)) -> + let answer = D.deriveNoul t e in pure (annotate (toJSON answer) (toJSON e)) + (JudgeChoice labels, ChoiceSetting ws, D.FieldChoice e) -> do + label <- first located (D.deriveChoice (map fst labels) ws e) + pure (annotate (toJSON label) (toJSON e)) + (JudgeOrdered _, ScoreSetting cs, D.FieldScore e) -> do + answer <- first located (D.deriveScore cs e) + pure (annotate (toJSON answer) (toJSON e)) + _ -> Left (located "evidence kind does not match judgment") + where + located msg = SchemaMismatch (judgmentField j <> ": " <> msg) + annotate result (Object o) = Object (KM.insert "x-shikumi-derived" result o) + annotate _ v = v diff --git a/src/Shikumi/LLM/Defaults.hs b/src/Shikumi/LLM/Defaults.hs --- a/src/Shikumi/LLM/Defaults.hs +++ b/src/Shikumi/LLM/Defaults.hs @@ -11,6 +11,7 @@ import Baikai (Options) import Baikai.Evidence (EvidenceRequest) +import Baikai.Model (isJudgmentOnly) import Baikai.Speed (Speed) import Baikai.ThinkingLevel (ThinkingLevel) import Control.Applicative ((<|>)) @@ -57,9 +58,12 @@ withRequestDefaults defaults action = do when (defaultMaxTokens defaults == Just 0) $ throwError (ValidationFailure "request defaults: defaultMaxTokens must be positive") + let forModel model + | isJudgmentOnly model = emptyRequestDefaults {defaultEvidence = defaultEvidence defaults} + | otherwise = defaults interpose ( \_ -> \case - Complete model ctx opts -> complete model ctx (applyRequestDefaults defaults opts) - Stream model ctx opts -> stream model ctx (applyRequestDefaults defaults opts) + Complete model ctx opts -> complete model ctx (applyRequestDefaults (forModel model) opts) + Stream model ctx opts -> stream model ctx (applyRequestDefaults (forModel model) opts) ) action diff --git a/src/Shikumi/Module.hs b/src/Shikumi/Module.hs --- a/src/Shikumi/Module.hs +++ b/src/Shikumi/Module.hs @@ -31,7 +31,7 @@ import Baikai (emptyContext, emptyModel, emptyOptions, user) import Control.Lens ((&), (.~)) -import Data.Aeson (Object, ToJSON (..), Value (Object)) +import Data.Aeson (Object, ToJSON (..), Value (Object, String)) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KM import Data.Generics.Labels () @@ -115,6 +115,10 @@ -- Render without leaning on @o@'s @Show@: reuse @o@'s own t'ToPrompt'. instance (ToPrompt o) => ToPrompt (WithReasoning o) where toPromptFields wr = ("reasoning", reasoning wr) : toPromptFields (value wr) + toEvidenceJSON = toPromptJSON + toPromptJSON wr = case toPromptJSON (value wr) of + Object fields -> Object (KM.insert "reasoning" (String (reasoning wr)) fields) + v -> v -- @value@ is polymorphic in @o@, so the generic image walk cannot resolve; a -- t'WithReasoning' is a text-only output wrapper and carries no image fields. diff --git a/src/Shikumi/Program.hs b/src/Shikumi/Program.hs --- a/src/Shikumi/Program.hs +++ b/src/Shikumi/Program.hs @@ -47,6 +47,10 @@ Params (..), Demo (..), emptyParams, + decisionSettingFor, + setDecisionSetting, + clearDecisionSetting, + parseResponseWithSettings, TempSchedule (..), -- * Construction & execution @@ -58,6 +62,7 @@ -- * Per-node field metadata (EP-16) NodeFields (..), nodeFieldsIndexed, + nodeDecisionFieldsIndexed, nodeInstructionsIndexed, -- * Execution internals (reused by alternative executors, e.g. @runProgramTraced@) @@ -85,11 +90,15 @@ where import Baikai (Model, emptyModel) -import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.!=), (.:), (.:?), (.=)) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM +import Data.Bifunctor (first) import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Settings import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -104,16 +113,24 @@ ToPrompt, adapterFor, assistantJSON, + attachDecisionState, attachNativeRender, attachSchema, + evidenceFields, + evidenceSchema, fallbackAdapter, nativeAdapter, nativeRenderPieces, + renderEvidenceRequest, + responseValue, stampTemperature, ) +import Shikumi.Decision (Judgment (..), judgmentsInSchema, renderDecisionState) +import Shikumi.Decision.Runtime (decodeDecisionEvidence, evidenceObject, evidenceOf) +import Shikumi.Decision.Setting (DecisionSetting, validateSetting) import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (LLM (..), Response, complete) -import Shikumi.Schema (FromModel, ToSchema, Validatable, deriveSchema, fromModel) +import Shikumi.Schema (FromModel, ToSchema, Validatable, deriveSchema, fromModel, fromModelChecked) import Shikumi.Schema.Types (fieldName) import Shikumi.Signature (Signature, getInstruction, inputFields, outputFields, setDemos, setInstruction) import Shikumi.Signature qualified as Sig @@ -130,14 +147,29 @@ -- @i@/@o@ — hence demos are stored as type-agnostic JSON (see t'Demo'). data Params = Params { instructionOverride :: !(Maybe Text), - demos :: ![Demo] + demos :: ![Demo], + decisionSettings :: !(Settings.Map Text DecisionSetting) } deriving stock (Eq, Show, Generic) -instance ToJSON Params +instance ToJSON Params where + toJSON ps = + object $ + ["instructionOverride" .= instructionOverride ps, "demos" .= demos ps] + ++ ["decisionSettings" .= decisionSettings ps | not (Settings.null (decisionSettings ps))] -instance FromJSON Params +instance FromJSON Params where + parseJSON = withObject "Params" $ \o -> Params <$> o .: "instructionOverride" <*> o .: "demos" <*> o .:? "decisionSettings" .!= Settings.empty +decisionSettingFor :: Text -> Params -> Maybe DecisionSetting +decisionSettingFor name = Settings.lookup name . decisionSettings + +setDecisionSetting :: Text -> DecisionSetting -> Params -> Params +setDecisionSetting name setting ps = ps {decisionSettings = Settings.insert name setting (decisionSettings ps)} + +clearDecisionSetting :: Text -> Params -> Params +clearDecisionSetting name ps = ps {decisionSettings = Settings.delete name (decisionSettings ps)} + -- | A worked input/output example, stored as JSON so it is uniform across nodes -- of differing types. At run time each demo is decoded back into the node's typed -- @Sig.Demo i o@ and spliced into the prompt by EP-3's adapter; a demo whose JSON @@ -154,7 +186,7 @@ -- | The default empty overlay: no instruction override, no demos. emptyParams :: Params -emptyParams = Params Nothing [] +emptyParams = Params Nothing [] Settings.empty -- | How 'MajorityVote' varies sampling temperature across its @K@ samples. -- 'TempFixed' lists an explicit temperature per sample (cycled if shorter than @@ -338,9 +370,18 @@ i -> Eff es o runPredict sig ps i = do + let fields = fst (judgmentsInSchema (deriveSchema @o)) + either throwError pure $ + mapM_ + ( \(name, setting) -> + case filter ((== name) . judgmentField) fields of + [j] -> () <$ first ValidationFailure (validateSetting j setting) + _ -> Left (ValidationFailure (name <> ": unknown decision field")) + ) + (Settings.toList (decisionSettings ps)) sig' <- effectiveSignature sig ps let adapter = adapterFor placeholderModel - (ctx, opts0) = render adapter sig' i + (ctx0, opts0) = render adapter sig' i -- Stamp the derived schema onto the metadata channel regardless of which -- adapter rendered the prompt; the router attaches a real @responseFormat@ -- from it for native-capable models and strips it otherwise. @@ -350,9 +391,15 @@ -- swaps in these native pieces once it knows the real model is native-capable -- (and strips them for fallback models / un-routed runs). (nativeSys, nativeDemos) = nativeRenderPieces @i @o sig' - opts = attachNativeRender nativeSys nativeDemos (attachSchema (deriveSchema @o) opts0) + schema = deriveSchema @o + (ctx, renderedOpts) + | null (evidenceFields @o (decisionSettings ps)) = (ctx0, attachNativeRender nativeSys nativeDemos (attachSchema schema opts0)) + | otherwise = renderEvidenceRequest (decisionSettings ps) sig' i + opts + | null (fst (judgmentsInSchema schema)) = renderedOpts + | otherwise = attachDecisionState (renderDecisionState sig' i) renderedOpts resp <- complete placeholderModel ctx opts - either throwError pure (parseResponse sig' resp) + either throwError pure (parseResponseWithSettings (decisionSettings ps) sig' resp) -- | Decode a response back into the typed output, tolerant of /either/ wire shape: -- a native model (whose @responseFormat@ the router enforced) replies with a JSON @@ -375,13 +422,38 @@ Signature i o -> Response -> Either ShikumiError o -parseResponse sig' resp = - case assistantJSON resp of - -- The body is JSON: the native wire shape. Keep the native parser's error. - Right _ -> parse (nativeAdapter @i @o) sig' resp - -- Not JSON: the fallback / marker wire shape. Exact prior behaviour. - Left _ -> parse (fallbackAdapter @i @o) sig' resp +parseResponse = parseResponseWithSettings Settings.empty +parseResponseWithSettings :: forall i o. (FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) => Settings.Map Text DecisionSetting -> Signature i o -> Response -> Either ShikumiError o +parseResponseWithSettings settings sig' resp + | Just ev <- evidenceOf (fst (judgmentsInSchema (deriveSchema @o))) resp = + ev >>= evidenceObject (deriveSchema @o) (fst (judgmentsInSchema (deriveSchema @o))) settings >>= fromModelChecked + | not (null selected) = do + raw <- responseValue (evidenceSchema (deriveSchema @o) selected) resp + evidence <- case raw of + Object fields -> + Settings.fromList + <$> traverse + ( \j -> do + let name = judgmentField j + value <- maybe (Left (MissingField name)) Right (KM.lookup (Key.fromText name) fields) + ev <- decodeDecisionEvidence j value + pure (name, ev) + ) + selected + _ -> Left (SchemaMismatch "decision response: expected object") + normalized <- evidenceObject (deriveSchema @o) selected settings evidence + case (normalized, raw) of + (Object derived, Object fields) -> fromModelChecked (Object (KM.union derived fields)) + _ -> Left (SchemaMismatch "decision response: expected object") + | otherwise = case assistantJSON resp of + -- The body is JSON: the native wire shape. Keep the native parser's error. + Right _ -> parse (nativeAdapter @i @o) sig' resp + -- Not JSON: the fallback / marker wire shape. Exact prior behaviour. + Left _ -> parse (fallbackAdapter @i @o) sig' resp + where + selected = evidenceFields @o settings + -- | The per-sample temperatures for a 'MajorityVote' of @k@ samples (at least -- one — @k@ is clamped up to 1 here so the executors need not). 'Nothing' leaves -- the provider default in place; 'Just t' is stamped onto the sample's requests. @@ -533,6 +605,29 @@ go (PredictCaptured _ sig ps) = go (Predict sig ps) go (Predict sig _) = [NodeFields (map fieldName (inputFields sig)) (map fieldName (outputFields sig))] + go (Compose a b) = go a ++ go b + go (FMap _ p) = go p + go (Map _ p) = go p + go (Parallel a b) = go a ++ go b + go (Retry _ p) = go p + go (RetryWhen _ _ p) = go p + go (Validate _ p) = go p + go (MajorityVote _ _ _ p) = go p + go (Ensemble ps _) = concatMap go ps + go (Embed _) = [] + +-- | Rich decision fields in parameter traversal order. Native booleans and +-- enums remain ordinary generation and are not calibration targets. +nodeDecisionFieldsIndexed :: Program i o -> [[Judgment]] +nodeDecisionFieldsIndexed = go + where + go :: forall x y. Program x y -> [[Judgment]] + go (PredictCaptured _ sig ps) = go (Predict sig ps) + go (Predict (_ :: Signature x y) _) = + let schema = deriveSchema @y + props = case schema of Object o | Just (Object ps) <- KM.lookup "properties" o -> ps; _ -> KM.empty + rich j = case KM.lookup (Key.fromText (judgmentField j)) props of Just (Object p) -> KM.member "x-shikumi-decision" p; _ -> False + in [filter rich (fst (judgmentsInSchema schema))] go (Compose a b) = go a ++ go b go (FMap _ p) = go p go (Map _ p) = go p diff --git a/src/Shikumi/Refine.hs b/src/Shikumi/Refine.hs --- a/src/Shikumi/Refine.hs +++ b/src/Shikumi/Refine.hs @@ -50,7 +50,7 @@ where import Control.Lens ((&), (.~), (^.)) -import Data.Aeson (Object, Value (Object)) +import Data.Aeson (Object, Value (Object, String)) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KM import Data.Generics.Labels () @@ -312,6 +312,8 @@ -- | Render the original input, then each attempt as a "Student Attempt #k" line: -- @"I tried to \; my answer is \"@ (mirroring DSPy's rendering). instance (ToPrompt i, ToPrompt o) => ToPrompt (MultiChainInput i o) where + toEvidenceJSON = toPromptJSON + toPromptJSON = Object . KM.fromList . map (\(k, v) -> (Key.fromText k, String v)) . toPromptFields toPromptFields mci = toPromptFields (original mci) ++ [ ("Student Attempt #" <> tshow k, renderAttempt a) diff --git a/src/Shikumi/Routing.hs b/src/Shikumi/Routing.hs --- a/src/Shikumi/Routing.hs +++ b/src/Shikumi/Routing.hs @@ -47,12 +47,14 @@ ) where -import Baikai (Context, JsonSchemaFormat (strict), Message (..), Model, Options, ResponseFormat (..), assistant, jsonSchemaFormat) +import Baikai (Context, JsonSchemaFormat (strict), Message (..), Model, Options, ResponseFormat (..), assistant, jsonSchemaFormat, userData) +import Control.Applicative ((<|>)) import Control.Lens ((&), (.~), (^.)) import Data.Aeson (FromJSON, Result (..), Value, fromJSON) import Data.Generics.Labels () 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 (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (interpose, interpret, send) @@ -60,12 +62,17 @@ import Shikumi.Adapter ( ModelCapability (..), capabilityFor, + metaDecisionEvidenceKey, + metaDecisionSchemaKey, + metaDecisionStateKey, metaNativeDemosKey, metaNativePromptKey, metaResponseSchemaKey, metaTemperatureKey, + stripDecisionMarkers, ) -import Shikumi.Error (ShikumiError) +import Shikumi.Decision (judgmentsInSchema) +import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (LLM (..), complete, stream) import Shikumi.LLM.Continuation (validateRequestContinuation) @@ -99,12 +106,13 @@ routeLLM = interpose $ \_ -> \case Complete _placeholder ctx opts -> do m <- currentModel - let (ctx', opts') = translateForWire m ctx opts + (ctx', opts') <- either throwError pure (translateForWire m ctx opts) either throwError pure (validateRequestContinuation m ctx' opts') complete m ctx' opts' Stream _placeholder ctx opts -> do m <- currentModel - let (ctx', opts') = translateForWire m ctx opts + if capabilityFor m == DecisionOnly || Map.member metaDecisionEvidenceKey (opts ^. #metadata) then throwError (ValidationFailure "decision outputs do not support streaming") else pure () + (ctx', opts') <- either throwError pure (translateForWire m ctx opts) either throwError pure (validateRequestContinuation m ctx' opts') stream m ctx' opts' @@ -116,10 +124,10 @@ -- Continuation expectations remain available for later boundary checks. Fallback-capability models keep the -- marker t'Context' unchanged; non-'Shikumi.Program.Predict' @Complete@ calls (no stamps) are never -- rewritten. -translateForWire :: Model -> Context -> Options -> (Context, Options) +translateForWire :: Model -> Context -> Options -> Either ShikumiError (Context, Options) translateForWire m ctx opts = let md = opts ^. #metadata - mSchema = Map.lookup metaResponseSchemaKey md + mSchema = (if capabilityFor m == DecisionOnly then Map.lookup metaDecisionSchemaKey md else Nothing) <|> Map.lookup metaResponseSchemaKey md mTemp = Map.lookup metaTemperatureKey md >>= valueToDouble mNativeSys = Map.lookup metaNativePromptKey md >>= fromJSONMaybe mNativeDemos = Map.lookup metaNativeDemosKey md >>= fromJSONMaybe @@ -127,12 +135,12 @@ foldr Map.delete md - [metaResponseSchemaKey, metaTemperatureKey, metaNativePromptKey, metaNativeDemosKey] - isNative = case capabilityFor m of NativeSchema -> True; PromptFallback -> False + [metaResponseSchemaKey, metaTemperatureKey, metaNativePromptKey, metaNativeDemosKey, metaDecisionStateKey, metaDecisionSchemaKey, metaDecisionEvidenceKey] + isNative = capabilityFor m /= PromptFallback withSchema o | isNative, Just s <- mSchema = - o & #responseFormat .~ Just (JsonSchema ((jsonSchemaFormat "output" s) {strict = True})) + o & #responseFormat .~ Just (JsonSchema ((jsonSchemaFormat "output" (stripDecisionMarkers s)) {strict = True})) | otherwise = o withTemp o = case mTemp of Just t -> o & #temperature .~ Just t @@ -141,7 +149,15 @@ ctx' = case (isNative, mNativeSys, mNativeDemos) of (True, Just sys, Just demos) -> rewriteNativeContext sys demos ctx _ -> ctx - in (ctx', opts') + in if capabilityFor m == DecisionOnly + then case (mSchema, Map.lookup metaDecisionStateKey md) of + (Just s, Just state) + | let (js, free) = judgmentsInSchema s, + not (null js), + null free -> + Right (ctx & #systemPrompt .~ Nothing & #tools .~ V.empty & #messages .~ V.singleton (userData state), opts') + _ -> Left (ValidationFailure ((m ^. #modelId) <> " answers only declared judgments; free-form output fields: " <> maybe "missing schema/state" (T.intercalate ", " . snd . judgmentsInSchema) mSchema)) + else Right (ctx', opts') -- | Install the native-format system prompt and demo assistant turns into a -- t'Context'. The assistant turns of a 'Shikumi.Program.Predict'-rendered context are exactly the diff --git a/src/Shikumi/Stream.hs b/src/Shikumi/Stream.hs --- a/src/Shikumi/Stream.hs +++ b/src/Shikumi/Stream.hs @@ -55,6 +55,7 @@ emptyTextContent, ) import Control.Lens ((&), (.~)) +import Control.Monad (when) import Data.Generics.Labels () import Data.Maybe (fromMaybe, listToMaybe) import Data.Text (Text) @@ -62,11 +63,11 @@ import Effectful (Eff, (:>)) import Effectful.Error.Static (Error, throwError) import GHC.Generics (Generic) -import Shikumi.Adapter (Adapter (..), ToPrompt, adapterFor, attachNativeRender, attachSchema, nativeRenderPieces) -import Shikumi.Error (ShikumiError) +import Shikumi.Adapter (Adapter (..), ToPrompt, adapterFor, attachNativeRender, attachSchema, evidenceFields, nativeRenderPieces) +import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (LLM, stream) import Shikumi.Program - ( Params, + ( Params (..), Program (Compose, Embed, FMap, MajorityVote, Map, Parallel, Predict, PredictCaptured, Retry, RetryWhen, Validate), acceptOrReject, effectiveSignature, @@ -238,7 +239,7 @@ -- | Stream a single 'Predict', mirroring 'Shikumi.Program.runPredict' exactly so -- the streamed and blocking paths share one wire + decode definition. It overlays --- 'Params' via the exported 'effectiveSignature', renders model-agnostically, stamps +-- t'Params' via the exported 'effectiveSignature', renders model-agnostically, stamps -- the derived schema and the native render alternative onto the metadata channel -- (so the router can attach a native @responseFormat@ and swap the native prompt for -- native-capable models), streams the first output field's chunks bracketed by @@ -260,6 +261,7 @@ (StreamEvent -> Eff es ()) -> Eff es o streamPredict sig ps i cb = do + when (not (null (evidenceFields @o (decisionSettings ps)))) (throwError (ValidationFailure "decision outputs do not support streaming")) sig' <- effectiveSignature sig ps let adapter = adapterFor emptyModel (ctx, opts0) = render adapter sig' i diff --git a/test/DecisionDeriveSpec.hs b/test/DecisionDeriveSpec.hs new file mode 100644 --- /dev/null +++ b/test/DecisionDeriveSpec.hs @@ -0,0 +1,94 @@ +module DecisionDeriveSpec (tests) where + +import Data.Aeson (eitherDecode, encode, object, toJSON, (.=)) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Shikumi.Decision +import Shikumi.Decision.Setting +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) +import Test.Tasty.QuickCheck (choose, forAll, testProperty) + +noul :: Judgment +noul = Judgment "urgent" Nothing (JudgeBoolean Nothing Nothing) + +score :: Judgment +score = Judgment "severity" Nothing (JudgeOrdered [toJSON ("Minor" :: Text), toJSON ("Disruptive" :: Text), toJSON ("Blocking" :: Text)]) + +choice :: Judgment +choice = Judgment "category" Nothing (JudgeChoice [("z", Nothing), ("a", Nothing)]) + +tests :: TestTree +tests = + testGroup + "Decision derivation" + [ testCase "Noul threshold 0.7 on p=0.8 gives True, confidence 0.142857" $ do + let (answer, c) = deriveNoul 0.7 (NoulEvidence 0.8) + answer @?= True + assertBool "confidence" (abs (c - 1 / 7) < 1e-12), + testCase "Noul endpoints and equality use an inclusive threshold" $ do + deriveNoul 0 (NoulEvidence 0) @?= (True, 0) + deriveNoul 1 (NoulEvidence 1) @?= (True, 0) + deriveNoul 0.7 (NoulEvidence 0.7) @?= (True, 0), + testCase "Score cuts change the level while preserving value" $ do + let e = ScoreEvidence (V.fromList [0.1, 0.3, 0.6]) (Just 0.55) + deriveScore [0.5, 1.6] e @?= Right (1.5, 1) + deriveScore [0.5, 1.5] e @?= Right (1.5, 2), + testCase "Choice raw tie follows declaration order" $ + deriveChoice ["z", "a"] Map.empty (ChoiceEvidence (Map.fromList [("z", 0.5), ("a", 0.5)]) Nothing) @?= Right "z", + testCase "Choice weighted tie prefers the raw winner" $ + deriveChoice ["z", "a"] (Map.singleton "z" 4) (ChoiceEvidence (Map.fromList [("z", 0.2), ("a", 0.8)]) (Just 0.65)) @?= Right "a", + testCase "zero-weight label is never selected" $ + deriveChoice ["z", "a"] (Map.singleton "z" 0) (ChoiceEvidence (Map.fromList [("z", 0.9), ("a", 0.1)]) Nothing) @?= Right "a", + testCase "weights greater than one can change the winner" $ + deriveChoice ["z", "a"] (Map.singleton "z" 5) (ChoiceEvidence (Map.fromList [("z", 0.2), ("a", 0.8)]) Nothing) @?= Right "z", + testCase "all-zero probability or weighted mass is rejected" $ do + deriveChoice ["z", "a"] Map.empty (ChoiceEvidence (Map.fromList [("z", 0), ("a", 0)]) Nothing) @?= Left "no remaining probability mass" + deriveChoice ["z", "a"] (Map.fromList [("z", 0), ("a", 0)]) (ChoiceEvidence (Map.fromList [("z", 0.5), ("a", 0.5)]) Nothing) @?= Left "no remaining probability mass" + deriveScore [0.5] (ScoreEvidence (V.fromList [0, 0]) Nothing) @?= Left "no remaining probability mass", + testCase "defaults match the declared kind and level count" $ do + defaultSetting noul @?= NoulSetting 0.5 + defaultSetting score @?= ScoreSetting [0.5, 1.5] + defaultSetting choice @?= ChoiceSetting Map.empty, + testCase "settings have stable tagged JSON and round-trip" $ do + let settings = [NoulSetting 0.7, ScoreSetting [0.5, 1.6], ChoiceSetting (Map.singleton "z" 2)] + map toJSON settings + @?= [object ["kind" .= ("noul" :: Text), "threshold" .= (0.7 :: Double)], object ["kind" .= ("score" :: Text), "cuts" .= ([0.5, 1.6] :: [Double])], object ["kind" .= ("choice" :: Text), "weights" .= Map.singleton ("z" :: Text) (2 :: Double)]] + eitherDecode (encode settings) @?= Right settings, + testCase "valid settings preserve sparse weights and endpoint thresholds" $ do + mapM_ (\t -> validateSetting noul (NoulSetting t) @?= Right (NoulSetting t)) [0, 0.5, 1] + validateSetting choice (ChoiceSetting (Map.singleton "z" 0)) @?= Right (ChoiceSetting (Map.singleton "z" 0)), + testCase "validation names the field and rejects each broken rule" $ do + let invalid = + [ (noul, ScoreSetting [], "kind"), + (noul, NoulSetting (-0.1), "threshold"), + (noul, NoulSetting 1.1, "threshold"), + (noul, NoulSetting (0 / 0), "finite"), + (score, ScoreSetting [0.5], "N-1"), + (score, ScoreSetting [0.5, 0.5], "increasing"), + (score, ScoreSetting [1.5, 0.5], "increasing"), + (score, ScoreSetting [0, 1], "(0,N-1)"), + (score, ScoreSetting [1, 2], "(0,N-1)"), + (score, ScoreSetting [0.5, 1 / 0], "finite"), + (choice, ChoiceSetting (Map.singleton "unknown" 1), "declared"), + (choice, ChoiceSetting (Map.singleton "z" (-1)), "non-negative"), + (choice, ChoiceSetting (Map.singleton "a" (1 / 0)), "finite") + ] + mapM_ + ( \(j, setting, rule) -> case validateSetting j setting of + Left msg -> do assertBool "field name" (judgmentField j `T.isInfixOf` msg); assertBool (T.unpack msg) (rule `T.isInfixOf` msg) + Right s -> assertFailure ("accepted invalid setting " <> show s) + ) + invalid, + testProperty "score value is independent of valid cuts and level is monotone in value" $ + forAll (choose (0.01, 0.99)) $ \c -> + forAll (choose (0, 1)) $ \p -> + forAll (choose (p, 1)) $ \q -> + let lo = ScoreEvidence (V.fromList [1 - p, p]) Nothing + hi = ScoreEvidence (V.fromList [1 - q, q]) Nothing + in case (deriveScore [c] lo, deriveScore [0.5] lo, deriveScore [c] hi) of + (Right (v, l), Right (v', _), Right (w, m)) -> v == v' && v <= w && l <= m + _ -> False + ] diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -33,7 +33,8 @@ httpStatus = Just 400, retryAfterSeconds = Nothing, refusalCategory = Nothing, - exitCode = Nothing + exitCode = Nothing, + requestProblem = Nothing } @?= ContextWindowExceeded "context length exceeded", testCase "isTransient classification" $ do diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -7,6 +7,7 @@ import CombinatorSpec qualified import ConstraintSpec qualified import ContinuationSpec qualified +import DecisionDeriveSpec qualified import EndToEndSpec qualified import ErrorSpec qualified import FallbackGuideSpec qualified @@ -38,6 +39,7 @@ testGroup "shikumi" [ ResponsesSpec.tests, + DecisionDeriveSpec.tests, RequestDefaultsSpec.tests, ContinuationSpec.tests, ErrorSpec.tests, diff --git a/test/ProgramAcceptanceSpec.hs b/test/ProgramAcceptanceSpec.hs --- a/test/ProgramAcceptanceSpec.hs +++ b/test/ProgramAcceptanceSpec.hs @@ -32,6 +32,7 @@ ( Demo (..), Params (..), Program, + emptyParams, foldParams, mapParamsAt, pipeline, @@ -104,4 +105,4 @@ where -- node 1 should remain the default overlay emptyParamsLike :: Params - emptyParamsLike = Params Nothing [] + emptyParamsLike = emptyParams diff --git a/test/RequestDefaultsSpec.hs b/test/RequestDefaultsSpec.hs --- a/test/RequestDefaultsSpec.hs +++ b/test/RequestDefaultsSpec.hs @@ -2,6 +2,7 @@ import Baikai (ToolChoice (..), emptyContext, emptyModel, emptyOptions, emptyResponse) import Baikai.Evidence qualified as E +import Baikai.Model (OutputKind (..)) import Baikai.Speed (Speed (..)) import Baikai.ThinkingLevel (ThinkingLevel (..)) import Control.Concurrent (forkFinally, newEmptyMVar, putMVar, takeMVar) @@ -26,7 +27,28 @@ tests = testGroup "Request defaults" - [ testCase "empty is identity and unrelated policy and metadata survive" $ do + [ testCase "judgment-only calls fill evidence alone and keep explicit controls" $ do + ref <- newIORef [] + result <- runEff + . runErrorNoCallStack @ShikumiError + . interpret + ( \_ -> \case + Complete _ _ o -> liftIO (modifyIORef' ref (++ [o])) >> pure emptyResponse + Stream {} -> pure [] + ) + . withRequestDefaults defaults + $ do + _ <- complete (emptyModel & #outputKind .~ JudgmentOutput) emptyContext emptyOptions + _ <- complete (emptyModel & #outputKind .~ JudgmentOutput) emptyContext (emptyOptions & #temperature .~ Just 0.2) + pure () + result @?= Right () + captured <- readIORef ref + map (^. #thinking) captured @?= [Nothing, Nothing] + map (^. #speed) captured @?= [Nothing, Nothing] + map (^. #maxTokens) captured @?= [Nothing, Nothing] + map (^. #temperature) captured @?= [Nothing, Just 0.2] + map (^. #evidence) captured @?= replicate 2 (defaultEvidence defaults), + testCase "empty is identity and unrelated policy and metadata survive" $ do let opts = emptyOptions & #temperature .~ Just 0.7 diff --git a/test/RoutingSpec.hs b/test/RoutingSpec.hs --- a/test/RoutingSpec.hs +++ b/test/RoutingSpec.hs @@ -55,6 +55,7 @@ Params (..), Program (Predict), TempSchedule (..), + emptyParams, runProgram, runProgramConc, ) @@ -220,7 +221,7 @@ Demo (object ["subject" .= ("dogs" :: Text)]) (object ["points" .= (["one", "two"] :: [Text])]) - node = Predict topicToOutline (Params Nothing [demo]) + node = Predict topicToOutline (emptyParams {demos = [demo]}) captured <- captureRouted openai_gpt_4o_mini node (Topic "cats") case captured of [(_, ctx, _)] -> case assistantTexts ctx of diff --git a/test/SerializeSpec.hs b/test/SerializeSpec.hs --- a/test/SerializeSpec.hs +++ b/test/SerializeSpec.hs @@ -35,10 +35,10 @@ $ defaultProg node0Params :: Params -node0Params = Params (Just "outline carefully") [Demo (String "a topic") (String "an outline")] +node0Params = emptyParams {instructionOverride = Just "outline carefully", demos = [Demo (String "a topic") (String "an outline")]} node1Params :: Params -node1Params = Params (Just "draft fluently") [] +node1Params = emptyParams {instructionOverride = Just "draft fluently"} tests :: TestTree tests = diff --git a/test/compile-fail/FreeFormDecision.hs b/test/compile-fail/FreeFormDecision.hs new file mode 100644 --- /dev/null +++ b/test/compile-fail/FreeFormDecision.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} + +module FreeFormDecision where + +import Data.Text (Text) +import GHC.Generics (Generic) +import Shikumi.Decision (DecisionOutputs) +import Shikumi.Schema (Field) + +newtype InvalidDecision = InvalidDecision {summary :: Field "Explain the answer" Text} + deriving stock (Generic) + deriving anyclass (DecisionOutputs) diff --git a/test/compile-fail/TooFewScoreLevels.hs b/test/compile-fail/TooFewScoreLevels.hs new file mode 100644 --- /dev/null +++ b/test/compile-fail/TooFewScoreLevels.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} + +module TooFewScoreLevels where + +import Shikumi.Decision (Score (..)) + +invalidValue :: Score '["Only"] +invalidValue = Score 0 0 mempty Nothing diff --git a/test/compile-fail/TooManyScoreLevels.hs b/test/compile-fail/TooManyScoreLevels.hs new file mode 100644 --- /dev/null +++ b/test/compile-fail/TooManyScoreLevels.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} + +module TooManyScoreLevels where + +import Shikumi.Decision (Score (..)) + +invalidValue :: Score '["0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10"] +invalidValue = Score 0 0 mempty Nothing