diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for agentic-anthropic + +## 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-anthropic.cabal b/agentic-anthropic.cabal new file mode 100644 --- /dev/null +++ b/agentic-anthropic.cabal @@ -0,0 +1,74 @@ +cabal-version: 3.0 +name: agentic-anthropic +version: 0.2.0.0 +synopsis: Claude as the System Two provider for agentic +description: + Runs agentic's draft steps on Claude through the Messages API, with strict structured outputs and tools, and can stand in as System One. +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-anthropic + +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.Anthropic + build-depends: + , agentic ==0.2.* + , agentic-aeson ==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-anthropic-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-anthropic ==0.2.* + , aeson >=2.1 && <2.3 + , base >=4.18 && <5 + , hspec >=2.10 && <3 + , text >=2.0 && <2.2 +-- Calls the real API. Pending unless ANTHROPIC_API_KEY is set (in the environment or .env). +test-suite agentic-anthropic-live + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test-live + main-is: Live.hs + build-depends: + , agentic ==0.2.* + , agentic-anthropic ==0.2.* + , agentic-io ==0.2.* + , base >=4.18 && <5 + , hspec >=2.10 && <3 + , text >=2.0 && <2.2 diff --git a/src/Agentic/Anthropic.hs b/src/Agentic/Anthropic.hs new file mode 100644 --- /dev/null +++ b/src/Agentic/Anthropic.hs @@ -0,0 +1,234 @@ +-- | Claude as a runtime's System Two (and, through 'viaLLM', System One). +-- +-- > rt <- pure runtime >>= withSystemTwo anthropic +-- > rt <- pure runtime >>= withSystemTwo (anthropic & model "claude-sonnet-5-5" & effort Low) +module Agentic.Anthropic + ( Anthropic (..) + , anthropic + , fallbacks + , AnthropicError (..) + -- * Wire format + , requestBody + , decodeTurn + ) where + +import Agentic.Aeson (fromAeson) +import Agentic.Core (Instruction (..)) +import Agentic.JsonSchema (objectSchema, unwrap) +import Agentic.Runtime +import Agentic.Schema (Schema) +import Agentic.Settings +import qualified Agentic.Value as A +import Agentic.ViaLLM (viaLLM) +import Control.Exception (Exception (..), throwIO) +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as J +import qualified Data.ByteString.Lazy as LBS +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Network.HTTP.Client as Http +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Types.Status (statusCode) +import System.Environment (lookupEnv) + +-- | Claude's settings. Start from 'anthropic' and change them with the setters +-- from "Agentic.Settings" ('Agentic.Settings.model', 'Agentic.Settings.system', +-- 'Agentic.Settings.effort', 'Agentic.Settings.maxTokens', 'Agentic.Settings.key', +-- 'Agentic.Settings.endpoint', 'Agentic.Settings.timeout') and @fallbacks@. +data Anthropic = Anthropic + { model :: Text + , system :: Maybe Text + -- ^ A system prompt for every @draft@ in the runtime. + , maxTokens :: Int + , effort :: Maybe Effort + -- ^ The model's default if unset. + , fallbacks :: Bool + -- ^ Let the API retry a refused request on a fallback model it picks. + , key :: Maybe Text + -- ^ Defaults to the @ANTHROPIC_API_KEY@ environment variable. + , endpoint :: String + , timeout :: Int + -- ^ Seconds. + } + +anthropic :: Anthropic +anthropic = + Anthropic + { model = "claude-opus-5-5" + , system = Nothing + , maxTokens = 16000 + , effort = Nothing + , fallbacks = True + , key = Nothing + , endpoint = "https://api.anthropic.com/v1/messages" + , timeout = 600 + } + +instance HasModel Anthropic where model m c = c {model = m} +instance HasSystem Anthropic where system t c = c {system = Just t} +instance HasMaxTokens Anthropic where maxTokens n c = c {maxTokens = n} +instance HasEffort Anthropic where effort e c = c {effort = Just e} +instance HasKey Anthropic where key k c = c {key = Just k} +instance HasEndpoint Anthropic where endpoint e c = c {endpoint = e} +instance HasTimeout Anthropic where timeout t c = c {timeout = t} + +-- | Whether the API may retry a refused request on a fallback model. On by +-- default. +fallbacks :: Bool -> Anthropic -> Anthropic +fallbacks on c = c {fallbacks = on} + +effortName :: Effort -> Text +effortName = \case + Low -> "low" + Medium -> "medium" + High -> "high" + XHigh -> "xhigh" + Max -> "max" + +-- | What can go wrong talking to the Messages API. Thrown in IO. +data AnthropicError + = MissingKey + | HttpError Int Text + -- ^ A non-200 status, and the API's error body. + | Refused (Maybe Text) + -- ^ Claude declined the request, with the category if the API gave one. + | Truncated + -- ^ The reply hit the token limit before it was complete. + | UnexpectedStop Text + | UnexpectedResponse Text + deriving (Show) + +instance Exception AnthropicError where + displayException = \case + MissingKey -> "Anthropic: no API key. Set ANTHROPIC_API_KEY, or use (anthropic & key ...)." + HttpError status body -> "Anthropic rejected the request (HTTP " <> show status <> "): " <> T.unpack body + Refused category -> "Claude declined the request" <> maybe "" (\c -> " (" <> T.unpack c <> ")") category + Truncated -> "Claude's reply hit the token limit; raise it with (anthropic & maxTokens ...)" + UnexpectedStop reason -> "Claude stopped for an unexpected reason: " <> T.unpack reason + UnexpectedResponse problem -> "Anthropic sent a response agentic can't read: " <> T.unpack problem + +instance ProvidesSystemTwo Anthropic where + toSystemTwo cfg = do + key' <- maybe (fmap T.pack <$> lookupEnv "ANTHROPIC_API_KEY") (pure . Just) cfg.key >>= maybe (throwIO MissingKey) pure + manager <- newTlsManager + base <- Http.parseRequest cfg.endpoint + pure $ SystemTwo $ \conversation -> do + let http = + base + { Http.method = "POST" + , Http.requestHeaders = + [ ("x-api-key", T.encodeUtf8 key') + , ("anthropic-version", "2023-06-01") + , ("content-type", "application/json") + ] + <> [("anthropic-beta", "server-side-fallback-2026-07-01") | cfg.fallbacks] + , Http.requestBody = Http.RequestBodyLBS (TL.encodeUtf8 (TL.fromStrict (A.renderJson (requestBody cfg conversation)))) + , 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 pure (decodeTurn conversation value) + +-- | Claude answers judgements too, with uncalibrated probabilities. +instance ProvidesSystemOne Anthropic where + toSystemOne cfg = viaLLM <$> toSystemTwo cfg + +-- | The Messages API request for one turn of a step. It's the core's 'A.Value' +-- so that schemas keep their field order (see "Agentic.JsonSchema"). +requestBody :: Anthropic -> Conversation -> A.Value +requestBody cfg c = + A.Object $ + [ ("model", A.String cfg.model) + , ("max_tokens", A.Integer (toInteger cfg.maxTokens)) + ] + <> maybe [] (\s -> [("system", A.String s)]) cfg.system + <> [("tools", A.Array (map tool (tools c))) | not (null (tools c))] + <> [ ("messages", A.Array (task : concatMap exchange (history c))) + , ( "output_config" + , A.Object + ( ("format", A.Object [("type", A.String "json_schema"), ("schema", objectSchema (output c))]) + : maybe [] (\e -> [("effort", A.String (effortName e))]) cfg.effort + ) + ) + , ("cache_control", A.Object [("type", A.String "ephemeral")]) + ] + <> [("fallbacks", A.String "default") | cfg.fallbacks] + where + task = message "user" (A.String (instructionText (instruction c) <> input)) + input = case state c of + A.Null -> "" + s -> "\n\nInput:\n" <> A.renderJson s + tool spec = + A.Object + [ ("name", A.String (specName spec)) + , ("description", A.String (specDescription spec)) + , ("input_schema", objectSchema (specInput spec)) + , ("strict", A.Bool True) + ] + exchange = \case + Called (Raw raw) results -> + [ message "assistant" raw + , message "user" (A.Array (map result results)) + ] + Rejected (Raw raw) problem -> + [ message "assistant" raw + , message "user" (A.String ("That answer was rejected: " <> problem <> ". Please answer again.")) + ] + result (callId', r) = case r of + ToolOk v -> A.Object [("type", A.String "tool_result"), ("tool_use_id", A.String callId'), ("content", A.String (asText v))] + ToolFailed problem -> + A.Object [("type", A.String "tool_result"), ("tool_use_id", A.String callId'), ("content", A.String problem), ("is_error", A.Bool True)] + asText = \case + A.String t -> t + v -> A.renderJson v + message :: Text -> A.Value -> A.Value + message role content = A.Object [("role", A.String role), ("content", content)] + +-- | Read one turn from a Messages API response. +decodeTurn :: Conversation -> J.Value -> Either AnthropicError Turn +decodeTurn c = either (Left . UnexpectedResponse . T.pack) id . J.parseEither parse + where + parse = J.withObject "response" $ \r -> do + content <- r .: "content" + blocks <- traverse block content + stop <- r .: "stop_reason" + details <- r .:? "stop_details" + category <- maybe (pure Nothing) (J.withObject "stop_details" (.:? "category")) details + let raw = Raw (fromAeson (J.toJSON content)) + calls = [ToolCall i n (unwrapInput n v) | ToolUse i n v <- blocks] + text = T.concat [t | Text t <- blocks] + pure $ case (stop :: Text) of + "tool_use" -> Right (Turn raw (CallTools calls)) + "end_turn" -> Right (Turn raw (Respond (final text))) + "stop_sequence" -> Right (Turn raw (Respond (final text))) + "refusal" -> Left (Refused category) + "max_tokens" -> Left Truncated + other -> Left (UnexpectedStop other) + block = J.withObject "block" $ \b -> do + kind <- b .: "type" + case kind :: Text of + "text" -> Text <$> b .: "text" + "tool_use" -> ToolUse <$> b .: "id" <*> b .: "name" <*> (fromAeson <$> b .: "input") + _ -> pure Other + -- A reply that isn't JSON goes back to the core as text; the output + -- contract then rejects it and the model gets another go. + final text = case J.eitherDecode (TL.encodeUtf8 (TL.fromStrict text)) of + Right v -> unwrap (output c) (fromAeson v) + Left _ -> A.String text + unwrapInput name v = maybe v (`unwrap` v) (inputSchema name) + inputSchema :: Text -> Maybe Schema + inputSchema name = case catMaybes [if specName s == name then Just (specInput s) else Nothing | s <- tools c] of + s : _ -> Just s + [] -> Nothing + +data Block = Text Text | ToolUse Text Text A.Value | Other 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,87 @@ +module Main (main) where + +import Agentic +import Agentic.Anthropic (anthropic) +import Agentic.IO.DotEnv (loadDotEnv) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import System.Environment (lookupEnv) +import Test.Hspec hiding (describe) +import qualified Test.Hspec + +data Joke = Joke {genre :: Text, setup :: Text, punchline :: Text} + deriving (Generic, Show, Contract) + +data BetterJoke + = DadJoke {setup' :: Text, punchline' :: Text} + | OneLiner {line :: Text} + | KnockKnock {whosThere :: Text, punchline' :: Text} + deriving (Generic, Show, Contract) + +data Square = Blank | X | O + deriving (Generic, Show, Eq, Contract) + +data Row = Row {left :: Square, centre :: Square, right :: Square} + deriving (Generic, Show, Contract) + +data Board = Board {top :: Row, middle :: Row, bottom :: Row} + deriving (Generic, Show, Contract) + +newtype Rating = Rating Int + deriving (Show, Eq) + +instance Contract Rating where + contract = mapCodec Rating (\(Rating n) -> n) (between 1 10 contract) + +main :: IO () +main = do + _ <- loadDotEnv + apiKey <- lookupEnv "ANTHROPIC_API_KEY" + hspec $ Test.Hspec.describe "Anthropic, live" $ case apiKey of + Nothing -> it "needs ANTHROPIC_API_KEY" (pendingWith "set ANTHROPIC_API_KEY in .env to run the live tests") + Just _ -> do + let fast = anthropic & effort Low + withClaude = pure runtime >>= withSystemTwo fast + + it "drafts a record" $ do + rt <- withClaude + j <- interpret rt (draft @Joke "a joke please") () + T.null j.punchline `shouldBe` False + + it "drafts a list, which has to be wrapped for structured outputs" $ do + rt <- withClaude + names <- interpret rt (draft @[Text] "Name exactly 3 dinosaurs") () + length names `shouldBe` 3 + + it "drafts a sum type from typed input" $ do + rt <- withClaude + j <- interpret rt (draft @BetterJoke "Convert this knock-knock joke") (Joke "knock-knock" "Knock knock. Who's there? Boo." "Don't cry, it's only a joke!") + case j of + KnockKnock {} -> pure () + other -> expectationFailure ("expected a KnockKnock, got " <> show other) + + it "runs a tool loop" $ do + calls <- newIORef (0 :: Int) + let lookupFossil = tool @Text @Text "fossil_count" "How many fossils the museum holds of a dinosaur" $ + act (\_ -> modifyIORef calls (+ 1) >> pure "The museum holds 17 fossils of it.") + rt <- withClaude + n <- interpret rt (draftWith @Int [lookupFossil] "How many Stegosaurus fossils does the museum hold? Use the tool.") () + n `shouldBe` 17 + readIORef calls >>= (`shouldSatisfy` (>= 1)) + + it "keeps within a contract's checks" $ do + rt <- withClaude + Rating n <- interpret rt (draft @Rating "Rate this joke") (Joke "pun" "Why was the scarecrow promoted?" "He was outstanding in his field.") + n `shouldSatisfy` (\x -> x >= 1 && x <= 10) + + it "drafts a type whose schema shares repeated parts through $defs" $ do + rt <- withClaude + b <- interpret rt (draft @Board "An empty tic-tac-toe board with X in the centre") () + b.middle.centre `shouldBe` X + + it "stands in as System One" $ do + rt <- pure runtime >>= withSystemOne fast + kept <- interpret rt (keep 0.5 (yesNo "Is this text a joke?")) ["Why was the scarecrow promoted? He was outstanding in his field.", "The meeting is at 3pm in room 4." :: Text] + length kept `shouldBe` 1 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,92 @@ +module Main (main) where + +import Agentic +import Agentic.Runtime (Conversation (..)) +import Agentic.Aeson (toAeson) +import Agentic.Anthropic +import qualified Data.Text as T +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Maybe (fromJust) +import Data.Text (Text) +import Test.Hspec hiding (describe) +import qualified Test.Hspec + +conversation :: Conversation +conversation = + Conversation + { path = [] + , instruction = "Suggest 3 dinosaurs" + , state = Null + , stateSchema = schemaOf SNull + , tools = [ToolSpec "search" "Search the fossil database" (codecSchema (contract @Text))] + , output = codecSchema (contract @[Text]) + , history = [] + } + +at :: J.Key -> J.Value -> J.Value +at k = \case + J.Object o -> fromJust (KeyMap.lookup k o) + other -> error ("not an object: " <> show other) + +decoded :: J.Value -> Either String Turn +decoded = either (Left . show) Right . decodeTurn conversation + +json :: J.Value -> J.Value +json = id + +main :: IO () +main = hspec $ Test.Hspec.describe "Agentic.Anthropic" $ do + it "wraps a non-object output in a value field for structured outputs" $ + at "format" (at "output_config" (toAeson (requestBody anthropic conversation))) + `shouldBe` fromJust + ( J.decode + "{\"type\":\"json_schema\",\"schema\":{\"type\":\"object\",\ + \\"properties\":{\"value\":{\"type\":\"array\",\"items\":{\"type\":\"string\"}}},\ + \\"required\":[\"value\"],\"additionalProperties\":false}}" + ) + + it "keeps a record's field order in its schema" $ do + let body = renderJson (requestBody anthropic conversation {output = codecSchema (contract @(Text, Text, Text))}) + at' k = T.length (fst (T.breakOn k body)) + (at' "\"_1\"" < at' "\"_2\"", at' "\"_2\"" < at' "\"_3\"") `shouldBe` (True, True) + + it "sends tools as strict, with wrapped inputs" $ + at "tools" (toAeson (requestBody anthropic conversation)) + `shouldBe` fromJust + ( J.decode + "[{\"name\":\"search\",\"description\":\"Search the fossil database\",\"strict\":true,\ + \\"input_schema\":{\"type\":\"object\",\"properties\":{\"value\":{\"type\":\"string\"}},\ + \\"required\":[\"value\"],\"additionalProperties\":false}}]" + ) + + it "sends earlier turns back unchanged, with tool results" $ do + let raw = Object [("type", String "tool_use"), ("id", String "t1"), ("name", String "search"), ("input", Object [("value", String "rex")])] + c = conversation {history = [Called (Raw (Array [raw])) [("t1", ToolOk (Array [String "T. rex"]))]]} + at "messages" (toAeson (requestBody anthropic c)) + `shouldBe` fromJust + ( J.decode + "[{\"role\":\"user\",\"content\":\"Suggest 3 dinosaurs\"},\ + \{\"role\":\"assistant\",\"content\":[{\"type\":\"tool_use\",\"id\":\"t1\",\"name\":\"search\",\"input\":{\"value\":\"rex\"}}]},\ + \{\"role\":\"user\",\"content\":[{\"type\":\"tool_result\",\"tool_use_id\":\"t1\",\"content\":\"[\\\"T. rex\\\"]\"}]}]" + ) + + it "reads tool calls, unwrapping their input" $ + fmap action (decoded (fromJust (J.decode "{\"stop_reason\":\"tool_use\",\"content\":[{\"type\":\"thinking\",\"thinking\":\"\",\"signature\":\"x\"},{\"type\":\"tool_use\",\"id\":\"t1\",\"name\":\"search\",\"input\":{\"value\":\"rex\"}}]}"))) + `shouldBe` Right (CallTools [ToolCall "t1" "search" (String "rex")]) + + it "reads a final answer, unwrapping it" $ + fmap action (decoded (fromJust (J.decode "{\"stop_reason\":\"end_turn\",\"content\":[{\"type\":\"text\",\"text\":\"{\\\"value\\\":[\\\"Stegosaurus\\\"]}\"}]}"))) + `shouldBe` Right (Respond (Array [String "Stegosaurus"])) + + it "keeps the whole content, thinking included, as the raw turn" $ + fmap raw (decoded (fromJust (J.decode "{\"stop_reason\":\"end_turn\",\"content\":[{\"type\":\"thinking\",\"thinking\":\"\",\"signature\":\"x\"},{\"type\":\"text\",\"text\":\"{}\"}]}"))) + -- aeson orders object keys, which JSON ignores; the blocks themselves are unchanged. + `shouldBe` Right (Raw (Array [Object [("signature", String "x"), ("thinking", String ""), ("type", String "thinking")], Object [("text", String "{}"), ("type", String "text")]])) + + it "reports refusals as errors, not answers" $ + either (\case Refused (Just "cyber") -> True; _ -> False) (const False) + (decodeTurn conversation (fromJust (J.decode "{\"stop_reason\":\"refusal\",\"stop_details\":{\"type\":\"refusal\",\"category\":\"cyber\"},\"content\":[]}"))) + `shouldBe` True + where + _unused = json