diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for agentic-jev + +## 0.2.0.0 - 2026-10-01 + +First release of the v2 design. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2026, Tom Wells + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/agentic-jev.cabal b/agentic-jev.cabal new file mode 100644 --- /dev/null +++ b/agentic-jev.cabal @@ -0,0 +1,72 @@ +cabal-version: 3.0 +name: agentic-jev +version: 0.2.0.0 +synopsis: Jev (TypeSafe) as the System One provider for agentic +description: + Answers agentic's judgements (yes/no, choice and score questions) with Jev, TypeSafe's System One model, which returns calibrated probabilities. +license: BSD-2-Clause +license-file: LICENSE +author: Tom Wells +maintainer: drshade@gmail.com +copyright: 2026 Tom Wells +category: AI +homepage: https://github.com/drshade/haskell-agentic +bug-reports: https://github.com/drshade/haskell-agentic/issues +build-type: Simple +extra-doc-files: CHANGELOG.md +tested-with: GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 || ==9.14.1 + +source-repository head + type: git + location: https://github.com/drshade/haskell-agentic.git + subdir: agentic-jev + +common shared + default-language: GHC2021 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + LambdaCase + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + ghc-options: -Wall + +library + import: shared + hs-source-dirs: src + exposed-modules: Agentic.Jev + build-depends: + , agentic ==0.2.* + , aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , http-client >=0.7 && <0.8 + , http-client-tls >=0.3 && <0.4 + , http-types >=0.12 && <0.13 + , text >=2.0 && <2.2 +test-suite agentic-jev-test + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + , agentic ==0.2.* + , agentic-aeson ==0.2.* + , agentic-jev ==0.2.* + , aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , hspec >=2.10 && <3 +-- Calls the real Jev. Pending unless JEV_TOKEN is set (in the environment or .env). +test-suite agentic-jev-live + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test-live + main-is: Live.hs + build-depends: + , agentic ==0.2.* + , agentic-io ==0.2.* + , agentic-jev ==0.2.* + , base >=4.18 && <5 + , hspec >=2.10 && <3 + , text >=2.0 && <2.2 diff --git a/src/Agentic/Jev.hs b/src/Agentic/Jev.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/Jev.hs @@ -0,0 +1,146 @@ +-- | Jev (TypeSafe's System One model) as a runtime's System One. +-- +-- > rt <- pure runtime >>= withSystemOne jev +-- > rt <- pure runtime >>= withSystemOne (jev & model "jev-1.13.0") +module Agentic.Jev + ( Jev (..) + , jev + , JevError (..) + -- * Wire format + , requestBody + , decodeResponse + ) where + +import qualified Agentic.Value as A +import Agentic.Questions +import Agentic.Runtime (ProvidesSystemOne (..), SystemOne (..)) +import Agentic.Settings +import Control.Exception (Exception (..), throwIO) +import Data.Aeson ((.:)) +import qualified Data.Aeson as J +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.Types as J +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Client as Http +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Types.Status (statusCode) +import System.Environment (lookupEnv) + +-- | Jev's settings. Start from 'jev' and change them with the setters from +-- "Agentic.Settings": 'Agentic.Settings.model', 'Agentic.Settings.key', +-- 'Agentic.Settings.endpoint' and 'Agentic.Settings.timeout'. +data Jev = Jev + { model :: Text + , key :: Maybe Text + -- ^ Defaults to the @JEV_TOKEN@ environment variable. + , endpoint :: String + , timeout :: Int + -- ^ Seconds. + } + +jev :: Jev +jev = + Jev + { model = "jev-latest" + , key = Nothing + , endpoint = "https://api.typesafe.ai/v1/systemone" + , timeout = 30 + } + +instance HasModel Jev where model m c = c {model = m} +instance HasKey Jev where key k c = c {key = Just k} +instance HasEndpoint Jev where endpoint e c = c {endpoint = e} +instance HasTimeout Jev where timeout t c = c {timeout = t} + +-- | What can go wrong talking to Jev. Thrown in IO. +data JevError + = MissingToken + | HttpError Int Text + -- ^ Jev answered with a non-200 status, and this body. + | UnexpectedResponse Text + deriving (Show) + +instance Exception JevError where + displayException = \case + MissingToken -> "Jev: no token. Set JEV_TOKEN, or use (jev & key ...)." + HttpError status body -> "Jev rejected the request (HTTP " <> show status <> "): " <> T.unpack body + UnexpectedResponse problem -> "Jev sent a response agentic can't read: " <> T.unpack problem + +instance ProvidesSystemOne Jev where + toSystemOne cfg = do + token <- maybe (fmap T.pack <$> lookupEnv "JEV_TOKEN") (pure . Just) cfg.key + token' <- maybe (throwIO MissingToken) pure token + manager <- newTlsManager + base <- Http.parseRequest cfg.endpoint + pure $ SystemOne $ \request -> do + let http = + base + { Http.method = "POST" + , Http.requestHeaders = + [ ("Authorization", "Bearer " <> T.encodeUtf8 token') + , ("Content-Type", "application/json") + ] + , Http.requestBody = Http.RequestBodyBS (T.encodeUtf8 (A.renderJson (requestBody cfg.model request))) + , Http.responseTimeout = Http.responseTimeoutMicro (cfg.timeout * 1000000) + } + response <- Http.httpLbs http manager + let status = statusCode (Http.responseStatus response) + body = Http.responseBody response + if status /= 200 + then throwIO (HttpError status (T.decodeUtf8Lenient (LBS.toStrict body))) + else case J.eitherDecode body of + Left problem -> throwIO (UnexpectedResponse (T.pack problem)) + Right value -> either (throwIO . UnexpectedResponse) pure (decodeResponse request value) + +-- | The request body: the state, and each question under an id (@q0@, @q1@, …). +-- It's the core's 'A.Value' so that options keep their order. +requestBody :: Text -> JudgeRequest -> A.Value +requestBody name request = + A.Object + [ ("model", A.String name) + , ("state", requestState request) + , ("questions", A.Object [(qid, question q) | (qid, q) <- ided (requestQuestions request)]) + ] + where + question = \case + AskYesNo q -> A.Object [("type", A.String "noul"), ("instructions", A.String q)] + AskChoice q opts -> + A.Object + [ ("type", A.String "choice") + , ("instructions", A.String q) + , ("criteria", A.Object [(l, maybe A.Null A.String d) | (l, d) <- opts]) + ] + AskScore q levels -> + A.Object + [ ("type", A.String "score") + , ("instructions", A.String q) + , ("criteria", A.Array [A.String (maybe l id d) | (l, d) <- levels]) + ] + +-- | Read Jev's answers back, in question order. +decodeResponse :: JudgeRequest -> J.Value -> Either Text [Answer] +decodeResponse request = either (Left . T.pack) Right . J.parseEither parse + where + parse = J.withObject "response" $ \response -> do + answers <- response .: "answers" + traverse (\(qid, q) -> answers .: Key.fromText qid >>= answer q) (ided (requestQuestions request)) + answer q = J.withObject "answer" $ \a -> case q of + AskYesNo _ -> YesNoAnswer . fromBasisPoints <$> a .: "noul" + AskChoice _ opts -> do + ps <- a .: "probabilities" + ChoiceAnswer + <$> a .: "choice" + <*> traverse (\(l, _) -> (l,) . fromBasisPoints <$> ps .: Key.fromText l) opts + <*> (fromBasisPoints <$> a .: "confidence") + AskScore _ levels -> do + ps <- a .: "probabilities" + ScoreAnswer + <$> a .: "score" + <*> traverse (\i -> (i,) . fromBasisPoints <$> ps .: Key.fromText (T.pack (show i))) [0 .. length levels - 1] + <*> (fromBasisPoints <$> a .: "confidence") + +ided :: [a] -> [(Text, a)] +ided = zip ["q" <> T.pack (show n) | n <- [0 :: Int ..]] diff --git a/test-live/Live.hs b/test-live/Live.hs new file mode 100644 --- /dev/null +++ b/test-live/Live.hs @@ -0,0 +1,58 @@ +module Main (main) where + +import Agentic +import Agentic.IO.DotEnv (loadDotEnv) +import Agentic.Jev (jev) +import Data.Text (Text) +import GHC.Generics (Generic) +import System.Environment (lookupEnv) +import Test.Hspec hiding (describe) +import qualified Test.Hspec + +data Joke = Joke {setup :: Text, punchline :: Text} + deriving (Generic, Show, Contract) + +data Groan = Mild | Solid | Unbearable + deriving (Generic, Show, Eq) + +instance Options Groan where + options = + described + "How much the audience groans" + [ option Mild "A polite smile; most people didn't notice" + , option Solid "An audible groan from most of the room" + , option Unbearable "People get up and leave" + ] + +joke :: Joke +joke = Joke "Why was the scarecrow promoted?" "He was outstanding in his field." + +main :: IO () +main = do + _ <- loadDotEnv + token <- lookupEnv "JEV_TOKEN" + hspec $ Test.Hspec.describe "Jev, live" $ case token of + Nothing -> it "needs JEV_TOKEN" (pendingWith "set JEV_TOKEN in .env to run the live tests") + Just _ -> do + it "answers a yes/no, a choice and a score in one request" $ do + rt <- pure runtime >>= withSystemOne jev + (funny, reaction, groan) <- + interpret rt + ( judge $ + (,,) + <$> yesNo "Would a 10-year-old laugh at this joke?" + <*> choice @Groan "How will the audience react?" + <*> score @Groan "How much will the audience groan?" + ) + joke + probability (yes funny) `shouldSatisfy` (\p -> p >= 0 && p <= 1) + map fst (choiceProbabilities reaction) `shouldBe` [Mild, Solid, Unbearable] + position groan `shouldSatisfy` (\p -> p >= 0 && p <= 2) + + it "filters with keep" $ do + rt <- pure runtime >>= withSystemOne jev + -- Plain text, not Joke: a record with "setup" and "punchline" fields + -- tells Jev it's a joke before it reads a word. + let texts = ["Why was the scarecrow promoted? He was outstanding in his field.", "The meeting is at 3pm in room 4." :: Text] + kept <- interpret rt (keep 0.5 (yesNo "Is this text a joke?")) texts + kept `shouldBe` take 1 texts diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,61 @@ +module Main (main) where + +import Agentic +import Agentic.Aeson (toAeson) +import Agentic.Jev +import qualified Data.Aeson as J +import Data.Maybe (fromJust) +import GHC.Generics (Generic) +import Test.Hspec hiding (describe) +import qualified Test.Hspec + +data Groan = Mild | Solid | Unbearable + deriving (Generic, Show, Eq) + +instance Options Groan where + options = described "" [option Mild "A polite smile", option Solid "An audible groan", option Unbearable "People leave"] + +request :: JudgeRequest +request = + JudgeRequest + (Object [("joke", String "Why was the scarecrow promoted?")]) + (specs ((,,) <$> yesNo "Is it funny?" <*> choice @Groan "Which reaction?" <*> score @Groan "How much groaning?")) + + +main :: IO () +main = hspec $ Test.Hspec.describe "Agentic.Jev" $ do + it "builds Jev's request body" $ + toAeson (requestBody "jev-latest" request) + `shouldBe` fromJust + ( J.decode + "{\"model\":\"jev-latest\",\ + \\"state\":{\"joke\":\"Why was the scarecrow promoted?\"},\ + \\"questions\":{\ + \\"q0\":{\"type\":\"noul\",\"instructions\":\"Is it funny?\"},\ + \\"q1\":{\"type\":\"choice\",\"instructions\":\"Which reaction?\",\ + \\"criteria\":{\"Mild\":\"A polite smile\",\"Solid\":\"An audible groan\",\"Unbearable\":\"People leave\"}},\ + \\"q2\":{\"type\":\"score\",\"instructions\":\"How much groaning?\",\ + \\"criteria\":[\"A polite smile\",\"An audible groan\",\"People leave\"]}}}" + ) + + it "decodes Jev's answers in question order" $ + decodeResponse + request + ( fromJust + ( J.decode + "{\"model\":\"jev-latest\",\"answers\":{\ + \\"q2\":{\"type\":\"score\",\"score\":1.25,\"legend\":{\"0\":\"A polite smile\",\"1\":\"An audible groan\",\"2\":\"People leave\"},\ + \\"probabilities\":{\"0\":0.1,\"1\":0.55,\"2\":0.35},\"confidence\":0.4},\ + \\"q0\":{\"type\":\"noul\",\"noul\":0.8132},\ + \\"q1\":{\"type\":\"choice\",\"choice\":\"Solid\",\"probabilities\":{\"Mild\":0.2,\"Solid\":0.7,\"Unbearable\":0.1},\"confidence\":0.5}},\ + \\"usage\":{\"input_tokens\":120,\"output_tokens\":3}}" + ) + ) + `shouldBe` Right + [ YesNoAnswer 0.8132 + , ChoiceAnswer "Solid" [("Mild", 0.2), ("Solid", 0.7), ("Unbearable", 0.1)] 0.5 + , ScoreAnswer 1.25 [(0, 0.1), (1, 0.55), (2, 0.35)] 0.4 + ] + + it "reports a response it can't read" $ + decodeResponse request (J.object []) `shouldSatisfy` either (const True) (const False)