shikumi-tools 0.4.2.0 → 0.4.2.1
raw patch · 3 files changed
+305/−10 lines, 3 filesdep ~shikumidep ~shikumi-toolsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: shikumi, shikumi-tools
API changes (from Hackage documentation)
Files
- CHANGELOG.md +9/−0
- shikumi-tools.cabal +4/−4
- test/SystemOneIntegrationSpec.hs +292/−6
CHANGELOG.md view
@@ -2,6 +2,15 @@ ## Unreleased +## 0.4.2.1 — 2026-11-03++### Changed++- Exercise typed judgment streaming against the released TypeSafe loopback, including+ calibration parity, atomic events, retry receipts, acknowledgement barriers,+ cancellation, callback failure and pre-dispatch refusals.+- Require `shikumi ^>=0.5.1.0` for this integration cohort. Tool APIs are unchanged.+ ## 0.4.2.0 — 2026-11-02 ### Changed
shikumi-tools.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: shikumi-tools-version: 0.4.2.0+version: 0.4.2.1 synopsis: Typed tools and ReAct agents for shikumi LM programs (EP-11) @@ -82,7 +82,7 @@ lens ^>=5.3, process >=1.6 && <1.7, regex-tdfa >=1.3 && <1.4,- shikumi ^>=0.5.0.0,+ shikumi ^>=0.5.1.0, text ^>=2.1, vector >=0.13 && <0.14, @@ -132,10 +132,10 @@ filepath, generic-lens, lens,- shikumi ^>=0.5.0.0,+ shikumi ^>=0.5.1.0, shikumi-cache ^>=0.2.1.0, shikumi-testing ^>=0.1.0.0,- shikumi-tools ^>=0.4.2.0,+ shikumi-tools ^>=0.4.2.1, tasty, tasty-hunit, text,
test/SystemOneIntegrationSpec.hs view
@@ -1,23 +1,36 @@ module SystemOneIntegrationSpec (tests) where import Baikai qualified as B+import Baikai.Evidence qualified as E+import Control.Concurrent.MVar+import Control.Exception (IOException, throwIO, try)+import Control.Lens ((&), (.~), (^.)) import Data.Aeson import Data.Aeson.KeyMap qualified as KM+import Data.Generics.Labels ()+import Data.IORef import Data.Map.Strict qualified as Map import Data.Text qualified as T-import Effectful (runEff)+import Effectful (Eff, liftIO, runEff, (:>))+import Effectful.Concurrent (runConcurrent)+import Effectful.Concurrent.Async (cancel, wait, waitCatch, withAsync) import Effectful.Dispatch.Dynamic (interpose)-import Effectful.Error.Static (runErrorNoCallStack)+import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) import Shikumi.Adapter (stampTemperature) import Shikumi.Decision+import Shikumi.Decision.Setting import Shikumi.Error import Shikumi.LLM qualified as L import Shikumi.LLM.Defaults+import Shikumi.LLM.Evidence import Shikumi.Program import Shikumi.Routing import Shikumi.Schema (field, unField)+import Shikumi.Stream import Shikumi.Testing.DecisionFixtures+import Shikumi.Testing.Fixtures qualified as F import Shikumi.Testing.Responses (fixtureOptions, withTransportOptions)+import Shikumi.Testing.StubLLM (captureLLMRequests) import Shikumi.Testing.SystemOne import Test.Tasty import Test.Tasty.HUnit@@ -39,8 +52,84 @@ tests = testGroup "SystemOne"- [ testCase "released provider sends state and criteria; defaults exempt" $+ [ lifecycleTests,+ testCase "complete and stream retain raw answers and wire bytes under local calibration" $ withSystemOneFixture reply $ \model registry requests -> do+ raw <- newIORef []+ events <- newIORef []+ outgoing <- newIORef []+ let retain = interpose $ \_ -> \case+ L.Complete m c o -> do+ r <- L.complete m c o+ liftIO (modifyIORef' raw (++ [r ^. #message . #content]))+ pure r+ L.Stream m c o -> do+ es <- L.stream m c o+ liftIO (map eventTag es @?= ["start", "data-start", "data-end", "done"])+ r <- either (error . show) pure (responseFromEvents m es)+ liftIO (modifyIORef' raw (++ [r ^. #message . #content]))+ pure es+ defaults = emptyRequestDefaults {defaultThinking = Just B.ThinkingHigh, defaultMaxTokens = Just 100}+ params =+ setDecisionSetting "urgent" (NoulSetting 0.9)+ . setDecisionSetting "category" (ChoiceSetting (Map.fromList [("billing", 5), ("technical", 1)]))+ . setDecisionSetting "severity" (ScoreSetting [0.5, 1.6])+ $ emptyParams+ execute streamed ps =+ runEff+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMWith registry+ . captureLLMRequests outgoing+ . withTransportOptions fixtureOptions+ . retain+ . withRequestDefaults defaults+ . routeLLM+ $ if streamed+ then streamProgram (Predict assessmentSig ps) (Ticket (field "x")) (\e -> liftIO (modifyIORef' events (++ [e])))+ else runProgram (Predict assessmentSig ps) (Ticket (field "x"))+ normal <- execute False emptyParams+ execute True emptyParams >>= (@?= normal)+ calibrated <- execute False params+ execute True params >>= (@?= calibrated)+ case calibrated of+ Right (Assessment u s c) -> do+ case unField u of Noul value p _ -> do value @?= False; p @?= 0.83+ case unField s of Score value level _ _ -> do value @?= 1.5; level @?= 1+ case unField c of Choice value _ _ -> value @?= Billing+ Left err -> assertFailure (show err)+ readIORef raw >>= assertFourEqual "unchanged raw answers"+ requests >>= assertFourEqual "identical wire requests"+ readIORef events >>= \xs -> length [() | StreamFieldChunk _ <- xs] @?= 0+ readIORef outgoing >>= mapM_ (\(_, _, o) -> do Map.null (o ^. #metadata) @?= True; o ^. #maxTokens @?= Nothing; o ^. #thinking @?= Nothing),+ testCase "program callback exceptions stop before dispatch or after acknowledged completion" $+ mapM_+ ( \failPhase -> withSystemOneFixture reply $ \model registry requests -> do+ receipts <- newIORef []+ result <-+ try @IOException+ $ runEff+ . runConcurrent+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMResilientWithEvidence (\r -> liftIO (modifyIORef' receipts (++ [r]))) (L.defaultLLMConfig registry)+ . withTransportOptions fixtureOptions+ . withEvidenceRuns E.EvidenceBestEffort (pure "callback")+ . routeLLM+ $ streamProgram+ (Predict assessmentSig emptyParams)+ (Ticket (field "x"))+ ( \case+ StreamStatus status | phase status == failPhase -> liftIO (throwIO (userError "callback failed"))+ _ -> pure ()+ )+ assertBool "callback failure" (case result of Left _ -> True; _ -> False)+ requests >>= \xs -> length xs @?= (if failPhase == LmStart then 0 else 1)+ readIORef receipts >>= \xs -> length xs @?= (if failPhase == LmStart then 0 else 1)+ )+ [LmStart, LmEnd],+ testCase "released provider sends state and criteria; defaults exempt" $+ withSystemOneFixture reply $ \model registry requests -> do let defaults = emptyRequestDefaults {defaultThinking = Just B.ThinkingHigh, defaultMaxTokens = Just 100} result <- runEff . runErrorNoCallStack @ShikumiError . runRouting model . L.runLLMWith registry . withTransportOptions fixtureOptions . withRequestDefaults defaults . routeLLM $@@ -64,14 +153,14 @@ let modifyAnswer name f = modifyObject "answers" (adjust (\case Object o -> Object (f o); v -> v) name) reply malformed = [modifyAnswer "category" (KM.delete "confidence"), modifyAnswer "severity" (KM.delete "score"), modifyAnswer "severity" (KM.delete "legend"), modifyObject "answers" (KM.insert "unexpected" (object ["type" .= String "noul", "noul" .= (0.5 :: Double)])) reply] mapM_- ( \bad -> withSystemOneFixture bad $ \model registry requests -> do+ ( \(streaming, bad) -> withSystemOneFixture bad $ \model registry requests -> do result <- runEff . runErrorNoCallStack @ShikumiError . runRouting model . L.runLLMWith registry . withTransportOptions fixtureOptions . routeLLM $- runProgram (Predict assessmentSig emptyParams) (Ticket (field "x"))+ execute streaming emptyParams assertBool "terminal InvalidJSON" (case result of Left (InvalidJSON _) -> True; _ -> False) requests >>= (\xs -> length xs @?= 1) )- malformed+ [(streaming, bad) | streaming <- [False, True], bad <- malformed] ] adjust :: (a -> a) -> Key -> KM.KeyMap a -> KM.KeyMap a@@ -80,3 +169,200 @@ modifyObject :: Key -> (KM.KeyMap Value -> KM.KeyMap Value) -> Value -> Value modifyObject key f (Object fields) = Object (adjust (\case Object o -> Object (f o); v -> v) key fields) modifyObject _ _ v = v++-- Real-provider lifecycle tests run both operations through the same transport.+lifecycleTests :: TestTree+lifecycleTests =+ testGroup+ "Lifecycle"+ [ testGroup+ (if streaming then "Stream" else "Complete")+ [ testCase "retry receipts settle before next HTTP request and success return" $+ withSystemOneScript [SystemOneReply 503 (object []) (pure ()), SystemOneReply 200 reply (pure ())] $ \model registry requests -> do+ receipts <- newIORef []+ entered <- newEmptyMVar+ release <- newEmptyMVar+ let observe r = do+ liftIO (modifyIORef' receipts (++ [r]))+ liftIO (putMVar entered (attemptOrdinal r) >> takeMVar release)+ cfg = (L.defaultLLMConfig registry) {L.retryPolicy = L.RetryPolicy 2 0 0}+ result <- runEff+ . runConcurrent+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMResilientWithEvidence observe cfg+ . withTransportOptions fixtureOptions+ . withEvidenceRuns E.EvidenceBestEffort (pure "logical-run")+ . routeLLM+ $ withAsync (execute streaming emptyParams)+ $ \worker -> do+ liftIO (takeMVar entered >>= (@?= 1))+ liftIO (requests >>= \xs -> length xs @?= 1)+ liftIO (putMVar release ())+ liftIO (takeMVar entered >>= (@?= 2))+ liftIO (requests >>= \xs -> length xs @?= 2)+ liftIO (putMVar release ())+ wait worker+ assertBool "typed success" (either (const False) (const True) result)+ readIORef receipts >>= \case+ [a, b] -> do+ logicalCallId a @?= logicalCallId b+ map attemptOrdinal [a, b] @?= [1, 2]+ evidence b ^. #attempt @?= 2+ evidence b ^. #supersedes @?= Just (evidence a ^. #callId)+ map ((^. #runId) . evidence) [a, b] @?= ["logical-run", "logical-run"]+ rs -> assertFailure (show rs),+ testCase "observer alone preserves wire bytes and emits no receipt" $+ withSystemOneFixture reply $ \model registry requests -> do+ receipts <- newIORef []+ let run observe =+ runEff+ . runConcurrent+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMResilientWithEvidence observe (L.defaultLLMConfig registry)+ . withTransportOptions fixtureOptions+ . routeLLM+ $ execute streaming emptyParams+ a <- run (const (pure ()))+ run (\r -> liftIO (modifyIORef' receipts (++ [r]))) >>= (@?= a)+ readIORef receipts >>= (@?= [])+ requests >>= \case [a, b] -> a @?= b; _ -> assertFailure "expected two requests",+ testCase "strict refusal returns one record before HTTP" $+ withSystemOneFixture reply $ \model registry requests -> do+ receipts <- newIORef []+ result <-+ runEff+ . runConcurrent+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMResilientWithEvidence (\r -> liftIO (modifyIORef' receipts (++ [r]))) (L.defaultLLMConfig registry)+ . withTransportOptions fixtureOptions+ . withEvidenceRuns (E.EvidenceRequired E.EvidenceFullyObserved) (pure "strict")+ . routeLLM+ $ execute streaming emptyParams+ assertBool "refused" (case result of Left _ -> True; _ -> False)+ requests >>= (@?= [])+ readIORef receipts >>= \rs -> length rs @?= 1,+ testCase "cancellation after HTTP arrival joins without a result or fabricated receipt" $ do+ arrived <- newEmptyMVar+ never <- newEmptyMVar+ withSystemOneScript [SystemOneReply 200 reply (putMVar arrived () >> takeMVar never)] $ \model registry requests -> do+ receipts <- newIORef []+ result <- runEff+ . runConcurrent+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMResilientWithEvidence (\r -> liftIO (modifyIORef' receipts (++ [r]))) (L.defaultLLMConfig registry)+ . withTransportOptions fixtureOptions+ . withEvidenceRuns E.EvidenceBestEffort (pure "cancel")+ . routeLLM+ $ withAsync (execute streaming emptyParams)+ $ \worker -> do+ liftIO (takeMVar arrived)+ cancel worker+ waitCatch worker+ assertBool "cancelled worker" (case result of Right (Left _) -> True; _ -> False)+ requests >>= \xs -> length xs @?= 1+ readIORef receipts >>= (@?= []),+ testCase "evidence observer failures on success and failure never redispatch" $+ mapM_+ ( \failed -> withSystemOneScript [SystemOneReply (if failed then 503 else 200) reply (pure ())] $ \model registry requests -> do+ let observer _ = throwError (ProviderFailure "persist failed")+ result <-+ try @EvidenceObserverFailed+ $ runEff+ . runConcurrent+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMResilientWithEvidence observer (L.defaultLLMConfig registry)+ . withTransportOptions fixtureOptions+ . withEvidenceRuns E.EvidenceBestEffort (pure "failure")+ . routeLLM+ $ retryWith (\_ _ -> execute streaming emptyParams) (const True) 3 (Predict assessmentSig emptyParams) (Ticket (field "x"))+ assertBool "observer failure" (case result of Left _ -> True; _ -> False)+ requests >>= \xs -> length xs @?= 1+ )+ [False, True],+ testCase "billing observer failure never redispatches" $+ withSystemOneFixture reply $ \model registry requests -> do+ let cfg = (L.defaultLLMConfig registry) {L.observer = Just (\_ -> throwIO (userError "billing failed"))}+ result <-+ try @IOException+ $ runEff+ . runConcurrent+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMResilient cfg+ . withTransportOptions fixtureOptions+ . routeLLM+ $ execute streaming emptyParams+ assertBool "billing failed" (case result of Left _ -> True; _ -> False)+ requests >>= \xs -> length xs @?= 1,+ testCase "generation controls and free-form judgment outputs refuse before HTTP" $+ withSystemOneFixture reply $ \model registry requests -> do+ let setControls = interpose $ \_ -> \case+ L.Complete m c o -> L.complete m c (o & #temperature .~ Just 0.7)+ L.Stream m c o -> L.stream m c (o & #temperature .~ Just 0.7)+ badControl <-+ runEff+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMWith registry+ . withTransportOptions fixtureOptions+ . setControls+ . routeLLM+ $ execute streaming emptyParams+ assertBool "generation refusal" (case badControl of Left SchemaMismatch {} -> True; _ -> False)+ freeform <-+ runEff+ . runErrorNoCallStack @ShikumiError+ . runRouting model+ . L.runLLMWith registry+ . withTransportOptions fixtureOptions+ . routeLLM+ $ if streaming then streamProgram F.instructedProg (F.Question "x") (const (pure ())) else runProgram F.instructedProg (F.Question "x")+ assertBool "free-form refusal" (case freeform of Left ValidationFailure {} -> True; _ -> False)+ requests >>= (@?= []),+ testCase "invalid local settings dispatch nothing in either mode" $+ withSystemOneFixture reply $ \model registry requests -> do+ let invalid =+ [ setDecisionSetting "urgent" (NoulSetting 1.2) emptyParams,+ setDecisionSetting "urgent" (ScoreSetting [0.5]) emptyParams,+ setDecisionSetting "missing" (NoulSetting 0.5) emptyParams,+ setDecisionSetting "category" (ChoiceSetting (Map.singleton "missing" 2)) emptyParams,+ setDecisionSetting "severity" (ScoreSetting [1.6, 0.5]) emptyParams+ ]+ mapM_+ ( \ps -> do+ statuses <- newIORef []+ result <-+ runEff . runErrorNoCallStack @ShikumiError . runRouting model . L.runLLMWith registry . withTransportOptions fixtureOptions . routeLLM $+ if streaming then streamProgram (Predict assessmentSig ps) (Ticket (field "x")) (\e -> liftIO (modifyIORef' statuses (++ [e]))) else execute False ps+ assertBool "validation refused" (case result of Left ValidationFailure {} -> True; _ -> False)+ readIORef statuses >>= (@?= [])+ )+ invalid+ requests >>= (@?= [])+ ]+ | streaming <- [False, True]+ ]++execute :: (L.LLM :> es, Error ShikumiError :> es) => Bool -> Params -> Eff es Assessment+execute streaming ps =+ if streaming+ then streamProgram (Predict assessmentSig ps) (Ticket (field "x")) (const (pure ()))+ else runProgram (Predict assessmentSig ps) (Ticket (field "x"))++eventTag :: B.AssistantMessageEvent -> String+eventTag = \case+ B.EventStart {} -> "start"+ B.DataStart {} -> "data-start"+ B.DataEnd {} -> "data-end"+ B.EventDone {} -> "done"+ _ -> "unexpected"++assertFourEqual :: (Eq a, Show a) => String -> [a] -> IO ()+assertFourEqual label = \case+ [a, b, c, d] -> assertBool label (a == b && a == c && a == d)+ xs -> assertFailure ("expected four values: " ++ show xs)