shikumi 0.4.1.1 → 0.5.0.0

raw patch · 23 files changed

+1285/−120 lines, 23 filesdep ~baikaidep ~baikai-claudedep ~baikai-effectfulPVP ok

version bump matches the API change (PVP)

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

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−0
• shikumi.cabal +19/−11
• src/Shikumi/Adapter.hs +98/−70
• src/Shikumi/Adapter/Prompt.hs +139/−0
• src/Shikumi/Decision.hs +507/−0
• src/Shikumi/Decision/Runtime.hs +98/−0
• src/Shikumi/Decision/Setting.hs +85/−0
• src/Shikumi/LLM/Defaults.hs +6/−2
• src/Shikumi/Module.hs +5/−1
• src/Shikumi/Program.hs +110/−15
• src/Shikumi/Refine.hs +3/−1
• src/Shikumi/Routing.hs +26/−10
• src/Shikumi/Stream.hs +6/−4
• test/DecisionDeriveSpec.hs +94/−0
• test/ErrorSpec.hs +2/−1
• test/Main.hs +2/−0
• test/ProgramAcceptanceSpec.hs +2/−1
• test/RequestDefaultsSpec.hs +23/−1
• test/RoutingSpec.hs +2/−1
• test/SerializeSpec.hs +2/−2
• test/compile-fail/FreeFormDecision.hs +13/−0
• test/compile-fail/TooFewScoreLevels.hs +8/−0
• test/compile-fail/TooManyScoreLevels.hs +8/−0

@@ -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

@@ -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,

@@ -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)))

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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 \<reasoning\>; my answer is \<answer\>"@ (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)

@@ -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

@@ -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

@@ -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+    ]

@@ -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

@@ -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,

@@ -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

@@ -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

@@ -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

@@ -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 =

@@ -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)

@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds #-}++module TooFewScoreLevels where++import Shikumi.Decision (Score (..))++invalidValue :: Score '["Only"]+invalidValue = Score 0 0 mempty Nothing

@@ -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