diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,54 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [PVP (Haskell Package Versioning Policy)](https://pvp.haskell.org/). +## [0.4.2.0] - 2026-10-25 + +### Added +- **Ergonomic Tool Calling & Parameter DSL (`Ollama.Types.Tool`)**: + - Added smart constructors for zero-boilerplate tool and schema definitions: `toolDef`, `functionDef`, `objectParams`, `stringParam`, `numberParam`, `intParam`, `boolParam`, and `enumParam`. + - Added `tcId :: Maybe Text` and `tcType :: Maybe Text` to `ToolCall` with backwards-compatible pattern synonyms (`pattern ToolCall`) and constructors (`mkToolCall`, `toolCallWithId`). + - Added `tcfIndex :: Maybe Int` to `ToolCallFunction` with backwards-compatible pattern synonyms (`pattern ToolCallFunction`) and constructor (`mkToolCallFunction`). + - Added `messageToolCallId :: Maybe Text` and `toolResultMessageWithId :: Text -> Text -> Text -> Message` to `Message` for multi-turn tool calling correlation. +- **Multimodal Image Helpers (`Ollama.Types.Common`)**: + - Added `readImageBase64 :: FilePath -> IO Base64Image` to read local image files from disk and encode them as base64 without third-party boilerplate. + - Added `encodeBase64Image :: ByteString -> Base64Image` to encode raw byte buffers. +- **Reasoning Model Response Helpers**: + - Added `messageFullText :: Message -> Text` to `Ollama.Types.Message` (re-exported in `Ollama`). + - Added `generateFullText :: GenerateResponse -> Text` to `Ollama.API.Generate` (re-exported in `Ollama`). + - Both safely combine reasoning/thinking tokens (`messageThinking` / `grThinking`) and final content (`messageContent` / `grResponse`), preventing empty strings when all tokens are consumed in the thinking phase. +- **Top-Level Umbrella Re-exports (`Ollama`)**: + - Re-exported `ModelDetails (..)`, `ShowRequest (..)`, `readImageBase64`, `encodeBase64Image`, `messageFullText`, `generateFullText`, and all tool smart constructors directly from `Ollama`. +- **System One Decision API (`Ollama.API.SystemOne`)**: + - Added native client support for Ollama's high-speed decision evaluation endpoint (`POST /v1/systemone`), matching `ollama-python` and `ollama-rs`. + - Supported question formats: `ChoiceQuestion` (multiple choice with class probabilities and confidence), `NoulQuestion` (binary true/false probability), and `ScoreQuestion` (ordinal scoring with expected fractional score, legend, and confidence). + - Provided ergonomic smart constructors (`choiceQuestion`, `noulQuestion`, `noulQuestionWithCriteria`, `scoreQuestion`, `systemOneRequest`) and flexible state input via `SystemOneContent` (text or JSON `Value`). +- **Logprobs Support**: + - Added `TokenLogprob` and `Logprob` domain types in `Ollama.Types.Common` (re-exported in `Ollama`). + - Added `chatLogprobs :: Maybe Bool` and `chatTopLogprobs :: Maybe Int` to `ChatRequest`, and `crLogprobs :: Maybe [Logprob]` to `ChatResponse`. + - Added `genLogprobs :: Maybe Bool` and `genTopLogprobs :: Maybe Int` to `GenerateRequest`, and `grLogprobs :: Maybe [Logprob]` to `GenerateResponse`. +- **Extended Request Convenience Methods**: + - Added `showModelWith` to `Ollama.API.Models` to support verbose model inspection (`srqVerbose = Just True`). + - Added `pullWith` and `pullStreamWith` to `Ollama.API.Models.Pull` for custom pull options (`insecure`, etc.). + - Added `pushWith` and `pushStreamWith` to `Ollama.API.Models.Push` for custom push options (`insecure`, etc.). +- **Model-Defined Custom Thinking Levels**: + - Added `ThinkCustom !Text` constructor to `ThinkingLevel` to support arbitrary reasoning effort levels (e.g. `"xhigh"`, `"ultra"`, or model-defined strings) matching official `ollama-python` v0.6.3 behavior. +- **Image Generation Diffusion Progress Tracking**: + - Added `grCompleted :: Maybe Int` and `grTotal :: Maybe Int` to `GenerateResponse` to monitor diffusion step progression during image generation streaming. +- **Comprehensive Runnable Examples**: + - Added 10 new runnable example executables (`ollama-example-generate`, `ollama-example-vision`, `ollama-example-logprobs`, `ollama-example-thinking`, `ollama-example-model-lifecycle`, `ollama-example-conversation-store`, `ollama-example-client-lifecycle`, `ollama-example-mcp-bridge`, `ollama-example-system-one`, `ollama-example-mock-testing`), ensuring every single library API and type is verified running against a live Ollama server. + +### Fixed +- **Image Generation `GenerateResponse` JSON Parsing**: + - Fixed a critical crash where image generation progress updates (`{ "completed": 5, "total": 20 }`) and final responses (`{ "image": "..." }`) fail to decode with `key "response" not found`. Made `response` gracefully default to empty string (`.!= ""`) when omitted by the server. +- **Tool Call `Message` JSON Parsing**: + - Fixed JSON decoding failure when the assistant returns tool calls without a `"content"` field (or with null content) by defaulting `content` to `""`. + +### Changed +- **Model Context Protocol (`Ollama.MCP`)**: + - Enforced `mcp-server >= 0.3 && < 0.4` dependency bounds (addressing Stackage issue [#8143](https://github.com/commercialhaskell/stackage/issues/8143)). + - Supported `SchemaRaw` constructor introduced in `mcp-server-0.3.0.0` within `mcpDefinitionToTool`. + - Updated all Stack snapshots (`stack.yaml`, `stack-nightly.yaml`, `stack-lts-24.52.yaml`, `stack-lts-23.28.yaml`, `stack-lts-22.44.yaml`, `stack-lts-21.25.yaml`) to `mcp-server-0.3.0.0`. + --- ## [0.4.1.0] - 2026-08-25 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,10 +11,11 @@ - **First-Class Streaming**: `conduit`-based response streaming (`chatStream`, `generateStream`, `pullStream`, `pushStream`, `createModelStream`). - **Model Context Protocol (MCP) Bridge**: Bidirectional integration with `mcp-server` for converting between Ollama tools and MCP tools, running MCP servers via stdio or HTTP (`Ollama.MCP`). - **Generic JSON Schema Derivation**: Automatically derive JSON schemas from Haskell data types via `GHC.Generics` with `ToSchema` and `formatFor`. -- **Complete API Surface**: Text generation, chat completions, vector embeddings, model management (list, show, copy, delete, pull, push, create), and system endpoints. +- **Complete API Surface**: Text generation, chat completions, vector embeddings, model management (list, show, copy, delete, pull, push, create), system endpoints, and System One decision evaluation. +- **System One Decision Models**: Native support for `/v1/systemone` fast classification, binary probability (`noul`), and scoring (`choiceQuestion`, `noulQuestion`, `scoreQuestion`). - **Structured Outputs DSL**: Powerful `SchemaBuilder` DSL (`|+`, `|++`, `|!`, `|!!`) for type-safe JSON Schema structured responses. - **Function / Tool Calling**: Full support for tool definitions (`Tool`), tool calls (`ToolCall`), and execution results (`toolResultMessage`). -- **Thinking Models Support**: Native support for reasoning models (`qwen3.5`, `deepseek-r1`) with `Think` / `ThinkingLevel` types. +- **Thinking Models & Logprobs**: Native support for reasoning models (`Think` / `ThinkingLevel` with custom model-defined levels) and token log probabilities (`Logprob` / `TokenLogprob`). - **Environment & Auth Integration**: Robust URL normalization for `OLLAMA_HOST` and bearer token support for `OLLAMA_API_KEY`. - **Configurable Resilience**: Flexible retry policies (`NoRetry`, `ConstantRetry`, `ExponentialRetry`), custom timeouts, lifecycle callbacks, and structured logging. - **Conversation Store**: Transactional STM-backed `InMemoryStore` and `ConversationStore` typeclass for managing multi-turn chat sessions. @@ -29,14 +30,14 @@ ```cabal build-depends: base >= 4.17 && < 5 - , ollama-haskell >= 0.4.1.0 + , ollama-haskell >= 0.4.2.0 ``` Or using Stack in `package.yaml`: ```yaml dependencies: - - ollama-haskell >= 0.4.1.0 + - ollama-haskell >= 0.4.2.0 ``` --- @@ -101,33 +102,94 @@ ## Function & Tool Calling -Define function signatures and let the LLM execute structured tool calls: +Define function signatures with zero boilerplate using `toolDef`, `objectParams`, and typed parameters: ```haskell import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Map.Strict as Map import Ollama calculatorTool :: Tool -calculatorTool = Tool "function" $ FunctionDef - { fnName = "add" - , fnDescription = Just "Add two numbers" - , fnParameters = Just (FunctionParameters "object" Nothing (Just ["a", "b"]) Nothing Nothing Nothing) - , fnStrict = Just True - } +calculatorTool = + toolDef "add" "Add two numbers" $ + objectParams + [ ("a", numberParam (Just "First number")) + , ("b", numberParam (Just "Second number")) + ] + ["a", "b"] main :: IO () main = do client <- defaultClient - let req = (chatRequest "qwen3.5:2b" (userMessage "What is 40 + 2?" :| [])) + let req = (chatRequest "llama3.2:latest" (userMessage "What is 25 + 17?" :| [])) { chatTools = Just [calculatorTool] } res <- chat client req case res of Left err -> print err - Right resp -> print (crMessage resp) + Right resp -> case crMessage resp of + Just msg -> case messageToolCalls msg of + Just (call : _) -> do + putStrLn $ "Tool called: " <> show (tcfName (tcFunction call)) + putStrLn $ "Arguments: " <> show (tcfArguments (tcFunction call)) + _ -> putStrLn "No tool called." + Nothing -> putStrLn "No message returned." ``` --- +## Multimodal Vision + +Load local images directly and send them to vision models (`gemma3`, `qwen3.5:2b`, etc.): + +```haskell +main :: IO () +main = do + client <- defaultClient + img <- readImageBase64 "chart.png" + let msg = imageMessage "Describe the chart in 2 sentences." [img] + res <- chat client (chatRequest "gemma3:latest" (msg :| [])) + case res of + Right resp -> mapM_ (putStrLn . messageFullText) (crMessage resp) + Left err -> print err +``` + +--- + +## Thinking / Reasoning Models + +Control chain-of-thought tokens on reasoning models (e.g. DeepSeek-R1, Qwen 3.5): + +```haskell +let req = (chatRequest "qwen3.5:2b" (userMessage "Which is larger: 9.11 or 9.9?" :| [])) + { chatThink = Just ThinkEnabled } -- or ThinkDisabled, ThinkLevel ThinkHigh, ThinkCustom "..." +res <- chat client req +case res of + Right resp -> case crMessage resp of + Just msg -> do + case messageThinking msg of + Just th -> putStrLn $ "Thinking trace:\n" <> th + Nothing -> pure () + putStrLn $ "Answer:\n" <> messageContent msg + Nothing -> pure () + Left err -> print err +``` + +--- + +## System One Decision Models + +Evaluate high-speed classification, probability (`noul`), and scoring with `/v1/systemone`: + +```haskell +let q1 = choiceQuestion "Customer eligibility" (Map.fromList [("eligible", Just "Standard"), ("ineligible", Nothing)]) + q2 = noulQuestion "Will this cause churn?" + req = systemOneRequest "nimble" "Customer account history..." (Map.fromList [("q1", q1), ("q2", q2)]) +res <- systemOne client req +``` + + +--- + ## Structured Outputs (JSON Schema DSL) Enforce structured JSON output formats using `SchemaBuilder` (re-exported directly from `Ollama`): @@ -185,6 +247,38 @@ --- +## Runnable Examples + +The repository includes complete, tested runnable examples for every library feature: + +| Target | Source File | Description | +| :--- | :--- | :--- | +| `ollama-example-basic-chat` | [`examples/BasicChat.hs`](examples/BasicChat.hs) | Non-streaming chat, system messages, and throughput metrics. | +| `ollama-example-streaming-chat` | [`examples/StreamingChat.hs`](examples/StreamingChat.hs) | Conduit-based real-time response streaming. | +| `ollama-example-tool-calling` | [`examples/ToolCalling.hs`](examples/ToolCalling.hs) | Multi-turn tool execution loop with `toolDef` and `objectParams`. | +| `ollama-example-structured-output` | [`examples/StructuredOutput.hs`](examples/StructuredOutput.hs) | Typed record JSON schema derivation via `ToSchema` and `formatFor`. | +| `ollama-example-embeddings` | [`examples/Embeddings.hs`](examples/Embeddings.hs) | Modern batch embeddings (`/api/embed`) and legacy embeddings. | +| `ollama-example-model-management` | [`examples/ModelManagement.hs`](examples/ModelManagement.hs) | Version inspection, model listing, details, and active VRAM ps. | +| `ollama-example-generate` | [`examples/GenerateText.hs`](examples/GenerateText.hs) | Single-turn text completion, streaming, and throughput metrics. | +| `ollama-example-vision` | [`examples/Vision.hs`](examples/Vision.hs) | Multimodal chat and generation with local images (`readImageBase64`). | +| `ollama-example-logprobs` | [`examples/Logprobs.hs`](examples/Logprobs.hs) | Token log probability inspection and alternative candidate analysis. | +| `ollama-example-thinking` | [`examples/Thinking.hs`](examples/Thinking.hs) | Reasoning models with `ThinkDisabled`, `ThinkEnabled`, and `ThinkCustom`. | +| `ollama-example-model-lifecycle` | [`examples/ModelLifecycle.hs`](examples/ModelLifecycle.hs) | Model copying, creation, blob checking, and deletion lifecycle. | +| `ollama-example-conversation-store` | [`examples/ConversationStore.hs`](examples/ConversationStore.hs) | STM-backed in-memory multi-turn conversation persistence. | +| `ollama-example-client-lifecycle` | [`examples/ClientLifecycle.hs`](examples/ClientLifecycle.hs) | `clientFromEnv`, `withClient`, retry backoff, and error taxonomy. | +| `ollama-example-mcp-bridge` | [`examples/MCPBridge.hs`](examples/MCPBridge.hs) | Bidirectional conversion between Ollama tools and MCP definitions. | +| `ollama-example-system-one` | [`examples/SystemOne.hs`](examples/SystemOne.hs) | Specialized decision evaluation questions (`/v1/systemone`). | +| `ollama-example-mock-testing` | [`examples/MockTesting.hs`](examples/MockTesting.hs) | Offline unit testing with `withMockClient` without a running server. | +| `ollama-example-all-features` | [`examples/AllFeatures.hs`](examples/AllFeatures.hs) | End-to-end showcase combining multiple library features. | + +Run any example with Stack: + +```bash +stack run ollama-example-tool-calling +``` + +--- + ## Feature Matrix | Feature | Haskell (`ollama-haskell`) | Official Python (`ollama-python`) | Official JS/TS (`ollama-js`) | Community Go (`ollama/ollama`) | @@ -193,6 +287,8 @@ | **Response Streaming** | ✅ `conduit` ($O(1)$ constant memory) | ⚠️ Python Generator | ⚠️ Async Iterator | ⚠️ Go Channels | | **Structured Output Derivation** | ✅ `GHC.Generics` (`ToSchema`) | ⚠️ Pydantic BaseModel | ⚠️ Zod / JSON Schema | ⚠️ Manual JSON Schema | | **Model Context Protocol (MCP)** | ✅ Native `mcp-server` Bridge | ❌ Manual | ❌ Manual | ❌ Manual | +| **System One Decision Models** | ✅ Full ADT (`/v1/systemone`) | ✅ Supported | ❌ None | ❌ None | +| **Token Logprobs Support** | ✅ `Logprob` / `TokenLogprob` | ✅ Supported | ❌ None | ❌ None | | **Thinking / Reasoning Models** | ✅ Dedicated `Think` ADT | ⚠️ Dict parameters | ⚠️ Object properties | ⚠️ Raw parameters | | **Transactional Chat Store** | ✅ STM `InMemoryStore` | ❌ None | ❌ None | ❌ None | | **Built-in Mock Testing** | ✅ `Ollama.Testing` (Pure) | ❌ None | ❌ None | ❌ None | diff --git a/examples/AllFeatures.hs b/examples/AllFeatures.hs --- a/examples/AllFeatures.hs +++ b/examples/AllFeatures.hs @@ -110,35 +110,20 @@ thinkRes <- generate client thinkReq case thinkRes of Left err -> putStrLn $ "Generate error: " <> show err - Right resp -> putStrLn $ "Result: " <> T.unpack (grResponse resp) + Right resp -> do + case grThinking resp of + Just th | not (T.null th) -> putStrLn $ "Thinking output: " <> T.unpack th + _ -> pure () + putStrLn $ "Full response: " <> T.unpack (generateFullText resp) -- 7. Tool / Function Calling putStrLn "\n[7] Tool / Function Calling..." let calcTool = - Tool - { toolType = "function" - , toolFunction = - FunctionDef - { fnName = "calculator" - , fnDescription = Just "Perform basic math calculations" - , fnParameters = - Just - FunctionParameters - { fpType = "object" - , fpProperties = Nothing - , fpRequired = Just ["expression"] - , fpAdditionalProperties = Nothing - , fpDescription = Nothing - , fpEnum = Nothing - } - , fnStrict = Just True - } - } + toolDef "calculator" "Perform basic math calculations" $ + objectParams [("expression", stringParam (Just "The mathematical expression"))] ["expression"] toolReq = - (chatRequest model (userMessage "Calculate 42 * 8" :| [])) + (chatRequest "llama3.2:latest" (userMessage "Calculate 42 * 8" :| [])) { chatTools = Just [calcTool] - , chatOptions = fastOptions - , chatThink = Just ThinkDisabled } toolRes <- chat client toolReq case toolRes of @@ -146,12 +131,12 @@ Right resp -> case crMessage resp of Just msg -> case messageToolCalls msg of Just calls -> putStrLn $ "Model requested tool execution: " <> show calls - Nothing -> putStrLn $ "Response: " <> T.unpack (messageContent msg) + Nothing -> putStrLn $ "Response: " <> T.unpack (messageFullText msg) Nothing -> putStrLn "No message returned." -- 8. Vector Embeddings putStrLn "\n[8] Vector Embeddings..." - let embReq = embedRequest model ["Haskell AI development", "Ollama LLM client"] + let embReq = embedRequest "nomic-embed-text" ["Haskell AI development", "Ollama LLM client"] embRes <- embed client embReq case embRes of Left err -> putStrLn $ "Embed error: " <> show err diff --git a/examples/BasicChat.hs b/examples/BasicChat.hs --- a/examples/BasicChat.hs +++ b/examples/BasicChat.hs @@ -1,21 +1,31 @@ module Main (main) where import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Text.IO qualified as TIO +import qualified Data.Text.IO as TIO import Ollama main :: IO () main = do client <- defaultClient - let opts = Just (defaultOptions {optNumPredict = Just 20}) + putStrLn "=== Basic Chat with System Message and Metrics ===" + let sysMsg = systemMessage "You are a concise, helpful assistant." + usrMsg = userMessage "Why is the sky blue in one short sentence?" + opts = Just (defaultOptions {optNumPredict = Just 30}) req = - (chatRequest "qwen3.5:2b" (userMessage "Why is the sky blue?" :| [])) + (chatRequest "llama3.2:latest" (sysMsg :| [usrMsg])) { chatOptions = opts - , chatThink = Just ThinkDisabled } + res <- chat client req case res of Left err -> putStrLn $ "Error: " <> show err Right resp -> case crMessage resp of - Just msg -> TIO.putStrLn $ "Response: " <> messageContent msg + Just msg -> do + TIO.putStrLn $ "Response: " <> messageFullText msg + case chatEvalTokensPerSecond resp of + Just tps -> putStrLn $ "Generation speed: " <> show tps <> " tokens/sec" + Nothing -> pure () + case chatPromptEvalTokensPerSecond resp of + Just ptps -> putStrLn $ "Prompt evaluation speed: " <> show ptps <> " tokens/sec" + Nothing -> pure () Nothing -> putStrLn "No content returned" diff --git a/examples/ClientLifecycle.hs b/examples/ClientLifecycle.hs new file mode 100644 --- /dev/null +++ b/examples/ClientLifecycle.hs @@ -0,0 +1,50 @@ +module Main (main) where + +import Control.Exception (try) +import Ollama + +main :: IO () +main = do + putStrLn "=== Ollama Client Lifecycle, Configuration & Error Handling ===" + + putStrLn "\n1. Client from environment variables (clientFromEnv)..." + envClient <- clientFromEnv + verRes <- getVersion envClient + case verRes of + Left err -> putStrLn $ "Error: " <> show err + Right (Version v) -> putStrLn $ "Connected via env client: v" <> show v + closeClient envClient + putStrLn "envClient successfully closed with closeClient." + + putStrLn "\n2. Scoped resource bracket (withClient) with custom config..." + let customCfg = + defaultConfig + { configBaseUrl = "http://localhost:11434" + , configRetry = ExponentialRetry 3 1 + , configTimeout = 15 + , configLogger = Just (\lvl msg -> putStrLn $ "[" <> show lvl <> "] " <> show msg) + , configHeaders = [("User-Agent", "ollama-haskell-demo/1.0")] + } + + withClient customCfg $ \client -> do + putStrLn "Inside withClient block (auto-cleanup guaranteed):" + modelsRes <- listModels client + case modelsRes of + Left err -> putStrLn $ "Error: " <> show err + Right (ListResponse ms) -> putStrLn $ "Successfully listed " <> show (length ms) <> " models." + + putStrLn "\n3. Testing error classification and isRetryable..." + let timeoutErr = TimeoutError + apiErr500 = ApiError 500 "Internal Server Error" + apiErr400 = ApiError 400 "Bad Request" + putStrLn $ "Is TimeoutError retryable? " <> show (isRetryable timeoutErr) + putStrLn $ "Is HTTP 500 retryable? " <> show (isRetryable apiErr500) + putStrLn $ "Is HTTP 400 retryable? " <> show (isRetryable apiErr400) + + putStrLn "\n4. Testing throwOllama exception raising..." + caught <- try (throwOllama (InvalidRequest "Simulated invalid parameter")) + case caught of + Left (err :: OllamaError) -> putStrLn $ "Successfully caught thrown OllamaError: " <> show err + Right () -> putStrLn "Error was not caught!" + + putStrLn "\n=== Client Lifecycle Showcase Completed Successfully ===" diff --git a/examples/ConversationStore.hs b/examples/ConversationStore.hs new file mode 100644 --- /dev/null +++ b/examples/ConversationStore.hs @@ -0,0 +1,59 @@ +module Main (main) where + +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import Ollama + +main :: IO () +main = do + putStrLn "=== STM In-Memory Conversation Store Showcase ===" + + putStrLn "\n1. Initializing in-memory store (initInMemoryStore)..." + store <- initInMemoryStore + + now <- getCurrentTime + let conv1 = + Conversation + { conversationId = "sess-alpha-1" + , messages = + [ systemMessage "You are an AI coding assistant." + , userMessage "What is an applicative functor?" + , assistantMessage "An applicative functor allows applying functions within a context." + ] + , model = "llama3.2:latest" + , createdAt = now + , lastUpdated = now + } + + conv2 = + Conversation + { conversationId = "sess-beta-2" + , messages = [userMessage "Hello world"] + , model = "qwen3.5:2b" + , createdAt = now + , lastUpdated = now + } + + putStrLn "\n2. Saving conversations (saveConversationInMemory)..." + saveConversationInMemory store conv1 + saveConversationInMemory store conv2 + putStrLn "Saved sessions: 'sess-alpha-1' and 'sess-beta-2'." + + putStrLn "\n3. Listing conversations (listConversationsInMemory)..." + allConvs <- listConversationsInMemory store + putStrLn $ "Total active conversations: " <> show (length allConvs) + mapM_ (\c -> putStrLn $ " - ID: " <> T.unpack (conversationId c) <> " | Messages: " <> show (length (messages c)) <> " | Model: " <> show (unModelName (model c))) allConvs + + putStrLn "\n4. Loading specific conversation (loadConversationInMemory)..." + loaded <- loadConversationInMemory store "sess-alpha-1" + case loaded of + Nothing -> putStrLn "Error: failed to load conversation." + Just c -> do + putStrLn $ "Successfully loaded " <> T.unpack (conversationId c) <> ":" + mapM_ (\m -> putStrLn $ " [" <> show (messageRole m) <> "] " <> T.unpack (messageContent m)) (messages c) + + putStrLn "\n5. Deleting conversation (deleteConversationInMemory)..." + _ <- deleteConversationInMemory store "sess-beta-2" + remaining <- listConversationsInMemory store + putStrLn $ "Remaining conversations after deletion: " <> show (length remaining) + mapM_ (\c -> putStrLn $ " - ID: " <> T.unpack (conversationId c)) remaining diff --git a/examples/Embeddings.hs b/examples/Embeddings.hs --- a/examples/Embeddings.hs +++ b/examples/Embeddings.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} module Main (main) where import Ollama @@ -5,8 +6,22 @@ main :: IO () main = do client <- defaultClient - let req = embedRequest "qwen3.5:2b" ["Hello world", "Haskell LLM integration"] + putStrLn "=== Ollama Modern Embeddings API (/api/embed) ===" + let req = embedRequest "nomic-embed-text" ["Hello world", "Haskell LLM integration"] res <- embed client req case res of Left err -> putStrLn $ "Error: " <> show err - Right resp -> putStrLn $ "Generated " <> show (length $ erEmbeddings resp) <> " embeddings." + Right resp -> do + let vectors = erEmbeddings resp + putStrLn $ "Generated " <> show (length vectors) <> " embeddings." + case vectors of + (v : _) -> putStrLn $ "Embedding vector dimension: " <> show (length v) + [] -> putStrLn "No vector generated" + + putStrLn "\n=== Ollama Legacy Embeddings API (/api/embeddings) ===" + let legacyReq = EmbeddingsRequest (ModelName "nomic-embed-text") "Functional programming in Haskell" Nothing Nothing + legacyRes <- embeddings client legacyReq + case legacyRes of + Left err -> putStrLn $ "Legacy Error: " <> show err + Right resp -> + putStrLn $ "Legacy embedding dimension: " <> show (length (ebrEmbedding resp)) diff --git a/examples/GenerateText.hs b/examples/GenerateText.hs new file mode 100644 --- /dev/null +++ b/examples/GenerateText.hs @@ -0,0 +1,35 @@ +module Main (main) where + +import qualified Data.Text.IO as TIO +import Ollama + +main :: IO () +main = do + client <- defaultClient + putStrLn "=== 1. Non-Streaming Text Generation ===" + let req = + (generateRequest "llama3.2:latest" "Write a haiku about Haskell compilers.") + { genOptions = Just (defaultOptions {optTemperature = Just 0.7, optNumPredict = Just 40}) + } + res <- generate client req + case res of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> do + putStrLn "Generated Response:" + TIO.putStrLn (generateFullText resp) + case evalTokensPerSecond resp of + Just tps -> putStrLn $ "Evaluation speed: " <> show tps <> " tokens/sec" + Nothing -> pure () + case promptEvalTokensPerSecond resp of + Just ptps -> putStrLn $ "Prompt evaluation speed: " <> show ptps <> " tokens/sec" + Nothing -> pure () + + putStrLn "\n=== 2. Streaming Text Generation with Conduit ===" + let streamReq = + (generateRequest "llama3.2:latest" "Name three benefits of pure functional programming.") + { genOptions = Just (defaultOptions {optNumPredict = Just 50}) + } + putStrLn "Streaming response chunks:" + chunks <- collectStream (generateStream client streamReq) + mapM_ (TIO.putStr . grResponse) chunks + putStrLn "\n--- Stream completed ---" diff --git a/examples/Logprobs.hs b/examples/Logprobs.hs new file mode 100644 --- /dev/null +++ b/examples/Logprobs.hs @@ -0,0 +1,54 @@ +module Main (main) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Text as T +import Ollama + +main :: IO () +main = do + client <- defaultClient + putStrLn "=== Ollama Token Logprobs API ===" + putStrLn "Sending chat request with chatLogprobs = Just True..." + + let opts = Just (defaultOptions {optNumPredict = Just 10}) + req = + (chatRequest "llama3.2:latest" (userMessage "The capital of France is" :| [])) + { chatLogprobs = Just True + , chatOptions = opts + } + + res <- chat client req + case res of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> do + case crMessage resp of + Just msg -> putStrLn $ "Response: " <> T.unpack (messageFullText msg) + Nothing -> putStrLn "No message returned." + + case crLogprobs resp of + Nothing -> putStrLn "No logprobs returned by model." + Just [] -> putStrLn "Logprobs list is empty." + Just tokens -> do + putStrLn $ "\nReceived logprobs for " <> show (length tokens) <> " tokens:" + mapM_ + ( \t -> do + let tok = lpToken t + lp = lpLogprob t + prob = exp lp * 100.0 :: Double + putStrLn $ " Token: " <> show tok <> " | logprob: " <> show lp <> " | prob: " <> show prob <> "%" + case lpTopLogprobs t of + Just tops | not (null tops) -> do + putStrLn " Top alternative candidates:" + mapM_ + ( \cand -> + putStrLn $ + " - " + <> show (tlpToken cand) + <> " (logprob: " + <> show (tlpLogprob cand) + <> ")" + ) + (take 3 tops) + _ -> pure () + ) + (take 5 tokens) diff --git a/examples/MCPBridge.hs b/examples/MCPBridge.hs new file mode 100644 --- /dev/null +++ b/examples/MCPBridge.hs @@ -0,0 +1,49 @@ +module Main (main) where + +import Data.Aeson (Value (String)) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Ollama + +main :: IO () +main = do + putStrLn "=== Model Context Protocol (MCP) Bridge Showcase ===" + + putStrLn "\n1. Defining an Ollama Tool..." + let weatherTool = + toolDef "get_weather" "Get current weather for a location" $ + objectParams + [ ("location", stringParam (Just "City and state, e.g. London, UK")) + , ("units", enumParam ["celsius", "fahrenheit"] (Just "Temperature unit")) + ] + ["location"] + putStrLn $ "Defined tool: " <> T.unpack (fnName (toolFunction weatherTool)) + + putStrLn "\n2. Converting Ollama Tool to MCP ToolDefinition (toolToMcpDefinition)..." + let mcpDef = toolToMcpDefinition weatherTool + putStrLn $ "MCP Tool Name: " <> T.unpack (toolDefinitionName mcpDef) + putStrLn $ "MCP Description: " <> T.unpack (toolDefinitionDescription mcpDef) + + putStrLn "\n3. Converting MCP ToolDefinition back to Ollama Tool (mcpDefinitionToTool)..." + let reconstructed = mcpDefinitionToTool mcpDef + putStrLn $ "Reconstructed Tool Name: " <> T.unpack (fnName (toolFunction reconstructed)) + putStrLn $ "Reconstructed Tool Type: " <> T.unpack (toolType reconstructed) + + putStrLn "\n4. Converting Ollama ToolCall to MCP argument pairs (toolCallToMcpArgs)..." + let callArgs = + Map.fromList + [ ("location", String "London, UK") + , ("units", String "celsius") + ] + ollamaCall = toolCallWithId "call_weather_99" (mkToolCallFunction "get_weather" callArgs) + (calledName, mcpArgs) = toolCallToMcpArgs ollamaCall + putStrLn $ "Target MCP Tool: " <> T.unpack calledName + putStrLn "Extracted MCP Arguments:" + mapM_ (\(k, v) -> putStrLn $ " - " <> T.unpack k <> " = " <> T.unpack v) mcpArgs + + putStrLn "\n5. Extracting text from MCP Content (mcpContentToToolOutput)..." + let mcpContent = ContentText "Sunny with 21°C in London." + toolOutput = mcpContentToToolOutput mcpContent + putStrLn $ "Extracted tool output: " <> T.unpack toolOutput + + putStrLn "\n=== MCP Bridge Showcase Completed Successfully ===" diff --git a/examples/MockTesting.hs b/examples/MockTesting.hs new file mode 100644 --- /dev/null +++ b/examples/MockTesting.hs @@ -0,0 +1,57 @@ +module Main (main) where + +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy as BSL +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Text as T +import Ollama + +main :: IO () +main = do + putStrLn "=== Offline Testing with withMockClient & Mock Fixtures ===" + + putStrLn "\n1. Mocking /api/chat with mockChatResponse..." + let chatFixture = mockChatResponse "mock-model:latest" "Hello from pure unit test!" + chatBytes = BSL.toStrict (encode chatFixture) + + withMockClient chatBytes $ \client -> do + res <- chat client (chatRequest "mock-model:latest" (userMessage "Hi!" :| [])) + case res of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> case crMessage resp of + Just msg -> putStrLn $ "Mock Chat Response: " <> T.unpack (messageContent msg) + Nothing -> putStrLn "No message returned." + + putStrLn "\n2. Mocking /api/generate with mockGenerateResponse..." + let genFixture = mockGenerateResponse "mock-model:latest" "Generated text without Ollama server." + genBytes = BSL.toStrict (encode genFixture) + + withMockClient genBytes $ \client -> do + res <- generate client (generateRequest "mock-model:latest" "Test prompt") + case res of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> putStrLn $ "Mock Generate Response: " <> T.unpack (grResponse resp) + + putStrLn "\n3. Mocking /api/embed with mockEmbedResponse..." + let embedFixture = mockEmbedResponse "mock-model:latest" [[0.1, 0.2, 0.3], [0.4, 0.5, 0.6]] + embedBytes = BSL.toStrict (encode embedFixture) + + withMockClient embedBytes $ \client -> do + res <- embed client (embedRequest "mock-model:latest" ["text 1", "text 2"]) + case res of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> putStrLn $ "Mock Embeddings count: " <> show (length (erEmbeddings resp)) + + putStrLn "\n4. Mocking /api/tags with mockListModelsResponse..." + let listFixture = mockListModelsResponse ["mock-llama:latest", "mock-gemma:latest"] + listBytes = BSL.toStrict (encode listFixture) + + withMockClient listBytes $ \client -> do + res <- listModels client + case res of + Left err -> putStrLn $ "Error: " <> show err + Right (ListResponse ms) -> do + putStrLn $ "Mock Models count: " <> show (length ms) + mapM_ (\m -> putStrLn $ " - " <> show (unModelName (miName m))) ms + + putStrLn "\n=== Mock Testing Showcase Completed Successfully ===" diff --git a/examples/ModelLifecycle.hs b/examples/ModelLifecycle.hs new file mode 100644 --- /dev/null +++ b/examples/ModelLifecycle.hs @@ -0,0 +1,53 @@ +module Main (main) where + +import Ollama + +main :: IO () +main = do + client <- defaultClient + let sourceModel = ModelName "llama3.2:latest" + destModel = ModelName "llama-backup-test:latest" + customModel = ModelName "haskell-expert:latest" + + putStrLn "=== 1. Copying Model (copyModel) ===" + putStrLn $ "Copying " <> show (unModelName sourceModel) <> " to " <> show (unModelName destModel) <> "..." + copyRes <- copyModel client sourceModel destModel + case copyRes of + Left err -> putStrLn $ "Copy failed: " <> show err + Right () -> do + putStrLn "Model copied successfully!" + + putStrLn "\n=== 2. Inspecting Copied Model (showModelWith) ===" + showRes <- showModelWith client (ShowRequest destModel (Just True)) + case showRes of + Left err -> putStrLn $ "Show failed: " <> show err + Right sr -> do + putStrLn $ "Model architecture family: " <> show (family (srsDetails sr)) + putStrLn $ "Parameter size: " <> show (parameterSize (srsDetails sr)) + + putStrLn "\n=== 3. Creating Custom Model with System Prompt (createModel) ===" + let createReq = + (defaultCreateRequest customModel) + { crqFrom = Just sourceModel + , crqSystem = Just "You are an expert Haskell compiler engineer." + } + createRes <- createModel client createReq + case createRes of + Left err -> putStrLn $ "Create failed: " <> show err + Right resp -> do + putStrLn $ "Create status: " <> show (crsStatus resp) + _ <- deleteModel client customModel + putStrLn $ "Custom model " <> show (unModelName customModel) <> " deleted." + + putStrLn "\n=== 4. Checking Blob Existence (checkBlob) ===" + let testDigest = Digest "sha256:0000000000000000000000000000000000000000000000000000000000000000" + blobRes <- checkBlob client testDigest + case blobRes of + Left err -> putStrLn $ "Blob check returned expected error/status: " <> show err + Right exists -> putStrLn $ "Dummy blob exists: " <> show exists + + putStrLn "\n=== 5. Deleting Copied Model (deleteModel) ===" + delRes <- deleteModel client destModel + case delRes of + Left err -> putStrLn $ "Delete failed: " <> show err + Right () -> putStrLn $ "Model " <> show (unModelName destModel) <> " deleted successfully." diff --git a/examples/ModelManagement.hs b/examples/ModelManagement.hs --- a/examples/ModelManagement.hs +++ b/examples/ModelManagement.hs @@ -1,13 +1,41 @@ module Main (main) where +import qualified Data.Text as T import Ollama main :: IO () main = do client <- defaultClient + + putStrLn "=== 1. Ollama Daemon Version ===" + verRes <- getVersion client + case verRes of + Left err -> putStrLn $ "Error fetching version: " <> show err + Right (Version ver) -> putStrLn $ "Ollama server version: " <> show ver + + putStrLn "\n=== 2. Installed Models (listModels) ===" res <- listModels client case res of Left err -> putStrLn $ "Error listing models: " <> show err Right (ListResponse ms) -> do - putStrLn "Installed Models:" - mapM_ (print . miName) ms + putStrLn $ "Found " <> show (length ms) <> " installed models:" + mapM_ (\m -> putStrLn $ " - " <> show (unModelName (miName m)) <> " (" <> show (miSize m `div` 1000000) <> " MB)") ms + + case ms of + (firstModel : _) -> do + putStrLn $ "\n=== 3. Inspecting Model Details (showModel for " <> show (unModelName (miName firstModel)) <> ") ===" + showRes <- showModel client (miName firstModel) + case showRes of + Left err -> putStrLn $ "Error showing model: " <> show err + Right sr -> do + putStrLn $ "Format: " <> show (srsDetails sr) + putStrLn $ "License length: " <> show (maybe 0 T.length (srsLicense sr)) + [] -> pure () + + putStrLn "\n=== 4. Running Models in Memory (listRunning / /api/ps) ===" + psRes <- listRunning client + case psRes of + Left err -> putStrLn $ "Error listing running models: " <> show err + Right (RunningModelsResponse rms) -> do + putStrLn $ "Currently active models in VRAM: " <> show (length rms) + mapM_ (\rm -> putStrLn $ " - " <> show (unModelName (rmName rm)) <> " (VRAM: " <> show (rmSizeVram rm `div` 1000000) <> " MB)") rms diff --git a/examples/StructuredOutput.hs b/examples/StructuredOutput.hs --- a/examples/StructuredOutput.hs +++ b/examples/StructuredOutput.hs @@ -19,7 +19,7 @@ main :: IO () main = do client <- defaultClient - let opts = Just (defaultOptions {optNumPredict = Just 20}) + let opts = Just (defaultOptions {optNumPredict = Just 60}) req = (generateRequest "qwen3.5:2b" "Generate a person profile.") { genFormat = Just (formatFor @Person) diff --git a/examples/SystemOne.hs b/examples/SystemOne.hs new file mode 100644 --- /dev/null +++ b/examples/SystemOne.hs @@ -0,0 +1,68 @@ +module Main (main) where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Ollama + +main :: IO () +main = do + client <- defaultClient + putStrLn "=== Ollama System One Decision API (/v1/systemone) ===" + + putStrLn "\n1. Defining System One evaluation questions..." + let state = "The customer requested a full refund after 45 days, but our policy limit is 30 days." + + -- Choice question: Categorize refund eligibility + q1 = + choiceQuestion + "Is the customer eligible for an automatic or discretionary refund?" + ( Map.fromList + [ ("eligible", Just "Within standard 30 day window") + , ("discretionary", Just "Requires manager escalation") + , ("ineligible", Just "Strict policy violation") + ] + ) + + -- Noul (binary probability) question + q2 = noulQuestion "Will this request result in customer churn if denied?" + + -- Score question (1 to 5 rating) + q3 = + scoreQuestion + "Rate customer frustration risk from 1 (low) to 5 (extreme)." + ["1", "2", "3", "4", "5"] + + questions = + Map.fromList + [ ("eligibility", q1) + , ("churn_risk", q2) + , ("frustration_score", q3) + ] + + req = systemOneRequest "nimble" state questions + + putStrLn "2. Dispatching decision evaluation request to Ollama..." + res <- systemOne client req + case res of + Left (ApiError 404 msg) -> do + putStrLn $ "Note: Server returned 404 (" <> T.unpack msg <> ")." + putStrLn "System One requires Ollama server with decision model support (e.g. 'ollama run nimble')." + putStrLn "Request serialization and client machinery verified successfully!" + Left err -> do + putStrLn $ "System One response: " <> show err + Right resp -> do + putStrLn "System One Answers:" + mapM_ + ( \(qName, ans) -> case ans of + AnswerChoice ca -> do + putStrLn $ " - Question [" <> T.unpack qName <> "]: Choice -> " <> T.unpack (choiceResult ca) + putStrLn $ " Probabilities: " <> show (choiceProbabilities ca) + AnswerNoul p -> do + putStrLn $ " - Question [" <> T.unpack qName <> "]: Noul probability -> " <> show p + AnswerScore sa -> do + putStrLn $ " - Question [" <> T.unpack qName <> "]: Score -> " <> show (scoreValue sa) + putStrLn $ " Legend: " <> show (scoreLegend sa) + ) + (Map.toList (sorAnswers resp)) + + putStrLn "\n=== System One Example Completed Successfully ===" diff --git a/examples/Thinking.hs b/examples/Thinking.hs new file mode 100644 --- /dev/null +++ b/examples/Thinking.hs @@ -0,0 +1,54 @@ +module Main (main) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (isJust) +import qualified Data.Text.IO as TIO +import Ollama + +main :: IO () +main = do + client <- defaultClient + let model = "qwen3.5:2b" + opts = Just (defaultOptions {optNumPredict = Just 80}) + + putStrLn "=== 1. Chat with Thinking Mode Disabled (ThinkDisabled) ===" + let reqNoThink = + (chatRequest model (userMessage "Which is larger: 9.11 or 9.9?" :| [])) + { chatThink = Just ThinkDisabled + , chatOptions = opts + } + resNoThink <- chat client reqNoThink + case resNoThink of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> case crMessage resp of + Just msg -> do + putStrLn $ "Thinking present? " <> show (isJust (messageThinking msg)) + putStrLn "Response content:" + TIO.putStrLn (messageContent msg) + Nothing -> putStrLn "No message returned." + + putStrLn "\n=== 2. Chat with Thinking Mode Enabled (ThinkEnabled) ===" + let reqThink = + (chatRequest model (userMessage "Which is larger: 9.11 or 9.9?" :| [])) + { chatThink = Just ThinkEnabled + , chatOptions = opts + } + resThink <- chat client reqThink + case resThink of + Left err -> putStrLn $ "Error: " <> show err + Right resp -> case crMessage resp of + Just msg -> do + case messageThinking msg of + Just th -> do + putStrLn "Extracted Thinking Trace:" + TIO.putStrLn th + Nothing -> putStrLn "No thinking content returned." + putStrLn "\nFinal Content:" + TIO.putStrLn (messageContent msg) + putStrLn "\nFull Combined Text (via messageFullText):" + TIO.putStrLn (messageFullText msg) + Nothing -> putStrLn "No message returned." + + putStrLn "\n=== 3. Custom Thinking Level (ThinkCustom) ===" + let customThink = ThinkCustom "budget_2048" + putStrLn $ "Demonstrating custom thinking level: " <> show customThink diff --git a/examples/ToolCalling.hs b/examples/ToolCalling.hs --- a/examples/ToolCalling.hs +++ b/examples/ToolCalling.hs @@ -1,41 +1,74 @@ module Main (main) where +import Data.Aeson (Value (Number)) import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Map.Strict as Map +import qualified Data.Scientific as Sci +import qualified Data.Text as T import Ollama +-- Define a tool using the ergonomic toolDef and objectParams smart constructors calculatorTool :: Tool calculatorTool = - Tool - { toolType = "function" - , toolFunction = - FunctionDef - { fnName = "add" - , fnDescription = Just "Add two numbers" - , fnParameters = - Just - FunctionParameters - { fpType = "object" - , fpProperties = Nothing - , fpRequired = Just ["a", "b"] - , fpAdditionalProperties = Nothing - , fpDescription = Nothing - , fpEnum = Nothing - } - , fnStrict = Just True - } - } + toolDef "add" "Add two numbers together" $ + objectParams + [ ("a", numberParam (Just "First number to add")) + , ("b", numberParam (Just "Second number to add")) + ] + ["a", "b"] main :: IO () main = do client <- defaultClient - let opts = Just (defaultOptions {optNumPredict = Just 20}) + putStrLn "=== Step 1: User asks a calculation question ===" + let userMsg = userMessage "What is 25 + 17?" req = - (chatRequest "qwen3.5:2b" (userMessage "What is 25 + 17?" :| [])) + (chatRequest "llama3.2:latest" (userMsg :| [])) { chatTools = Just [calculatorTool] - , chatOptions = opts - , chatThink = Just ThinkDisabled } + + putStrLn "Sending chat request to Ollama with calculatorTool..." res <- chat client req case res of Left err -> putStrLn $ "Error: " <> show err - Right resp -> print (crMessage resp) + Right resp -> case crMessage resp of + Nothing -> putStrLn "No message returned by model." + Just assistantMsg -> do + putStrLn "\n=== Step 2: Model responds with tool call ===" + case messageToolCalls assistantMsg of + Nothing -> putStrLn "No tool calls generated." + Just [] -> putStrLn "Tool calls list was empty." + Just (tc : _) -> do + let fn = tcFunction tc + fnName = tcfName fn + args = tcfArguments fn + callId = tcId tc + putStrLn $ "Model requested tool: " <> T.unpack fnName + putStrLn $ "Call ID: " <> show callId + putStrLn $ "Arguments: " <> show args + + putStrLn "\n=== Step 3: Executing requested function ===" + let result = case (Map.lookup "a" args, Map.lookup "b" args) of + (Just (Number a), Just (Number b)) -> + let sumVal = a + b + in T.pack (Sci.formatScientific Sci.Fixed Nothing sumVal) + _ -> "Error: invalid arguments" + putStrLn $ "Calculated result: " <> T.unpack result + + putStrLn "\n=== Step 4: Providing tool result back to model ===" + let toolMsg = case callId of + Just cid -> toolResultMessageWithId result fnName cid + Nothing -> toolResultMessage result fnName + followUpReq = + (chatRequest "llama3.2:latest" (userMsg :| [assistantMsg, toolMsg])) + { chatTools = Just [calculatorTool] + } + + followUpRes <- chat client followUpReq + case followUpRes of + Left err -> putStrLn $ "Follow-up error: " <> show err + Right followUpResp -> case crMessage followUpResp of + Nothing -> putStrLn "No final response message returned." + Just finalMsg -> do + putStrLn "Final Model Response:" + putStrLn (T.unpack (messageFullText finalMsg)) diff --git a/examples/Vision.hs b/examples/Vision.hs new file mode 100644 --- /dev/null +++ b/examples/Vision.hs @@ -0,0 +1,43 @@ +module Main (main) where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.Text.IO as TIO +import Ollama + +main :: IO () +main = do + client <- defaultClient + putStrLn "=== Multimodal / Vision API with Local Image ===" + putStrLn "Reading examples/sample.png using readImageBase64..." + img <- readImageBase64 "examples/sample.png" + putStrLn "Image loaded and encoded successfully." + + putStrLn "\n--- 1. Multimodal Chat (gemma3:latest) ---" + let chatMsg = imageMessage "What colors and shapes do you see in this image? Keep it to 2 sentences." [img] + opts = Just (defaultOptions {optNumPredict = Just 60}) + chatReq = + (chatRequest "gemma3:latest" (chatMsg :| [])) + { chatOptions = opts + } + + chatRes <- chat client chatReq + case chatRes of + Left err -> putStrLn $ "Vision chat error: " <> show err + Right resp -> case crMessage resp of + Just msg -> do + putStrLn "Model Description:" + TIO.putStrLn (messageFullText msg) + Nothing -> putStrLn "No message returned." + + putStrLn "\n--- 2. Multimodal Generation (generate endpoint with genImages) ---" + let genReq = + (generateRequest "gemma3:latest" "Identify what kind of asset or diagram this is in one line.") + { genImages = Just [img] + , genOptions = opts + } + genRes <- generate client genReq + case genRes of + Left err -> putStrLn $ "Vision generate error: " <> show err + Right resp -> do + putStrLn "Generated Answer:" + TIO.putStrLn (generateFullText resp) diff --git a/ollama-haskell.cabal b/ollama-haskell.cabal --- a/ollama-haskell.cabal +++ b/ollama-haskell.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ollama-haskell -version: 0.4.1.0 +version: 0.4.2.0 synopsis: Industry-grade Haskell client for Ollama local LLMs description: A type-safe Haskell client for interacting with @@ -79,6 +79,7 @@ Ollama.API.Blobs Ollama.API.Ps Ollama.API.Version + Ollama.API.SystemOne Ollama.Types Ollama.Types.Message Ollama.Types.Tool @@ -98,6 +99,7 @@ build-depends: aeson >= 2.0 && < 3 , base >= 4.17 && < 5 + , base64-bytestring >= 1.0 && < 1.3 , bytestring >= 0.10 && < 0.13 , case-insensitive >= 1.2 && < 1.3 , conduit >= 1.3 && < 1.4 @@ -113,7 +115,7 @@ , text >= 2.0 && < 3 , time >= 1.11 && < 2 , unliftio-core >= 0.2 && < 0.3 - , mcp-server >= 0.2 && < 0.3 + , mcp-server >= 0.3 && < 0.4 test-suite ollama-haskell-test import: warnings, lang @@ -205,8 +207,12 @@ main-is: ToolCalling.hs hs-source-dirs: examples build-depends: - base + aeson + , base + , containers , ollama-haskell + , scientific >= 0.3 && < 0.4 + , text executable ollama-example-structured-output import: warnings, lang @@ -233,6 +239,7 @@ build-depends: base , ollama-haskell + , text executable ollama-example-all-features import: warnings, lang @@ -243,4 +250,98 @@ , ollama-haskell , text , time + +executable ollama-example-generate + import: warnings, lang + main-is: GenerateText.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + , text + +executable ollama-example-vision + import: warnings, lang + main-is: Vision.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + , text + +executable ollama-example-logprobs + import: warnings, lang + main-is: Logprobs.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + , text + +executable ollama-example-thinking + import: warnings, lang + main-is: Thinking.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + , text + +executable ollama-example-model-lifecycle + import: warnings, lang + main-is: ModelLifecycle.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + +executable ollama-example-conversation-store + import: warnings, lang + main-is: ConversationStore.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + , text + , time + +executable ollama-example-client-lifecycle + import: warnings, lang + main-is: ClientLifecycle.hs + hs-source-dirs: examples + build-depends: + base + , ollama-haskell + +executable ollama-example-mcp-bridge + import: warnings, lang + main-is: MCPBridge.hs + hs-source-dirs: examples + build-depends: + aeson + , base + , containers + , ollama-haskell + , text + +executable ollama-example-system-one + import: warnings, lang + main-is: SystemOne.hs + hs-source-dirs: examples + build-depends: + base + , containers + , ollama-haskell + , text + +executable ollama-example-mock-testing + import: warnings, lang + main-is: MockTesting.hs + hs-source-dirs: examples + build-depends: + aeson + , base + , bytestring + , ollama-haskell + , text diff --git a/src/Ollama.hs b/src/Ollama.hs --- a/src/Ollama.hs +++ b/src/Ollama.hs @@ -61,6 +61,7 @@ generateRequest, evalTokensPerSecond, promptEvalTokensPerSecond, + generateFullText, -- ** Embeddings embed, @@ -74,10 +75,13 @@ -- ** Model Management listModels, showModel, + showModelWith, + ShowRequest (..), copyModel, deleteModel, ListResponse (..), ModelInfo (..), + ModelDetails (..), RunningModel (..), ShowResponse (..), @@ -91,9 +95,13 @@ -- ** Pull & Push pull, + pullWith, pullStream, + pullStreamWith, push, + pushWith, pushStream, + pushStreamWith, PullResponse (..), PushResponse (..), @@ -101,16 +109,21 @@ checkBlob, pushBlob, - -- ** System + -- ** System & Diagnostics getVersion, listRunning, RunningModelsResponse (..), + -- ** System One Decision API + module Ollama.API.SystemOne, + -- * Types & Primitives ModelName (..), mkModelName, Digest (..), Base64Image (..), + encodeBase64Image, + readImageBase64, Duration (..), durationToSeconds, durationToMillis, @@ -118,6 +131,8 @@ Version (..), Think (..), ThinkingLevel (..), + TokenLogprob (..), + Logprob (..), -- ** Messages Role (..), @@ -127,7 +142,9 @@ assistantMessage, toolMessage, toolResultMessage, + toolResultMessageWithId, imageMessage, + messageFullText, -- ** Tools & Functions Tool (..), @@ -135,6 +152,17 @@ FunctionParameters (..), ToolCall (..), ToolCallFunction (..), + mkToolCall, + toolCallWithId, + mkToolCallFunction, + objectParams, + stringParam, + numberParam, + intParam, + boolParam, + enumParam, + functionDef, + toolDef, -- ** Options & Format ModelOptions (..), @@ -205,6 +233,7 @@ import Ollama.API.Models.Pull import Ollama.API.Models.Push import Ollama.API.Ps +import Ollama.API.SystemOne import Ollama.API.Version import Ollama.Client import Ollama.Client.Config diff --git a/src/Ollama/API/Chat.hs b/src/Ollama/API/Chat.hs --- a/src/Ollama/API/Chat.hs +++ b/src/Ollama/API/Chat.hs @@ -33,7 +33,7 @@ import Ollama.Client.Internal (request, requestStreaming) import Ollama.Error (OllamaError) import Ollama.Streaming (HasDone (..)) -import Ollama.Types.Common (Duration, ModelName, Think, tokensPerSecond) +import Ollama.Types.Common (Duration, Logprob, ModelName, Think, tokensPerSecond) import Ollama.Types.Format (Format) import Ollama.Types.Message (Message) import Ollama.Types.Options (ModelOptions) @@ -52,6 +52,8 @@ , chStream :: !(Maybe Bool) , chatKeepAlive :: !(Maybe Text) , chatThink :: !(Maybe Think) + , chatLogprobs :: !(Maybe Bool) + , chatTopLogprobs :: !(Maybe Int) } deriving stock (Eq, Show, Generic) @@ -67,6 +69,8 @@ , ("stream" .=) <$> chStream , ("keep_alive" .=) <$> chatKeepAlive , ("think" .=) <$> chatThink + , ("logprobs" .=) <$> chatLogprobs + , ("top_logprobs" .=) <$> chatTopLogprobs ] {- | Create a default 'ChatRequest' for a model and message history. @@ -84,6 +88,8 @@ , chStream = Just False , chatKeepAlive = Nothing , chatThink = Nothing + , chatLogprobs = Nothing + , chatTopLogprobs = Nothing } {- | Chat completion response payload. @@ -102,6 +108,7 @@ , crPromptEvalDuration :: !(Maybe Duration) , crEvalCount :: !(Maybe Int) , crEvalDuration :: !(Maybe Duration) + , crLogprobs :: !(Maybe [Logprob]) } deriving stock (Eq, Show, Generic) @@ -119,6 +126,7 @@ <*> v .:? "prompt_eval_duration" <*> v .:? "eval_count" <*> v .:? "eval_duration" + <*> v .:? "logprobs" instance ToJSON ChatResponse where toJSON ChatResponse {..} = @@ -134,6 +142,7 @@ , "prompt_eval_duration" .= crPromptEvalDuration , "eval_count" .= crEvalCount , "eval_duration" .= crEvalDuration + , "logprobs" .= crLogprobs ] instance HasDone ChatResponse where diff --git a/src/Ollama/API/Generate.hs b/src/Ollama/API/Generate.hs --- a/src/Ollama/API/Generate.hs +++ b/src/Ollama/API/Generate.hs @@ -18,6 +18,7 @@ generateStream, evalTokensPerSecond, promptEvalTokensPerSecond, + generateFullText, ) where import Conduit (ConduitT) @@ -26,13 +27,14 @@ import Data.Aeson import Data.Maybe (catMaybes) import Data.Text (Text) +import Data.Text qualified as Text import Data.Time (UTCTime) import GHC.Generics (Generic) import Ollama.Client (OllamaClient) import Ollama.Client.Internal (request, requestStreaming) import Ollama.Error (OllamaError) import Ollama.Streaming (HasDone (..)) -import Ollama.Types.Common (Base64Image, Duration, ModelName, Think, tokensPerSecond) +import Ollama.Types.Common (Base64Image, Duration, Logprob, ModelName, Think, tokensPerSecond) import Ollama.Types.Format (Format) import Ollama.Types.Options (ModelOptions) @@ -56,6 +58,8 @@ , genWidth :: !(Maybe Int) , genHeight :: !(Maybe Int) , genSteps :: !(Maybe Int) + , genLogprobs :: !(Maybe Bool) + , genTopLogprobs :: !(Maybe Int) } deriving stock (Eq, Show, Generic) @@ -78,6 +82,8 @@ , ("width" .=) <$> genWidth , ("height" .=) <$> genHeight , ("steps" .=) <$> genSteps + , ("logprobs" .=) <$> genLogprobs + , ("top_logprobs" .=) <$> genTopLogprobs ] {- | Create a default 'GenerateRequest' for a model and prompt. @@ -102,6 +108,8 @@ , genWidth = Nothing , genHeight = Nothing , genSteps = Nothing + , genLogprobs = Nothing + , genTopLogprobs = Nothing } {- | Response payload returned by text generation. @@ -123,6 +131,9 @@ , grEvalDuration :: !(Maybe Duration) , grThinking :: !(Maybe Text) , grImage :: !(Maybe Base64Image) + , grLogprobs :: !(Maybe [Logprob]) + , grCompleted :: !(Maybe Int) + , grTotal :: !(Maybe Int) } deriving stock (Eq, Show, Generic) @@ -131,7 +142,7 @@ GenerateResponse <$> v .: "model" <*> v .: "created_at" - <*> v .: "response" + <*> v .:? "response" .!= "" <*> v .: "done" <*> v .:? "done_reason" <*> v .:? "context" @@ -143,6 +154,9 @@ <*> v .:? "eval_duration" <*> v .:? "thinking" <*> v .:? "image" + <*> v .:? "logprobs" + <*> v .:? "completed" + <*> v .:? "total" instance ToJSON GenerateResponse where toJSON GenerateResponse {..} = @@ -161,6 +175,9 @@ , "eval_duration" .= grEvalDuration , "thinking" .= grThinking , "image" .= grImage + , "logprobs" .= grLogprobs + , "completed" .= grCompleted + , "total" .= grTotal ] instance HasDone GenerateResponse where @@ -197,3 +214,18 @@ promptEvalTokensPerSecond :: GenerateResponse -> Maybe Double promptEvalTokensPerSecond GenerateResponse {..} = tokensPerSecond <$> grPromptEvalCount <*> grPromptEvalDuration + +{- | Retrieve the complete text representation of a generate response, combining +thinking content and final response content if both are present. + +This is especially helpful for reasoning models (e.g., DeepSeek-R1, Qwen 2.5/3.5) +where intermediate tokens are streamed or stored in 'grThinking'. + +@since 0.4.2.0 +-} +generateFullText :: GenerateResponse -> Text +generateFullText resp = case (grThinking resp, grResponse resp) of + (Just th, r) + | not (Text.null th) && not (Text.null r) -> th <> "\n\n" <> r + | not (Text.null th) -> th + (_, r) -> r diff --git a/src/Ollama/API/Models.hs b/src/Ollama/API/Models.hs --- a/src/Ollama/API/Models.hs +++ b/src/Ollama/API/Models.hs @@ -17,6 +17,7 @@ -- * Show Info showModel, + showModelWith, ShowRequest (..), ShowResponse (..), ShowModelInfo (..), @@ -154,7 +155,14 @@ @since 1.0.0.0 -} showModel :: (MonadIO m) => OllamaClient -> ModelName -> m (Either OllamaError ShowResponse) -showModel client model = request client "POST" "/api/show" (Just $ ShowRequest model Nothing) +showModel client model = showModelWith client (ShowRequest model Nothing) + +{- | Fetch detailed model inspection with custom request options (e.g. verbose) (@POST /api/show@). + +@since 0.4.2.0 +-} +showModelWith :: (MonadIO m) => OllamaClient -> ShowRequest -> m (Either OllamaError ShowResponse) +showModelWith client req = request client "POST" "/api/show" (Just req) {- | Duplicate an existing model under a new tag (@POST /api/copy@). diff --git a/src/Ollama/API/Models/Pull.hs b/src/Ollama/API/Models/Pull.hs --- a/src/Ollama/API/Models/Pull.hs +++ b/src/Ollama/API/Models/Pull.hs @@ -14,7 +14,9 @@ PullRequest (..), PullResponse (..), pull, + pullWith, pullStream, + pullStreamWith, ) where import Conduit (ConduitT) @@ -88,13 +90,25 @@ @since 1.0.0.0 -} pull :: (MonadIO m) => OllamaClient -> ModelName -> m (Either OllamaError PullResponse) -pull client model = - request client "POST" "/api/pull" (Just $ PullRequest model Nothing (Just False)) +pull client model = pullWith client (PullRequest model Nothing (Just False)) +{- | Download / pull a model with custom request options (e.g. insecure) (non-streaming). + +@since 0.4.2.0 +-} +pullWith :: (MonadIO m) => OllamaClient -> PullRequest -> m (Either OllamaError PullResponse) +pullWith client req = request client "POST" "/api/pull" (Just req {prqStream = Just False}) + {- | Download / pull a model streaming progress updates. @since 1.0.0.0 -} pullStream :: (MonadUnliftIO m) => OllamaClient -> ModelName -> ConduitT () PullResponse m () -pullStream client model = - requestStreaming client "/api/pull" (PullRequest model Nothing (Just True)) +pullStream client model = pullStreamWith client (PullRequest model Nothing (Just True)) + +{- | Download / pull a model with custom request options streaming progress updates. + +@since 0.4.2.0 +-} +pullStreamWith :: (MonadUnliftIO m) => OllamaClient -> PullRequest -> ConduitT () PullResponse m () +pullStreamWith client req = requestStreaming client "/api/pull" (req {prqStream = Just True}) diff --git a/src/Ollama/API/Models/Push.hs b/src/Ollama/API/Models/Push.hs --- a/src/Ollama/API/Models/Push.hs +++ b/src/Ollama/API/Models/Push.hs @@ -14,7 +14,9 @@ PushRequest (..), PushResponse (..), push, + pushWith, pushStream, + pushStreamWith, ) where import Conduit (ConduitT) @@ -88,13 +90,25 @@ @since 1.0.0.0 -} push :: (MonadIO m) => OllamaClient -> ModelName -> m (Either OllamaError PushResponse) -push client model = - request client "POST" "/api/push" (Just $ PushRequest model Nothing (Just False)) +push client model = pushWith client (PushRequest model Nothing (Just False)) +{- | Push a model with custom request options (e.g. insecure) (non-streaming). + +@since 0.4.2.0 +-} +pushWith :: (MonadIO m) => OllamaClient -> PushRequest -> m (Either OllamaError PushResponse) +pushWith client req = request client "POST" "/api/push" (Just req {psqStream = Just False}) + {- | Push a model streaming upload progress updates. @since 1.0.0.0 -} pushStream :: (MonadUnliftIO m) => OllamaClient -> ModelName -> ConduitT () PushResponse m () -pushStream client model = - requestStreaming client "/api/push" (PushRequest model Nothing (Just True)) +pushStream client model = pushStreamWith client (PushRequest model Nothing (Just True)) + +{- | Push a model with custom request options streaming upload progress updates. + +@since 0.4.2.0 +-} +pushStreamWith :: (MonadUnliftIO m) => OllamaClient -> PushRequest -> ConduitT () PushResponse m () +pushStreamWith client req = requestStreaming client "/api/push" (req {psqStream = Just True}) diff --git a/src/Ollama/API/SystemOne.hs b/src/Ollama/API/SystemOne.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/API/SystemOne.hs @@ -0,0 +1,344 @@ +{- | +Module : Ollama.API.SystemOne +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +System One decision evaluation API endpoint (@/v1/systemone@). + +Evaluates high-speed classification, probability, and scoring questions +with specialized decision models (e.g. @nimble@). + +@since 0.4.2.0 +-} +module Ollama.API.SystemOne ( + -- * Client Function + systemOne, + + -- * Request & Response + SystemOneRequest (..), + systemOneRequest, + SystemOneResponse (..), + SystemOneUsage (..), + + -- * Content + SystemOneContent (..), + + -- * Questions + SystemOneQuestion (..), + questionInstructions, + choiceQuestion, + noulQuestion, + noulQuestionWithCriteria, + scoreQuestion, + + -- * Answers + SystemOneAnswer (..), + ChoiceAnswer (..), + ScoreAnswer (..), +) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Ollama.Client (OllamaClient) +import Ollama.Client.Internal (request) +import Ollama.Error (OllamaError) +import Ollama.Types.Common (ModelName) + +{- | State or context payload passed to System One, represented as text or structured JSON. + +@since 0.4.2.0 +-} +data SystemOneContent + = StateText !Text + | StateJson !Value + deriving stock (Eq, Show, Generic) + +instance IsString SystemOneContent where + fromString = StateText . T.pack + +instance ToJSON SystemOneContent where + toJSON (StateText t) = String t + toJSON (StateJson v) = v + +instance FromJSON SystemOneContent where + parseJSON (String t) = pure (StateText t) + parseJSON v = pure (StateJson v) + +{- | Specification of a question to evaluate against the state. + +@since 0.4.2.0 +-} +data SystemOneQuestion + = ChoiceQuestion !SystemOneContent !(Map Text (Maybe Text)) + | NoulQuestion !SystemOneContent !(Maybe (Map Text Text)) + | ScoreQuestion !SystemOneContent ![Text] + deriving stock (Eq, Show, Generic) + +-- | Extract the instructions from any question variant. +questionInstructions :: SystemOneQuestion -> SystemOneContent +questionInstructions (ChoiceQuestion inst _) = inst +questionInstructions (NoulQuestion inst _) = inst +questionInstructions (ScoreQuestion inst _) = inst + +instance ToJSON SystemOneQuestion where + toJSON (ChoiceQuestion inst criteria) = + object + [ "type" .= ("choice" :: Text) + , "instructions" .= inst + , "criteria" .= criteria + ] + toJSON (NoulQuestion inst criteria) = + object $ + [ "type" .= ("noul" :: Text) + , "instructions" .= inst + ] + ++ maybe [] (\c -> ["criteria" .= c]) criteria + toJSON (ScoreQuestion inst criteria) = + object + [ "type" .= ("score" :: Text) + , "instructions" .= inst + , "criteria" .= criteria + ] + +instance FromJSON SystemOneQuestion where + parseJSON = withObject "SystemOneQuestion" $ \v -> do + qType <- v .: "type" + case (qType :: Text) of + "choice" -> ChoiceQuestion <$> v .: "instructions" <*> v .: "criteria" + "noul" -> NoulQuestion <$> v .: "instructions" <*> v .:? "criteria" + "score" -> ScoreQuestion <$> v .: "instructions" <*> v .: "criteria" + other -> fail $ "Unknown SystemOne question type: " <> T.unpack other + +{- | Smart constructor for a multiple-choice question with candidate descriptions. + +@since 0.4.2.0 +-} +choiceQuestion :: SystemOneContent -> Map Text (Maybe Text) -> SystemOneQuestion +choiceQuestion = ChoiceQuestion + +{- | Smart constructor for a binary probability (noul) question. + +@since 0.4.2.0 +-} +noulQuestion :: SystemOneContent -> SystemOneQuestion +noulQuestion instructions = NoulQuestion instructions Nothing + +{- | Smart constructor for a binary probability (noul) question with custom true\/false descriptions. + +@since 0.4.2.0 +-} +noulQuestionWithCriteria :: SystemOneContent -> Map Text Text -> SystemOneQuestion +noulQuestionWithCriteria instructions criteria = NoulQuestion instructions (Just criteria) + +{- | Smart constructor for an ordinal scoring question with descriptions from lowest to highest score. + +@since 0.4.2.0 +-} +scoreQuestion :: SystemOneContent -> [Text] -> SystemOneQuestion +scoreQuestion = ScoreQuestion + +{- | Result of a multiple-choice question evaluation. + +@since 0.4.2.0 +-} +data ChoiceAnswer = ChoiceAnswer + { choiceResult :: !Text + , choiceProbabilities :: !(Map Text Double) + , choiceConfidence :: !Double + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ChoiceAnswer where + parseJSON = withObject "ChoiceAnswer" $ \v -> + ChoiceAnswer + <$> v .: "choice" + <*> v .: "probabilities" + <*> v .: "confidence" + +instance ToJSON ChoiceAnswer where + toJSON ChoiceAnswer {..} = + object + [ "choice" .= choiceResult + , "probabilities" .= choiceProbabilities + , "confidence" .= choiceConfidence + ] + +{- | Result of an ordinal scoring question evaluation. + +@since 0.4.2.0 +-} +data ScoreAnswer = ScoreAnswer + { scoreValue :: !Double + , scoreLegend :: !(Map Text Text) + , scoreProbabilities :: !(Map Text Double) + , scoreConfidence :: !Double + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ScoreAnswer where + parseJSON = withObject "ScoreAnswer" $ \v -> + ScoreAnswer + <$> v .: "score" + <*> v .: "legend" + <*> v .: "probabilities" + <*> v .: "confidence" + +instance ToJSON ScoreAnswer where + toJSON ScoreAnswer {..} = + object + [ "score" .= scoreValue + , "legend" .= scoreLegend + , "probabilities" .= scoreProbabilities + , "confidence" .= scoreConfidence + ] + +{- | Answer returned by the model for a question. + +@since 0.4.2.0 +-} +data SystemOneAnswer + = AnswerChoice !ChoiceAnswer + | AnswerNoul !Double + | AnswerScore !ScoreAnswer + deriving stock (Eq, Show, Generic) + +instance FromJSON SystemOneAnswer where + parseJSON = withObject "SystemOneAnswer" $ \v -> do + aType <- v .: "type" + case (aType :: Text) of + "choice" -> AnswerChoice <$> parseJSON (Object v) + "noul" -> AnswerNoul <$> v .: "noul" + "score" -> AnswerScore <$> parseJSON (Object v) + other -> fail $ "Unknown SystemOne answer type: " <> T.unpack other + +instance ToJSON SystemOneAnswer where + toJSON (AnswerChoice ChoiceAnswer {..}) = + object + [ "type" .= ("choice" :: Text) + , "choice" .= choiceResult + , "probabilities" .= choiceProbabilities + , "confidence" .= choiceConfidence + ] + toJSON (AnswerNoul p) = + object + [ "type" .= ("noul" :: Text) + , "noul" .= p + ] + toJSON (AnswerScore ScoreAnswer {..}) = + object + [ "type" .= ("score" :: Text) + , "score" .= scoreValue + , "legend" .= scoreLegend + , "probabilities" .= scoreProbabilities + , "confidence" .= scoreConfidence + ] + +{- | Token usage statistics for System One requests. + +@since 0.4.2.0 +-} +data SystemOneUsage = SystemOneUsage + { souInputTokens :: !Int + , souOutputTokens :: !Int + } + deriving stock (Eq, Show, Generic) + +instance FromJSON SystemOneUsage where + parseJSON = withObject "SystemOneUsage" $ \v -> + SystemOneUsage <$> v .: "input_tokens" <*> v .: "output_tokens" + +instance ToJSON SystemOneUsage where + toJSON SystemOneUsage {..} = + object + [ "input_tokens" .= souInputTokens + , "output_tokens" .= souOutputTokens + ] + +{- | Request payload for the System One evaluation endpoint. + +@since 0.4.2.0 +-} +data SystemOneRequest = SystemOneRequest + { soModel :: !ModelName + , soState :: !SystemOneContent + , soQuestions :: !(Map Text SystemOneQuestion) + , soKeepAlive :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON SystemOneRequest where + toJSON SystemOneRequest {..} = + object $ + catMaybes + [ Just ("model" .= soModel) + , Just ("state" .= soState) + , Just ("questions" .= soQuestions) + , ("keep_alive" .=) <$> soKeepAlive + ] + +instance FromJSON SystemOneRequest where + parseJSON = withObject "SystemOneRequest" $ \v -> + SystemOneRequest + <$> v .: "model" + <*> v .: "state" + <*> v .: "questions" + <*> v .:? "keep_alive" + +{- | Smart constructor for a 'SystemOneRequest'. + +@since 0.4.2.0 +-} +systemOneRequest :: ModelName -> SystemOneContent -> Map Text SystemOneQuestion -> SystemOneRequest +systemOneRequest model state questions = + SystemOneRequest + { soModel = model + , soState = state + , soQuestions = questions + , soKeepAlive = Nothing + } + +{- | Response payload returned by the System One endpoint. + +@since 0.4.2.0 +-} +data SystemOneResponse = SystemOneResponse + { sorModel :: !ModelName + , sorAnswers :: !(Map Text SystemOneAnswer) + , sorUsage :: !SystemOneUsage + } + deriving stock (Eq, Show, Generic) + +instance FromJSON SystemOneResponse where + parseJSON = withObject "SystemOneResponse" $ \v -> + SystemOneResponse + <$> v .: "model" + <*> v .: "answers" + <*> v .: "usage" + +instance ToJSON SystemOneResponse where + toJSON SystemOneResponse {..} = + object + [ "model" .= sorModel + , "answers" .= sorAnswers + , "usage" .= sorUsage + ] + +{- | Score and evaluate choice, noul, and score questions with a local System One model (@POST /v1/systemone@). + +@since 0.4.2.0 +-} +systemOne :: + (MonadIO m) => + OllamaClient -> + SystemOneRequest -> + m (Either OllamaError SystemOneResponse) +systemOne client req = request client "POST" "/v1/systemone" (Just req) diff --git a/src/Ollama/MCP.hs b/src/Ollama/MCP.hs --- a/src/Ollama/MCP.hs +++ b/src/Ollama/MCP.hs @@ -71,7 +71,9 @@ mcpContentToToolOutput, ) where -import Data.Aeson (Value (..), encode) +import Control.Applicative ((<|>)) +import Data.Aeson (Result (..), Value (..), encode, fromJSON) +import Data.Aeson.KeyMap qualified as KM import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -231,6 +233,29 @@ , fpDescription = mDesc , fpEnum = Nothing } + SchemaRaw rawObj -> + let rawDesc = case KM.lookup "description" rawObj of + Just (String d) -> Just d + _ -> Nothing + effectiveDesc = mDesc <|> rawDesc + rawObjWithType = + if KM.member "type" rawObj + then rawObj + else KM.insert "type" (String "object") rawObj + in case fromJSON (Object rawObjWithType) of + Success fp -> + case mDesc of + Just d -> fp {fpDescription = Just d} + Nothing -> fp + Error _ -> + FunctionParameters + { fpType = "object" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = effectiveDesc + , fpEnum = Nothing + } params = convertSchema toolDefinitionInputSchema in Tool { toolType = "function" diff --git a/src/Ollama/Testing.hs b/src/Ollama/Testing.hs --- a/src/Ollama/Testing.hs +++ b/src/Ollama/Testing.hs @@ -97,6 +97,9 @@ , grEvalDuration = Just (Duration 700000000) , grThinking = Nothing , grImage = Nothing + , grLogprobs = Nothing + , grCompleted = Nothing + , grTotal = Nothing } {- | Construct a mock 'ChatResponse'. @@ -117,6 +120,7 @@ , crPromptEvalDuration = Just (Duration 200000000) , crEvalCount = Just 20 , crEvalDuration = Just (Duration 700000000) + , crLogprobs = Nothing } {- | Construct a mock 'EmbedResponse'. diff --git a/src/Ollama/Types.hs b/src/Ollama/Types.hs --- a/src/Ollama/Types.hs +++ b/src/Ollama/Types.hs @@ -19,12 +19,25 @@ assistantMessage, toolMessage, toolResultMessage, + toolResultMessageWithId, imageMessage, + messageFullText, Tool (..), FunctionDef (..), FunctionParameters (..), ToolCall (..), ToolCallFunction (..), + mkToolCall, + toolCallWithId, + mkToolCallFunction, + objectParams, + stringParam, + numberParam, + intParam, + boolParam, + enumParam, + functionDef, + toolDef, module Ollama.Types.Options, module Ollama.Types.Format, module Ollama.Types.Model, diff --git a/src/Ollama/Types/Common.hs b/src/Ollama/Types/Common.hs --- a/src/Ollama/Types/Common.hs +++ b/src/Ollama/Types/Common.hs @@ -15,6 +15,8 @@ mkModelName, Digest (..), Base64Image (..), + encodeBase64Image, + readImageBase64, Duration (..), durationToSeconds, durationToMillis, @@ -22,15 +24,32 @@ Version (..), Think (..), ThinkingLevel (..), + TokenLogprob (..), + Logprob (..), ) where -import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withText, (.:), (.=)) +import Data.Aeson ( + FromJSON (..), + ToJSON (..), + Value (..), + object, + withObject, + withText, + (.:), + (.:?), + (.=), + ) import Data.Aeson.Types (typeMismatch) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Base64 qualified as B64 import Data.Hashable (Hashable) import Data.Int (Int64) +import Data.Maybe (catMaybes) import Data.String (IsString) import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding qualified as TE import GHC.Generics (Generic) {- | Model name following the @model:tag@ format. @@ -63,6 +82,20 @@ newtype Base64Image = Base64Image {unBase64Image :: Text} deriving newtype (Eq, Show, ToJSON, FromJSON) +{- | Encode raw binary image data into a 'Base64Image'. + +@since 0.4.2.0 +-} +encodeBase64Image :: ByteString -> Base64Image +encodeBase64Image bs = Base64Image (TE.decodeUtf8 (B64.encode bs)) + +{- | Read a local image file from disk and encode it as a 'Base64Image'. + +@since 0.4.2.0 +-} +readImageBase64 :: FilePath -> IO Base64Image +readImageBase64 path = encodeBase64Image <$> BS.readFile path + {- | Duration in nanoseconds as returned by the Ollama API. @since 3.0.0.0 @@ -109,18 +142,25 @@ instance ToJSON Version where toJSON (Version s) = object ["version" .= s] -{- | Thinking level settings for reasoning models. +{- | Thinking level settings for reasoning models. Supports standard levels +as well as model-defined custom thinking levels. @since 3.0.0.0 -} -data ThinkingLevel = ThinkLow | ThinkMedium | ThinkHigh | ThinkMax - deriving stock (Eq, Show, Bounded, Enum, Generic) +data ThinkingLevel + = ThinkLow + | ThinkMedium + | ThinkHigh + | ThinkMax + | ThinkCustom !Text + deriving stock (Eq, Show, Generic) instance ToJSON ThinkingLevel where toJSON ThinkLow = String "low" toJSON ThinkMedium = String "medium" toJSON ThinkHigh = String "high" toJSON ThinkMax = String "max" + toJSON (ThinkCustom custom) = String custom instance FromJSON ThinkingLevel where parseJSON = withText "ThinkingLevel" $ \case @@ -128,7 +168,7 @@ "medium" -> pure ThinkMedium "high" -> pure ThinkHigh "max" -> pure ThinkMax - other -> fail $ "Unknown thinking level: " <> T.unpack other + other -> pure (ThinkCustom other) {- | Controls whether a thinking/reasoning model outputs its thoughts. @@ -150,3 +190,53 @@ parseJSON (Bool False) = pure ThinkDisabled parseJSON (String s) = ThinkLevel <$> parseJSON (String s) parseJSON v = typeMismatch "Think" v + +{- | Individual token log probability. + +@since 0.4.2.0 +-} +data TokenLogprob = TokenLogprob + { tlpToken :: !Text + , tlpLogprob :: !Double + } + deriving stock (Eq, Show, Generic) + +instance ToJSON TokenLogprob where + toJSON TokenLogprob {..} = + object + [ "token" .= tlpToken + , "logprob" .= tlpLogprob + ] + +instance FromJSON TokenLogprob where + parseJSON = withObject "TokenLogprob" $ \v -> + TokenLogprob + <$> v .: "token" + <*> v .: "logprob" + +{- | Log probability information for a generated token and optional top alternatives. + +@since 0.4.2.0 +-} +data Logprob = Logprob + { lpToken :: !Text + , lpLogprob :: !Double + , lpTopLogprobs :: !(Maybe [TokenLogprob]) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON Logprob where + toJSON Logprob {..} = + object $ + catMaybes + [ Just ("token" .= lpToken) + , Just ("logprob" .= lpLogprob) + , ("top_logprobs" .=) <$> lpTopLogprobs + ] + +instance FromJSON Logprob where + parseJSON = withObject "Logprob" $ \v -> + Logprob + <$> v .: "token" + <*> v .: "logprob" + <*> v .:? "top_logprobs" diff --git a/src/Ollama/Types/Message.hs b/src/Ollama/Types/Message.hs --- a/src/Ollama/Types/Message.hs +++ b/src/Ollama/Types/Message.hs @@ -18,12 +18,15 @@ assistantMessage, toolMessage, toolResultMessage, + toolResultMessageWithId, imageMessage, + messageFullText, ) where import Data.Aeson import Data.Maybe (catMaybes) import Data.Text (Text) +import Data.Text qualified as Text import GHC.Generics (Generic) import Ollama.Types.Common (Base64Image) import Ollama.Types.Tool (ToolCall) @@ -60,6 +63,7 @@ , messageToolCalls :: !(Maybe [ToolCall]) , messageToolName :: !(Maybe Text) , messageThinking :: !(Maybe Text) + , messageToolCallId :: !(Maybe Text) } deriving stock (Eq, Show, Generic) @@ -73,45 +77,47 @@ , ("tool_calls" .=) <$> messageToolCalls , ("tool_name" .=) <$> messageToolName , ("thinking" .=) <$> messageThinking + , ("tool_call_id" .=) <$> messageToolCallId ] instance FromJSON Message where parseJSON = withObject "Message" $ \v -> Message <$> v .: "role" - <*> v .: "content" + <*> v .:? "content" .!= "" <*> v .:? "images" <*> v .:? "tool_calls" <*> v .:? "tool_name" <*> v .:? "thinking" + <*> v .:? "tool_call_id" {- | Create a 'User' role message. @since 3.0.0.0 -} userMessage :: Text -> Message -userMessage t = Message User t Nothing Nothing Nothing Nothing +userMessage t = Message User t Nothing Nothing Nothing Nothing Nothing {- | Create a 'System' role message. @since 3.0.0.0 -} systemMessage :: Text -> Message -systemMessage t = Message System t Nothing Nothing Nothing Nothing +systemMessage t = Message System t Nothing Nothing Nothing Nothing Nothing {- | Create an 'Assistant' role message. @since 3.0.0.0 -} assistantMessage :: Text -> Message -assistantMessage t = Message Assistant t Nothing Nothing Nothing Nothing +assistantMessage t = Message Assistant t Nothing Nothing Nothing Nothing Nothing {- | Create a 'Tool' role message. @since 3.0.0.0 -} toolMessage :: Text -> Message -toolMessage t = Message Tool t Nothing Nothing Nothing Nothing +toolMessage t = Message Tool t Nothing Nothing Nothing Nothing Nothing {- | Create a 'Tool' role message with specific @tool_name@ informing the model of tool execution. @@ -119,11 +125,34 @@ -} toolResultMessage :: Text -> Text -> Message toolResultMessage content toolName = - Message Tool content Nothing Nothing (Just toolName) Nothing + Message Tool content Nothing Nothing (Just toolName) Nothing Nothing +{- | Create a 'Tool' role message with specific @tool_name@ and @tool_call_id@. + +@since 0.4.2.0 +-} +toolResultMessageWithId :: Text -> Text -> Text -> Message +toolResultMessageWithId content toolName callId = + Message Tool content Nothing Nothing (Just toolName) Nothing (Just callId) + {- | Create a 'User' message with attached Base64 image data. @since 3.0.0.0 -} imageMessage :: Text -> [Base64Image] -> Message -imageMessage t imgs = Message User t (Just imgs) Nothing Nothing Nothing +imageMessage t imgs = Message User t (Just imgs) Nothing Nothing Nothing Nothing + +{- | Retrieve the complete text representation of a message, combining +thinking content and final response content if both are present. + +This is especially helpful for reasoning models (e.g., DeepSeek-R1, Qwen 2.5/3.5) +where intermediate tokens are streamed or stored in 'messageThinking'. + +@since 0.4.2.0 +-} +messageFullText :: Message -> Text +messageFullText msg = case (messageThinking msg, messageContent msg) of + (Just th, c) + | not (Text.null th) && not (Text.null c) -> th <> "\n\n" <> c + | not (Text.null th) -> th + (_, c) -> c diff --git a/src/Ollama/Types/Tool.hs b/src/Ollama/Types/Tool.hs --- a/src/Ollama/Types/Tool.hs +++ b/src/Ollama/Types/Tool.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + {- | Module : Ollama.Types.Tool Copyright : (c) 2024-2026 Tushar Adhatrao @@ -14,12 +16,24 @@ Tool (..), FunctionDef (..), FunctionParameters (..), - ToolCall (..), - ToolCallFunction (..), + ToolCall (.., ToolCall), + ToolCallFunction (.., ToolCallFunction), + mkToolCall, + toolCallWithId, + mkToolCallFunction, + objectParams, + stringParam, + numberParam, + intParam, + boolParam, + enumParam, + functionDef, + toolDef, ) where import Data.Aeson import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Data.Text (Text) import GHC.Generics (Generic) @@ -112,37 +126,208 @@ @since 3.0.0.0 -} -newtype ToolCall = ToolCall - { tcFunction :: ToolCallFunction +data ToolCall = ToolCall' + { tcFunction :: !ToolCallFunction + , tcId :: !(Maybe Text) + , tcType :: !(Maybe Text) } deriving stock (Eq, Show, Generic) +{- | Pattern synonym providing backwards compatibility with 1-argument construction +and pattern matching. + +@since 0.4.2.0 +-} +pattern ToolCall :: ToolCallFunction -> ToolCall +pattern ToolCall fn <- ToolCall' fn _ _ + where + ToolCall fn = ToolCall' fn Nothing Nothing + +{-# COMPLETE ToolCall #-} + +{- | Construct a 'ToolCall' with only the function payload. + +@since 0.4.2.0 +-} +mkToolCall :: ToolCallFunction -> ToolCall +mkToolCall fn = ToolCall' fn Nothing Nothing + +{- | Construct a 'ToolCall' with an identifier, type, and function payload. + +@since 0.4.2.0 +-} +toolCallWithId :: Text -> ToolCallFunction -> ToolCall +toolCallWithId callId fn = ToolCall' fn (Just callId) (Just "function") + instance ToJSON ToolCall where - toJSON ToolCall {..} = object ["function" .= tcFunction] + toJSON ToolCall' {..} = + object $ + ["function" .= tcFunction] + ++ maybe [] (\i -> ["id" .= i]) tcId + ++ maybe [] (\t -> ["type" .= t]) tcType instance FromJSON ToolCall where parseJSON = withObject "ToolCall" $ \v -> - ToolCall <$> v .: "function" + ToolCall' + <$> v .: "function" + <*> v .:? "id" + <*> v .:? "type" {- | Function invocation payload inside a tool call. @since 3.0.0.0 -} -data ToolCallFunction = ToolCallFunction +data ToolCallFunction = ToolCallFunction' { tcfName :: !Text , tcfArguments :: !(Map Text Value) + , tcfIndex :: !(Maybe Int) } deriving stock (Eq, Show, Generic) +{- | Pattern synonym providing backwards compatibility with 2-argument construction +and pattern matching. + +@since 0.4.2.0 +-} +pattern ToolCallFunction :: Text -> Map Text Value -> ToolCallFunction +pattern ToolCallFunction name args <- ToolCallFunction' name args _ + where + ToolCallFunction name args = ToolCallFunction' name args Nothing + +{-# COMPLETE ToolCallFunction #-} + +{- | Construct a 'ToolCallFunction' with name and arguments map. + +@since 0.4.2.0 +-} +mkToolCallFunction :: Text -> Map Text Value -> ToolCallFunction +mkToolCallFunction name args = ToolCallFunction' name args Nothing + instance ToJSON ToolCallFunction where - toJSON ToolCallFunction {..} = - object + toJSON ToolCallFunction' {..} = + object $ [ "name" .= tcfName , "arguments" .= tcfArguments ] + ++ maybe [] (\i -> ["index" .= i]) tcfIndex instance FromJSON ToolCallFunction where parseJSON = withObject "ToolCallFunction" $ \v -> - ToolCallFunction + ToolCallFunction' <$> v .: "name" - <*> v .: "arguments" + <*> v .:? "arguments" .!= mempty + <*> v .:? "index" + +{- | Smart constructor for a function parameter representing an object with properties. + +@since 0.4.2.0 +-} +objectParams :: [(Text, FunctionParameters)] -> [Text] -> FunctionParameters +objectParams props req = + FunctionParameters + { fpType = "object" + , fpProperties = Just (Map.fromList props) + , fpRequired = if null req then Nothing else Just req + , fpAdditionalProperties = Nothing + , fpDescription = Nothing + , fpEnum = Nothing + } + +{- | Smart constructor for a string parameter. + +@since 0.4.2.0 +-} +stringParam :: Maybe Text -> FunctionParameters +stringParam mdesc = + FunctionParameters + { fpType = "string" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mdesc + , fpEnum = Nothing + } + +{- | Smart constructor for a number (floating point) parameter. + +@since 0.4.2.0 +-} +numberParam :: Maybe Text -> FunctionParameters +numberParam mdesc = + FunctionParameters + { fpType = "number" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mdesc + , fpEnum = Nothing + } + +{- | Smart constructor for an integer parameter. + +@since 0.4.2.0 +-} +intParam :: Maybe Text -> FunctionParameters +intParam mdesc = + FunctionParameters + { fpType = "integer" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mdesc + , fpEnum = Nothing + } + +{- | Smart constructor for a boolean parameter. + +@since 0.4.2.0 +-} +boolParam :: Maybe Text -> FunctionParameters +boolParam mdesc = + FunctionParameters + { fpType = "boolean" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mdesc + , fpEnum = Nothing + } + +{- | Smart constructor for an enum parameter with predefined string choices. + +@since 0.4.2.0 +-} +enumParam :: [Text] -> Maybe Text -> FunctionParameters +enumParam choices mdesc = + FunctionParameters + { fpType = "string" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mdesc + , fpEnum = Just choices + } + +{- | Smart constructor for a 'FunctionDef'. + +@since 0.4.2.0 +-} +functionDef :: Text -> Text -> FunctionParameters -> FunctionDef +functionDef name desc params = + FunctionDef + { fnName = name + , fnDescription = Just desc + , fnParameters = Just params + , fnStrict = Just True + } + +{- | Smart constructor for a 'Tool'. + +@since 0.4.2.0 +-} +toolDef :: Text -> Text -> FunctionParameters -> Tool +toolDef name desc params = + Tool + { toolType = "function" + , toolFunction = functionDef name desc params + } diff --git a/test/Test/Ollama/Property/Arbitrary.hs b/test/Test/Ollama/Property/Arbitrary.hs --- a/test/Test/Ollama/Property/Arbitrary.hs +++ b/test/Test/Ollama/Property/Arbitrary.hs @@ -27,7 +27,11 @@ arbitrary = Duration <$> choose (1, 1000000000) instance Arbitrary ThinkingLevel where - arbitrary = elements [ThinkLow, ThinkMedium, ThinkHigh, ThinkMax] + arbitrary = + oneof + [ elements [ThinkLow, ThinkMedium, ThinkHigh, ThinkMax] + , ThinkCustom <$> elements ["xhigh", "deep", "ultra"] + ] instance Arbitrary Think where arbitrary = @@ -42,6 +46,7 @@ Message <$> arbitrary <*> genNonEmptyText + <*> pure Nothing <*> pure Nothing <*> pure Nothing <*> pure Nothing diff --git a/test/Test/Ollama/Unit/MCP.hs b/test/Test/Ollama/Unit/MCP.hs --- a/test/Test/Ollama/Unit/MCP.hs +++ b/test/Test/Ollama/Unit/MCP.hs @@ -3,6 +3,8 @@ module Test.Ollama.Unit.MCP (tests) where +import Data.Aeson ((.=)) +import Data.Aeson.KeyMap qualified as KM import Data.Map.Strict qualified as Map import MCP.Server.Types ( Content (..), @@ -97,4 +99,24 @@ let resContent = ContentEmbeddedResource (ResourceText uri "text/plain" "file contents") mcpContentToToolOutput resContent @?= "[Resource: file:///workspace/test.txt]" Nothing -> assertFailure "Failed to parse URI" + , testCase "mcpDefinitionToTool handles SchemaRaw from mcp-server >= 0.3" $ do + let rawKeywords = + KM.fromList + [ "type" .= ("object" :: String) + , "description" .= ("Inner description" :: String) + , "required" .= (["input"] :: [String]) + ] + s = describedSchema "Outer description" (SchemaRaw rawKeywords) + mcpDef = mkToolDefinition "raw_tool" "Tool with raw schema" s + ollamaTool = mcpDefinitionToTool mcpDef + fn = toolFunction ollamaTool + + fnName fn @?= "raw_tool" + fnDescription fn @?= Just "Tool with raw schema" + case fnParameters fn of + Just FunctionParameters {..} -> do + fpType @?= "object" + fpRequired @?= Just ["input"] + fpDescription @?= Just "Outer description" + Nothing -> assertFailure "Expected parameters from SchemaRaw" ] diff --git a/test/Test/Ollama/Unit/Types.hs b/test/Test/Ollama/Unit/Types.hs --- a/test/Test/Ollama/Unit/Types.hs +++ b/test/Test/Ollama/Unit/Types.hs @@ -3,6 +3,8 @@ import Conduit (yield) import Data.Aeson (decode, encode) import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) import Data.Time (getCurrentTime) import Ollama import Ollama.Types.Message qualified as M @@ -69,4 +71,89 @@ let mockStream = mapM_ yield [1 .. 5 :: Int] sumVal <- foldStream (+) 0 mockStream assertEqual "Folded sum" 15 sumVal + , testCase "GenerateResponse parses image generation progress (no response field)" $ do + let progressJson = + "{\"model\":\"x/z-image-turbo\",\"created_at\":\"2026-10-25T10:00:00Z\",\"completed\":5,\"total\":20,\"done\":false}" + case decode @GenerateResponse progressJson of + Nothing -> assertFailure "Failed to parse image generation progress JSON" + Just resp -> do + assertEqual "Response default" "" (grResponse resp) + assertEqual "Completed steps" (Just 5) (grCompleted resp) + assertEqual "Total steps" (Just 20) (grTotal resp) + assertBool "Not done" (not $ grDone resp) + , testCase "GenerateResponse parses image generation final response" $ do + let finalJson = + "{\"model\":\"x/z-image-turbo\",\"created_at\":\"2026-10-25T10:00:15Z\",\"image\":\"iVBORw0KGgoAAAANSUhEUg==\",\"done\":true,\"done_reason\":\"stop\"}" + case decode @GenerateResponse finalJson of + Nothing -> assertFailure "Failed to parse image generation final JSON" + Just resp -> do + assertEqual "Response default" "" (grResponse resp) + assertEqual "Image data" (Just $ Base64Image "iVBORw0KGgoAAAANSUhEUg==") (grImage resp) + assertBool "Done" (grDone resp) + , testCase "Message parses tool call response without content field" $ do + let toolCallJson = + "{\"role\":\"assistant\",\"tool_calls\":[{\"function\":{\"name\":\"calc\",\"arguments\":{\"x\":1}}}]}" + case decode @Message toolCallJson of + Nothing -> assertFailure "Failed to parse tool call message without content" + Just msg -> do + assertEqual "Role assistant" Assistant (messageRole msg) + assertEqual "Content default" "" (messageContent msg) + assertBool "Tool calls present" (isJust (messageToolCalls msg)) + , testCase "ThinkingLevel supports custom model-defined levels" $ do + let customLvl = ThinkCustom "xhigh" + customJson = encode (ThinkLevel customLvl) + assertEqual "Serialized to string" "\"xhigh\"" customJson + assertEqual "Roundtrip decode" (Just (ThinkLevel customLvl)) (decode customJson) + , testCase "Logprob and TokenLogprob roundtrip in ChatResponse and GenerateResponse" $ do + let logprobData = + [ Logprob + { lpToken = "Hello" + , lpLogprob = -0.15 + , lpTopLogprobs = + Just + [ TokenLogprob "Hello" (-0.15) + , TokenLogprob "Hi" (-1.25) + ] + } + ] + chatJson = + "{\"model\":\"llama3.2\",\"created_at\":\"2026-10-25T10:00:00Z\",\"done\":true,\"logprobs\":[{\"token\":\"Hello\",\"logprob\":-0.15,\"top_logprobs\":[{\"token\":\"Hello\",\"logprob\":-0.15},{\"token\":\"Hi\",\"logprob\":-1.25}]}]}" + case decode @ChatResponse chatJson of + Nothing -> assertFailure "Failed to parse ChatResponse with logprobs" + Just cResp -> assertEqual "Logprobs match" (Just logprobData) (crLogprobs cResp) + , testCase "SystemOne questions and answers JSON roundtrip" $ do + let choiceQ = + choiceQuestion "Which team?" (Map.fromList [("billing", Just "Billing issues"), ("bugs", Nothing)]) + noulQ = noulQuestion "Is urgent?" + scoreQ = scoreQuestion "Severity" ["low", "medium", "high"] + sReq = + systemOneRequest + "nimble" + "I was charged twice" + (Map.fromList [("team", choiceQ), ("urgent", noulQ), ("severity", scoreQ)]) + encodedReq = encode sReq + case decode @SystemOneRequest encodedReq of + Nothing -> assertFailure "Failed to decode SystemOneRequest" + Just decodedReq -> assertEqual "SystemOneRequest roundtrip" sReq decodedReq + + let ansChoice = AnswerChoice (ChoiceAnswer "billing" (Map.fromList [("billing", 0.95), ("bugs", 0.05)]) 0.95) + ansNoul = AnswerNoul 0.88 + ansScore = + AnswerScore + ( ScoreAnswer + 2.1 + (Map.fromList [("0", "low"), ("1", "medium"), ("2", "high")]) + (Map.fromList [("0", 0.1), ("1", 0.2), ("2", 0.7)]) + 0.7 + ) + resp = + SystemOneResponse + { sorModel = "nimble" + , sorAnswers = Map.fromList [("team", ansChoice), ("urgent", ansNoul), ("severity", ansScore)] + , sorUsage = SystemOneUsage 42 12 + } + encodedResp = encode resp + case decode @SystemOneResponse encodedResp of + Nothing -> assertFailure "Failed to decode SystemOneResponse" + Just decodedResp -> assertEqual "SystemOneResponse roundtrip" resp decodedResp ]