packages feed

agentic-anthropic (empty) → 0.2.0.0

raw patch · 6 files changed

+517/−0 lines, 6 filesdep +aesondep +agenticdep +agentic-aeson

Dependencies added: aeson, agentic, agentic-aeson, agentic-anthropic, agentic-io, base, bytestring, hspec, http-client, http-client-tls, http-types, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for agentic-anthropic++## 0.2.0.0 - 2026-10-01++First release of the v2 design.
+ LICENSE view
@@ -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.
+ agentic-anthropic.cabal view
@@ -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
+ src/Agentic/Anthropic.hs view
@@ -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
+ test-live/Live.hs view
@@ -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
+ test/Spec.hs view
@@ -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