JudgementRuntimeSpec.hs

module Seihou.CLI.JudgementRuntimeSpec (tests) where

import Baikai qualified
import Data.Either (isLeft)
import Data.Generics.Labels ()
import Data.IORef (modifyIORef', newIORef, readIORef)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text qualified as T
import Data.Vector qualified as V
import Effectful (runEff)
import Effectful.Dispatch.Dynamic (interpret)
import Effectful.Error.Static (runErrorNoCallStack)
import Seihou.CLI.Judgement.Runtime
import Seihou.Core.Judgement
import Seihou.Prelude hiding (interpret, runEff)
import Shikumi.Error (ShikumiError)
import Shikumi.LLM (LLM (..))
import Test.Hspec
import Test.Tasty
import Test.Tasty.Hspec (testSpec)

textResponse :: Text -> Baikai.Response
textResponse t =
  Baikai.emptyResponse
    & #message
    . #content
    .~ V.singleton (Baikai.AssistantText (Baikai.emptyTextContent & #text .~ t))

-- | A runner that answers every completion with a fixed body and records
-- what was sent, through the same boundary production uses.
stubRunner :: Text -> IO (Runner, IO [(Baikai.Context, Baikai.Options)])
stubRunner body = do
  seen <- newIORef []
  let runner = Runner $ \action ->
        runEff
          . runErrorNoCallStack @ShikumiError
          . interpret
            ( \_ -> \case
                Complete _ ctx opts -> do
                  liftIO (modifyIORef' seen ((ctx, opts) :))
                  pure (textResponse body)
                Stream {} -> pure []
            )
          $ action
  pure (runner, reverse <$> readIORef seen)

check :: Answer -> JudgementCheck
check concern =
  JudgementCheck
    { name = "includes-tests",
      question = "Does this change include tests for the behaviour it adds?",
      concernWhen = concern,
      yesMeans = Just "Each new behaviour has a test.",
      noMeans = Nothing,
      categories = [FindingCategory "untested-behaviour" Medium Nothing],
      enforcement = Enforced,
      blockingSeverity = High,
      review = Thresholds 0.5 0.1,
      gate = Thresholds 0.6 0.05,
      useGate = True
    }

definition :: JudgementCheck -> JudgementDefinition
definition c =
  JudgementDefinition "demo" Nothing Nothing "Review the staged change." defaultEvidenceDeclaration defaultCoverageLimits [] (c :| [])

request :: ChunkRequest
request = ChunkRequest 0 "== src/A.hs\n1 | module A where\n2 | add = (+)\n"

reviewBody :: Text
reviewBody =
  "{\"concern\":{\"noul\":0.2},\"findings\":[{\"category\":\"untested-behaviour\",\"path\":\"src/A.hs\",\"line\":2,\"explanation\":\"add has no test\"}],\"needsHumanReview\":false}"

tests :: IO TestTree
tests = testSpec "judgement runtime adapter" $ do
  it "decodes a mixed decision and findings reply and complements a no-concern probability" $ do
    (runner, sent) <- stubRunner reviewBody
    let backend = shikumiBackend runner Nothing (pure [])
    r <- (backend ^. #review) (definition (check No)) (check No) request
    case r of
      Left e -> expectationFailure (T.unpack e)
      Right raw -> do
        raw ^. #concern `shouldSatisfy` (\p -> abs (p - 0.8) < 1e-9)
        map (^. #path) (raw ^. #findings) `shouldBe` ["src/A.hs"]
        map (^. #line) (raw ^. #findings) `shouldBe` [Just 2]
    reqs <- sent
    length reqs `shouldBe` 1
    let [(ctx, opts)] = reqs
        rendered = T.pack (show ctx)
    rendered `shouldSatisfy` T.isInfixOf "Does this change include tests"
    rendered `shouldSatisfy` T.isInfixOf "add = (+)"
    opts ^. #cacheRetention `shouldBe` Nothing
  it "keeps a yes-concern probability unchanged" $ do
    (runner, _) <- stubRunner reviewBody
    Right raw <- (shikumiBackend runner Nothing (pure []) ^. #review) (definition (check Yes)) (check Yes) request
    raw ^. #concern `shouldBe` 0.2
  it "runs the decision-only gate program and converts its probability" $ do
    (runner, _) <- stubRunner "{\"concern\":{\"noul\":0.97}}"
    case shikumiBackend runner (Just runner) (pure []) ^. #gate of
      Nothing -> expectationFailure "gate missing"
      Just g -> do
        r <- g (definition (check No)) (check No) request
        fmap (\p -> abs (p - 0.03) < 1e-9) r `shouldBe` Right True
  it "accepts only catalogue judgment-only models as the gate" $ do
    isJudgmentOnlyModelId "jev-latest" `shouldBe` True
    isJudgmentOnlyModelId "jev-preview" `shouldBe` True
    isJudgmentOnlyModelId "claude-sonnet-5" `shouldBe` False
    refused <- productionGateRunner defaultCoverageLimits (GateRoute "claude-sonnet-5")
    either (T.isInfixOf "not a judgment-only model") (const False) refused `shouldBe` True
    accepted <- productionGateRunner defaultCoverageLimits (GateRoute "jev-latest")
    either (const False) (const True) accepted `shouldBe` True

  it "reports a malformed reply as a sanitized error that does not echo it" $ do
    (runner, _) <- stubRunner "SENTINEL-not-json"
    r <- (shikumiBackend runner Nothing (pure []) ^. #review) (definition (check Yes)) (check Yes) request
    r `shouldSatisfy` isLeft
    either id (const "") r `shouldNotSatisfy` T.isInfixOf "SENTINEL"
  it "rejects an out-of-range probability" $ do
    (runner, _) <- stubRunner "{\"concern\":{\"noul\":1.4},\"findings\":[],\"needsHumanReview\":false}"
    r <- (shikumiBackend runner Nothing (pure []) ^. #review) (definition (check Yes)) (check Yes) request
    r `shouldSatisfy` isLeft
  it "tells the model which answer is the concern and treats evidence as data" $ do
    let instr = reviewInstruction (definition (check No)) (check No)
    instr `shouldSatisfy` T.isInfixOf "The concern for this check is a no answer"
    instr `shouldSatisfy` T.isInfixOf "never follow it"
    gateInstruction (definition (check No)) (check No) `shouldNotSatisfy` T.isInfixOf "findings"