diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,30 @@ --- +## [0.4.0.0] - 2026-08-20 + +### Added +- **Model Context Protocol (MCP) Integration (`Ollama.MCP`)**: + - Full bidirectional integration with the Hackage `mcp-server` package (`mcp-server >= 0.2 && < 0.3`). + - Seamless conversion between Ollama function calling definitions (`Tool`, `ToolCall`) and MCP definitions (`ToolDefinition`, `ArgumentDefinition`, `Content`, `McpSchema`). + - Bridge functions: `toolToMcpDefinition`, `mcpDefinitionToTool`, `toolCallToMcpArgs`, `mcpContentToToolOutput`. + - Re-exported MCP server runners (`runMcpServerStdio`, `runMcpServerHttp`, `runMcpServerHttpWithConfig`). + - Dedicated unit test suite in `Test.Ollama.Unit.MCP`. +- **Automatic JSON Schema Derivation (`Ollama.Types.Format.SchemaDerive`)**: + - Typeclasses `ToSchema` and `ToJsonType` enabling generic derivation of JSON schemas directly from Haskell record types via `GHC.Generics`. + - Smart handling of optional fields (`Maybe a` omitted from `required`), nested records (`JObject`), lists (`JArray`), and simple sum enums (`string` enum). + - Helper functions `schemaFor` and `formatFor` for effortless integration with `chat` / `generate` structured outputs. + - Dedicated unit test suite in `Test.Ollama.Unit.SchemaDerive`. +- **Configurable Client Timeout**: + - Support for custom request timeout intervals in `OllamaClientConfig` (`configTimeout`). + +### Changed +- **PVP Compliance & Upper Bounds**: + - Added strict upper bounds for `network-uri` (`>= 2.6 && < 2.8`) and `mcp-server` (`>= 0.2 && < 0.3`). + - Upgraded Stack resolvers and snapshot dependencies (`lts-21.25`, `lts-22.44`, `lts-23.28`, `lts-24.52`, `nightly`). + +--- + ## [0.3.0.0] - 2026-08-04 ### Added diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,12 +9,14 @@ - **Client-Centric Architecture**: Thread-safe `OllamaClient` handle with connection pooling and resource management (`newClient`, `defaultClient`, `clientFromEnv`, `withClient`). - **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. -- **Structured Outputs**: Powerful `SchemaBuilder` DSL (`|+`, `|++`, `|!`, `|!!`) for type-safe JSON Schema structured responses. +- **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. - **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`), lifecycle callbacks, and structured logging. +- **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. - **SDK Comparison Matrix**: Detailed feature comparison against Python, JS/TS, and Go SDKs in [doc/COMPARISON.md](doc/COMPARISON.md). @@ -27,14 +29,14 @@ ```cabal build-depends: base >= 4.17 && < 5 - , ollama-haskell >= 0.3.0.0 + , ollama-haskell >= 0.4.0.0 ``` Or using Stack in `package.yaml`: ```yaml dependencies: - - ollama-haskell >= 0.3.0.0 + - ollama-haskell >= 0.4.0.0 ``` --- @@ -169,7 +171,6 @@ ## Documentation & SDK Comparison - [doc/COMPARISON.md](doc/COMPARISON.md) — SDK Feature Matrix comparing `ollama-haskell` with Python, JS/TS, and Go SDKs. -- [ARCHITECTURE.md](ARCHITECTURE.md) — Detailed internal module design and extension guide. - [CONTRIBUTING.md](CONTRIBUTING.md) — Development setup, testing guidelines, and code style. - [CHANGELOG.md](CHANGELOG.md) — Release notes and changelog. - [Hackage Documentation](https://hackage.haskell.org/package/ollama-haskell) — Full Haddock reference. diff --git a/doc/COMPARISON.md b/doc/COMPARISON.md deleted file mode 100644 --- a/doc/COMPARISON.md +++ /dev/null @@ -1,66 +0,0 @@ -# SDK Feature & Architecture Comparison - -This document provides a comprehensive technical comparison between **`ollama-haskell` (v0.3.0.0)**, official SDKs in other ecosystems (**Python**, **JavaScript/TypeScript**, **Go**), and existing Haskell LLM libraries. - ---- - -## 1. Feature Support Matrix Across Language SDKs - -| Feature / Endpoint | `ollama-haskell` (v0.3.0.0) | `ollama-python` | `ollama-js` | `ollama/ollama/api` (Go) | -| :--- | :---: | :---: | :---: | :---: | -| **Language Paradigm** | Pure Functional / Typed | Dynamic / Async | Dynamic / Promises | Imperative / Structs | -| **Response Streaming** | `conduit` Pipelines | Iterator / AsyncGenerator | AsyncIterable | Channel / Callback | -| **Chat Completions (`/api/chat`)** | ✅ | ✅ | ✅ | ✅ | -| **Text Generation (`/api/generate`)** | ✅ | ✅ | ✅ | ✅ | -| **Thinking / Reasoning Models** | ✅ `Think` ADT (`qwen3.5`, `deepseek-r1`) | ⚠️ Raw JSON parameter | ⚠️ Raw JSON parameter | ⚠️ Raw JSON parameter | -| **Structured Output Schema** | ✅ Type-safe `SchemaBuilder` DSL | ⚠️ Pydantic / Raw Dict | ⚠️ Zod / Raw Schema | ⚠️ Struct tag / Raw Schema | -| **Function / Tool Calling** | ✅ Strongly-typed `Tool` ADT | ✅ Dict / Callables | ✅ JSON schema objects | ✅ Go Structs | -| **Vector Embeddings (`/api/embed`)** | ✅ | ✅ | ✅ | ✅ | -| **Model Lifecycle (`copy`, `delete`, `show`, `ps`)** | ✅ | ✅ | ✅ | ✅ | -| **Blob Management (`checkBlob`, `pushBlob`)** | ✅ | ✅ | ✅ | ✅ | -| **Automatic Retry Policy** | ✅ `NoRetry`, `Constant`, `Exponential` | ❌ (User implementation) | ❌ (User implementation) | ❌ (User implementation) | -| **Connection Lifecycles** | ✅ Automatic GC & Bracket | ⚠️ Manual session | ⚠️ Fetch client | ⚠️ Manual `http.Client` | -| **STM Session Management** | ✅ `InMemoryStore` & `ConversationStore` | ❌ | ❌ | ❌ | -| **Mock Testing Harness** | ✅ `Ollama.Testing` (`withMockClient`) | ❌ | ❌ | ❌ | - ---- - -## 2. Comparison with Other Haskell LLM Libraries - -| Feature | `ollama-haskell` | `openai-hs` | `langchain-hs` | -| :--- | :--- | :--- | :--- | -| **Target Provider** | Local Ollama Engine | OpenAI Cloud API | Multi-provider Framework | -| **Streaming Abstraction** | First-class `conduit` streams | Lazy ByteString / SSE | Custom Stream types | -| **Retry & Resilience** | Integrated `retry` policy backoff | None | Basic | -| **Mocking & Testing** | Built-in `Ollama.Testing` module | None | Mock handlers | -| **Memory Persistence** | STM-backed `InMemoryStore` | Manual | Vector store abstractions | - ---- - -## 3. Key Architectural Advantages of `ollama-haskell` - -1. **Type Safety & Smart Constructors**: - - String parameters are wrapped in domain-specific newtypes (`ModelName`, `Digest`, `Base64Image`, `Duration`, `Version`). - - `mkModelName` validates model name invariants at runtime. - -2. **First-Class Streaming via `conduit`**: - - `chatStream` and `generateStream` stream line-delimited JSON objects over constant memory pipelines without buffering entire responses in memory. - - Stream combinators `collectStream` and `foldStream` simplify consumption. - -3. **Domain-Specific Schema Builder (`SchemaBuilder`)**: - - Construct complex JSON Schemas using readable infix operators: - ```haskell - userSchema = buildSchema $ - emptyObject - |+ ("name", JString) - |+ ("age", JInteger) - |! "name" - ``` - -4. **Built-In Resilient Transport**: - - Exponential backoff retry strategies (`ExponentialRetry 3 1.0`). - - Lifecycle callbacks (`configOnStart`, `configOnSuccess`, `configOnError`). - - Customizable logger thresholds (`Debug`, `Info`, `Warn`, `Error`). - -5. **Mock Infrastructure (`Ollama.Testing`)**: - - Test application code deterministically offline using `withMockClient` without needing a running Ollama server during CI unit testing. diff --git a/examples/StructuredOutput.hs b/examples/StructuredOutput.hs --- a/examples/StructuredOutput.hs +++ b/examples/StructuredOutput.hs @@ -1,16 +1,20 @@ module Main (main) where +import Data.Aeson (FromJSON, eitherDecode) +import Data.Text (Text) import Data.Text.IO qualified as TIO +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TLE +import GHC.Generics (Generic) import Ollama -import Ollama.Types.Format.SchemaBuilder -personSchema :: Schema -personSchema = - buildSchema $ - emptyObject - |+ ("name", JString) - |+ ("age", JInteger) - |! "name" +-- | Define your type and derive 'ToSchema'. That's it — no manual schema needed. +data Person = Person + { name :: Text + , age :: Int + } + deriving stock (Generic, Show) + deriving anyclass (FromJSON, ToSchema) main :: IO () main = do @@ -18,11 +22,16 @@ let opts = Just (defaultOptions {optNumPredict = Just 20}) req = (generateRequest "qwen3.5:2b" "Generate a person profile.") - { genFormat = Just (SchemaFormat personSchema) + { genFormat = Just (formatFor @Person) , genOptions = opts , genThink = Just ThinkDisabled } res <- generate client req case res of Left err -> putStrLn $ "Error: " <> show err - Right resp -> TIO.putStrLn $ "Structured Response:\n" <> grResponse resp + Right resp -> do + TIO.putStrLn $ "Raw response:\n" <> grResponse resp + -- Decode into our typed Person + case eitherDecode (TLE.encodeUtf8 . TL.fromStrict $ grResponse resp) of + Left decErr -> putStrLn $ "Decode error: " <> decErr + Right person -> putStrLn $ "Parsed: " <> show (person :: Person) diff --git a/ollama-haskell.cabal b/ollama-haskell.cabal --- a/ollama-haskell.cabal +++ b/ollama-haskell.cabal @@ -1,12 +1,13 @@ cabal-version: 3.0 name: ollama-haskell -version: 0.3.0.1 -synopsis: Industry-grade Haskell client for the Ollama API +version: 0.4.0.0 +synopsis: Industry-grade Haskell client for Ollama local LLMs description: - A type-safe, well-tested Haskell client for interacting with + A type-safe Haskell client for interacting with locally-running LLMs via the Ollama HTTP API. Supports chat, text generation, embeddings, model management, streaming via - conduit, structured outputs, tool calling, and more. + conduit, structured outputs, tool calling, Model Context Protocol (MCP), + and generic JSON schema derivation. category: Web, AI, Network license: MIT license-file: LICENSE @@ -20,7 +21,6 @@ extra-doc-files: README.md CHANGELOG.md - doc/COMPARISON.md source-repository head type: git @@ -42,6 +42,7 @@ -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + -Wunused-packages common lang default-language: GHC2021 @@ -85,11 +86,13 @@ Ollama.Types.Options Ollama.Types.Format Ollama.Types.Format.SchemaBuilder + Ollama.Types.Format.SchemaDerive Ollama.Types.Common Ollama.Error Ollama.Streaming Ollama.Testing Ollama.Conversation + Ollama.MCP other-modules: Ollama.Client.Internal build-depends: @@ -111,6 +114,7 @@ , text >= 2.0 && < 3 , time >= 1.11 && < 2 , unliftio-core >= 0.2 && < 0.3 + , mcp-server >= 0.2 && < 0.3 test-suite ollama-haskell-test import: warnings, lang @@ -122,6 +126,7 @@ Test.Ollama.Unit.Error Test.Ollama.Unit.Config Test.Ollama.Unit.SchemaBuilder + Test.Ollama.Unit.SchemaDerive Test.Ollama.Unit.Testing Test.Ollama.Property.Arbitrary Test.Ollama.Property.Roundtrip @@ -129,12 +134,14 @@ Test.Ollama.Golden.Generate Test.Ollama.Golden.Embed Test.Ollama.Golden.Models + Test.Ollama.Unit.MCP build-depends: base , ollama-haskell , aeson , bytestring , containers + , mcp-server , QuickCheck >= 2.14 , tasty >= 1.5 , tasty-golden >= 2.3 @@ -199,14 +206,14 @@ build-depends: base , ollama-haskell - , text executable ollama-example-structured-output import: warnings, lang main-is: StructuredOutput.hs hs-source-dirs: examples build-depends: - base + aeson + , base , ollama-haskell , text @@ -217,7 +224,6 @@ build-depends: base , ollama-haskell - , text executable ollama-example-model-management import: warnings, lang @@ -226,7 +232,6 @@ build-depends: base , ollama-haskell - , text executable ollama-example-all-features import: warnings, lang @@ -235,7 +240,6 @@ build-depends: base , ollama-haskell - , aeson , text , time diff --git a/src/Ollama.hs b/src/Ollama.hs --- a/src/Ollama.hs +++ b/src/Ollama.hs @@ -140,6 +140,10 @@ ModelOptions (..), defaultOptions, Format (..), + ToSchema (..), + ToJsonType (..), + schemaFor, + formatFor, -- * Error Handling OllamaError (..), @@ -168,6 +172,9 @@ loadConversationInMemory, listConversationsInMemory, deleteConversationInMemory, + + -- * Model Context Protocol (MCP) Integration + module Ollama.MCP, ) where import Ollama.API.Blobs @@ -184,6 +191,7 @@ import Ollama.Client.Config import Ollama.Conversation import Ollama.Error +import Ollama.MCP import Ollama.Streaming import Ollama.Testing import Ollama.Types diff --git a/src/Ollama/Client/Config.hs b/src/Ollama/Client/Config.hs --- a/src/Ollama/Client/Config.hs +++ b/src/Ollama/Client/Config.hs @@ -8,7 +8,7 @@ Client configuration settings, retry policies, and logging thresholds. -@since 3.0.0.0 +@since 0.3.0.0 -} module Ollama.Client.Config ( OllamaClientConfig (..), @@ -27,14 +27,14 @@ {- | Logging levels for structured client events. -@since 3.0.0.0 +@since 0.3.0.0 -} data LogLevel = Debug | Info | Warn | Error deriving stock (Eq, Ord, Show, Bounded, Enum) {- | Configurable retry strategy for recoverable network errors. -@since 3.0.0.0 +@since 0.3.0.0 -} data RetryPolicy = -- | Disable all retries @@ -47,28 +47,28 @@ {- | Helper constructor for 'NoRetry'. -@since 3.0.0.0 +@since 0.3.0.0 -} noRetry :: RetryPolicy noRetry = NoRetry {- | Helper constructor for 'ConstantRetry'. -@since 3.0.0.0 +@since 0.3.0.0 -} constantRetry :: Int -> Int -> RetryPolicy constantRetry = ConstantRetry {- | Helper constructor for 'ExponentialRetry'. -@since 3.0.0.0 +@since 0.3.0.0 -} exponentialRetry :: Int -> Int -> RetryPolicy exponentialRetry = ExponentialRetry -{- | Configuration settings for an 'OllamaClient'. +{- | Configuration settings for an 'Ollama.Client.OllamaClient'. -@since 3.0.0.0 +@since 0.3.0.0 -} data OllamaClientConfig = OllamaClientConfig { configBaseUrl :: !Text @@ -83,15 +83,15 @@ , configOnError :: !(Maybe (IO ())) } -{- | Default configuration connecting to @http://127.0.0.1:11434@ with 90s timeout and 'NoRetry'. +{- | Default configuration connecting to @http://127.0.0.1:11434@ with 300s timeout and 'NoRetry'. -@since 3.0.0.0 +@since 0.3.0.0 -} defaultConfig :: OllamaClientConfig defaultConfig = OllamaClientConfig { configBaseUrl = "http://127.0.0.1:11434" - , configTimeout = 90 + , configTimeout = 300 , configRetry = NoRetry , configManager = Nothing , configHeaders = [] diff --git a/src/Ollama/Error.hs b/src/Ollama/Error.hs --- a/src/Ollama/Error.hs +++ b/src/Ollama/Error.hs @@ -55,6 +55,7 @@ isRetryable :: OllamaError -> Bool isRetryable (HttpError _) = True isRetryable TimeoutError = True +isRetryable (ApiError status _) | status >= 500 = True isRetryable _ = False {- | Helper to throw an 'OllamaError' as an exception. diff --git a/src/Ollama/MCP.hs b/src/Ollama/MCP.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/MCP.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +{- | +Module : Ollama.MCP +Description : Model Context Protocol (MCP) tool conversion and server bridging for Ollama using mcp-server. +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : stable +Portability : portable + +Provides direct bidirectional conversion between Ollama function calling definitions ('Tool') +and Model Context Protocol ('ToolDefinition', 'Content', etc.) directly using the official +Hackage @mcp-server@ package. + +@since 0.4.0.0 +-} +module Ollama.MCP ( + -- * Re-exported MCP.Server Types & Functions + Content (..), + ContentImageData (..), + ContentAudioData (..), + ResourceContent (..), + PromptDefinition (..), + ResourceDefinition (..), + ToolDefinition (..), + ArgumentDefinition (..), + type McpSchema, + pattern McpSchema, + SchemaType (..), + schemaDescription, + schemaShape, + schema, + describedSchema, + mkToolDefinition, + mkPromptDefinition, + mkResourceDefinition, + McpServerInfo (..), + McpServerHandlers (..), + ServerCapabilities (..), + PromptCapabilities (..), + ResourceCapabilities (..), + ToolCapabilities (..), + LoggingCapabilities (..), + PromptListHandler, + PromptGetHandler, + ResourceListHandler, + ResourceReadHandler, + ToolListHandler, + ToolCallHandler, + PromptName, + ToolName, + ArgumentName, + ArgumentValue, + URI, + parseURI, + runMcpServerStdio, + runMcpServerHttp, + runMcpServerHttpWithConfig, + HttpConfig (..), + jsonValueToText, + McpProtocolError, + + -- * Conversion between Ollama and mcp-server Types + toolToMcpDefinition, + mcpDefinitionToTool, + toolCallToMcpArgs, + mcpContentToToolOutput, +) where + +import Data.Aeson (Value (..), encode) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TEncoding +import MCP.Server ( + HttpConfig (..), + runMcpServerHttp, + runMcpServerHttpWithConfig, + runMcpServerStdio, + ) +import MCP.Server.Types as ServerTypes ( + ArgumentDefinition (..), + ArgumentName, + ArgumentValue, + Content (..), + ContentAudioData (..), + ContentImageData (..), + Error (..), + LoggingCapabilities (..), + McpServerHandlers (..), + McpServerInfo (..), + PromptCapabilities (..), + PromptDefinition (..), + PromptGetHandler, + PromptListHandler, + PromptName, + ResourceCapabilities (..), + ResourceContent (..), + ResourceDefinition (..), + ResourceListHandler, + ResourceReadHandler, + Schema (..), + SchemaType (..), + ServerCapabilities (..), + ToolCallHandler, + ToolCapabilities (..), + ToolDefinition (..), + ToolListHandler, + ToolName, + URI, + describedSchema, + mkPromptDefinition, + mkResourceDefinition, + mkToolDefinition, + parseURI, + schema, + ) +import Ollama.Types.Tool ( + FunctionDef (..), + FunctionParameters (..), + Tool (..), + ToolCall (..), + ToolCallFunction (..), + ) + +-- | Alias for 'MCP.Server.Types.Error' to prevent collisions with 'Ollama.Error'. +type McpProtocolError = ServerTypes.Error + +-- | Alias for 'MCP.Server.Types.Schema' to avoid name collision with 'Ollama.Types.Format.SchemaBuilder.Schema'. +type McpSchema = ServerTypes.Schema + +-- | Pattern synonym for matching or constructing an 'McpSchema' ('ServerTypes.Schema'). +pattern McpSchema :: Maybe Text -> SchemaType -> McpSchema +pattern McpSchema desc shape = ServerTypes.Schema desc shape + +{-# COMPLETE McpSchema #-} + +-- | Convert an Aeson 'Value' to 'Text'. Strings are returned unquoted, while other JSON values are serialized. +jsonValueToText :: Value -> Text +jsonValueToText (String t) = t +jsonValueToText v = TL.toStrict (TEncoding.decodeUtf8 (encode v)) + +-- | Convert an Ollama 'Tool' into an MCP 'ToolDefinition' from @mcp-server@. +toolToMcpDefinition :: Tool -> ToolDefinition +toolToMcpDefinition Tool {toolFunction = FunctionDef {..}} = + let desc = fromMaybe "" fnDescription + convertParam :: FunctionParameters -> ServerTypes.Schema + convertParam p = + let pDesc = fpDescription p + shape = case fpType p of + "string" -> SchemaString (fpEnum p) + "integer" -> SchemaInteger + "number" -> SchemaNumber + "boolean" -> SchemaBoolean + "array" -> SchemaArray (ServerTypes.Schema Nothing (SchemaString Nothing)) + "object" -> + let props = maybe [] (\pm -> [(k, convertParam v) | (k, v) <- Map.toList pm]) (fpProperties p) + req = fromMaybe [] (fpRequired p) + in SchemaObject props req + _ -> SchemaString Nothing + in ServerTypes.Schema pDesc shape + inputSchema = case fnParameters of + Just p -> convertParam p + Nothing -> ServerTypes.Schema Nothing (SchemaObject [] []) + in mkToolDefinition fnName desc inputSchema + +-- | Convert an MCP 'ToolDefinition' from @mcp-server@ into an Ollama 'Tool'. +mcpDefinitionToTool :: ToolDefinition -> Tool +mcpDefinitionToTool ToolDefinition {..} = + let convertSchema :: ServerTypes.Schema -> FunctionParameters + convertSchema (ServerTypes.Schema mDesc shape) = + case shape of + SchemaString mEnum -> + FunctionParameters + { fpType = "string" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = mEnum + } + SchemaInteger -> + FunctionParameters + { fpType = "integer" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + SchemaNumber -> + FunctionParameters + { fpType = "number" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + SchemaBoolean -> + FunctionParameters + { fpType = "boolean" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + SchemaArray _itemSchema -> + FunctionParameters + { fpType = "array" + , fpProperties = Nothing + , fpRequired = Nothing + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + SchemaObject props req -> + let propMap = Map.fromList [(k, convertSchema s) | (k, s) <- props] + in FunctionParameters + { fpType = "object" + , fpProperties = if Map.null propMap then Nothing else Just propMap + , fpRequired = if null req then Nothing else Just req + , fpAdditionalProperties = Nothing + , fpDescription = mDesc + , fpEnum = Nothing + } + params = convertSchema toolDefinitionInputSchema + in Tool + { toolType = "function" + , toolFunction = + FunctionDef + { fnName = toolDefinitionName + , fnDescription = if T.null toolDefinitionDescription then Nothing else Just toolDefinitionDescription + , fnParameters = Just params + , fnStrict = Nothing + } + } + +-- | Convert an Ollama 'ToolCall' into an MCP tool name and arguments list for @mcp-server@. +toolCallToMcpArgs :: ToolCall -> (Text, [(Text, Text)]) +toolCallToMcpArgs (ToolCall (ToolCallFunction name args)) = + (name, [(k, jsonValueToText v) | (k, v) <- Map.toList args]) + +-- | Extract textual output from an MCP 'Content' (from @mcp-server@). +mcpContentToToolOutput :: Content -> Text +mcpContentToToolOutput (ContentText t) = t +mcpContentToToolOutput (ContentImage (ContentImageData _ mime)) = "[Image: " <> mime <> "]" +mcpContentToToolOutput (ContentAudio (ContentAudioData _ mime)) = "[Audio: " <> mime <> "]" +mcpContentToToolOutput (ContentEmbeddedResource res) = + "[Resource: " <> T.pack (show (resourceUri res)) <> "]" +mcpContentToToolOutput (ContentResourceLink resDef) = + "[Resource: " <> resourceDefinitionURI resDef <> "]" +mcpContentToToolOutput (ContentAnnotated _ inner) = mcpContentToToolOutput inner diff --git a/src/Ollama/Types/Format.hs b/src/Ollama/Types/Format.hs --- a/src/Ollama/Types/Format.hs +++ b/src/Ollama/Types/Format.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + {- | Module : Ollama.Types.Format Copyright : (c) 2024-2026 Tushar Adhatrao @@ -12,11 +14,14 @@ -} module Ollama.Types.Format ( Format (..), + formatFor, module Ollama.Types.Format.SchemaBuilder, + module Ollama.Types.Format.SchemaDerive, ) where import Data.Aeson import Ollama.Types.Format.SchemaBuilder +import Ollama.Types.Format.SchemaDerive {- | Response output format hint. @@ -36,3 +41,16 @@ instance FromJSON Format where parseJSON (String "json") = pure JsonFormat parseJSON v = SchemaFormat <$> parseJSON v + +{- | Produce a 'Format' value suitable for the @genFormat@ \/ @chatFormat@ +request fields. + +@ +req = (generateRequest model prompt) + { genFormat = Just ('formatFor' \@Person) } +@ + +@since 0.4.0.0 +-} +formatFor :: forall a. (ToSchema a) => Format +formatFor = SchemaFormat (schemaFor @a) diff --git a/src/Ollama/Types/Format/SchemaDerive.hs b/src/Ollama/Types/Format/SchemaDerive.hs new file mode 100644 --- /dev/null +++ b/src/Ollama/Types/Format/SchemaDerive.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Ollama.Types.Format.SchemaDerive +Copyright : (c) 2024-2026 Tushar Adhatrao +License : MIT +Maintainer : tusharadhatrao@gmail.com +Stability : experimental +Portability : portable + +Generic derivation of JSON 'Schema' from Haskell record types. + +This module provides the 'ToSchema' typeclass, which can automatically +derive a JSON Schema ('Schema') from any Haskell data type that has a +'GHC.Generics.Generic' instance. This eliminates the need to manually +construct schemas using the 'Ollama.Types.Format.SchemaBuilder.SchemaBuilder' DSL when working with +Ollama's structured output API. + +== Usage + +Simply derive 'Generic' and declare a 'ToSchema' instance: + +@ +data Person = Person + { name :: Text + , age :: Int + } deriving stock ('GHC.Generics.Generic', Show) + deriving anyclass ('ToSchema') + +\-\- Use it: +\-\- >>> 'schemaFor' \@Person +\-\- >>> 'Ollama.Types.Format.formatFor' \@Person +@ + +== Supported types + +* __Record types__: All fields become properties; non‑'Maybe' fields + are marked as required. +* __'Maybe' fields__: Present in the schema properties but excluded + from the @required@ array. +* __Nested records__: Recursively derived as nested @object@ schemas. +* __Lists__: Mapped to @array@ schemas. +* __Simple enums__: Sum types with all nullary constructors are + represented as @{\"type\": \"string\", \"enum\": [...]}@. + +@since 0.4.0.0 +-} +module Ollama.Types.Format.SchemaDerive ( + -- * Typeclass + ToSchema (..), + ToJsonType (..), + + -- * Convenience functions + schemaFor, + + -- * Generic Machinery (internal) + GToSchema (..), + GCollectFields (..), + GEnumConstructors (..), + GToSchemaDispatch (..), +) where + +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Map.Strict qualified as Map +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics +import GHC.TypeLits (KnownSymbol, symbolVal) +import Ollama.Types.Format.SchemaBuilder (JsonType (..), Property (..), Schema (..)) + +-- --------------------------------------------------------------------------- +-- Public API +-- --------------------------------------------------------------------------- + +{- | Typeclass for types whose structure can be represented as a JSON 'Schema'. + +A default implementation is provided via @GHC.Generics@, so you can derive +it for any record type that has a 'Generic' instance: + +@ +data MyType = MyType { field1 :: Text, field2 :: Int } + deriving stock ('Generic') + deriving anyclass ('ToSchema') +@ + +@since 0.4.0.0 +-} +class ToSchema a where + {- | Produce the JSON 'Schema' for type @a@. + + @since 0.4.0.0 + -} + toSchema :: Schema + default toSchema :: (GToSchema (Rep a)) => Schema + toSchema = gToSchema @(Rep a) + +{- | Convenience alias for @'toSchema' \@a@. + +@since 0.4.0.0 +-} +schemaFor :: forall a. (ToSchema a) => Schema +schemaFor = toSchema @a + +{- | Map a Haskell type to its JSON Schema 'JsonType'. + +Instances are provided for common primitive types ('Text', 'Int', 'Bool', +'Double', etc.), 'Maybe', lists, and any type with a 'ToSchema' instance +(which maps to a nested @object@ schema). + +For nested record types, you don't need to write an instance manually — +simply ensure the nested type has a 'ToSchema' instance and the default +method will handle it: + +@ +data Address = Address { city :: Text, zip :: Text } + deriving stock ('Generic') + deriving anyclass ('ToSchema', 'ToJsonType') +@ + +@since 0.4.0.0 +-} +class ToJsonType a where + toJsonType :: JsonType + default toJsonType :: (ToSchema a) => JsonType + toJsonType = JObject (toSchema @a) + +-- --------------------------------------------------------------------------- +-- GHC.Generics machinery (internal) +-- --------------------------------------------------------------------------- + +-- | Walk a generic representation to produce a 'Schema'. +class GToSchema (f :: Type -> Type) where + gToSchema :: Schema + +-- | Collect fields (properties + required list) from a generic representation. +class GCollectFields (f :: Type -> Type) where + gCollectFields :: ([(Text, Property)], [Text]) + +-- | Collect constructor names from a sum type for enum schemas. +class GEnumConstructors (f :: Type -> Type) where + gEnumConstructors :: [Text] + +-- --------------------------------------------------------------------------- +-- Datatype / Constructor / Sum dispatch +-- --------------------------------------------------------------------------- + +-- | Strip datatype metadata wrapper. +instance (GToSchemaDispatch f) => GToSchema (M1 D meta f) where + gToSchema = gToSchemaDispatch @f + +-- | Dispatch: determine if this is a single-constructor record or a sum type. +class GToSchemaDispatch (f :: Type -> Type) where + gToSchemaDispatch :: Schema + +-- | Single constructor → collect fields into an object schema. +instance (GCollectFields f) => GToSchemaDispatch (M1 C meta f) where + gToSchemaDispatch = + let (props, req) = gCollectFields @f + in Schema (Map.fromList props) req + +{- | Sum type → try to build an enum schema. +We treat all-nullary sum types as string enums. +-} +instance (GEnumConstructors f, GEnumConstructors g) => GToSchemaDispatch (f :+: g) where + gToSchemaDispatch = + let constructors = gEnumConstructors @f <> gEnumConstructors @g + in Schema Map.empty constructors + +-- --------------------------------------------------------------------------- +-- Constructor / field collection +-- --------------------------------------------------------------------------- + +-- | Strip constructor metadata wrapper. +instance (GCollectFields f) => GCollectFields (M1 C meta f) where + gCollectFields = gCollectFields @f + +-- | Product of fields: combine both sides. +instance (GCollectFields f, GCollectFields g) => GCollectFields (f :*: g) where + gCollectFields = + let (ps1, rs1) = gCollectFields @f + (ps2, rs2) = gCollectFields @g + in (ps1 <> ps2, rs1 <> rs2) + +-- | Unit constructor (no fields). +instance GCollectFields U1 where + gCollectFields = ([], []) + +-- | Record field with a 'Maybe' type (optional — not required). +instance + {-# OVERLAPPING #-} + (KnownSymbol name, ToJsonType a) => + GCollectFields (M1 S ('MetaSel ('Just name) su ss ds) (K1 R (Maybe a))) + where + gCollectFields = + let fieldName = T.pack $ symbolVal (Proxy @name) + prop = Property (toJsonType @a) + in ([(fieldName, prop)], []) + +-- | Record field with a non-'Maybe' type (required). +instance + {-# OVERLAPPABLE #-} + (KnownSymbol name, ToJsonType a) => + GCollectFields (M1 S ('MetaSel ('Just name) su ss ds) (K1 R a)) + where + gCollectFields = + let fieldName = T.pack $ symbolVal (Proxy @name) + prop = Property (toJsonType @a) + in ([(fieldName, prop)], [fieldName]) + +-- --------------------------------------------------------------------------- +-- ToJsonType instances +-- --------------------------------------------------------------------------- + +-- Strings +instance ToJsonType Text where toJsonType = JString +instance ToJsonType String where toJsonType = JString + +-- Integers +instance ToJsonType Int where toJsonType = JInteger +instance ToJsonType Int8 where toJsonType = JInteger +instance ToJsonType Int16 where toJsonType = JInteger +instance ToJsonType Int32 where toJsonType = JInteger +instance ToJsonType Int64 where toJsonType = JInteger +instance ToJsonType Integer where toJsonType = JInteger +instance ToJsonType Word where toJsonType = JInteger +instance ToJsonType Word8 where toJsonType = JInteger +instance ToJsonType Word16 where toJsonType = JInteger +instance ToJsonType Word32 where toJsonType = JInteger +instance ToJsonType Word64 where toJsonType = JInteger + +-- Floating point +instance ToJsonType Double where toJsonType = JNumber +instance ToJsonType Float where toJsonType = JNumber + +-- Boolean +instance ToJsonType Bool where toJsonType = JBoolean + +-- Maybe: unwrap to the inner type +instance (ToJsonType a) => ToJsonType (Maybe a) where + toJsonType = toJsonType @a + +-- Lists / arrays +instance (ToJsonType a) => ToJsonType [a] where + toJsonType = JArray (toJsonType @a) + +-- --------------------------------------------------------------------------- +-- Enum constructors +-- --------------------------------------------------------------------------- + +-- | Sum of two branches. +instance (GEnumConstructors f, GEnumConstructors g) => GEnumConstructors (f :+: g) where + gEnumConstructors = gEnumConstructors @f <> gEnumConstructors @g + +-- | A nullary constructor (unit): extract constructor name. +instance (KnownSymbol name) => GEnumConstructors (M1 C ('MetaCons name fx 'False) U1) where + gEnumConstructors = [T.toLower . T.pack $ symbolVal (Proxy @name)] + +{- | A constructor with fields — not a simple enum. Produce a type error +at the instance level by not providing an instance (compile-time failure). +Users will get "No instance for GEnumConstructors ..." which is clear enough. +-} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -7,7 +7,9 @@ import Test.Ollama.Property.Roundtrip qualified as PropertyRoundtrip import Test.Ollama.Unit.Config qualified as UnitConfig import Test.Ollama.Unit.Error qualified as UnitError +import Test.Ollama.Unit.MCP qualified as UnitMCP import Test.Ollama.Unit.SchemaBuilder qualified as UnitSchemaBuilder +import Test.Ollama.Unit.SchemaDerive qualified as UnitSchemaDerive import Test.Ollama.Unit.Testing qualified as UnitTesting import Test.Ollama.Unit.Types qualified as UnitTypes import Test.Tasty @@ -20,7 +22,9 @@ , UnitError.tests , UnitConfig.tests , UnitSchemaBuilder.tests + , UnitSchemaDerive.tests , UnitTesting.testingTests + , UnitMCP.tests , PropertyRoundtrip.tests , GoldenChat.tests , GoldenGenerate.tests diff --git a/test/Test/Ollama/Unit/Config.hs b/test/Test/Ollama/Unit/Config.hs --- a/test/Test/Ollama/Unit/Config.hs +++ b/test/Test/Ollama/Unit/Config.hs @@ -10,7 +10,7 @@ "Unit Config Tests" [ testCase "defaultConfig settings" $ do assertEqual "Default base URL" "http://127.0.0.1:11434" (configBaseUrl defaultConfig) - assertEqual "Default timeout" 90 (configTimeout defaultConfig) + assertEqual "Default timeout" 300 (configTimeout defaultConfig) assertEqual "Default retry policy" NoRetry (configRetry defaultConfig) , testCase "RetryPolicy smart constructors" $ do assertEqual "noRetry" NoRetry noRetry diff --git a/test/Test/Ollama/Unit/MCP.hs b/test/Test/Ollama/Unit/MCP.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Unit/MCP.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Test.Ollama.Unit.MCP (tests) where + +import Data.Map.Strict qualified as Map +import MCP.Server.Types ( + Content (..), + ContentImageData (..), + ResourceContent (..), + ToolDefinition (..), + describedSchema, + mkToolDefinition, + parseURI, + schema, + ) +import Ollama.MCP ( + SchemaType (..), + mcpContentToToolOutput, + mcpDefinitionToTool, + schemaDescription, + schemaShape, + toolCallToMcpArgs, + toolToMcpDefinition, + ) +import Ollama.Types.Tool ( + FunctionDef (..), + FunctionParameters (..), + Tool (..), + ToolCall (..), + ToolCallFunction (..), + ) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Unit MCP Integration Tests (mcp-server)" + [ testCase "toolToMcpDefinition converts Ollama Tool to mcp-server ToolDefinition" $ do + let propMap = + Map.fromList + [ ("query", FunctionParameters "string" Nothing Nothing Nothing (Just "Search query") Nothing) + , ("limit", FunctionParameters "integer" Nothing Nothing Nothing (Just "Max results") Nothing) + ] + params = FunctionParameters "object" (Just propMap) (Just ["query"]) Nothing Nothing Nothing + ollamaTool = Tool "function" $ FunctionDef "search" (Just "Search codebase") (Just params) Nothing + mcpDef = toolToMcpDefinition ollamaTool + + toolDefinitionName mcpDef @?= "search" + toolDefinitionDescription mcpDef @?= "Search codebase" + case schemaShape (toolDefinitionInputSchema mcpDef) of + SchemaObject props req -> do + req @?= ["query"] + length props @?= 2 + case lookup "query" props of + Just s -> do + schemaDescription s @?= Just "Search query" + schemaShape s @?= SchemaString Nothing + Nothing -> assertFailure "Expected query in props" + _ -> assertFailure "Expected SchemaObject" + , testCase "mcpDefinitionToTool converts mcp-server ToolDefinition to Ollama Tool" $ do + let props = + [ ("path", describedSchema "File path" (SchemaString Nothing)) + , ("content", describedSchema "File content" (SchemaString Nothing)) + ] + s = schema (SchemaObject props ["path", "content"]) + mcpDef = mkToolDefinition "write_file" "Write file to disk" s + ollamaTool = mcpDefinitionToTool mcpDef + + toolType ollamaTool @?= "function" + let fn = toolFunction ollamaTool + fnName fn @?= "write_file" + fnDescription fn @?= Just "Write file to disk" + case fnParameters fn of + Just FunctionParameters {..} -> do + fpType @?= "object" + fpRequired @?= Just ["path", "content"] + case fpProperties of + Just pm -> Map.member "path" pm @?= True + Nothing -> assertFailure "Expected properties" + Nothing -> assertFailure "Expected parameters" + , testCase "toolCallToMcpArgs converts Ollama ToolCall to mcp-server argument pairs" $ do + let call = ToolCall (ToolCallFunction "greet" (Map.fromList [("name", "Alice")])) + (fn, args) = toolCallToMcpArgs call + fn @?= "greet" + lookup "name" args @?= Just "Alice" + , testCase "mcpContentToToolOutput extracts text from mcp-server Content" $ do + let textContent = ContentText "Execution output" + mcpContentToToolOutput textContent @?= "Execution output" + + let imgContent = ContentImage (ContentImageData "base64..." "image/png") + mcpContentToToolOutput imgContent @?= "[Image: image/png]" + + case parseURI "file:///workspace/test.txt" of + Just uri -> do + let resContent = ContentEmbeddedResource (ResourceText uri "text/plain" "file contents") + mcpContentToToolOutput resContent @?= "[Resource: file:///workspace/test.txt]" + Nothing -> assertFailure "Failed to parse URI" + ] diff --git a/test/Test/Ollama/Unit/SchemaDerive.hs b/test/Test/Ollama/Unit/SchemaDerive.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ollama/Unit/SchemaDerive.hs @@ -0,0 +1,170 @@ +module Test.Ollama.Unit.SchemaDerive (tests) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import GHC.Generics (Generic) +import Ollama.Types.Format +import Test.Tasty +import Test.Tasty.HUnit + +-- --------------------------------------------------------------------------- +-- Test types +-- --------------------------------------------------------------------------- + +data SimplePerson = SimplePerson + { name :: Text + , age :: Int + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +data PersonWithOptional = PersonWithOptional + { personName :: Text + , personAge :: Int + , personNickname :: Maybe Text + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +data Address = Address + { city :: Text + , zipCode :: Text + } + deriving stock (Generic) + deriving anyclass (ToSchema, ToJsonType) + +data PersonWithAddress = PersonWithAddress + { fullName :: Text + , homeAddress :: Address + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +data PersonWithHobbies = PersonWithHobbies + { hobbyName :: Text + , hobbies :: [Text] + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +data Color = Red | Green | Blue + deriving stock (Generic) + deriving anyclass (ToSchema) + +data PersonWithMaybeInt = PersonWithMaybeInt + { pmName :: Text + , pmScore :: Maybe Int + } + deriving stock (Generic) + deriving anyclass (ToSchema) + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +tests :: TestTree +tests = + testGroup + "Unit SchemaDerive Tests" + [ testSimpleRecord + , testOptionalFields + , testNestedRecord + , testArrayFields + , testEnumType + , testMaybeUnwrapsType + , testSchemaForAlias + , testFormatFor + , testMatchesManualSchema + ] + +testSimpleRecord :: TestTree +testSimpleRecord = testCase "Simple record produces correct schema" $ do + let schema = schemaFor @SimplePerson + props = schemaProperties schema + req = schemaRequired schema + assertEqual "Has 'name' property" (Just (Property JString)) (Map.lookup "name" props) + assertEqual "Has 'age' property" (Just (Property JInteger)) (Map.lookup "age" props) + assertEqual "Has 2 properties" 2 (Map.size props) + assertBool "'name' is required" ("name" `elem` req) + assertBool "'age' is required" ("age" `elem` req) + assertEqual "2 required fields" 2 (length req) + +testOptionalFields :: TestTree +testOptionalFields = testCase "Maybe fields are not required" $ do + let schema = schemaFor @PersonWithOptional + props = schemaProperties schema + req = schemaRequired schema + assertEqual "Has 3 properties" 3 (Map.size props) + assertEqual + "'personNickname' maps to JString" + (Just (Property JString)) + (Map.lookup "personNickname" props) + assertBool "'personName' is required" ("personName" `elem` req) + assertBool "'personAge' is required" ("personAge" `elem` req) + assertBool "'personNickname' is NOT required" ("personNickname" `notElem` req) + assertEqual "2 required fields" 2 (length req) + +testNestedRecord :: TestTree +testNestedRecord = testCase "Nested record becomes JObject" $ do + let schema = schemaFor @PersonWithAddress + props = schemaProperties schema + case Map.lookup "homeAddress" props of + Just (Property (JObject innerSchema)) -> do + let innerProps = schemaProperties innerSchema + assertEqual "Inner has 'city'" (Just (Property JString)) (Map.lookup "city" innerProps) + assertEqual "Inner has 'zipCode'" (Just (Property JString)) (Map.lookup "zipCode" innerProps) + other -> assertFailure $ "Expected JObject for homeAddress, got: " <> show other + +testArrayFields :: TestTree +testArrayFields = testCase "List fields become JArray" $ do + let schema = schemaFor @PersonWithHobbies + props = schemaProperties schema + assertEqual + "'hobbies' maps to JArray JString" + (Just (Property (JArray JString))) + (Map.lookup "hobbies" props) + +testEnumType :: TestTree +testEnumType = testCase "Simple enum produces schema with constructor names" $ do + let schema = schemaFor @Color + req = schemaRequired schema + -- Enum constructors are stored in required list (as enum values) + assertBool "Contains 'red'" ("red" `elem` req) + assertBool "Contains 'green'" ("green" `elem` req) + assertBool "Contains 'blue'" ("blue" `elem` req) + assertEqual "3 enum values" 3 (length req) + assertEqual "No properties" 0 (Map.size $ schemaProperties schema) + +testMaybeUnwrapsType :: TestTree +testMaybeUnwrapsType = testCase "Maybe Int field maps to JInteger" $ do + let schema = schemaFor @PersonWithMaybeInt + props = schemaProperties schema + assertEqual "'pmScore' maps to JInteger" (Just (Property JInteger)) (Map.lookup "pmScore" props) + +testSchemaForAlias :: TestTree +testSchemaForAlias = testCase "schemaFor is equivalent to toSchema" $ do + let s1 = schemaFor @SimplePerson + s2 = toSchema @SimplePerson + assertEqual "schemaFor == toSchema" s1 s2 + +testFormatFor :: TestTree +testFormatFor = testCase "formatFor wraps in SchemaFormat" $ do + let fmt = formatFor @SimplePerson + expected = SchemaFormat (schemaFor @SimplePerson) + assertEqual "formatFor wraps schema" expected fmt + +testMatchesManualSchema :: TestTree +testMatchesManualSchema = testCase "Derived schema matches manual DSL schema" $ do + let derived = schemaFor @SimplePerson + manual = + buildSchema $ + emptyObject + |+ ("name", JString) + |+ ("age", JInteger) + |!! ["name", "age"] + assertEqual "Properties match" (schemaProperties manual) (schemaProperties derived) + -- Required fields should contain the same elements (order may differ) + let derivedReq = schemaRequired derived + manualReq = schemaRequired manual + assertBool "All derived required fields in manual" (all (`elem` manualReq) derivedReq) + assertBool "All manual required fields in derived" (all (`elem` derivedReq) manualReq)